From 0332309647d7a01ae2aa33e9b13039b6a01b2a01 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?S=C3=A9bastien=20Villemot?= Date: Thu, 30 Aug 2012 14:49:21 +0200 Subject: [PATCH] Remove embedded SLICOT, rely on external binary --- mex/build/kalman_steady_state.am | 3 +- mex/build/libslicot.am | 478 ----- mex/build/matlab/Makefile.am | 5 +- mex/build/matlab/configure.ac | 27 +- mex/build/matlab/libslicot/Makefile.am | 2 - mex/build/octave/Makefile.am | 5 +- mex/build/octave/configure.ac | 14 +- mex/build/octave/libslicot/Makefile.am | 3 - mex/sources/Makefile.am | 1 - 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 - 481 files changed, 38 insertions(+), 211313 deletions(-) delete mode 100644 mex/build/libslicot.am delete mode 100644 mex/build/matlab/libslicot/Makefile.am delete mode 100644 mex/build/octave/libslicot/Makefile.am delete mode 100644 mex/sources/libslicot/AB01MD.f delete mode 100644 mex/sources/libslicot/AB01ND.f delete mode 100644 mex/sources/libslicot/AB01OD.f delete mode 100644 mex/sources/libslicot/AB04MD.f delete mode 100644 mex/sources/libslicot/AB05MD.f delete mode 100644 mex/sources/libslicot/AB05ND.f delete mode 100644 mex/sources/libslicot/AB05OD.f delete mode 100644 mex/sources/libslicot/AB05PD.f delete mode 100644 mex/sources/libslicot/AB05QD.f delete mode 100644 mex/sources/libslicot/AB05RD.f delete mode 100644 mex/sources/libslicot/AB05SD.f delete mode 100644 mex/sources/libslicot/AB07MD.f delete mode 100644 mex/sources/libslicot/AB07ND.f delete mode 100644 mex/sources/libslicot/AB08MD.f delete mode 100644 mex/sources/libslicot/AB08MZ.f delete mode 100644 mex/sources/libslicot/AB08ND.f delete mode 100644 mex/sources/libslicot/AB08NX.f delete mode 100644 mex/sources/libslicot/AB08NZ.f delete mode 100644 mex/sources/libslicot/AB09AD.f delete mode 100644 mex/sources/libslicot/AB09AX.f delete mode 100644 mex/sources/libslicot/AB09BD.f delete mode 100644 mex/sources/libslicot/AB09BX.f delete mode 100644 mex/sources/libslicot/AB09CD.f delete mode 100644 mex/sources/libslicot/AB09CX.f delete mode 100644 mex/sources/libslicot/AB09DD.f delete mode 100644 mex/sources/libslicot/AB09ED.f delete mode 100644 mex/sources/libslicot/AB09FD.f delete mode 100644 mex/sources/libslicot/AB09GD.f delete mode 100644 mex/sources/libslicot/AB09HD.f delete mode 100644 mex/sources/libslicot/AB09HX.f delete mode 100644 mex/sources/libslicot/AB09HY.f delete mode 100644 mex/sources/libslicot/AB09ID.f delete mode 100644 mex/sources/libslicot/AB09IX.f delete mode 100644 mex/sources/libslicot/AB09IY.f delete mode 100644 mex/sources/libslicot/AB09JD.f delete mode 100644 mex/sources/libslicot/AB09JV.f delete mode 100644 mex/sources/libslicot/AB09JW.f delete mode 100644 mex/sources/libslicot/AB09JX.f delete mode 100644 mex/sources/libslicot/AB09KD.f delete mode 100644 mex/sources/libslicot/AB09KX.f delete mode 100644 mex/sources/libslicot/AB09MD.f delete mode 100644 mex/sources/libslicot/AB09ND.f delete mode 100644 mex/sources/libslicot/AB13AD.f delete mode 100644 mex/sources/libslicot/AB13AX.f delete mode 100644 mex/sources/libslicot/AB13BD.f delete mode 100644 mex/sources/libslicot/AB13CD.f delete mode 100644 mex/sources/libslicot/AB13DD.f delete mode 100644 mex/sources/libslicot/AB13DX.f delete mode 100644 mex/sources/libslicot/AB13ED.f delete mode 100644 mex/sources/libslicot/AB13FD.f delete mode 100644 mex/sources/libslicot/AB13MD.f delete mode 100644 mex/sources/libslicot/AB8NXZ.f delete mode 100644 mex/sources/libslicot/AG07BD.f delete mode 100644 mex/sources/libslicot/AG08BD.f delete mode 100644 mex/sources/libslicot/AG08BY.f delete mode 100644 mex/sources/libslicot/AG08BZ.f delete mode 100644 mex/sources/libslicot/AG8BYZ.f delete mode 100644 mex/sources/libslicot/BB01AD.f delete mode 100644 mex/sources/libslicot/BB02AD.f delete mode 100644 mex/sources/libslicot/BB03AD.f delete mode 100644 mex/sources/libslicot/BB04AD.f delete mode 100644 mex/sources/libslicot/BD01AD.f delete mode 100644 mex/sources/libslicot/BD02AD.f delete mode 100644 mex/sources/libslicot/DE01OD.f delete mode 100644 mex/sources/libslicot/DE01PD.f delete mode 100644 mex/sources/libslicot/DF01MD.f delete mode 100644 mex/sources/libslicot/DG01MD.f delete mode 100644 mex/sources/libslicot/DG01ND.f delete mode 100644 mex/sources/libslicot/DG01NY.f delete mode 100644 mex/sources/libslicot/DG01OD.f delete mode 100644 mex/sources/libslicot/DK01MD.f delete mode 100644 mex/sources/libslicot/FB01QD.f delete mode 100644 mex/sources/libslicot/FB01RD.f delete mode 100644 mex/sources/libslicot/FB01SD.f delete mode 100644 mex/sources/libslicot/FB01TD.f delete mode 100644 mex/sources/libslicot/FB01VD.f delete mode 100644 mex/sources/libslicot/FD01AD.f delete mode 100644 mex/sources/libslicot/IB01AD.f delete mode 100644 mex/sources/libslicot/IB01BD.f delete mode 100644 mex/sources/libslicot/IB01CD.f delete mode 100644 mex/sources/libslicot/IB01MD.f delete mode 100644 mex/sources/libslicot/IB01MY.f delete mode 100644 mex/sources/libslicot/IB01ND.f delete mode 100644 mex/sources/libslicot/IB01OD.f delete mode 100644 mex/sources/libslicot/IB01OY.f delete mode 100644 mex/sources/libslicot/IB01PD.f delete mode 100644 mex/sources/libslicot/IB01PX.f delete mode 100644 mex/sources/libslicot/IB01PY.f delete mode 100644 mex/sources/libslicot/IB01QD.f delete mode 100644 mex/sources/libslicot/IB01RD.f delete mode 100644 mex/sources/libslicot/IB03AD.f delete mode 100644 mex/sources/libslicot/IB03BD.f delete mode 100644 mex/sources/libslicot/MA01AD.f delete mode 100644 mex/sources/libslicot/MA02AD.f delete mode 100644 mex/sources/libslicot/MA02BD.f delete mode 100644 mex/sources/libslicot/MA02BZ.f delete mode 100644 mex/sources/libslicot/MA02CD.f delete mode 100644 mex/sources/libslicot/MA02CZ.f delete mode 100644 mex/sources/libslicot/MA02DD.f delete mode 100644 mex/sources/libslicot/MA02ED.f delete mode 100644 mex/sources/libslicot/MA02FD.f delete mode 100644 mex/sources/libslicot/MA02GD.f delete mode 100644 mex/sources/libslicot/MA02HD.f delete mode 100644 mex/sources/libslicot/MA02ID.f delete mode 100644 mex/sources/libslicot/MA02JD.f delete mode 100644 mex/sources/libslicot/MB01MD.f delete mode 100644 mex/sources/libslicot/MB01ND.f delete mode 100644 mex/sources/libslicot/MB01PD.f delete mode 100644 mex/sources/libslicot/MB01QD.f delete mode 100644 mex/sources/libslicot/MB01RD.f delete mode 100644 mex/sources/libslicot/MB01RU.f delete mode 100644 mex/sources/libslicot/MB01RW.f delete mode 100644 mex/sources/libslicot/MB01RX.f delete mode 100644 mex/sources/libslicot/MB01RY.f delete mode 100644 mex/sources/libslicot/MB01SD.f delete mode 100644 mex/sources/libslicot/MB01TD.f delete mode 100644 mex/sources/libslicot/MB01UD.f delete mode 100644 mex/sources/libslicot/MB01UW.f delete mode 100644 mex/sources/libslicot/MB01UX.f delete mode 100644 mex/sources/libslicot/MB01VD.f delete mode 100644 mex/sources/libslicot/MB01WD.f delete mode 100644 mex/sources/libslicot/MB01XD.f delete mode 100644 mex/sources/libslicot/MB01XY.f delete mode 100644 mex/sources/libslicot/MB01YD.f delete mode 100644 mex/sources/libslicot/MB01ZD.f delete mode 100644 mex/sources/libslicot/MB02CD.f delete mode 100644 mex/sources/libslicot/MB02CU.f delete mode 100644 mex/sources/libslicot/MB02CV.f delete mode 100644 mex/sources/libslicot/MB02CX.f delete mode 100644 mex/sources/libslicot/MB02CY.f delete mode 100644 mex/sources/libslicot/MB02DD.f delete mode 100644 mex/sources/libslicot/MB02ED.f delete mode 100644 mex/sources/libslicot/MB02FD.f delete mode 100644 mex/sources/libslicot/MB02GD.f delete mode 100644 mex/sources/libslicot/MB02HD.f delete mode 100644 mex/sources/libslicot/MB02ID.f delete mode 100644 mex/sources/libslicot/MB02JD.f delete mode 100644 mex/sources/libslicot/MB02JX.f delete mode 100644 mex/sources/libslicot/MB02KD.f delete mode 100644 mex/sources/libslicot/MB02MD.f delete mode 100644 mex/sources/libslicot/MB02ND.f delete mode 100644 mex/sources/libslicot/MB02NY.f delete mode 100644 mex/sources/libslicot/MB02OD.f delete mode 100644 mex/sources/libslicot/MB02PD.f delete mode 100644 mex/sources/libslicot/MB02QD.f delete mode 100644 mex/sources/libslicot/MB02QY.f delete mode 100644 mex/sources/libslicot/MB02RD.f delete mode 100644 mex/sources/libslicot/MB02RZ.f delete mode 100644 mex/sources/libslicot/MB02SD.f delete mode 100644 mex/sources/libslicot/MB02SZ.f delete mode 100644 mex/sources/libslicot/MB02TD.f delete mode 100644 mex/sources/libslicot/MB02TZ.f delete mode 100644 mex/sources/libslicot/MB02UD.f delete mode 100644 mex/sources/libslicot/MB02UU.f delete mode 100644 mex/sources/libslicot/MB02UV.f delete mode 100644 mex/sources/libslicot/MB02VD.f delete mode 100644 mex/sources/libslicot/MB02WD.f delete mode 100644 mex/sources/libslicot/MB02XD.f delete mode 100644 mex/sources/libslicot/MB02YD.f delete mode 100644 mex/sources/libslicot/MB03MD.f delete mode 100644 mex/sources/libslicot/MB03MY.f delete mode 100644 mex/sources/libslicot/MB03ND.f delete mode 100644 mex/sources/libslicot/MB03NY.f delete mode 100644 mex/sources/libslicot/MB03OD.f delete mode 100644 mex/sources/libslicot/MB03OY.f delete mode 100644 mex/sources/libslicot/MB03PD.f delete mode 100644 mex/sources/libslicot/MB03PY.f delete mode 100644 mex/sources/libslicot/MB03QD.f delete mode 100644 mex/sources/libslicot/MB03QX.f delete mode 100644 mex/sources/libslicot/MB03QY.f delete mode 100644 mex/sources/libslicot/MB03RD.f delete mode 100644 mex/sources/libslicot/MB03RX.f delete mode 100644 mex/sources/libslicot/MB03RY.f delete mode 100644 mex/sources/libslicot/MB03SD.f delete mode 100644 mex/sources/libslicot/MB03TD.f delete mode 100644 mex/sources/libslicot/MB03TS.f delete mode 100644 mex/sources/libslicot/MB03UD.f delete mode 100644 mex/sources/libslicot/MB03VD.f delete mode 100644 mex/sources/libslicot/MB03VY.f delete mode 100644 mex/sources/libslicot/MB03WA.f delete mode 100644 mex/sources/libslicot/MB03WD.f delete mode 100644 mex/sources/libslicot/MB03WX.f delete mode 100644 mex/sources/libslicot/MB03XD.f delete mode 100644 mex/sources/libslicot/MB03XP.f delete mode 100644 mex/sources/libslicot/MB03XU.f delete mode 100644 mex/sources/libslicot/MB03YA.f delete mode 100644 mex/sources/libslicot/MB03YD.f delete mode 100644 mex/sources/libslicot/MB03YT.f delete mode 100644 mex/sources/libslicot/MB03ZA.f delete mode 100644 mex/sources/libslicot/MB03ZD.f delete mode 100644 mex/sources/libslicot/MB04DD.f delete mode 100644 mex/sources/libslicot/MB04DI.f delete mode 100644 mex/sources/libslicot/MB04DS.f delete mode 100644 mex/sources/libslicot/MB04DY.f delete mode 100644 mex/sources/libslicot/MB04GD.f delete mode 100644 mex/sources/libslicot/MB04ID.f delete mode 100644 mex/sources/libslicot/MB04IY.f delete mode 100644 mex/sources/libslicot/MB04IZ.f delete mode 100644 mex/sources/libslicot/MB04JD.f delete mode 100644 mex/sources/libslicot/MB04KD.f delete mode 100644 mex/sources/libslicot/MB04LD.f delete mode 100644 mex/sources/libslicot/MB04MD.f delete mode 100644 mex/sources/libslicot/MB04ND.f delete mode 100644 mex/sources/libslicot/MB04NY.f delete mode 100644 mex/sources/libslicot/MB04OD.f delete mode 100644 mex/sources/libslicot/MB04OW.f delete mode 100644 mex/sources/libslicot/MB04OX.f delete mode 100644 mex/sources/libslicot/MB04OY.f delete mode 100644 mex/sources/libslicot/MB04PA.f delete mode 100644 mex/sources/libslicot/MB04PB.f delete mode 100644 mex/sources/libslicot/MB04PU.f delete mode 100644 mex/sources/libslicot/MB04PY.f delete mode 100644 mex/sources/libslicot/MB04QB.f delete mode 100644 mex/sources/libslicot/MB04QC.f delete mode 100644 mex/sources/libslicot/MB04QF.f delete mode 100644 mex/sources/libslicot/MB04QU.f delete mode 100644 mex/sources/libslicot/MB04TB.f delete mode 100644 mex/sources/libslicot/MB04TS.f delete mode 100644 mex/sources/libslicot/MB04TT.f delete mode 100644 mex/sources/libslicot/MB04TU.f delete mode 100644 mex/sources/libslicot/MB04TV.f delete mode 100644 mex/sources/libslicot/MB04TW.f delete mode 100644 mex/sources/libslicot/MB04TX.f delete mode 100644 mex/sources/libslicot/MB04TY.f delete mode 100644 mex/sources/libslicot/MB04UD.f delete mode 100644 mex/sources/libslicot/MB04VD.f delete mode 100644 mex/sources/libslicot/MB04VX.f delete mode 100644 mex/sources/libslicot/MB04WD.f delete mode 100644 mex/sources/libslicot/MB04WP.f delete mode 100644 mex/sources/libslicot/MB04WR.f delete mode 100644 mex/sources/libslicot/MB04WU.f delete mode 100644 mex/sources/libslicot/MB04XD.f delete mode 100644 mex/sources/libslicot/MB04XY.f delete mode 100644 mex/sources/libslicot/MB04YD.f delete mode 100644 mex/sources/libslicot/MB04YW.f delete mode 100644 mex/sources/libslicot/MB04ZD.f delete mode 100644 mex/sources/libslicot/MB05MD.f delete mode 100644 mex/sources/libslicot/MB05MY.f delete mode 100644 mex/sources/libslicot/MB05ND.f delete mode 100644 mex/sources/libslicot/MB05OD.f delete mode 100644 mex/sources/libslicot/MB05OY.f delete mode 100644 mex/sources/libslicot/MB3OYZ.f delete mode 100644 mex/sources/libslicot/MB3PYZ.f delete mode 100644 mex/sources/libslicot/MC01MD.f delete mode 100644 mex/sources/libslicot/MC01ND.f delete mode 100644 mex/sources/libslicot/MC01OD.f delete mode 100644 mex/sources/libslicot/MC01PD.f delete mode 100644 mex/sources/libslicot/MC01PY.f delete mode 100644 mex/sources/libslicot/MC01QD.f delete mode 100644 mex/sources/libslicot/MC01RD.f delete mode 100644 mex/sources/libslicot/MC01SD.f delete mode 100644 mex/sources/libslicot/MC01SW.f delete mode 100644 mex/sources/libslicot/MC01SX.f delete mode 100644 mex/sources/libslicot/MC01SY.f delete mode 100644 mex/sources/libslicot/MC01TD.f delete mode 100644 mex/sources/libslicot/MC01VD.f delete mode 100644 mex/sources/libslicot/MC01WD.f delete mode 100644 mex/sources/libslicot/MC03MD.f delete mode 100644 mex/sources/libslicot/MC03ND.f delete mode 100644 mex/sources/libslicot/MC03NX.f delete mode 100644 mex/sources/libslicot/MC03NY.f delete mode 100644 mex/sources/libslicot/MD03AD.f delete mode 100644 mex/sources/libslicot/MD03BA.f delete mode 100644 mex/sources/libslicot/MD03BB.f delete mode 100644 mex/sources/libslicot/MD03BD.f delete mode 100644 mex/sources/libslicot/MD03BF.f delete mode 100644 mex/sources/libslicot/MD03BX.f delete mode 100644 mex/sources/libslicot/MD03BY.f delete mode 100644 mex/sources/libslicot/NF01AD.f delete mode 100644 mex/sources/libslicot/NF01AY.f delete mode 100644 mex/sources/libslicot/NF01BA.f delete mode 100644 mex/sources/libslicot/NF01BB.f delete mode 100644 mex/sources/libslicot/NF01BD.f delete mode 100644 mex/sources/libslicot/NF01BE.f delete mode 100644 mex/sources/libslicot/NF01BF.f delete mode 100644 mex/sources/libslicot/NF01BP.f delete mode 100644 mex/sources/libslicot/NF01BQ.f delete mode 100644 mex/sources/libslicot/NF01BR.f delete mode 100644 mex/sources/libslicot/NF01BS.f delete mode 100644 mex/sources/libslicot/NF01BU.f delete mode 100644 mex/sources/libslicot/NF01BV.f delete mode 100644 mex/sources/libslicot/NF01BW.f delete mode 100644 mex/sources/libslicot/NF01BX.f delete mode 100644 mex/sources/libslicot/NF01BY.f delete mode 100644 mex/sources/libslicot/SB01BD.f delete mode 100644 mex/sources/libslicot/SB01BX.f delete mode 100644 mex/sources/libslicot/SB01BY.f delete mode 100644 mex/sources/libslicot/SB01DD.f delete mode 100644 mex/sources/libslicot/SB01FY.f delete mode 100644 mex/sources/libslicot/SB01MD.f delete mode 100644 mex/sources/libslicot/SB02CX.f delete mode 100644 mex/sources/libslicot/SB02MD.f delete mode 100644 mex/sources/libslicot/SB02MR.f delete mode 100644 mex/sources/libslicot/SB02MS.f delete mode 100644 mex/sources/libslicot/SB02MT.f delete mode 100644 mex/sources/libslicot/SB02MU.f delete mode 100644 mex/sources/libslicot/SB02MV.f delete mode 100644 mex/sources/libslicot/SB02MW.f delete mode 100644 mex/sources/libslicot/SB02ND.f delete mode 100644 mex/sources/libslicot/SB02OD.f delete mode 100644 mex/sources/libslicot/SB02OU.f delete mode 100644 mex/sources/libslicot/SB02OV.f delete mode 100644 mex/sources/libslicot/SB02OW.f delete mode 100644 mex/sources/libslicot/SB02OX.f delete mode 100644 mex/sources/libslicot/SB02OY.f delete mode 100644 mex/sources/libslicot/SB02PD.f delete mode 100644 mex/sources/libslicot/SB02QD.f delete mode 100644 mex/sources/libslicot/SB02RD.f delete mode 100644 mex/sources/libslicot/SB02RU.f delete mode 100644 mex/sources/libslicot/SB02SD.f delete mode 100644 mex/sources/libslicot/SB03MD.f delete mode 100644 mex/sources/libslicot/SB03MU.f delete mode 100644 mex/sources/libslicot/SB03MV.f delete mode 100644 mex/sources/libslicot/SB03MW.f delete mode 100644 mex/sources/libslicot/SB03MX.f delete mode 100644 mex/sources/libslicot/SB03MY.f delete mode 100644 mex/sources/libslicot/SB03OD.f delete mode 100644 mex/sources/libslicot/SB03OR.f delete mode 100644 mex/sources/libslicot/SB03OT.f delete mode 100644 mex/sources/libslicot/SB03OU.f delete mode 100644 mex/sources/libslicot/SB03OV.f delete mode 100644 mex/sources/libslicot/SB03OY.f delete mode 100644 mex/sources/libslicot/SB03PD.f delete mode 100644 mex/sources/libslicot/SB03QD.f delete mode 100644 mex/sources/libslicot/SB03QX.f delete mode 100644 mex/sources/libslicot/SB03QY.f delete mode 100644 mex/sources/libslicot/SB03RD.f delete mode 100644 mex/sources/libslicot/SB03SD.f delete mode 100644 mex/sources/libslicot/SB03SX.f delete mode 100644 mex/sources/libslicot/SB03SY.f delete mode 100644 mex/sources/libslicot/SB03TD.f delete mode 100644 mex/sources/libslicot/SB03UD.f delete mode 100644 mex/sources/libslicot/SB04MD.f delete mode 100644 mex/sources/libslicot/SB04MR.f delete mode 100644 mex/sources/libslicot/SB04MU.f delete mode 100644 mex/sources/libslicot/SB04MW.f delete mode 100644 mex/sources/libslicot/SB04MY.f delete mode 100644 mex/sources/libslicot/SB04ND.f delete mode 100644 mex/sources/libslicot/SB04NV.f delete mode 100644 mex/sources/libslicot/SB04NW.f delete mode 100644 mex/sources/libslicot/SB04NX.f delete mode 100644 mex/sources/libslicot/SB04NY.f delete mode 100644 mex/sources/libslicot/SB04OD.f delete mode 100644 mex/sources/libslicot/SB04OW.f delete mode 100644 mex/sources/libslicot/SB04PD.f delete mode 100644 mex/sources/libslicot/SB04PX.f delete mode 100644 mex/sources/libslicot/SB04PY.f delete mode 100644 mex/sources/libslicot/SB04QD.f delete mode 100644 mex/sources/libslicot/SB04QR.f delete mode 100644 mex/sources/libslicot/SB04QU.f delete mode 100644 mex/sources/libslicot/SB04QY.f delete mode 100644 mex/sources/libslicot/SB04RD.f delete mode 100644 mex/sources/libslicot/SB04RV.f delete mode 100644 mex/sources/libslicot/SB04RW.f delete mode 100644 mex/sources/libslicot/SB04RX.f delete mode 100644 mex/sources/libslicot/SB04RY.f delete mode 100644 mex/sources/libslicot/SB06ND.f delete mode 100644 mex/sources/libslicot/SB08CD.f delete mode 100644 mex/sources/libslicot/SB08DD.f delete mode 100644 mex/sources/libslicot/SB08ED.f delete mode 100644 mex/sources/libslicot/SB08FD.f delete mode 100644 mex/sources/libslicot/SB08GD.f delete mode 100644 mex/sources/libslicot/SB08HD.f delete mode 100644 mex/sources/libslicot/SB08MD.f delete mode 100644 mex/sources/libslicot/SB08MY.f delete mode 100644 mex/sources/libslicot/SB08ND.f delete mode 100644 mex/sources/libslicot/SB08NY.f delete mode 100644 mex/sources/libslicot/SB09MD.f delete mode 100644 mex/sources/libslicot/SB10AD.f delete mode 100644 mex/sources/libslicot/SB10DD.f delete mode 100644 mex/sources/libslicot/SB10ED.f delete mode 100644 mex/sources/libslicot/SB10FD.f delete mode 100644 mex/sources/libslicot/SB10HD.f delete mode 100644 mex/sources/libslicot/SB10ID.f delete mode 100644 mex/sources/libslicot/SB10JD.f delete mode 100644 mex/sources/libslicot/SB10KD.f delete mode 100644 mex/sources/libslicot/SB10LD.f delete mode 100644 mex/sources/libslicot/SB10MD.f delete mode 100644 mex/sources/libslicot/SB10PD.f delete mode 100644 mex/sources/libslicot/SB10QD.f delete mode 100644 mex/sources/libslicot/SB10RD.f delete mode 100644 mex/sources/libslicot/SB10SD.f delete mode 100644 mex/sources/libslicot/SB10TD.f delete mode 100644 mex/sources/libslicot/SB10UD.f delete mode 100644 mex/sources/libslicot/SB10VD.f delete mode 100644 mex/sources/libslicot/SB10WD.f delete mode 100644 mex/sources/libslicot/SB10YD.f delete mode 100644 mex/sources/libslicot/SB10ZD.f delete mode 100644 mex/sources/libslicot/SB10ZP.f delete mode 100644 mex/sources/libslicot/SB16AD.f delete mode 100644 mex/sources/libslicot/SB16AY.f delete mode 100644 mex/sources/libslicot/SB16BD.f delete mode 100644 mex/sources/libslicot/SB16CD.f delete mode 100644 mex/sources/libslicot/SB16CY.f delete mode 100644 mex/sources/libslicot/SG02AD.f delete mode 100644 mex/sources/libslicot/SG03AD.f delete mode 100644 mex/sources/libslicot/SG03AX.f delete mode 100644 mex/sources/libslicot/SG03AY.f delete mode 100644 mex/sources/libslicot/SG03BD.f delete mode 100644 mex/sources/libslicot/SG03BU.f delete mode 100644 mex/sources/libslicot/SG03BV.f delete mode 100644 mex/sources/libslicot/SG03BW.f delete mode 100644 mex/sources/libslicot/SG03BX.f delete mode 100644 mex/sources/libslicot/SG03BY.f delete mode 100644 mex/sources/libslicot/TB01ID.f delete mode 100644 mex/sources/libslicot/TB01IZ.f delete mode 100644 mex/sources/libslicot/TB01KD.f delete mode 100644 mex/sources/libslicot/TB01LD.f delete mode 100644 mex/sources/libslicot/TB01MD.f delete mode 100644 mex/sources/libslicot/TB01ND.f delete mode 100644 mex/sources/libslicot/TB01PD.f delete mode 100644 mex/sources/libslicot/TB01TD.f delete mode 100644 mex/sources/libslicot/TB01TY.f delete mode 100644 mex/sources/libslicot/TB01UD.f delete mode 100644 mex/sources/libslicot/TB01VD.f delete mode 100644 mex/sources/libslicot/TB01VY.f delete mode 100644 mex/sources/libslicot/TB01WD.f delete mode 100644 mex/sources/libslicot/TB01XD.f delete mode 100644 mex/sources/libslicot/TB01XZ.f delete mode 100644 mex/sources/libslicot/TB01YD.f delete mode 100644 mex/sources/libslicot/TB01ZD.f delete mode 100644 mex/sources/libslicot/TB03AD.f delete mode 100644 mex/sources/libslicot/TB03AY.f delete mode 100644 mex/sources/libslicot/TB04AD.f delete mode 100644 mex/sources/libslicot/TB04AY.f delete mode 100644 mex/sources/libslicot/TB04BD.f delete mode 100644 mex/sources/libslicot/TB04BV.f delete mode 100644 mex/sources/libslicot/TB04BW.f delete mode 100644 mex/sources/libslicot/TB04BX.f delete mode 100644 mex/sources/libslicot/TB04CD.f delete mode 100644 mex/sources/libslicot/TB05AD.f delete mode 100644 mex/sources/libslicot/TC01OD.f delete mode 100644 mex/sources/libslicot/TC04AD.f delete mode 100644 mex/sources/libslicot/TC05AD.f delete mode 100644 mex/sources/libslicot/TD03AD.f delete mode 100644 mex/sources/libslicot/TD03AY.f delete mode 100644 mex/sources/libslicot/TD04AD.f delete mode 100644 mex/sources/libslicot/TD05AD.f delete mode 100644 mex/sources/libslicot/TF01MD.f delete mode 100644 mex/sources/libslicot/TF01MX.f delete mode 100644 mex/sources/libslicot/TF01MY.f delete mode 100644 mex/sources/libslicot/TF01ND.f delete mode 100644 mex/sources/libslicot/TF01OD.f delete mode 100644 mex/sources/libslicot/TF01PD.f delete mode 100644 mex/sources/libslicot/TF01QD.f delete mode 100644 mex/sources/libslicot/TF01RD.f delete mode 100644 mex/sources/libslicot/TG01AD.f delete mode 100644 mex/sources/libslicot/TG01AZ.f delete mode 100644 mex/sources/libslicot/TG01BD.f delete mode 100644 mex/sources/libslicot/TG01CD.f delete mode 100644 mex/sources/libslicot/TG01DD.f delete mode 100644 mex/sources/libslicot/TG01ED.f delete mode 100644 mex/sources/libslicot/TG01FD.f delete mode 100644 mex/sources/libslicot/TG01FZ.f delete mode 100644 mex/sources/libslicot/TG01HD.f delete mode 100644 mex/sources/libslicot/TG01HX.f delete mode 100644 mex/sources/libslicot/TG01ID.f delete mode 100644 mex/sources/libslicot/TG01JD.f delete mode 100644 mex/sources/libslicot/TG01WD.f delete mode 100644 mex/sources/libslicot/UD01BD.f delete mode 100644 mex/sources/libslicot/UD01CD.f delete mode 100644 mex/sources/libslicot/UD01DD.f delete mode 100644 mex/sources/libslicot/UD01MD.f delete mode 100644 mex/sources/libslicot/UD01MZ.f delete mode 100644 mex/sources/libslicot/UD01ND.f delete mode 100644 mex/sources/libslicot/UE01MD.f delete mode 100644 mex/sources/libslicot/dcabs1.f delete mode 100644 mex/sources/libslicot/delctg.f delete mode 100644 mex/sources/libslicot/dhgeqz.f delete mode 100644 mex/sources/libslicot/dtgsy2.f delete mode 100644 mex/sources/libslicot/readme delete mode 100644 mex/sources/libslicot/select.f diff --git a/mex/build/kalman_steady_state.am b/mex/build/kalman_steady_state.am index 80ed84de6..735c4576c 100644 --- a/mex/build/kalman_steady_state.am +++ b/mex/build/kalman_steady_state.am @@ -1,6 +1,5 @@ noinst_PROGRAMS = kalman_steady_state -kalman_steady_state_LDADD = ../libslicot/libslicot.a -kalman_steady_state_LDADD +=../libslicot/libauxslicot.a +kalman_steady_state_LDADD = $(LIBADD_SLICOT) nodist_kalman_steady_state_SOURCES = $(top_srcdir)/../../sources/kalman_steady_state/kalman_steady_state.cc diff --git a/mex/build/libslicot.am b/mex/build/libslicot.am deleted file mode 100644 index d5d9b21ff..000000000 --- a/mex/build/libslicot.am +++ /dev/null @@ -1,478 +0,0 @@ -noinst_LIBRARIES = libslicot.a libauxslicot.a - -TOPDIR = $(top_srcdir)/../../sources/libslicot - -nodist_libslicot_a_SOURCES = \ - $(TOPDIR)/AB01MD.f \ - $(TOPDIR)/AB01ND.f \ - $(TOPDIR)/AB01OD.f \ - $(TOPDIR)/AB04MD.f \ - $(TOPDIR)/AB05MD.f \ - $(TOPDIR)/AB05ND.f \ - $(TOPDIR)/AB05OD.f \ - $(TOPDIR)/AB05PD.f \ - $(TOPDIR)/AB05QD.f \ - $(TOPDIR)/AB05RD.f \ - $(TOPDIR)/AB05SD.f \ - $(TOPDIR)/AB07MD.f \ - $(TOPDIR)/AB07ND.f \ - $(TOPDIR)/AB08MD.f \ - $(TOPDIR)/AB08MZ.f \ - $(TOPDIR)/AB08ND.f \ - $(TOPDIR)/AB08NX.f \ - $(TOPDIR)/AB08NZ.f \ - $(TOPDIR)/AB09AD.f \ - $(TOPDIR)/AB09AX.f \ - $(TOPDIR)/AB09BD.f \ - $(TOPDIR)/AB09BX.f \ - $(TOPDIR)/AB09CD.f \ - $(TOPDIR)/AB09CX.f \ - $(TOPDIR)/AB09DD.f \ - $(TOPDIR)/AB09ED.f \ - $(TOPDIR)/AB09FD.f \ - $(TOPDIR)/AB09GD.f \ - $(TOPDIR)/AB09HD.f \ - $(TOPDIR)/AB09HX.f \ - $(TOPDIR)/AB09HY.f \ - $(TOPDIR)/AB09ID.f \ - $(TOPDIR)/AB09IX.f \ - $(TOPDIR)/AB09IY.f \ - $(TOPDIR)/AB09JD.f \ - $(TOPDIR)/AB09JV.f \ - $(TOPDIR)/AB09JW.f \ - $(TOPDIR)/AB09JX.f \ - $(TOPDIR)/AB09KD.f \ - $(TOPDIR)/AB09KX.f \ - $(TOPDIR)/AB09MD.f \ - $(TOPDIR)/AB09ND.f \ - $(TOPDIR)/AB13AD.f \ - $(TOPDIR)/AB13AX.f \ - $(TOPDIR)/AB13BD.f \ - $(TOPDIR)/AB13CD.f \ - $(TOPDIR)/AB13DD.f \ - $(TOPDIR)/AB13DX.f \ - $(TOPDIR)/AB13ED.f \ - $(TOPDIR)/AB13FD.f \ - $(TOPDIR)/AB13MD.f \ - $(TOPDIR)/AB8NXZ.f \ - $(TOPDIR)/AG07BD.f \ - $(TOPDIR)/AG08BD.f \ - $(TOPDIR)/AG08BY.f \ - $(TOPDIR)/AG08BZ.f \ - $(TOPDIR)/AG8BYZ.f \ - $(TOPDIR)/BB01AD.f \ - $(TOPDIR)/BB02AD.f \ - $(TOPDIR)/BB03AD.f \ - $(TOPDIR)/BB04AD.f \ - $(TOPDIR)/BD01AD.f \ - $(TOPDIR)/BD02AD.f \ - $(TOPDIR)/DE01OD.f \ - $(TOPDIR)/DE01PD.f \ - $(TOPDIR)/delctg.f \ - $(TOPDIR)/DF01MD.f \ - $(TOPDIR)/DG01MD.f \ - $(TOPDIR)/DG01ND.f \ - $(TOPDIR)/DG01NY.f \ - $(TOPDIR)/DG01OD.f \ - $(TOPDIR)/DK01MD.f \ - $(TOPDIR)/FB01QD.f \ - $(TOPDIR)/FB01RD.f \ - $(TOPDIR)/FB01SD.f \ - $(TOPDIR)/FB01TD.f \ - $(TOPDIR)/FB01VD.f \ - $(TOPDIR)/FD01AD.f \ - $(TOPDIR)/IB01AD.f \ - $(TOPDIR)/IB01BD.f \ - $(TOPDIR)/IB01CD.f \ - $(TOPDIR)/IB01MD.f \ - $(TOPDIR)/IB01MY.f \ - $(TOPDIR)/IB01ND.f \ - $(TOPDIR)/IB01OD.f \ - $(TOPDIR)/IB01OY.f \ - $(TOPDIR)/IB01PD.f \ - $(TOPDIR)/IB01PX.f \ - $(TOPDIR)/IB01PY.f \ - $(TOPDIR)/IB01QD.f \ - $(TOPDIR)/IB01RD.f \ - $(TOPDIR)/IB03AD.f \ - $(TOPDIR)/IB03BD.f \ - $(TOPDIR)/MA01AD.f \ - $(TOPDIR)/MA02AD.f \ - $(TOPDIR)/MA02BD.f \ - $(TOPDIR)/MA02BZ.f \ - $(TOPDIR)/MA02CD.f \ - $(TOPDIR)/MA02CZ.f \ - $(TOPDIR)/MA02DD.f \ - $(TOPDIR)/MA02ED.f \ - $(TOPDIR)/MA02FD.f \ - $(TOPDIR)/MA02GD.f \ - $(TOPDIR)/MA02HD.f \ - $(TOPDIR)/MA02ID.f \ - $(TOPDIR)/MA02JD.f \ - $(TOPDIR)/MB01MD.f \ - $(TOPDIR)/MB01ND.f \ - $(TOPDIR)/MB01PD.f \ - $(TOPDIR)/MB01QD.f \ - $(TOPDIR)/MB01RD.f \ - $(TOPDIR)/MB01RU.f \ - $(TOPDIR)/MB01RW.f \ - $(TOPDIR)/MB01RX.f \ - $(TOPDIR)/MB01RY.f \ - $(TOPDIR)/MB01SD.f \ - $(TOPDIR)/MB01TD.f \ - $(TOPDIR)/MB01UD.f \ - $(TOPDIR)/MB01UW.f \ - $(TOPDIR)/MB01UX.f \ - $(TOPDIR)/MB01VD.f \ - $(TOPDIR)/MB01WD.f \ - $(TOPDIR)/MB01XD.f \ - $(TOPDIR)/MB01XY.f \ - $(TOPDIR)/MB01YD.f \ - $(TOPDIR)/MB01ZD.f \ - $(TOPDIR)/MB02CD.f \ - $(TOPDIR)/MB02CU.f \ - $(TOPDIR)/MB02CV.f \ - $(TOPDIR)/MB02CX.f \ - $(TOPDIR)/MB02CY.f \ - $(TOPDIR)/MB02DD.f \ - $(TOPDIR)/MB02ED.f \ - $(TOPDIR)/MB02FD.f \ - $(TOPDIR)/MB02GD.f \ - $(TOPDIR)/MB02HD.f \ - $(TOPDIR)/MB02ID.f \ - $(TOPDIR)/MB02JD.f \ - $(TOPDIR)/MB02JX.f \ - $(TOPDIR)/MB02KD.f \ - $(TOPDIR)/MB02MD.f \ - $(TOPDIR)/MB02ND.f \ - $(TOPDIR)/MB02NY.f \ - $(TOPDIR)/MB02OD.f \ - $(TOPDIR)/MB02PD.f \ - $(TOPDIR)/MB02QD.f \ - $(TOPDIR)/MB02QY.f \ - $(TOPDIR)/MB02RD.f \ - $(TOPDIR)/MB02RZ.f \ - $(TOPDIR)/MB02SD.f \ - $(TOPDIR)/MB02SZ.f \ - $(TOPDIR)/MB02TD.f \ - $(TOPDIR)/MB02TZ.f \ - $(TOPDIR)/MB02UD.f \ - $(TOPDIR)/MB02UU.f \ - $(TOPDIR)/MB02UV.f \ - $(TOPDIR)/MB02VD.f \ - $(TOPDIR)/MB02WD.f \ - $(TOPDIR)/MB02XD.f \ - $(TOPDIR)/MB02YD.f \ - $(TOPDIR)/MB03MD.f \ - $(TOPDIR)/MB03MY.f \ - $(TOPDIR)/MB03ND.f \ - $(TOPDIR)/MB03NY.f \ - $(TOPDIR)/MB03OD.f \ - $(TOPDIR)/MB03OY.f \ - $(TOPDIR)/MB03PD.f \ - $(TOPDIR)/MB03PY.f \ - $(TOPDIR)/MB03QD.f \ - $(TOPDIR)/MB03QX.f \ - $(TOPDIR)/MB03QY.f \ - $(TOPDIR)/MB03RD.f \ - $(TOPDIR)/MB03RX.f \ - $(TOPDIR)/MB03RY.f \ - $(TOPDIR)/MB03SD.f \ - $(TOPDIR)/MB03TD.f \ - $(TOPDIR)/MB03TS.f \ - $(TOPDIR)/MB03UD.f \ - $(TOPDIR)/MB03VD.f \ - $(TOPDIR)/MB03VY.f \ - $(TOPDIR)/MB03WA.f \ - $(TOPDIR)/MB03WD.f \ - $(TOPDIR)/MB03WX.f \ - $(TOPDIR)/MB03XD.f \ - $(TOPDIR)/MB03XP.f \ - $(TOPDIR)/MB03XU.f \ - $(TOPDIR)/MB03YA.f \ - $(TOPDIR)/MB03YD.f \ - $(TOPDIR)/MB03YT.f \ - $(TOPDIR)/MB03ZA.f \ - $(TOPDIR)/MB03ZD.f \ - $(TOPDIR)/MB04DD.f \ - $(TOPDIR)/MB04DI.f \ - $(TOPDIR)/MB04DS.f \ - $(TOPDIR)/MB04DY.f \ - $(TOPDIR)/MB04GD.f \ - $(TOPDIR)/MB04ID.f \ - $(TOPDIR)/MB04IY.f \ - $(TOPDIR)/MB04IZ.f \ - $(TOPDIR)/MB04JD.f \ - $(TOPDIR)/MB04KD.f \ - $(TOPDIR)/MB04LD.f \ - $(TOPDIR)/MB04MD.f \ - $(TOPDIR)/MB04ND.f \ - $(TOPDIR)/MB04NY.f \ - $(TOPDIR)/MB04OD.f \ - $(TOPDIR)/MB04OW.f \ - $(TOPDIR)/MB04OX.f \ - $(TOPDIR)/MB04OY.f \ - $(TOPDIR)/MB04PA.f \ - $(TOPDIR)/MB04PB.f \ - $(TOPDIR)/MB04PU.f \ - $(TOPDIR)/MB04PY.f \ - $(TOPDIR)/MB04QB.f \ - $(TOPDIR)/MB04QC.f \ - $(TOPDIR)/MB04QF.f \ - $(TOPDIR)/MB04QU.f \ - $(TOPDIR)/MB04TB.f \ - $(TOPDIR)/MB04TS.f \ - $(TOPDIR)/MB04TT.f \ - $(TOPDIR)/MB04TU.f \ - $(TOPDIR)/MB04TV.f \ - $(TOPDIR)/MB04TW.f \ - $(TOPDIR)/MB04TX.f \ - $(TOPDIR)/MB04TY.f \ - $(TOPDIR)/MB04UD.f \ - $(TOPDIR)/MB04VD.f \ - $(TOPDIR)/MB04VX.f \ - $(TOPDIR)/MB04WD.f \ - $(TOPDIR)/MB04WP.f \ - $(TOPDIR)/MB04WR.f \ - $(TOPDIR)/MB04WU.f \ - $(TOPDIR)/MB04XD.f \ - $(TOPDIR)/MB04XY.f \ - $(TOPDIR)/MB04YD.f \ - $(TOPDIR)/MB04YW.f \ - $(TOPDIR)/MB04ZD.f \ - $(TOPDIR)/MB05MD.f \ - $(TOPDIR)/MB05MY.f \ - $(TOPDIR)/MB05ND.f \ - $(TOPDIR)/MB05OD.f \ - $(TOPDIR)/MB05OY.f \ - $(TOPDIR)/MB3OYZ.f \ - $(TOPDIR)/MB3PYZ.f \ - $(TOPDIR)/MC01MD.f \ - $(TOPDIR)/MC01ND.f \ - $(TOPDIR)/MC01OD.f \ - $(TOPDIR)/MC01PD.f \ - $(TOPDIR)/MC01PY.f \ - $(TOPDIR)/MC01QD.f \ - $(TOPDIR)/MC01RD.f \ - $(TOPDIR)/MC01SD.f \ - $(TOPDIR)/MC01SW.f \ - $(TOPDIR)/MC01SX.f \ - $(TOPDIR)/MC01SY.f \ - $(TOPDIR)/MC01TD.f \ - $(TOPDIR)/MC01VD.f \ - $(TOPDIR)/MC01WD.f \ - $(TOPDIR)/MC03MD.f \ - $(TOPDIR)/MC03ND.f \ - $(TOPDIR)/MC03NX.f \ - $(TOPDIR)/MC03NY.f \ - $(TOPDIR)/MD03AD.f \ - $(TOPDIR)/MD03BA.f \ - $(TOPDIR)/MD03BB.f \ - $(TOPDIR)/MD03BD.f \ - $(TOPDIR)/MD03BF.f \ - $(TOPDIR)/MD03BX.f \ - $(TOPDIR)/MD03BY.f \ - $(TOPDIR)/NF01AD.f \ - $(TOPDIR)/NF01AY.f \ - $(TOPDIR)/NF01BA.f \ - $(TOPDIR)/NF01BB.f \ - $(TOPDIR)/NF01BD.f \ - $(TOPDIR)/NF01BE.f \ - $(TOPDIR)/NF01BF.f \ - $(TOPDIR)/NF01BP.f \ - $(TOPDIR)/NF01BQ.f \ - $(TOPDIR)/NF01BR.f \ - $(TOPDIR)/NF01BS.f \ - $(TOPDIR)/NF01BU.f \ - $(TOPDIR)/NF01BV.f \ - $(TOPDIR)/NF01BW.f \ - $(TOPDIR)/NF01BX.f \ - $(TOPDIR)/NF01BY.f \ - $(TOPDIR)/SB01BD.f \ - $(TOPDIR)/SB01BX.f \ - $(TOPDIR)/SB01BY.f \ - $(TOPDIR)/SB01DD.f \ - $(TOPDIR)/SB01FY.f \ - $(TOPDIR)/SB01MD.f \ - $(TOPDIR)/SB02CX.f \ - $(TOPDIR)/SB02MD.f \ - $(TOPDIR)/SB02MR.f \ - $(TOPDIR)/SB02MS.f \ - $(TOPDIR)/SB02MT.f \ - $(TOPDIR)/SB02MU.f \ - $(TOPDIR)/SB02MV.f \ - $(TOPDIR)/SB02MW.f \ - $(TOPDIR)/SB02ND.f \ - $(TOPDIR)/SB02OD.f \ - $(TOPDIR)/SB02OU.f \ - $(TOPDIR)/SB02OV.f \ - $(TOPDIR)/SB02OW.f \ - $(TOPDIR)/SB02OX.f \ - $(TOPDIR)/SB02OY.f \ - $(TOPDIR)/SB02PD.f \ - $(TOPDIR)/SB02QD.f \ - $(TOPDIR)/SB02RD.f \ - $(TOPDIR)/SB02RU.f \ - $(TOPDIR)/SB02SD.f \ - $(TOPDIR)/SB03MD.f \ - $(TOPDIR)/SB03MU.f \ - $(TOPDIR)/SB03MV.f \ - $(TOPDIR)/SB03MW.f \ - $(TOPDIR)/SB03MX.f \ - $(TOPDIR)/SB03MY.f \ - $(TOPDIR)/SB03OD.f \ - $(TOPDIR)/SB03OR.f \ - $(TOPDIR)/SB03OT.f \ - $(TOPDIR)/SB03OU.f \ - $(TOPDIR)/SB03OV.f \ - $(TOPDIR)/SB03OY.f \ - $(TOPDIR)/SB03PD.f \ - $(TOPDIR)/SB03QD.f \ - $(TOPDIR)/SB03QX.f \ - $(TOPDIR)/SB03QY.f \ - $(TOPDIR)/SB03RD.f \ - $(TOPDIR)/SB03SD.f \ - $(TOPDIR)/SB03SX.f \ - $(TOPDIR)/SB03SY.f \ - $(TOPDIR)/SB03TD.f \ - $(TOPDIR)/SB03UD.f \ - $(TOPDIR)/SB04MD.f \ - $(TOPDIR)/SB04MR.f \ - $(TOPDIR)/SB04MU.f \ - $(TOPDIR)/SB04MW.f \ - $(TOPDIR)/SB04MY.f \ - $(TOPDIR)/SB04ND.f \ - $(TOPDIR)/SB04NV.f \ - $(TOPDIR)/SB04NW.f \ - $(TOPDIR)/SB04NX.f \ - $(TOPDIR)/SB04NY.f \ - $(TOPDIR)/SB04OD.f \ - $(TOPDIR)/SB04OW.f \ - $(TOPDIR)/SB04PD.f \ - $(TOPDIR)/SB04PX.f \ - $(TOPDIR)/SB04PY.f \ - $(TOPDIR)/SB04QD.f \ - $(TOPDIR)/SB04QR.f \ - $(TOPDIR)/SB04QU.f \ - $(TOPDIR)/SB04QY.f \ - $(TOPDIR)/SB04RD.f \ - $(TOPDIR)/SB04RV.f \ - $(TOPDIR)/SB04RW.f \ - $(TOPDIR)/SB04RX.f \ - $(TOPDIR)/SB04RY.f \ - $(TOPDIR)/SB06ND.f \ - $(TOPDIR)/SB08CD.f \ - $(TOPDIR)/SB08DD.f \ - $(TOPDIR)/SB08ED.f \ - $(TOPDIR)/SB08FD.f \ - $(TOPDIR)/SB08GD.f \ - $(TOPDIR)/SB08HD.f \ - $(TOPDIR)/SB08MD.f \ - $(TOPDIR)/SB08MY.f \ - $(TOPDIR)/SB08ND.f \ - $(TOPDIR)/SB08NY.f \ - $(TOPDIR)/SB09MD.f \ - $(TOPDIR)/SB10AD.f \ - $(TOPDIR)/SB10DD.f \ - $(TOPDIR)/SB10ED.f \ - $(TOPDIR)/SB10FD.f \ - $(TOPDIR)/SB10HD.f \ - $(TOPDIR)/SB10ID.f \ - $(TOPDIR)/SB10JD.f \ - $(TOPDIR)/SB10KD.f \ - $(TOPDIR)/SB10LD.f \ - $(TOPDIR)/SB10MD.f \ - $(TOPDIR)/SB10PD.f \ - $(TOPDIR)/SB10QD.f \ - $(TOPDIR)/SB10RD.f \ - $(TOPDIR)/SB10SD.f \ - $(TOPDIR)/SB10TD.f \ - $(TOPDIR)/SB10UD.f \ - $(TOPDIR)/SB10VD.f \ - $(TOPDIR)/SB10WD.f \ - $(TOPDIR)/SB10YD.f \ - $(TOPDIR)/SB10ZD.f \ - $(TOPDIR)/SB10ZP.f \ - $(TOPDIR)/SB16AD.f \ - $(TOPDIR)/SB16AY.f \ - $(TOPDIR)/SB16BD.f \ - $(TOPDIR)/SB16CD.f \ - $(TOPDIR)/SB16CY.f \ - $(TOPDIR)/select.f \ - $(TOPDIR)/SG02AD.f \ - $(TOPDIR)/SG03AD.f \ - $(TOPDIR)/SG03AX.f \ - $(TOPDIR)/SG03AY.f \ - $(TOPDIR)/SG03BD.f \ - $(TOPDIR)/SG03BU.f \ - $(TOPDIR)/SG03BV.f \ - $(TOPDIR)/SG03BW.f \ - $(TOPDIR)/SG03BX.f \ - $(TOPDIR)/SG03BY.f \ - $(TOPDIR)/TB01ID.f \ - $(TOPDIR)/TB01IZ.f \ - $(TOPDIR)/TB01KD.f \ - $(TOPDIR)/TB01LD.f \ - $(TOPDIR)/TB01MD.f \ - $(TOPDIR)/TB01ND.f \ - $(TOPDIR)/TB01PD.f \ - $(TOPDIR)/TB01TD.f \ - $(TOPDIR)/TB01TY.f \ - $(TOPDIR)/TB01UD.f \ - $(TOPDIR)/TB01VD.f \ - $(TOPDIR)/TB01VY.f \ - $(TOPDIR)/TB01WD.f \ - $(TOPDIR)/TB01XD.f \ - $(TOPDIR)/TB01XZ.f \ - $(TOPDIR)/TB01YD.f \ - $(TOPDIR)/TB01ZD.f \ - $(TOPDIR)/TB03AD.f \ - $(TOPDIR)/TB03AY.f \ - $(TOPDIR)/TB04AD.f \ - $(TOPDIR)/TB04AY.f \ - $(TOPDIR)/TB04BD.f \ - $(TOPDIR)/TB04BV.f \ - $(TOPDIR)/TB04BW.f \ - $(TOPDIR)/TB04BX.f \ - $(TOPDIR)/TB04CD.f \ - $(TOPDIR)/TB05AD.f \ - $(TOPDIR)/TC01OD.f \ - $(TOPDIR)/TC04AD.f \ - $(TOPDIR)/TC05AD.f \ - $(TOPDIR)/TD03AD.f \ - $(TOPDIR)/TD03AY.f \ - $(TOPDIR)/TD04AD.f \ - $(TOPDIR)/TD05AD.f \ - $(TOPDIR)/TF01MD.f \ - $(TOPDIR)/TF01MX.f \ - $(TOPDIR)/TF01MY.f \ - $(TOPDIR)/TF01ND.f \ - $(TOPDIR)/TF01OD.f \ - $(TOPDIR)/TF01PD.f \ - $(TOPDIR)/TF01QD.f \ - $(TOPDIR)/TF01RD.f \ - $(TOPDIR)/TG01AD.f \ - $(TOPDIR)/TG01AZ.f \ - $(TOPDIR)/TG01BD.f \ - $(TOPDIR)/TG01CD.f \ - $(TOPDIR)/TG01DD.f \ - $(TOPDIR)/TG01ED.f \ - $(TOPDIR)/TG01FD.f \ - $(TOPDIR)/TG01FZ.f \ - $(TOPDIR)/TG01HD.f \ - $(TOPDIR)/TG01HX.f \ - $(TOPDIR)/TG01ID.f \ - $(TOPDIR)/TG01JD.f \ - $(TOPDIR)/TG01WD.f \ - $(TOPDIR)/UD01BD.f \ - $(TOPDIR)/UD01CD.f \ - $(TOPDIR)/UD01DD.f \ - $(TOPDIR)/UD01MD.f \ - $(TOPDIR)/UD01MZ.f \ - $(TOPDIR)/UD01ND.f \ - $(TOPDIR)/UE01MD.f - -nodist_libauxslicot_a_SOURCES = \ - $(TOPDIR)/dcabs1.f \ - $(TOPDIR)/dhgeqz.f \ - $(TOPDIR)/dtgsy2.f diff --git a/mex/build/matlab/Makefile.am b/mex/build/matlab/Makefile.am index 82904454f..ae91caf93 100644 --- a/mex/build/matlab/Makefile.am +++ b/mex/build/matlab/Makefile.am @@ -8,9 +8,8 @@ if HAVE_GSL SUBDIRS += ms_sbvar endif -# libslicot must come before kalman_steady_state -if HAVE_FORT -SUBDIRS += libslicot kalman_steady_state +if HAVE_SLICOT +SUBDIRS += kalman_steady_state endif if HAVE_M2HTML diff --git a/mex/build/matlab/configure.ac b/mex/build/matlab/configure.ac index ca948b4db..0072c6704 100644 --- a/mex/build/matlab/configure.ac +++ b/mex/build/matlab/configure.ac @@ -54,7 +54,6 @@ FFLAGS="$FFLAGS -Wall" CXXFLAGS="$CXXFLAGS -Wall -Wno-parentheses" AC_PROG_F77([gfortran g77 f77]) -AM_CONDITIONAL([HAVE_FORT], [test "x$F77" != "x"]) AC_PROG_CC AC_PROG_CXX AC_PROG_RANLIB @@ -77,6 +76,27 @@ AC_SUBST([LIBADD_DLOPEN]) AX_GSL AM_CONDITIONAL([HAVE_GSL], [test "x$has_gsl" = "xyes"]) +# Check for libslicot, needed by kalman_steady_state +AC_F77_FUNC(sb02od) +LDFLAGS_SAVED=$LDFLAGS +LDFLAGS=$MATLAB_LDFLAGS +case ${MATLAB_ARCH} in + glnxa64 | win64 | maci64) + AX_COMPARE_VERSION([$MATLAB_VERSION], [ge], [7.8], [use_64_bit_indexing=yes], [use_64_bit_indexing=no]) + ;; + *) + use_64_bit_indexing=no + ;; +esac +if test "$use_64_bit_indexing" = "yes"; then + AC_CHECK_LIB([slicot64_pic], [$sb02od], [LIBADD_SLICOT="-lslicot64_pic"], [], [$MATLAB_LIBS]) +else + AC_CHECK_LIB([slicot_pic], [$sb02od], [LIBADD_SLICOT="-lslicot_pic"], [], [$MATLAB_LIBS]) +fi +LDFLAGS=$LDFLAGS_SAVED +AC_SUBST([LIBADD_SLICOT]) +AM_CONDITIONAL([HAVE_SLICOT], [test "x$LIBADD_SLICOT" != "x"]) + AM_CONDITIONAL([DO_SOMETHING], [test "x$ax_enable_matlab" = "xyes" -a "x$ax_matlab_version_ok" = "xyes" -a "x$ax_mexopts_ok" = "xyes"]) if test "x$ax_enable_matlab" = "xyes" -a "x$ax_matlab_version_ok" = "xyes" -a "x$ax_mexopts_ok" = "xyes"; then @@ -89,10 +109,10 @@ else BUILD_MEX_MATLAB="no (missing MATLAB, or unknown version, or unknown architecture)" fi -if test "x$ax_enable_matlab" = "xyes" -a "x$ax_matlab_version_ok" = "xyes" -a "x$ax_mexopts_ok" = "xyes" -a "x$F77" != "x"; then +if test "x$ax_enable_matlab" = "xyes" -a "x$ax_matlab_version_ok" = "xyes" -a "x$ax_mexopts_ok" = "xyes" -a "x$LIBADD_SLICOT" != "x"; then BUILD_KALMAN_STEADY_STATE_MATLAB="yes" else - BUILD_KALMAN_STEADY_STATE_MATLAB="no (missing Fortran Compiler for compilation of libslicot)" + BUILD_KALMAN_STEADY_STATE_MATLAB="no (missing SLICOT)" fi if test "x$ax_enable_matlab" = "xyes" -a "x$ax_matlab_version_ok" = "xyes" -a "x$ax_mexopts_ok" = "xyes" -a "x$has_gsl" = "xyes"; then @@ -140,7 +160,6 @@ AC_CONFIG_FILES([Makefile k_order_perturbation/Makefile dynare_simul_/Makefile estimation/Makefile - libslicot/Makefile kalman_steady_state/Makefile ms_sbvar/Makefile block_kalman_filter/Makefile diff --git a/mex/build/matlab/libslicot/Makefile.am b/mex/build/matlab/libslicot/Makefile.am deleted file mode 100644 index 680519fea..000000000 --- a/mex/build/matlab/libslicot/Makefile.am +++ /dev/null @@ -1,2 +0,0 @@ -include ../mex.am -include ../../libslicot.am diff --git a/mex/build/octave/Makefile.am b/mex/build/octave/Makefile.am index 2689afab4..2b99916b8 100644 --- a/mex/build/octave/Makefile.am +++ b/mex/build/octave/Makefile.am @@ -10,9 +10,8 @@ SUBDIRS += ms_sbvar endif endif -# libslicot must come before kalman_steady_state -if HAVE_FORT -SUBDIRS += libslicot kalman_steady_state +if HAVE_SLICOT +SUBDIRS += kalman_steady_state endif if HAVE_MATIO diff --git a/mex/build/octave/configure.ac b/mex/build/octave/configure.ac index 0a1362799..187ae8a63 100644 --- a/mex/build/octave/configure.ac +++ b/mex/build/octave/configure.ac @@ -37,7 +37,6 @@ FFLAGS="$FFLAGS -Wall" CXXFLAGS="$CXXFLAGS -Wall -Wno-parentheses" AC_PROG_F77([gfortran g77 f77]) -AM_CONDITIONAL([HAVE_FORT], [test "x$F77" != "x"]) AC_PROG_CC AC_PROG_CXX AC_PROG_RANLIB @@ -66,6 +65,14 @@ AC_CHECK_LIB([matio], [Mat_Open], [LIBADD_MATIO="-lmatio"]) AC_SUBST([LIBADD_MATIO]) AM_CONDITIONAL([HAVE_MATIO], [test "x$ac_cv_header_matio_h" = "xyes" -a "x$ac_cv_lib_matio_Mat_Open" = "xyes"]) +# Check for libslicot, needed by kalman_steady_state +AC_F77_FUNC(sb02od) +AC_CHECK_LIB([slicot], [$sb02od], [LIBADD_SLICOT="-lslicot"], + [AC_CHECK_LIB([slicot_pic], [$sb02od], [LIBADD_SLICOT="-lslicot_pic"], [], [`$MKOCTFILE -p BLAS_LIBS` `$MKOCTFILE -p LAPACK_LIBS`])], # Fallback on libslicot_pic if dynamic libslicot not found + [`$MKOCTFILE -p BLAS_LIBS` `$MKOCTFILE -p LAPACK_LIBS`]) +AC_SUBST([LIBADD_SLICOT]) +AM_CONDITIONAL([HAVE_SLICOT], [test "x$LIBADD_SLICOT" != "x"]) + AM_CONDITIONAL([DO_SOMETHING], [test "x$MKOCTFILE" != "x"]) if test "x$MKOCTFILE" != "x"; then @@ -84,10 +91,10 @@ else BUILD_ESTIMATION_MEX_OCTAVE="no (missing MatIO library)" fi -if test "x$MKOCTFILE" != "x" -a "x$F77" != "x"; then +if test "x$MKOCTFILE" != "x" -a "x$LIBADD_SLICOT" != "x"; then BUILD_KALMAN_STEADY_STATE_OCTAVE="yes" else - BUILD_KALMAN_STEADY_STATE_OCTAVE="no (missing Fortran Compiler for compilation of libslicot)" + BUILD_KALMAN_STEADY_STATE_OCTAVE="no (missing SLICOT)" fi if test "x$MKOCTFILE" != "x" -a "x$has_gsl" = "xyes"; then @@ -127,7 +134,6 @@ AC_CONFIG_FILES([Makefile estimation/Makefile qzcomplex/Makefile ordschur/Makefile - libslicot/Makefile kalman_steady_state/Makefile ms_sbvar/Makefile block_kalman_filter/Makefile diff --git a/mex/build/octave/libslicot/Makefile.am b/mex/build/octave/libslicot/Makefile.am deleted file mode 100644 index 47b05ecff..000000000 --- a/mex/build/octave/libslicot/Makefile.am +++ /dev/null @@ -1,3 +0,0 @@ -EXEEXT = .mex -include ../mex.am -include ../../libslicot.am diff --git a/mex/sources/Makefile.am b/mex/sources/Makefile.am index 57934b164..2d9c6021d 100644 --- a/mex/sources/Makefile.am +++ b/mex/sources/Makefile.am @@ -10,7 +10,6 @@ EXTRA_DIST = \ qzcomplex \ k_order_perturbation \ ordschur \ - libslicot \ kalman_steady_state \ ms-sbvar \ block_kalman_filter \ diff --git a/mex/sources/libslicot/AB01MD.f b/mex/sources/libslicot/AB01MD.f deleted file mode 100644 index d00d02a82..000000000 --- a/mex/sources/libslicot/AB01MD.f +++ /dev/null @@ -1,402 +0,0 @@ - SUBROUTINE AB01MD( JOBZ, N, A, LDA, B, NCONT, Z, LDZ, TAU, TOL, - $ DWORK, LDWORK, INFO ) -C -C SLICOT RELEASE 5.0. -C -C Copyright (c) 2002-2009 NICONET e.V. -C -C This program is free software: you can redistribute it and/or -C modify it under the terms of the GNU General Public License as -C published by the Free Software Foundation, either version 2 of -C the License, or (at your option) any later version. -C -C This program is distributed in the hope that it will be useful, -C but WITHOUT ANY WARRANTY; without even the implied warranty of -C MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the -C GNU General Public License for more details. -C -C You should have received a copy of the GNU General Public License -C along with this program. If not, see -C . -C -C PURPOSE -C -C To find a controllable realization for the linear time-invariant -C single-input system -C -C dX/dt = A * X + B * U, -C -C where A is an N-by-N matrix and B is an N element vector which -C are reduced by this routine to orthogonal canonical form using -C (and optionally accumulating) orthogonal similarity -C transformations. -C -C ARGUMENTS -C -C Mode Parameters -C -C JOBZ CHARACTER*1 -C Indicates whether the user wishes to accumulate in a -C matrix Z the orthogonal similarity transformations for -C reducing the system, as follows: -C = 'N': Do not form Z and do not store the orthogonal -C transformations; -C = 'F': Do not form Z, but store the orthogonal -C transformations in the factored form; -C = 'I': Z is initialized to the unit matrix and the -C orthogonal transformation matrix Z is returned. -C -C Input/Output Parameters -C -C N (input) INTEGER -C The order of the original state-space representation, -C i.e. the order of the matrix A. N >= 0. -C -C A (input/output) DOUBLE PRECISION array, dimension (LDA,N) -C On entry, the leading N-by-N part of this array must -C contain the original state dynamics matrix A. -C On exit, the leading NCONT-by-NCONT upper Hessenberg -C part of this array contains the canonical form of the -C state dynamics matrix, given by Z' * A * Z, of a -C controllable realization for the original system. The -C elements below the first subdiagonal are set to zero. -C -C LDA INTEGER -C The leading dimension of array A. LDA >= MAX(1,N). -C -C B (input/output) DOUBLE PRECISION array, dimension (N) -C On entry, the original input/state vector B. -C On exit, the leading NCONT elements of this array contain -C canonical form of the input/state vector, given by Z' * B, -C with all elements but B(1) set to zero. -C -C NCONT (output) INTEGER -C The order of the controllable state-space representation. -C -C Z (output) DOUBLE PRECISION array, dimension (LDZ,N) -C If JOBZ = 'I', then the leading N-by-N part of this array -C contains the matrix of accumulated orthogonal similarity -C transformations which reduces the given system to -C orthogonal canonical form. -C If JOBZ = 'F', the elements below the diagonal, with the -C array TAU, represent the orthogonal transformation matrix -C as a product of elementary reflectors. The transformation -C matrix can then be obtained by calling the LAPACK Library -C routine DORGQR. -C If JOBZ = 'N', the array Z is not referenced and can be -C supplied as a dummy array (i.e. set parameter LDZ = 1 and -C declare this array to be Z(1,1) in the calling program). -C -C LDZ INTEGER -C The leading dimension of array Z. If JOBZ = 'I' or -C JOBZ = 'F', LDZ >= MAX(1,N); if JOBZ = 'N', LDZ >= 1. -C -C TAU (output) DOUBLE PRECISION array, dimension (N) -C The elements of TAU contain the scalar factors of the -C elementary reflectors used in the reduction of B and A. -C -C Tolerances -C -C TOL DOUBLE PRECISION -C The tolerance to be used in determining the -C controllability of (A,B). If the user sets TOL > 0, then -C the given value of TOL is used as an absolute tolerance; -C elements with absolute value less than TOL are considered -C neglijible. If the user sets TOL <= 0, then an implicitly -C computed, default tolerance, defined by -C TOLDEF = N*EPS*MAX( NORM(A), NORM(B) ) is used instead, -C where EPS is the machine precision (see LAPACK Library -C routine DLAMCH). -C -C Workspace -C -C DWORK DOUBLE PRECISION array, dimension (LDWORK) -C On exit, if INFO = 0, DWORK(1) returns the optimal value -C of LDWORK. -C -C LDWORK INTEGER -C The length of the array DWORK. LDWORK >= MAX(1,N). -C For optimum performance LDWORK should be larger. -C -C Error Indicator -C -C INFO INTEGER -C = 0: successful exit; -C < 0: if INFO = -i, the i-th argument had an illegal -C value. -C -C METHOD -C -C The Householder matrix which reduces all but the first element -C of vector B to zero is found and this orthogonal similarity -C transformation is applied to the matrix A. The resulting A is then -C reduced to upper Hessenberg form by a sequence of Householder -C transformations. Finally, the order of the controllable state- -C space representation (NCONT) is determined by finding the position -C of the first sub-diagonal element of A which is below an -C appropriate zero threshold, either TOL or TOLDEF (see parameter -C TOL); if NORM(B) is smaller than this threshold, NCONT is set to -C zero, and no computations for reducing the system to orthogonal -C canonical form are performed. -C -C REFERENCES -C -C [1] Konstantinov, M.M., Petkov, P.Hr. and Christov, N.D. -C Orthogonal Invariants and Canonical Forms for Linear -C Controllable Systems. -C Proc. 8th IFAC World Congress, Kyoto, 1, pp. 49-54, 1981. -C -C [2] Hammarling, S.J. -C Notes on the use of orthogonal similarity transformations in -C control. -C NPL Report DITC 8/82, August 1982. -C -C [3] Paige, C.C -C Properties of numerical algorithms related to computing -C controllability. -C IEEE Trans. Auto. Contr., AC-26, pp. 130-138, 1981. -C -C NUMERICAL ASPECTS -C 3 -C The algorithm requires 0(N ) operations and is backward stable. -C -C CONTRIBUTOR -C -C Release 3.0: V. Sima, Katholieke Univ. Leuven, Belgium, Oct. 1996. -C Supersedes Release 2.0 routine AB01AD by T.W.C. Williams, -C Kingston Polytechnic, United Kingdom, October 1982. -C -C REVISIONS -C -C V. Sima, February 16, 1998, October 19, 2001, February 2, 2005. -C -C KEYWORDS -C -C Controllability, minimal realization, orthogonal canonical form, -C orthogonal transformation. -C -C ****************************************************************** -C -C .. Parameters .. - DOUBLE PRECISION ZERO, ONE - PARAMETER ( ZERO = 0.0D0, ONE = 1.0D0 ) -C .. Scalar Arguments .. - CHARACTER JOBZ - INTEGER INFO, LDA, LDZ, LDWORK, N, NCONT - DOUBLE PRECISION TOL -C .. Array Arguments .. - DOUBLE PRECISION A(LDA,*), B(*), DWORK(*), TAU(*), Z(LDZ,*) -C .. Local Scalars .. - LOGICAL LJOBF, LJOBI, LJOBZ - INTEGER ITAU, J - DOUBLE PRECISION ANORM, B1, BNORM, FANORM, FBNORM, H, THRESH, - $ TOLDEF, WRKOPT -C .. Local Arrays .. - DOUBLE PRECISION NBLK(1) -C .. External Functions .. - LOGICAL LSAME - DOUBLE PRECISION DLAMCH, DLANGE - EXTERNAL DLAMCH, DLANGE, LSAME -C .. External Subroutines .. - EXTERNAL DGEHRD, DLACPY, DLARF, DLARFG, DLASET, DORGQR, - $ MB01PD, XERBLA -C .. Intrinsic Functions .. - INTRINSIC ABS, DBLE, MAX -C .. Executable Statements .. -C - INFO = 0 - LJOBF = LSAME( JOBZ, 'F' ) - LJOBI = LSAME( JOBZ, 'I' ) - LJOBZ = LJOBF.OR.LJOBI -C -C Test the input scalar arguments. -C - IF( .NOT.LJOBZ .AND. .NOT.LSAME( JOBZ, 'N' ) ) THEN - INFO = -1 - ELSE IF( N.LT.0 ) THEN - INFO = -2 - ELSE IF( LDA.LT.MAX(1,N) ) THEN - INFO = -4 - ELSE IF( .NOT.LJOBZ .AND. LDZ.LT.1 .OR. - $ LJOBZ .AND. LDZ.LT.MAX(1,N) ) THEN - INFO = -8 - ELSE IF( LDWORK.LT.MAX( 1, N ) ) THEN - INFO = -12 - END IF -C - IF ( INFO.NE.0 ) THEN -C -C Error return. -C - CALL XERBLA( 'AB01MD', -INFO ) - RETURN - END IF -C -C Quick return if possible. -C - NCONT = 0 - DWORK(1) = ONE - IF ( N.EQ.0 ) - $ RETURN -C -C (Note: Comments in the code beginning "Workspace:" describe the -C minimal amount of real workspace needed at that point in the -C code, as well as the preferred amount for good performance. -C NB refers to the optimal block size for the immediately -C following subroutine, as returned by ILAENV.) -C - WRKOPT = ONE -C -C Calculate the absolute norms of A and B (used for scaling). -C - ANORM = DLANGE( 'M', N, N, A, LDA, DWORK ) - BNORM = DLANGE( 'M', N, 1, B, N, DWORK ) -C -C Return if matrix B is zero. -C - IF( BNORM.EQ.ZERO ) THEN - IF( LJOBF ) THEN - CALL DLASET( 'F', N, N, ZERO, ZERO, Z, LDZ ) - CALL DLASET( 'F', N, 1, ZERO, ZERO, TAU, N ) - ELSE IF( LJOBI ) THEN - CALL DLASET( 'F', N, N, ZERO, ONE, Z, LDZ ) - END IF - RETURN - END IF -C -C Scale (if needed) the matrices A and B. -C - CALL MB01PD( 'S', 'G', N, N, 0, 0, ANORM, 0, NBLK, A, LDA, INFO ) - CALL MB01PD( 'S', 'G', N, 1, 0, 0, BNORM, 0, NBLK, B, N, INFO ) -C -C Calculate the Frobenius norm of A and the 1-norm of B (used for -C controlability test). -C - FANORM = DLANGE( 'F', N, N, A, LDA, DWORK ) - FBNORM = DLANGE( '1', N, 1, B, N, DWORK ) -C - TOLDEF = TOL - IF ( TOLDEF.LE.ZERO ) THEN -C -C Use the default tolerance in controllability determination. -C - THRESH = DBLE(N)*DLAMCH( 'EPSILON' ) - TOLDEF = THRESH*MAX( FANORM, FBNORM ) - END IF -C - ITAU = 1 - IF ( FBNORM.GT.TOLDEF ) THEN -C -C B is not negligible compared with A. -C - IF ( N.GT.1 ) THEN -C -C Transform B by a Householder matrix Z1: store vector -C describing this temporarily in B and in the local scalar H. -C - CALL DLARFG( N, B(1), B(2), 1, H ) -C - B1 = B(1) - B(1) = ONE -C -C Form Z1 * A * Z1. -C - CALL DLARF( 'R', N, N, B, 1, H, A, LDA, DWORK ) - CALL DLARF( 'L', N, N, B, 1, H, A, LDA, DWORK ) -C - B(1) = B1 - TAU(1) = H - ITAU = ITAU + 1 - ELSE - B1 = B(1) - END IF -C -C Reduce modified A to upper Hessenberg form by an orthogonal -C similarity transformation with matrix Z2. -C Workspace: need N; prefer N*NB. -C - CALL DGEHRD( N, 1, N, A, LDA, TAU(ITAU), DWORK, LDWORK, INFO ) - WRKOPT = DWORK(1) -C - IF ( LJOBZ ) THEN -C -C Save the orthogonal transformations used, so that they could -C be accumulated by calling DORGQR routine. -C - IF ( N.GT.1 ) - $ CALL DLACPY( 'F', N-1, 1, B(2), N-1, Z(2,1), LDZ ) - IF ( N.GT.2 ) - $ CALL DLACPY( 'L', N-2, N-2, A(3,1), LDA, Z(3,2), LDZ ) - IF ( LJOBI ) THEN -C -C Form the orthogonal transformation matrix Z = Z1 * Z2. -C Workspace: need N; prefer N*NB. -C - CALL DORGQR( N, N, N, Z, LDZ, TAU, DWORK, LDWORK, INFO ) - WRKOPT = MAX( WRKOPT, DWORK(1) ) - END IF - END IF -C -C Annihilate the lower part of A and B. -C - IF ( N.GT.2 ) - $ CALL DLASET( 'L', N-2, N-2, ZERO, ZERO, A(3,1), LDA ) - IF ( N.GT.1 ) - $ CALL DLASET( 'F', N-1, 1, ZERO, ZERO, B(2), N-1 ) -C -C Find NCONT by checking sizes of the sub-diagonal elements of -C transformed A. -C - IF ( TOL.LE.ZERO ) TOLDEF = THRESH*MAX( FANORM, ABS( B1 ) ) -C - J = 1 -C -C WHILE ( J < N and ABS( A(J+1,J) ) > TOLDEF ) DO -C - 10 CONTINUE - IF ( J.LT.N ) THEN - IF ( ABS( A(J+1,J) ).GT.TOLDEF ) THEN - J = J + 1 - GO TO 10 - END IF - END IF -C -C END WHILE 10 -C -C First negligible sub-diagonal element found, if any: set NCONT. -C - NCONT = J - IF ( J.LT.N ) A(J+1,J) = ZERO -C -C Undo scaling of A and B. -C - CALL MB01PD( 'U', 'H', NCONT, NCONT, 0, 0, ANORM, 0, NBLK, A, - $ LDA, INFO ) - CALL MB01PD( 'U', 'G', 1, 1, 0, 0, BNORM, 0, NBLK, B, N, INFO ) - IF ( NCONT.LT.N ) - $ CALL MB01PD( 'U', 'G', N, N-NCONT, 0, 0, ANORM, 0, NBLK, - $ A(1,NCONT+1), LDA, INFO ) - ELSE -C -C B is negligible compared with A. No computations for reducing -C the system to orthogonal canonical form have been performed, -C except scaling (which is undoed). -C - IF( LJOBF ) THEN - CALL DLASET( 'F', N, N, ZERO, ZERO, Z, LDZ ) - CALL DLASET( 'F', N, 1, ZERO, ZERO, TAU, N ) - ELSE IF( LJOBI ) THEN - CALL DLASET( 'F', N, N, ZERO, ONE, Z, LDZ ) - END IF - CALL MB01PD( 'U', 'G', N, N, 0, 0, ANORM, 0, NBLK, A, LDA, - $ INFO ) - CALL MB01PD( 'U', 'G', N, 1, 0, 0, BNORM, 0, NBLK, B, N, INFO ) - END IF -C -C Set optimal workspace dimension. -C - DWORK(1) = WRKOPT -C - RETURN -C *** Last line of AB01MD *** - END diff --git a/mex/sources/libslicot/AB01ND.f b/mex/sources/libslicot/AB01ND.f deleted file mode 100644 index c6280fcbe..000000000 --- a/mex/sources/libslicot/AB01ND.f +++ /dev/null @@ -1,470 +0,0 @@ - SUBROUTINE AB01ND( JOBZ, N, M, A, LDA, B, LDB, NCONT, INDCON, - $ NBLK, Z, LDZ, TAU, TOL, IWORK, DWORK, LDWORK, - $ INFO ) -C -C SLICOT RELEASE 5.0. -C -C Copyright (c) 2002-2009 NICONET e.V. -C -C This program is free software: you can redistribute it and/or -C modify it under the terms of the GNU General Public License as -C published by the Free Software Foundation, either version 2 of -C the License, or (at your option) any later version. -C -C This program is distributed in the hope that it will be useful, -C but WITHOUT ANY WARRANTY; without even the implied warranty of -C MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the -C GNU General Public License for more details. -C -C You should have received a copy of the GNU General Public License -C along with this program. If not, see -C . -C -C PURPOSE -C -C To find a controllable realization for the linear time-invariant -C multi-input system -C -C dX/dt = A * X + B * U, -C -C where A and B are N-by-N and N-by-M matrices, respectively, -C which are reduced by this routine to orthogonal canonical form -C using (and optionally accumulating) orthogonal similarity -C transformations. Specifically, the pair (A, B) is reduced to -C the pair (Ac, Bc), Ac = Z' * A * Z, Bc = Z' * B, given by -C -C [ Acont * ] [ Bcont ] -C Ac = [ ], Bc = [ ], -C [ 0 Auncont ] [ 0 ] -C -C and -C -C [ A11 A12 . . . A1,p-1 A1p ] [ B1 ] -C [ A21 A22 . . . A2,p-1 A2p ] [ 0 ] -C [ 0 A32 . . . A3,p-1 A3p ] [ 0 ] -C Acont = [ . . . . . . . ], Bc = [ . ], -C [ . . . . . . ] [ . ] -C [ . . . . . ] [ . ] -C [ 0 0 . . . Ap,p-1 App ] [ 0 ] -C -C where the blocks B1, A21, ..., Ap,p-1 have full row ranks and -C p is the controllability index of the pair. The size of the -C block Auncont is equal to the dimension of the uncontrollable -C subspace of the pair (A, B). -C -C ARGUMENTS -C -C Mode Parameters -C -C JOBZ CHARACTER*1 -C Indicates whether the user wishes to accumulate in a -C matrix Z the orthogonal similarity transformations for -C reducing the system, as follows: -C = 'N': Do not form Z and do not store the orthogonal -C transformations; -C = 'F': Do not form Z, but store the orthogonal -C transformations in the factored form; -C = 'I': Z is initialized to the unit matrix and the -C orthogonal transformation matrix Z is returned. -C -C Input/Output Parameters -C -C N (input) INTEGER -C The order of the original state-space representation, -C i.e. the order of the matrix A. N >= 0. -C -C M (input) INTEGER -C The number of system inputs, or of columns of B. M >= 0. -C -C A (input/output) DOUBLE PRECISION array, dimension (LDA,N) -C On entry, the leading N-by-N part of this array must -C contain the original state dynamics matrix A. -C On exit, the leading NCONT-by-NCONT part contains the -C upper block Hessenberg state dynamics matrix Acont in Ac, -C given by Z' * A * Z, of a controllable realization for -C the original system. The elements below the first block- -C subdiagonal are set to zero. -C -C LDA INTEGER -C The leading dimension of array A. LDA >= MAX(1,N). -C -C B (input/output) DOUBLE PRECISION array, dimension (LDB,M) -C On entry, the leading N-by-M part of this array must -C contain the input matrix B. -C On exit, the leading NCONT-by-M part of this array -C contains the transformed input matrix Bcont in Bc, given -C by Z' * B, with all elements but the first block set to -C zero. -C -C LDB INTEGER -C The leading dimension of array B. LDB >= MAX(1,N). -C -C NCONT (output) INTEGER -C The order of the controllable state-space representation. -C -C INDCON (output) INTEGER -C The controllability index of the controllable part of the -C system representation. -C -C NBLK (output) INTEGER array, dimension (N) -C The leading INDCON elements of this array contain the -C the orders of the diagonal blocks of Acont. -C -C Z (output) DOUBLE PRECISION array, dimension (LDZ,N) -C If JOBZ = 'I', then the leading N-by-N part of this -C array contains the matrix of accumulated orthogonal -C similarity transformations which reduces the given system -C to orthogonal canonical form. -C If JOBZ = 'F', the elements below the diagonal, with the -C array TAU, represent the orthogonal transformation matrix -C as a product of elementary reflectors. The transformation -C matrix can then be obtained by calling the LAPACK Library -C routine DORGQR. -C If JOBZ = 'N', the array Z is not referenced and can be -C supplied as a dummy array (i.e. set parameter LDZ = 1 and -C declare this array to be Z(1,1) in the calling program). -C -C LDZ INTEGER -C The leading dimension of array Z. If JOBZ = 'I' or -C JOBZ = 'F', LDZ >= MAX(1,N); if JOBZ = 'N', LDZ >= 1. -C -C TAU (output) DOUBLE PRECISION array, dimension (N) -C The elements of TAU contain the scalar factors of the -C elementary reflectors used in the reduction of B and A. -C -C Tolerances -C -C TOL DOUBLE PRECISION -C The tolerance to be used in rank determination when -C transforming (A, B). If the user sets TOL > 0, then -C the given value of TOL is used as a lower bound for the -C reciprocal condition number (see the description of the -C argument RCOND in the SLICOT routine MB03OD); a -C (sub)matrix whose estimated condition number is less than -C 1/TOL is considered to be of full rank. If the user sets -C TOL <= 0, then an implicitly computed, default tolerance, -C defined by TOLDEF = N*N*EPS, is used instead, where EPS -C is the machine precision (see LAPACK Library routine -C DLAMCH). -C -C Workspace -C -C IWORK INTEGER array, dimension (M) -C -C DWORK DOUBLE PRECISION array, dimension (LDWORK) -C On exit, if INFO = 0, DWORK(1) returns the optimal value -C of LDWORK. -C -C LDWORK INTEGER -C The length of the array DWORK. -C LDWORK >= MAX(1, N, 3*M). -C For optimum performance LDWORK should be larger. -C -C Error Indicator -C -C INFO INTEGER -C = 0: successful exit; -C < 0: if INFO = -i, the i-th argument had an illegal -C value. -C -C METHOD -C -C Matrix B is first QR-decomposed and the appropriate orthogonal -C similarity transformation applied to the matrix A. Leaving the -C first rank(B) states unchanged, the remaining lower left block -C of A is then QR-decomposed and the new orthogonal matrix, Q1, -C is also applied to the right of A to complete the similarity -C transformation. By continuing in this manner, a completely -C controllable state-space pair (Acont, Bcont) is found for the -C given (A, B), where Acont is upper block Hessenberg with each -C subdiagonal block of full row rank, and Bcont is zero apart from -C its (independent) first rank(B) rows. -C NOTE that the system controllability indices are easily -C calculated from the dimensions of the blocks of Acont. -C -C REFERENCES -C -C [1] Konstantinov, M.M., Petkov, P.Hr. and Christov, N.D. -C Orthogonal Invariants and Canonical Forms for Linear -C Controllable Systems. -C Proc. 8th IFAC World Congress, Kyoto, 1, pp. 49-54, 1981. -C -C [2] Paige, C.C. -C Properties of numerical algorithms related to computing -C controllablity. -C IEEE Trans. Auto. Contr., AC-26, pp. 130-138, 1981. -C -C [3] Petkov, P.Hr., Konstantinov, M.M., Gu, D.W. and -C Postlethwaite, I. -C Optimal Pole Assignment Design of Linear Multi-Input Systems. -C Leicester University, Report 99-11, May 1996. -C -C NUMERICAL ASPECTS -C 3 -C The algorithm requires 0(N ) operations and is backward stable. -C -C FURTHER COMMENTS -C -C If the system matrices A and B are badly scaled, it would be -C useful to scale them with SLICOT routine TB01ID, before calling -C the routine. -C -C CONTRIBUTOR -C -C Release 3.0: V. Sima, Katholieke Univ. Leuven, Belgium, Nov. 1996. -C Supersedes Release 2.0 routine AB01BD by P.Hr. Petkov. -C -C REVISIONS -C -C January 14, 1997, June 4, 1997, February 13, 1998, -C September 22, 2003, February 29, 2004. -C -C KEYWORDS -C -C Controllability, minimal realization, orthogonal canonical form, -C orthogonal transformation. -C -C ****************************************************************** -C -C .. Parameters .. - DOUBLE PRECISION ZERO, ONE - PARAMETER ( ZERO = 0.0D0, ONE = 1.0D0 ) -C .. Scalar Arguments .. - CHARACTER JOBZ - INTEGER INDCON, INFO, LDA, LDB, LDWORK, LDZ, M, N, NCONT - DOUBLE PRECISION TOL -C .. Array Arguments .. - DOUBLE PRECISION A(LDA,*), B(LDB,*), DWORK(*), TAU(*), Z(LDZ,*) - INTEGER IWORK(*), NBLK(*) -C .. Local Scalars .. - LOGICAL LJOBF, LJOBI, LJOBZ - INTEGER IQR, ITAU, J, MCRT, NBL, NCRT, NI, NJ, RANK, - $ WRKOPT - DOUBLE PRECISION ANORM, BNORM, FNRM, TOLDEF -C .. Local Arrays .. - DOUBLE PRECISION SVAL(3) -C .. External Functions .. - LOGICAL LSAME - DOUBLE PRECISION DLAMCH, DLANGE, DLAPY2 - EXTERNAL DLAMCH, DLANGE, DLAPY2, LSAME -C .. External Subroutines .. - EXTERNAL DCOPY, DLACPY, DLAPMT, DLASET, DORGQR, DORMQR, - $ MB01PD, MB03OY, XERBLA -C .. Intrinsic Functions .. - INTRINSIC DBLE, INT, MAX, MIN -C .. -C .. Executable Statements .. -C - INFO = 0 - LJOBF = LSAME( JOBZ, 'F' ) - LJOBI = LSAME( JOBZ, 'I' ) - LJOBZ = LJOBF.OR.LJOBI -C -C Test the input scalar arguments. -C - IF( .NOT.LJOBZ .AND. .NOT.LSAME( JOBZ, 'N' ) ) THEN - INFO = -1 - ELSE IF( N.LT.0 ) THEN - INFO = -2 - ELSE IF( M.LT.0 ) THEN - INFO = -3 - ELSE IF( LDA.LT.MAX( 1, N ) ) THEN - INFO = -5 - ELSE IF( LDB.LT.MAX( 1, N ) ) THEN - INFO = -7 - ELSE IF( LDZ.LT.1 .OR. ( LJOBZ .AND. LDZ.LT.N ) ) THEN - INFO = -12 - ELSE IF( LDWORK.LT.MAX( 1, N, 3*M ) ) THEN - INFO = -17 - END IF -C - IF ( INFO.NE.0 ) THEN -C -C Error return. -C - CALL XERBLA( 'AB01ND', -INFO ) - RETURN - END IF -C - NCONT = 0 - INDCON = 0 -C -C Quick return if possible. -C - IF ( MIN( N, M ).EQ.0 ) THEN - IF( N.GT.0 ) THEN - IF ( LJOBI ) THEN - CALL DLASET( 'Full', N, N, ZERO, ONE, Z, LDZ ) - ELSE IF ( LJOBF ) THEN - CALL DLASET( 'Full', N, N, ZERO, ZERO, Z, LDZ ) - CALL DLASET( 'Full', N, 1, ZERO, ZERO, TAU, N ) - END IF - END IF - DWORK(1) = ONE - RETURN - END IF -C -C Calculate the absolute norms of A and B (used for scaling). -C - ANORM = DLANGE( 'M', N, N, A, LDA, DWORK ) - BNORM = DLANGE( 'M', N, M, B, LDB, DWORK ) -C -C Return if matrix B is zero. -C - IF( BNORM.EQ.ZERO ) THEN - IF ( LJOBI ) THEN - CALL DLASET( 'Full', N, N, ZERO, ONE, Z, LDZ ) - ELSE IF ( LJOBF ) THEN - CALL DLASET( 'Full', N, N, ZERO, ZERO, Z, LDZ ) - CALL DLASET( 'Full', N, 1, ZERO, ZERO, TAU, N ) - END IF - DWORK(1) = ONE - RETURN - END IF -C -C Scale (if needed) the matrices A and B. -C - CALL MB01PD( 'Scale', 'G', N, N, 0, 0, ANORM, 0, NBLK, A, LDA, - $ INFO ) - CALL MB01PD( 'Scale', 'G', N, M, 0, 0, BNORM, 0, NBLK, B, LDB, - $ INFO ) -C -C Compute the Frobenius norm of [ B A ] (used for rank estimation). -C - FNRM = DLAPY2( DLANGE( 'F', N, M, B, LDB, DWORK ), - $ DLANGE( 'F', N, N, A, LDA, DWORK ) ) -C - TOLDEF = TOL - IF ( TOLDEF.LE.ZERO ) THEN -C -C Use the default tolerance in controllability determination. -C - TOLDEF = DBLE( N*N )*DLAMCH( 'EPSILON' ) - END IF -C - WRKOPT = 1 - NI = 0 - ITAU = 1 - NCRT = N - MCRT = M - IQR = 1 -C -C (Note: Comments in the code beginning "Workspace:" describe the -C minimal amount of real workspace needed at that point in the -C code, as well as the preferred amount for good performance. -C NB refers to the optimal block size for the immediately -C following subroutine, as returned by ILAENV.) -C - 10 CONTINUE -C -C Rank-revealing QR decomposition with column pivoting. -C The calculation is performed in NCRT rows of B starting from -C the row IQR (initialized to 1 and then set to rank(B)+1). -C Workspace: 3*MCRT. -C - CALL MB03OY( NCRT, MCRT, B(IQR,1), LDB, TOLDEF, FNRM, RANK, - $ SVAL, IWORK, TAU(ITAU), DWORK, INFO ) -C - IF ( RANK.NE.0 ) THEN - NJ = NI - NI = NCONT - NCONT = NCONT + RANK - INDCON = INDCON + 1 - NBLK(INDCON) = RANK -C -C Premultiply and postmultiply the appropriate block row -C and block column of A by Q' and Q, respectively. -C Workspace: need NCRT; -C prefer NCRT*NB. -C - CALL DORMQR( 'Left', 'Transpose', NCRT, NCRT, RANK, - $ B(IQR,1), LDB, TAU(ITAU), A(NI+1,NI+1), LDA, - $ DWORK, LDWORK, INFO ) - WRKOPT = MAX( WRKOPT, INT( DWORK(1) ) ) -C -C Workspace: need N; -C prefer N*NB. -C - CALL DORMQR( 'Right', 'No transpose', N, NCRT, RANK, - $ B(IQR,1), LDB, TAU(ITAU), A(1,NI+1), LDA, - $ DWORK, LDWORK, INFO ) - WRKOPT = MAX( WRKOPT, INT( DWORK(1) ) ) -C -C If required, save transformations. -C - IF ( LJOBZ.AND.NCRT.GT.1 ) THEN - CALL DLACPY( 'L', NCRT-1, MIN( RANK, NCRT-1 ), - $ B(IQR+1,1), LDB, Z(NI+2,ITAU), LDZ ) - END IF -C -C Zero the subdiagonal elements of the current matrix. -C - IF ( RANK.GT.1 ) - $ CALL DLASET( 'L', RANK-1, RANK-1, ZERO, ZERO, B(IQR+1,1), - $ LDB ) -C -C Backward permutation of the columns of B or A. -C - IF ( INDCON.EQ.1 ) THEN - CALL DLAPMT( .FALSE., RANK, M, B(IQR,1), LDB, IWORK ) - IQR = RANK + 1 - ELSE - DO 20 J = 1, MCRT - CALL DCOPY( RANK, B(IQR,J), 1, A(NI+1,NJ+IWORK(J)), - $ 1 ) - 20 CONTINUE - END IF -C - ITAU = ITAU + RANK - IF ( RANK.NE.NCRT ) THEN - MCRT = RANK - NCRT = NCRT - RANK - CALL DLACPY( 'G', NCRT, MCRT, A(NCONT+1,NI+1), LDA, - $ B(IQR,1), LDB ) - CALL DLASET( 'G', NCRT, MCRT, ZERO, ZERO, - $ A(NCONT+1,NI+1), LDA ) - GO TO 10 - END IF - END IF -C -C If required, accumulate transformations. -C Workspace: need N; prefer N*NB. -C - IF ( LJOBI ) THEN - CALL DORGQR( N, N, MAX( 1, ITAU-1 ), Z, LDZ, TAU, DWORK, - $ LDWORK, INFO ) - WRKOPT = MAX( WRKOPT, INT( DWORK(1) ) ) - END IF -C -C Annihilate the trailing blocks of B. -C - IF ( N.GE.IQR ) - $ CALL DLASET( 'G', N-IQR+1, M, ZERO, ZERO, B(IQR,1), LDB ) -C -C Annihilate the trailing elements of TAU, if JOBZ = 'F'. -C - IF ( LJOBF ) THEN - DO 30 J = ITAU, N - TAU(J) = ZERO - 30 CONTINUE - END IF -C -C Undo scaling of A and B. -C - IF ( INDCON.LT.N ) THEN - NBL = INDCON + 1 - NBLK(NBL) = N - NCONT - ELSE - NBL = 0 - END IF - CALL MB01PD( 'Undo', 'H', N, N, 0, 0, ANORM, NBL, NBLK, A, - $ LDA, INFO ) - CALL MB01PD( 'Undo', 'G', NBLK(1), M, 0, 0, BNORM, 0, NBLK, B, - $ LDB, INFO ) -C -C Set optimal workspace dimension. -C - DWORK(1) = WRKOPT - RETURN -C *** Last line of AB01ND *** - END diff --git a/mex/sources/libslicot/AB01OD.f b/mex/sources/libslicot/AB01OD.f deleted file mode 100644 index f85ed5626..000000000 --- a/mex/sources/libslicot/AB01OD.f +++ /dev/null @@ -1,535 +0,0 @@ - SUBROUTINE AB01OD( STAGES, JOBU, JOBV, N, M, A, LDA, B, LDB, U, - $ LDU, V, LDV, NCONT, INDCON, KSTAIR, TOL, IWORK, - $ DWORK, LDWORK, INFO ) -C -C SLICOT RELEASE 5.0. -C -C Copyright (c) 2002-2009 NICONET e.V. -C -C This program is free software: you can redistribute it and/or -C modify it under the terms of the GNU General Public License as -C published by the Free Software Foundation, either version 2 of -C the License, or (at your option) any later version. -C -C This program is distributed in the hope that it will be useful, -C but WITHOUT ANY WARRANTY; without even the implied warranty of -C MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the -C GNU General Public License for more details. -C -C You should have received a copy of the GNU General Public License -C along with this program. If not, see -C . -C -C PURPOSE -C -C To reduce the matrices A and B using (and optionally accumulating) -C state-space and input-space transformations U and V respectively, -C such that the pair of matrices -C -C Ac = U' * A * U, Bc = U' * B * V -C -C are in upper "staircase" form. Specifically, -C -C [ Acont * ] [ Bcont ] -C Ac = [ ], Bc = [ ], -C [ 0 Auncont ] [ 0 ] -C -C and -C -C [ A11 A12 . . . A1,p-1 A1p ] [ B1 ] -C [ A21 A22 . . . A2,p-1 A2p ] [ 0 ] -C [ 0 A32 . . . A3,p-1 A3p ] [ 0 ] -C Acont = [ . . . . . . . ], Bc = [ . ], -C [ . . . . . . ] [ . ] -C [ . . . . . ] [ . ] -C [ 0 0 . . . Ap,p-1 App ] [ 0 ] -C -C where the blocks B1, A21, ..., Ap,p-1 have full row ranks and -C p is the controllability index of the pair. The size of the -C block Auncont is equal to the dimension of the uncontrollable -C subspace of the pair (A, B). The first stage of the reduction, -C the "forward" stage, accomplishes the reduction to the orthogonal -C canonical form (see SLICOT library routine AB01ND). The blocks -C B1, A21, ..., Ap,p-1 are further reduced in a second, "backward" -C stage to upper triangular form using RQ factorization. Each of -C these stages is optional. -C -C ARGUMENTS -C -C Mode Parameters -C -C STAGES CHARACTER*1 -C Specifies the reduction stages to be performed as follows: -C = 'F': Perform the forward stage only; -C = 'B': Perform the backward stage only; -C = 'A': Perform both (all) stages. -C -C JOBU CHARACTER*1 -C Indicates whether the user wishes to accumulate in a -C matrix U the state-space transformations as follows: -C = 'N': Do not form U; -C = 'I': U is internally initialized to the unit matrix (if -C STAGES <> 'B'), or updated (if STAGES = 'B'), and -C the orthogonal transformation matrix U is -C returned. -C -C JOBV CHARACTER*1 -C Indicates whether the user wishes to accumulate in a -C matrix V the input-space transformations as follows: -C = 'N': Do not form V; -C = 'I': V is initialized to the unit matrix and the -C orthogonal transformation matrix V is returned. -C JOBV is not referenced if STAGES = 'F'. -C -C Input/Output Parameters -C -C N (input) INTEGER -C The actual state dimension, i.e. the order of the -C matrix A. N >= 0. -C -C M (input) INTEGER -C The actual input dimension. M >= 0. -C -C A (input/output) DOUBLE PRECISION array, dimension (LDA,N) -C On entry, the leading N-by-N part of this array must -C contain the state transition matrix A to be transformed. -C If STAGES = 'B', A should be in the orthogonal canonical -C form, as returned by SLICOT library routine AB01ND. -C On exit, the leading N-by-N part of this array contains -C the transformed state transition matrix U' * A * U. -C The leading NCONT-by-NCONT part contains the upper block -C Hessenberg state matrix Acont in Ac, given by U' * A * U, -C of a controllable realization for the original system. -C The elements below the first block-subdiagonal are set to -C zero. If STAGES <> 'F', the subdiagonal blocks of A are -C triangularized by RQ factorization, and the annihilated -C elements are explicitly zeroed. -C -C LDA INTEGER -C The leading dimension of array A. LDA >= MAX(1,N). -C -C B (input/output) DOUBLE PRECISION array, dimension (LDB,M) -C On entry, the leading N-by-M part of this array must -C contain the input matrix B to be transformed. -C If STAGES = 'B', B should be in the orthogonal canonical -C form, as returned by SLICOT library routine AB01ND. -C On exit with STAGES = 'F', the leading N-by-M part of -C this array contains the transformed input matrix U' * B, -C with all elements but the first block set to zero. -C On exit with STAGES <> 'F', the leading N-by-M part of -C this array contains the transformed input matrix -C U' * B * V, with all elements but the first block set to -C zero and the first block in upper triangular form. -C -C LDB INTEGER -C The leading dimension of array B. LDB >= MAX(1,N). -C -C U (input/output) DOUBLE PRECISION array, dimension (LDU,N) -C If STAGES <> 'B' or JOBU = 'N', then U need not be set -C on entry. -C If STAGES = 'B' and JOBU = 'I', then, on entry, the -C leading N-by-N part of this array must contain the -C transformation matrix U that reduced the pair to the -C orthogonal canonical form. -C On exit, if JOBU = 'I', the leading N-by-N part of this -C array contains the transformation matrix U that performed -C the specified reduction. -C If JOBU = 'N', the array U is not referenced and can be -C supplied as a dummy array (i.e. set parameter LDU = 1 and -C declare this array to be U(1,1) in the calling program). -C -C LDU INTEGER -C The leading dimension of array U. -C If JOBU = 'I', LDU >= MAX(1,N); if JOBU = 'N', LDU >= 1. -C -C V (output) DOUBLE PRECISION array, dimension (LDV,M) -C If JOBV = 'I', then the leading M-by-M part of this array -C contains the transformation matrix V. -C If STAGES = 'F', or JOBV = 'N', the array V is not -C referenced and can be supplied as a dummy array (i.e. set -C parameter LDV = 1 and declare this array to be V(1,1) in -C the calling program). -C -C LDV INTEGER -C The leading dimension of array V. -C If STAGES <> 'F' and JOBV = 'I', LDV >= MAX(1,M); -C if STAGES = 'F' or JOBV = 'N', LDV >= 1. -C -C NCONT (input/output) INTEGER -C The order of the controllable state-space representation. -C NCONT is input only if STAGES = 'B'. -C -C INDCON (input/output) INTEGER -C The number of stairs in the staircase form (also, the -C controllability index of the controllable part of the -C system representation). -C INDCON is input only if STAGES = 'B'. -C -C KSTAIR (input/output) INTEGER array, dimension (N) -C The leading INDCON elements of this array contain the -C dimensions of the stairs, or, also, the orders of the -C diagonal blocks of Acont. -C KSTAIR is input if STAGES = 'B', and output otherwise. -C -C Tolerances -C -C TOL DOUBLE PRECISION -C The tolerance to be used in rank determination when -C transforming (A, B). If the user sets TOL > 0, then -C the given value of TOL is used as a lower bound for the -C reciprocal condition number (see the description of the -C argument RCOND in the SLICOT routine MB03OD); a -C (sub)matrix whose estimated condition number is less than -C 1/TOL is considered to be of full rank. If the user sets -C TOL <= 0, then an implicitly computed, default tolerance, -C defined by TOLDEF = N*N*EPS, is used instead, where EPS -C is the machine precision (see LAPACK Library routine -C DLAMCH). -C TOL is not referenced if STAGES = 'B'. -C -C Workspace -C -C IWORK INTEGER array, dimension (M) -C IWORK is not referenced if STAGES = 'B'. -C -C DWORK DOUBLE PRECISION array, dimension (LDWORK) -C On exit, if INFO = 0, DWORK(1) returns the optimal value -C of LDWORK. -C -C LDWORK INTEGER -C The length of the array DWORK. -C If STAGES <> 'B', LDWORK >= MAX(1, N + MAX(N,3*M)); -C If STAGES = 'B', LDWORK >= MAX(1, M + MAX(N,M)). -C For optimum performance LDWORK should be larger. -C -C Error Indicator -C -C INFO INTEGER -C = 0: successful exit; -C < 0: if INFO = -i, the i-th argument had an illegal -C value. -C -C METHOD -C -C Staircase reduction of the pencil [B|sI - A] is used. Orthogonal -C transformations U and V are constructed such that -C -C -C |B |sI-A * . . . * * | -C | 1| 11 . . . | -C | | A sI-A . . . | -C | | 21 22 . . . | -C | | . . * * | -C [U'BV|sI - U'AU] = |0 | 0 . . | -C | | A sI-A * | -C | | p,p-1 pp | -C | | | -C |0 | 0 0 sI-A | -C | | p+1,p+1| -C -C -C where the i-th diagonal block of U'AU has dimension KSTAIR(i), -C for i = 1,...,p. The value of p is returned in INDCON. The last -C block contains the uncontrollable modes of the (A,B)-pair which -C are also the generalized eigenvalues of the above pencil. -C -C The complete reduction is performed in two stages. The first, -C forward stage accomplishes the reduction to the orthogonal -C canonical form. The second, backward stage consists in further -C reduction to triangular form by applying left and right orthogonal -C transformations. -C -C REFERENCES -C -C [1] Van Dooren, P. -C The generalized eigenvalue problem in linear system theory. -C IEEE Trans. Auto. Contr., AC-26, pp. 111-129, 1981. -C -C [2] Miminis, G. and Paige, C. -C An algorithm for pole assignment of time-invariant multi-input -C linear systems. -C Proc. 21st IEEE CDC, Orlando, Florida, 1, pp. 62-67, 1982. -C -C NUMERICAL ASPECTS -C -C The algorithm requires O((N + M) x N**2) operations and is -C backward stable (see [1]). -C -C FURTHER COMMENTS -C -C If the system matrices A and B are badly scaled, it would be -C useful to scale them with SLICOT routine TB01ID, before calling -C the routine. -C -C CONTRIBUTOR -C -C Release 3.0: V. Sima, Katholieke Univ. Leuven, Belgium, Nov. 1996. -C Supersedes Release 2.0 routine AB01CD by M. Vanbegin, and -C P. Van Dooren, Philips Research Laboratory, Brussels, Belgium. -C -C REVISIONS -C -C January 14, 1997, February 12, 1998, September 22, 2003. -C -C KEYWORDS -C -C Controllability, generalized eigenvalue problem, orthogonal -C transformation, staircase form. -C -C ****************************************************************** -C -C .. Parameters .. - DOUBLE PRECISION ZERO, ONE - PARAMETER ( ZERO = 0.0D0, ONE = 1.0D0 ) -C .. Scalar Arguments .. - CHARACTER JOBU, JOBV, STAGES - INTEGER INDCON, INFO, LDA, LDB, LDU, LDV, LDWORK, M, N, - $ NCONT - DOUBLE PRECISION TOL -C .. Array Arguments .. - INTEGER IWORK(*), KSTAIR(*) - DOUBLE PRECISION A(LDA,*), B(LDB,*), DWORK(*), U(LDU,*), V(LDV,*) -C .. Local Scalars .. - LOGICAL LJOBUI, LJOBVI, LSTAGB, LSTGAB - INTEGER I, I0, IBSTEP, ITAU, J0, JINI, JWORK, MCRT, MM, - $ NCRT, WRKOPT -C .. External Functions .. - LOGICAL LSAME - EXTERNAL LSAME -C .. External Subroutines .. - EXTERNAL AB01ND, DGERQF, DLACPY, DLASET, DORGRQ, DORMRQ, - $ DSWAP, XERBLA -C .. Intrinsic Functions .. - INTRINSIC INT, MAX, MIN -C .. Executable Statements .. -C - INFO = 0 - LJOBUI = LSAME( JOBU, 'I' ) -C - LSTAGB = LSAME( STAGES, 'B' ) - LSTGAB = LSAME( STAGES, 'A' ).OR.LSTAGB -C - IF ( LSTGAB ) THEN - LJOBVI = LSAME( JOBV, 'I' ) - END IF -C -C Test the input scalar arguments. -C - IF( .NOT.LSTGAB .AND. .NOT.LSAME( STAGES, 'F' ) ) THEN - INFO = -1 - ELSE IF( .NOT.LJOBUI .AND. .NOT.LSAME( JOBU, 'N' ) ) THEN - INFO = -2 - ELSE IF( N.LT.0 ) THEN - INFO = -4 - ELSE IF( M.LT.0 ) THEN - INFO = -5 - ELSE IF( LDA.LT.MAX( 1, N ) ) THEN - INFO = -7 - ELSE IF( LDB.LT.MAX( 1, N ) ) THEN - INFO = -9 - ELSE IF( LDU.LT.1 .OR. ( LJOBUI .AND. LDU.LT.N ) ) THEN - INFO = -11 - ELSE IF( .NOT.LSTAGB .AND. LDWORK.LT.MAX( 1, N + MAX( N, 3*M ) ) - $ .OR. LSTAGB .AND. LDWORK.LT.MAX( 1, M + MAX( N, M ) ) ) - $ THEN - INFO = -20 - ELSE IF( LSTAGB .AND. NCONT.GT.N ) THEN - INFO = -14 - ELSE IF( LSTAGB .AND. INDCON.GT.N ) THEN - INFO = -15 - ELSE IF( LSTGAB ) THEN - IF( .NOT.LJOBVI .AND. .NOT.LSAME( JOBV, 'N' ) ) THEN - INFO = -3 - ELSE IF( LDV.LT.1 .OR. ( LJOBVI .AND. LDV.LT.M ) ) THEN - INFO = -13 - END IF - END IF -C - IF ( INFO.NE.0 ) THEN -C -C Error return. -C - CALL XERBLA( 'AB01OD', -INFO ) - RETURN - END IF -C -C Quick return if possible. -C - IF ( MIN( N, M ).EQ.0 ) THEN - NCONT = 0 - INDCON = 0 - IF( N.GT.0 .AND. LJOBUI ) - $ CALL DLASET( 'F', N, N, ZERO, ONE, U, LDU ) - IF( LSTGAB ) THEN - IF( M.GT.0 .AND. LJOBVI ) - $ CALL DLASET( 'F', M, M, ZERO, ONE, V, LDV ) - END IF - DWORK(1) = ONE - RETURN - END IF -C -C (Note: Comments in the code beginning "Workspace:" describe the -C minimal amount of real workspace needed at that point in the -C code, as well as the preferred amount for good performance. -C NB refers to the optimal block size for the immediately -C following subroutine, as returned by ILAENV.) -C - ITAU = 1 - WRKOPT = 1 -C - IF ( .NOT.LSTAGB ) THEN -C -C Perform the forward stage computations of the staircase -C algorithm on B and A: reduce the (A, B) pair to orthogonal -C canonical form. -C -C Workspace: N + MAX(N,3*M). -C - JWORK = N + 1 - CALL AB01ND( JOBU, N, M, A, LDA, B, LDB, NCONT, INDCON, - $ KSTAIR, U, LDU, DWORK(ITAU), TOL, IWORK, - $ DWORK(JWORK), LDWORK-JWORK+1, INFO ) -C - WRKOPT = INT( DWORK(JWORK) ) + JWORK - 1 - END IF -C -C Exit if no further reduction to triangularize B1 and subdiagonal -C blocks of A is required, or if the order of the controllable part -C is 0. -C - IF ( .NOT.LSTGAB ) THEN - DWORK(1) = WRKOPT - RETURN - ELSE IF ( NCONT.EQ.0 .OR. INDCON.EQ.0 ) THEN - IF( LJOBVI ) - $ CALL DLASET( 'F', M, M, ZERO, ONE, V, LDV ) - DWORK(1) = WRKOPT - RETURN - END IF -C -C Now perform the backward steps except the last one. -C - MCRT = KSTAIR(INDCON) - I0 = NCONT - MCRT + 1 - JWORK = M + 1 -C - DO 10 IBSTEP = INDCON, 2, -1 - NCRT = KSTAIR(IBSTEP-1) - J0 = I0 - NCRT - MM = MIN( NCRT, MCRT ) -C -C Compute the RQ factorization of the current subdiagonal block -C of A, Ai,i-1 = R*Q (where i is IBSTEP), of dimension -C MCRT-by-NCRT, starting in position (I0,J0). -C The matrix Q' should postmultiply U, if required. -C Workspace: need M + MCRT; -C prefer M + MCRT*NB. -C - CALL DGERQF( MCRT, NCRT, A(I0,J0), LDA, DWORK(ITAU), - $ DWORK(JWORK), LDWORK-JWORK+1, INFO ) - WRKOPT = MAX( WRKOPT, INT( DWORK(JWORK) )+JWORK-1 ) -C -C Set JINI to the first column number in A where the current -C transformation Q is to be applied, taking the block Hessenberg -C form into account. -C - IF ( IBSTEP.GT.2 ) THEN - JINI = J0 - KSTAIR(IBSTEP-2) - ELSE - JINI = 1 -C -C Premultiply the first block row (B1) of B by Q. -C Workspace: need 2*M; -C prefer M + M*NB. -C - CALL DORMRQ( 'Left', 'No transpose', NCRT, M, MM, A(I0,J0), - $ LDA, DWORK(ITAU), B, LDB, DWORK(JWORK), - $ LDWORK-JWORK+1, INFO ) - WRKOPT = MAX( WRKOPT, INT( DWORK(JWORK) )+JWORK-1 ) - END IF -C -C Premultiply the appropriate block row of A by Q. -C Workspace: need M + N; -C prefer M + N*NB. -C - CALL DORMRQ( 'Left', 'No transpose', NCRT, N-JINI+1, MM, - $ A(I0,J0), LDA, DWORK(ITAU), A(J0,JINI), LDA, - $ DWORK(JWORK), LDWORK-JWORK+1, INFO ) - WRKOPT = MAX( WRKOPT, INT( DWORK(JWORK) )+JWORK-1 ) -C -C Postmultiply the appropriate block column of A by Q'. -C Workspace: need M + I0-1; -C prefer M + (I0-1)*NB. -C - CALL DORMRQ( 'Right', 'Transpose', I0-1, NCRT, MM, A(I0,J0), - $ LDA, DWORK(ITAU), A(1,J0), LDA, DWORK(JWORK), - $ LDWORK-JWORK+1, INFO ) - WRKOPT = MAX( WRKOPT, INT( DWORK(JWORK) )+JWORK-1 ) -C - IF ( LJOBUI ) THEN -C -C Update U, postmultiplying it by Q'. -C Workspace: need M + N; -C prefer M + N*NB. -C - CALL DORMRQ( 'Right', 'Transpose', N, NCRT, MM, A(I0,J0), - $ LDA, DWORK(ITAU), U(1,J0), LDU, DWORK(JWORK), - $ LDWORK-JWORK+1, INFO ) - WRKOPT = MAX( WRKOPT, INT( DWORK(JWORK) )+JWORK-1 ) - END IF -C -C Zero the subdiagonal elements of the current subdiagonal block -C of A. -C - CALL DLASET( 'F', MCRT, NCRT-MCRT, ZERO, ZERO, A(I0,J0), LDA ) - IF ( I0.LT.N ) - $ CALL DLASET( 'L', MCRT-1, MCRT-1, ZERO, ZERO, - $ A(I0+1,I0-MCRT), LDA ) -C - MCRT = NCRT - I0 = J0 -C - 10 CONTINUE -C -C Now perform the last backward step on B, V = Qb'. -C -C Compute the RQ factorization of the first block of B, B1 = R*Qb. -C Workspace: need M + MCRT; -C prefer M + MCRT*NB. -C - CALL DGERQF( MCRT, M, B, LDB, DWORK(ITAU), DWORK(JWORK), - $ LDWORK-JWORK+1, INFO ) - WRKOPT = MAX( WRKOPT, INT( DWORK(JWORK) )+JWORK-1 ) -C - IF ( LJOBVI ) THEN -C -C Accumulate the input-space transformations V. -C Workspace: need 2*M; prefer M + M*NB. -C - CALL DLACPY( 'F', MCRT, M-MCRT, B, LDB, V(M-MCRT+1,1), LDV ) - IF ( MCRT.GT.1 ) - $ CALL DLACPY( 'L', MCRT-1, MCRT-1, B(2,M-MCRT+1), LDB, - $ V(M-MCRT+2,M-MCRT+1), LDV ) - CALL DORGRQ( M, M, MCRT, V, LDV, DWORK(ITAU), DWORK(JWORK), - $ LDWORK-JWORK+1, INFO ) -C - DO 20 I = 2, M - CALL DSWAP( I-1, V(I,1), LDV, V(1,I), 1 ) - 20 CONTINUE -C - WRKOPT = MAX( WRKOPT, INT( DWORK(JWORK) )+JWORK-1 ) - END IF -C -C Zero the subdiagonal elements of the submatrix B1. -C - CALL DLASET( 'F', MCRT, M-MCRT, ZERO, ZERO, B, LDB ) - IF ( MCRT.GT.1 ) - $ CALL DLASET( 'L', MCRT-1, MCRT-1, ZERO, ZERO, B(2,M-MCRT+1), - $ LDB ) -C -C Set optimal workspace dimension. -C - DWORK(1) = WRKOPT - RETURN -C *** Last line of AB01OD *** - END diff --git a/mex/sources/libslicot/AB04MD.f b/mex/sources/libslicot/AB04MD.f deleted file mode 100644 index b5856fcd9..000000000 --- a/mex/sources/libslicot/AB04MD.f +++ /dev/null @@ -1,345 +0,0 @@ - SUBROUTINE AB04MD( TYPE, N, M, P, ALPHA, BETA, A, LDA, B, LDB, C, - $ LDC, D, LDD, IWORK, DWORK, LDWORK, INFO ) -C -C SLICOT RELEASE 5.0. -C -C Copyright (c) 2002-2009 NICONET e.V. -C -C This program is free software: you can redistribute it and/or -C modify it under the terms of the GNU General Public License as -C published by the Free Software Foundation, either version 2 of -C the License, or (at your option) any later version. -C -C This program is distributed in the hope that it will be useful, -C but WITHOUT ANY WARRANTY; without even the implied warranty of -C MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the -C GNU General Public License for more details. -C -C You should have received a copy of the GNU General Public License -C along with this program. If not, see -C . -C -C PURPOSE -C -C To perform a transformation on the parameters (A,B,C,D) of a -C system, which is equivalent to a bilinear transformation of the -C corresponding transfer function matrix. -C -C ARGUMENTS -C -C Mode Parameters -C -C TYPE CHARACTER*1 -C Indicates the type of the original system and the -C transformation to be performed as follows: -C = 'D': discrete-time -> continuous-time; -C = 'C': continuous-time -> discrete-time. -C -C Input/Output Parameters -C -C N (input) INTEGER -C The order of the state matrix A. N >= 0. -C -C M (input) INTEGER -C The number of system inputs. M >= 0. -C -C P (input) INTEGER -C The number of system outputs. P >= 0. -C -C ALPHA, (input) DOUBLE PRECISION -C BETA Parameters specifying the bilinear transformation. -C Recommended values for stable systems: ALPHA = 1, -C BETA = 1. ALPHA <> 0, BETA <> 0. -C -C A (input/output) DOUBLE PRECISION array, dimension (LDA,N) -C On entry, the leading N-by-N part of this array must -C contain the state matrix A of the original system. -C On exit, the leading N-by-N part of this array contains -C _ -C the state matrix A of the transformed system. -C -C LDA INTEGER -C The leading dimension of array A. LDA >= MAX(1,N). -C -C B (input/output) DOUBLE PRECISION array, dimension (LDB,M) -C On entry, the leading N-by-M part of this array must -C contain the input matrix B of the original system. -C On exit, the leading N-by-M part of this array contains -C _ -C the input matrix B of the transformed system. -C -C LDB INTEGER -C The leading dimension of array B. LDB >= MAX(1,N). -C -C C (input/output) DOUBLE PRECISION array, dimension (LDC,N) -C On entry, the leading P-by-N part of this array must -C contain the output matrix C of the original system. -C On exit, the leading P-by-N part of this array contains -C _ -C the output matrix C of the transformed system. -C -C LDC INTEGER -C The leading dimension of array C. LDC >= MAX(1,P). -C -C D (input/output) DOUBLE PRECISION array, dimension (LDD,M) -C On entry, the leading P-by-M part of this array must -C contain the input/output matrix D for the original system. -C On exit, the leading P-by-M part of this array contains -C _ -C the input/output matrix D of the transformed system. -C -C LDD INTEGER -C The leading dimension of array D. LDD >= MAX(1,P). -C -C Workspace -C -C IWORK INTEGER array, dimension (N) -C -C DWORK DOUBLE PRECISION array, dimension (LDWORK) -C On exit, if INFO = 0, DWORK(1) returns the optimal value -C of LDWORK. -C -C LDWORK INTEGER -C The length of the array DWORK. LDWORK >= MAX(1,N). -C For optimum performance LDWORK >= MAX(1,N*NB), where NB -C is the optimal blocksize. -C -C Error Indicator -C -C INFO INTEGER -C = 0: successful exit; -C < 0: if INFO = -i, the i-th argument had an illegal -C value; -C = 1: if the matrix (ALPHA*I + A) is exactly singular; -C = 2: if the matrix (BETA*I - A) is exactly singular. -C -C METHOD -C -C The parameters of the discrete-time system are transformed into -C the parameters of the continuous-time system (TYPE = 'D'), or -C vice-versa (TYPE = 'C') by the transformation: -C -C 1. Discrete -> continuous -C _ -1 -C A = beta*(alpha*I + A) * (A - alpha*I) -C _ -1 -C B = sqrt(2*alpha*beta) * (alpha*I + A) * B -C _ -1 -C C = sqrt(2*alpha*beta) * C * (alpha*I + A) -C _ -1 -C D = D - C * (alpha*I + A) * B -C -C which is equivalent to the bilinear transformation -C -C z - alpha -C z -> s = beta --------- . -C z + alpha -C -C of one transfer matrix onto the other. -C -C 2. Continuous -> discrete -C _ -1 -C A = alpha*(beta*I - A) * (beta*I + A) -C _ -1 -C B = sqrt(2*alpha*beta) * (beta*I - A) * B -C _ -1 -C C = sqrt(2*alpha*beta) * C * (beta*I - A) -C _ -1 -C D = D + C * (beta*I - A) * B -C -C which is equivalent to the bilinear transformation -C -C beta + s -C s -> z = alpha -------- . -C beta - s -C -C of one transfer matrix onto the other. -C -C REFERENCES -C -C [1] Al-Saggaf, U.M. and Franklin, G.F. -C Model reduction via balanced realizations: a extension and -C frequency weighting techniques. -C IEEE Trans. Autom. Contr., AC-33, pp. 687-692, 1988. -C -C NUMERICAL ASPECTS -C 3 -C The time taken is approximately proportional to N . -C The accuracy depends mainly on the condition number of the matrix -C to be inverted. -C -C CONTRIBUTORS -C -C Release 3.0: V. Sima, Katholieke Univ. Leuven, Belgium, and -C A. Varga, German Aerospace Research Establishment, -C Oberpfaffenhofen, Germany, Nov. 1996. -C Supersedes Release 2.0 routine AB04AD by W. van der Linden, and -C A.J. Geurts, Technische Hogeschool Eindhoven, Holland. -C -C REVISIONS -C -C - -C -C KEYWORDS -C -C Bilinear transformation, continuous-time system, discrete-time -C system, state-space model. -C -C ****************************************************************** -C -C .. Parameters .. - DOUBLE PRECISION ZERO, ONE, TWO - PARAMETER ( ZERO=0.0D0, ONE=1.0D0, TWO=2.0D0 ) -C .. Scalar Arguments .. - CHARACTER TYPE - INTEGER INFO, LDA, LDB, LDC, LDD, LDWORK, M, N, P - DOUBLE PRECISION ALPHA, BETA -C .. Array Arguments .. - INTEGER IWORK(*) - DOUBLE PRECISION A(LDA,*), B(LDB,*), C(LDC,*), D(LDD,*), DWORK(*) -C .. Local Scalars .. - LOGICAL LTYPE - INTEGER I, IP - DOUBLE PRECISION AB2, PALPHA, PBETA, SQRAB2 -C .. External Functions .. - LOGICAL LSAME - EXTERNAL LSAME -C .. External Subroutines .. - EXTERNAL DGEMM, DGETRF, DGETRS, DGETRI, DLASCL, DSCAL, - $ DSWAP, XERBLA -C .. Intrinsic Functions .. - INTRINSIC ABS, MAX, SIGN, SQRT -C .. Executable Statements .. -C - INFO = 0 - LTYPE = LSAME( TYPE, 'D' ) -C -C Test the input scalar arguments. -C - IF( .NOT.LTYPE .AND. .NOT.LSAME( TYPE, 'C' ) ) THEN - INFO = -1 - ELSE IF( N.LT.0 ) THEN - INFO = -2 - ELSE IF( M.LT.0 ) THEN - INFO = -3 - ELSE IF( P.LT.0 ) THEN - INFO = -4 - ELSE IF( ALPHA.EQ.ZERO ) THEN - INFO = -5 - ELSE IF( BETA.EQ.ZERO ) THEN - INFO = -6 - ELSE IF( LDA.LT.MAX( 1, N ) ) THEN - INFO = -8 - ELSE IF( LDB.LT.MAX( 1, N ) ) THEN - INFO = -10 - ELSE IF( LDC.LT.MAX( 1, P ) ) THEN - INFO = -12 - ELSE IF( LDD.LT.MAX( 1, P ) ) THEN - INFO = -14 - ELSE IF( LDWORK.LT.MAX( 1, N ) ) THEN - INFO = -17 - END IF -C - IF ( INFO.NE.0 ) THEN -C -C Error return. -C - CALL XERBLA( 'AB04MD', -INFO ) - RETURN - END IF -C -C Quick return if possible. -C - IF ( MAX( N, M, P ).EQ.0 ) - $ RETURN -C -C (Note: Comments in the code beginning "Workspace:" describe the -C minimal amount of real workspace needed at that point in the -C code, as well as the preferred amount for good performance. -C NB refers to the optimal block size for the immediately -C following subroutine, as returned by ILAENV.) -C - IF (LTYPE) THEN -C -C Discrete-time to continuous-time with (ALPHA, BETA). -C - PALPHA = ALPHA - PBETA = BETA - ELSE -C -C Continuous-time to discrete-time with (ALPHA, BETA) is -C equivalent with discrete-time to continuous-time with -C (-BETA, -ALPHA), if B and C change the sign. -C - PALPHA = -BETA - PBETA = -ALPHA - END IF -C - AB2 = PALPHA*PBETA*TWO - SQRAB2 = SIGN( SQRT( ABS( AB2 ) ), PALPHA ) -C -1 -C Compute (alpha*I + A) . -C - DO 10 I = 1, N - A(I,I) = A(I,I) + PALPHA - 10 CONTINUE -C - CALL DGETRF( N, N, A, LDA, IWORK, INFO ) -C - IF (INFO.NE.0) THEN -C -C Error return. -C - IF (LTYPE) THEN - INFO = 1 - ELSE - INFO = 2 - END IF - RETURN - END IF -C -1 -C Compute (alpha*I+A) *B. -C - CALL DGETRS( 'No transpose', N, M, A, LDA, IWORK, B, LDB, INFO ) -C -1 -C Compute D - C*(alpha*I+A) *B. -C - CALL DGEMM( 'No transpose', 'No transpose', P, M, N, -ONE, C, - $ LDC, B, LDB, ONE, D, LDD ) -C -C Scale B by sqrt(2*alpha*beta). -C - CALL DLASCL( 'General', 0, 0, ONE, SQRAB2, N, M, B, LDB, INFO ) -C -1 -C Compute sqrt(2*alpha*beta)*C*(alpha*I + A) . -C - CALL DTRSM( 'Right', 'Upper', 'No transpose', 'Non-unit', P, N, - $ SQRAB2, A, LDA, C, LDC ) -C - CALL DTRSM( 'Right', 'Lower', 'No transpose', 'Unit', P, N, ONE, - $ A, LDA, C, LDC ) -C -C Apply column interchanges to the solution matrix. -C - DO 20 I = N-1, 1, -1 - IP = IWORK(I) - IF ( IP.NE.I ) - $ CALL DSWAP( P, C(1,I), 1, C(1,IP), 1 ) - 20 CONTINUE -C -1 -C Compute beta*(alpha*I + A) *(A - alpha*I) as -C -1 -C beta*I - 2*alpha*beta*(alpha*I + A) . -C -C Workspace: need N; prefer N*NB. -C - CALL DGETRI( N, A, LDA, IWORK, DWORK, LDWORK, INFO ) -C - DO 30 I = 1, N - CALL DSCAL(N, -AB2, A(1,I), 1) - A(I,I) = A(I,I) + PBETA - 30 CONTINUE -C - RETURN -C *** Last line of AB04MD *** - END diff --git a/mex/sources/libslicot/AB05MD.f b/mex/sources/libslicot/AB05MD.f deleted file mode 100644 index 0324368bf..000000000 --- a/mex/sources/libslicot/AB05MD.f +++ /dev/null @@ -1,547 +0,0 @@ - SUBROUTINE AB05MD( UPLO, OVER, N1, M1, P1, N2, P2, A1, LDA1, B1, - $ LDB1, C1, LDC1, D1, LDD1, A2, LDA2, B2, LDB2, - $ C2, LDC2, D2, LDD2, N, A, LDA, B, LDB, C, LDC, - $ D, LDD, DWORK, LDWORK, INFO ) -C -C SLICOT RELEASE 5.0. -C -C Copyright (c) 2002-2009 NICONET e.V. -C -C This program is free software: you can redistribute it and/or -C modify it under the terms of the GNU General Public License as -C published by the Free Software Foundation, either version 2 of -C the License, or (at your option) any later version. -C -C This program is distributed in the hope that it will be useful, -C but WITHOUT ANY WARRANTY; without even the implied warranty of -C MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the -C GNU General Public License for more details. -C -C You should have received a copy of the GNU General Public License -C along with this program. If not, see -C . -C -C PURPOSE -C -C To obtain the state-space model (A,B,C,D) for the cascaded -C inter-connection of two systems, each given in state-space form. -C -C ARGUMENTS -C -C Mode Parameters -C -C UPLO CHARACTER*1 -C Indicates whether the user wishes to obtain the matrix A -C in the upper or lower block diagonal form, as follows: -C = 'U': Obtain A in the upper block diagonal form; -C = 'L': Obtain A in the lower block diagonal form. -C -C OVER CHARACTER*1 -C Indicates whether the user wishes to overlap pairs of -C arrays, as follows: -C = 'N': Do not overlap; -C = 'O': Overlap pairs of arrays: A1 and A, B1 and B, -C C1 and C, and D1 and D (for UPLO = 'L'), or A2 -C and A, B2 and B, C2 and C, and D2 and D (for -C UPLO = 'U'), i.e. the same name is effectively -C used for each pair (for all pairs) in the routine -C call. In this case, setting LDA1 = LDA, -C LDB1 = LDB, LDC1 = LDC, and LDD1 = LDD, or -C LDA2 = LDA, LDB2 = LDB, LDC2 = LDC, and LDD2 = LDD -C will give maximum efficiency. -C -C Input/Output Parameters -C -C N1 (input) INTEGER -C The number of state variables in the first system, i.e. -C the order of the matrix A1. N1 >= 0. -C -C M1 (input) INTEGER -C The number of input variables for the first system. -C M1 >= 0. -C -C P1 (input) INTEGER -C The number of output variables from the first system and -C the number of input variables for the second system. -C P1 >= 0. -C -C N2 (input) INTEGER -C The number of state variables in the second system, i.e. -C the order of the matrix A2. N2 >= 0. -C -C P2 (input) INTEGER -C The number of output variables from the second system. -C P2 >= 0. -C -C A1 (input) DOUBLE PRECISION array, dimension (LDA1,N1) -C The leading N1-by-N1 part of this array must contain the -C state transition matrix A1 for the first system. -C -C LDA1 INTEGER -C The leading dimension of array A1. LDA1 >= MAX(1,N1). -C -C B1 (input) DOUBLE PRECISION array, dimension (LDB1,M1) -C The leading N1-by-M1 part of this array must contain the -C input/state matrix B1 for the first system. -C -C LDB1 INTEGER -C The leading dimension of array B1. LDB1 >= MAX(1,N1). -C -C C1 (input) DOUBLE PRECISION array, dimension (LDC1,N1) -C The leading P1-by-N1 part of this array must contain the -C state/output matrix C1 for the first system. -C -C LDC1 INTEGER -C The leading dimension of array C1. -C LDC1 >= MAX(1,P1) if N1 > 0. -C LDC1 >= 1 if N1 = 0. -C -C D1 (input) DOUBLE PRECISION array, dimension (LDD1,M1) -C The leading P1-by-M1 part of this array must contain the -C input/output matrix D1 for the first system. -C -C LDD1 INTEGER -C The leading dimension of array D1. LDD1 >= MAX(1,P1). -C -C A2 (input) DOUBLE PRECISION array, dimension (LDA2,N2) -C The leading N2-by-N2 part of this array must contain the -C state transition matrix A2 for the second system. -C -C LDA2 INTEGER -C The leading dimension of array A2. LDA2 >= MAX(1,N2). -C -C B2 (input) DOUBLE PRECISION array, dimension (LDB2,P1) -C The leading N2-by-P1 part of this array must contain the -C input/state matrix B2 for the second system. -C -C LDB2 INTEGER -C The leading dimension of array B2. LDB2 >= MAX(1,N2). -C -C C2 (input) DOUBLE PRECISION array, dimension (LDC2,N2) -C The leading P2-by-N2 part of this array must contain the -C state/output matrix C2 for the second system. -C -C LDC2 INTEGER -C The leading dimension of array C2. -C LDC2 >= MAX(1,P2) if N2 > 0. -C LDC2 >= 1 if N2 = 0. -C -C D2 (input) DOUBLE PRECISION array, dimension (LDD2,P1) -C The leading P2-by-P1 part of this array must contain the -C input/output matrix D2 for the second system. -C -C LDD2 INTEGER -C The leading dimension of array D2. LDD2 >= MAX(1,P2). -C -C N (output) INTEGER -C The number of state variables (N1 + N2) in the resulting -C system, i.e. the order of the matrix A, the number of rows -C of B and the number of columns of C. -C -C A (output) DOUBLE PRECISION array, dimension (LDA,N1+N2) -C The leading N-by-N part of this array contains the state -C transition matrix A for the cascaded system. -C If OVER = 'O', the array A can overlap A1, if UPLO = 'L', -C or A2, if UPLO = 'U'. -C -C LDA INTEGER -C The leading dimension of array A. LDA >= MAX(1,N1+N2). -C -C B (output) DOUBLE PRECISION array, dimension (LDB,M1) -C The leading N-by-M1 part of this array contains the -C input/state matrix B for the cascaded system. -C If OVER = 'O', the array B can overlap B1, if UPLO = 'L', -C or B2, if UPLO = 'U'. -C -C LDB INTEGER -C The leading dimension of array B. LDB >= MAX(1,N1+N2). -C -C C (output) DOUBLE PRECISION array, dimension (LDC,N1+N2) -C The leading P2-by-N part of this array contains the -C state/output matrix C for the cascaded system. -C If OVER = 'O', the array C can overlap C1, if UPLO = 'L', -C or C2, if UPLO = 'U'. -C -C LDC INTEGER -C The leading dimension of array C. -C LDC >= MAX(1,P2) if N1+N2 > 0. -C LDC >= 1 if N1+N2 = 0. -C -C D (output) DOUBLE PRECISION array, dimension (LDD,M1) -C The leading P2-by-M1 part of this array contains the -C input/output matrix D for the cascaded system. -C If OVER = 'O', the array D can overlap D1, if UPLO = 'L', -C or D2, if UPLO = 'U'. -C -C LDD INTEGER -C The leading dimension of array D. LDD >= MAX(1,P2). -C -C Workspace -C -C DWORK DOUBLE PRECISION array, dimension (LDWORK) -C The array DWORK is not referenced if OVER = 'N'. -C -C LDWORK INTEGER -C The length of the array DWORK. -C LDWORK >= MAX( 1, P1*MAX(N1, M1, N2, P2) ) if OVER = 'O'. -C LDWORK >= 1 if OVER = 'N'. -C -C Error Indicator -C -C INFO INTEGER -C = 0: successful exit; -C < 0: if INFO = -i, the i-th argument had an illegal -C value. -C -C METHOD -C -C After cascaded inter-connection of the two systems -C -C X1' = A1*X1 + B1*U -C V = C1*X1 + D1*U -C -C X2' = A2*X2 + B2*V -C Y = C2*X2 + D2*V -C -C (where ' denotes differentiation with respect to time) -C -C the following state-space model will be obtained: -C -C X' = A*X + B*U -C Y = C*X + D*U -C -C where matrix A has the form ( A1 0 ), -C ( B2*C1 A2) -C -C matrix B has the form ( B1 ), -C ( B2*D1 ) -C -C matrix C has the form ( D2*C1 C2 ) and -C -C matrix D has the form ( D2*D1 ). -C -C This form is returned by the routine when UPLO = 'L'. Note that -C when A1 and A2 are block lower triangular, the resulting state -C matrix is also block lower triangular. -C -C By applying a similarity transformation to the system above, -C using the matrix ( 0 I ), where I is the identity matrix of -C ( J 0 ) -C order N2, and J is the identity matrix of order N1, the -C system matrices become -C -C A = ( A2 B2*C1 ), -C ( 0 A1 ) -C -C B = ( B2*D1 ), -C ( B1 ) -C -C C = ( C2 D2*C1 ) and -C -C D = ( D2*D1 ). -C -C This form is returned by the routine when UPLO = 'U'. Note that -C when A1 and A2 are block upper triangular (for instance, in the -C real Schur form), the resulting state matrix is also block upper -C triangular. -C -C REFERENCES -C -C None -C -C NUMERICAL ASPECTS -C -C The algorithm requires P1*(N1+M1)*(N2+P2) operations. -C -C CONTRIBUTORS -C -C Release 3.0: V. Sima, Katholieke Univ. Leuven, Belgium, and -C A. Varga, German Aerospace Research Establishment, -C Oberpfaffenhofen, Germany, Nov. 1996. -C Supersedes Release 2.0 routine AB05AD by C.J.Benson, Kingston -C Polytechnic, United Kingdom, January 1982. -C -C REVISIONS -C -C V. Sima, Research Institute for Informatics, Bucharest, July 2003, -C Feb. 2004. -C -C KEYWORDS -C -C Cascade control, continuous-time system, multivariable -C system, state-space model, state-space representation. -C -C ****************************************************************** -C -C .. Parameters .. - DOUBLE PRECISION ZERO, ONE - PARAMETER ( ZERO = 0.0D0, ONE = 1.0D0 ) -C .. Scalar Arguments .. - CHARACTER OVER, UPLO - INTEGER INFO, LDA, LDA1, LDA2, LDB, LDB1, LDB2, LDC, - $ LDC1, LDC2, LDD, LDD1, LDD2, LDWORK, M1, N, N1, - $ N2, P1, P2 -C .. Array Arguments .. - DOUBLE PRECISION A(LDA,*), A1(LDA1,*), A2(LDA2,*), B(LDB,*), - $ B1(LDB1,*), B2(LDB2,*), C(LDC,*), C1(LDC1,*), - $ C2(LDC2,*), D(LDD,*), D1(LDD1,*), D2(LDD2,*), - $ DWORK(*) -C .. Local Scalars .. - LOGICAL LOVER, LUPLO - INTEGER I, I1, I2, J, LDWN2, LDWP1, LDWP2 -C .. External Functions .. - LOGICAL LSAME - EXTERNAL LSAME -C .. External Subroutines .. - EXTERNAL DGEMM, DLACPY, DLASET, XERBLA -C .. Intrinsic Functions .. - INTRINSIC MAX, MIN -C .. Executable Statements .. -C - LOVER = LSAME( OVER, 'O' ) - LUPLO = LSAME( UPLO, 'L' ) - N = N1 + N2 - INFO = 0 -C -C Test the input scalar arguments. -C - IF( .NOT.LUPLO .AND. .NOT.LSAME( UPLO, 'U' ) ) THEN - INFO = -1 - ELSE IF( .NOT.LOVER .AND. .NOT.LSAME( OVER, 'N' ) ) THEN - INFO = -2 - ELSE IF( N1.LT.0 ) THEN - INFO = -3 - ELSE IF( M1.LT.0 ) THEN - INFO = -4 - ELSE IF( P1.LT.0 ) THEN - INFO = -5 - ELSE IF( N2.LT.0 ) THEN - INFO = -6 - ELSE IF( P2.LT.0 ) THEN - INFO = -7 - ELSE IF( LDA1.LT.MAX( 1, N1 ) ) THEN - INFO = -9 - ELSE IF( LDB1.LT.MAX( 1, N1 ) ) THEN - INFO = -11 - ELSE IF( ( N1.GT.0 .AND. LDC1.LT.MAX( 1, P1 ) ) .OR. - $ ( N1.EQ.0 .AND. LDC1.LT.1 ) ) THEN - INFO = -13 - ELSE IF( LDD1.LT.MAX( 1, P1 ) ) THEN - INFO = -15 - ELSE IF( LDA2.LT.MAX( 1, N2 ) ) THEN - INFO = -17 - ELSE IF( LDB2.LT.MAX( 1, N2 ) ) THEN - INFO = -19 - ELSE IF( ( N2.GT.0 .AND. LDC2.LT.MAX( 1, P2 ) ) .OR. - $ ( N2.EQ.0 .AND. LDC2.LT.1 ) ) THEN - INFO = -21 - ELSE IF( LDD2.LT.MAX( 1, P2 ) ) THEN - INFO = -23 - ELSE IF( LDA.LT.MAX( 1, N ) ) THEN - INFO = -26 - ELSE IF( LDB.LT.MAX( 1, N ) ) THEN - INFO = -28 - ELSE IF( ( N.GT.0 .AND. LDC.LT.MAX( 1, P2 ) ) .OR. - $ ( N.EQ.0 .AND. LDC.LT.1 ) ) THEN - INFO = -30 - ELSE IF( LDD.LT.MAX( 1, P2 ) ) THEN - INFO = -32 - ELSE IF( ( LOVER.AND.LDWORK.LT.MAX( 1, P1*MAX( N1, M1, N2, P2 )) ) - $.OR.( .NOT.LOVER.AND.LDWORK.LT.1 ) ) THEN - INFO = -34 - END IF -C - IF ( INFO.NE.0 ) THEN -C -C Error return. -C - CALL XERBLA( 'AB05MD', -INFO ) - RETURN - END IF -C -C Quick return if possible. -C - IF ( MAX( N, MIN( M1, P2 ) ).EQ.0 ) - $ RETURN -C -C Set row/column indices for storing the results. -C - IF ( LUPLO ) THEN - I1 = 1 - I2 = MIN( N1 + 1, N ) - ELSE - I1 = MIN( N2 + 1, N ) - I2 = 1 - END IF -C - LDWN2 = MAX( 1, N2 ) - LDWP1 = MAX( 1, P1 ) - LDWP2 = MAX( 1, P2 ) -C -C Construct the cascaded system matrices, taking the desired block -C structure and possible overwriting into account. -C -C Form the diagonal blocks of matrix A. -C - IF ( LUPLO ) THEN -C -C Lower block diagonal structure. -C - IF ( LOVER .AND. LDA1.LE.LDA ) THEN - IF ( LDA1.LT.LDA ) THEN -C - DO 20 J = N1, 1, -1 - DO 10 I = N1, 1, -1 - A(I,J) = A1(I,J) - 10 CONTINUE - 20 CONTINUE -C - END IF - ELSE - CALL DLACPY( 'F', N1, N1, A1, LDA1, A, LDA ) - END IF - IF ( N2.GT.0 ) - $ CALL DLACPY( 'F', N2, N2, A2, LDA2, A(I2,I2), LDA ) - ELSE -C -C Upper block diagonal structure. -C - IF ( LOVER .AND. LDA2.LE.LDA ) THEN - IF ( LDA2.LT.LDA ) THEN -C - DO 40 J = N2, 1, -1 - DO 30 I = N2, 1, -1 - A(I,J) = A2(I,J) - 30 CONTINUE - 40 CONTINUE -C - END IF - ELSE - CALL DLACPY( 'F', N2, N2, A2, LDA2, A, LDA ) - END IF - IF ( N1.GT.0 ) - $ CALL DLACPY( 'F', N1, N1, A1, LDA1, A(I1,I1), LDA ) - END IF -C -C Form the off-diagonal blocks of matrix A. -C - IF ( MIN( N1, N2 ).GT.0 ) THEN - CALL DLASET( 'F', N1, N2, ZERO, ZERO, A(I1,I2), LDA ) - CALL DGEMM ( 'No transpose', 'No transpose', N2, N1, P1, ONE, - $ B2, LDB2, C1, LDC1, ZERO, A(I2,I1), LDA ) - END IF -C - IF ( LUPLO ) THEN -C -C Form the matrix B. -C - IF ( LOVER .AND. LDB1.LE.LDB ) THEN - IF ( LDB1.LT.LDB ) THEN -C - DO 60 J = M1, 1, -1 - DO 50 I = N1, 1, -1 - B(I,J) = B1(I,J) - 50 CONTINUE - 60 CONTINUE -C - END IF - ELSE - CALL DLACPY( 'F', N1, M1, B1, LDB1, B, LDB ) - END IF -C - IF ( MIN( N2, M1 ).GT.0 ) - $ CALL DGEMM ( 'No transpose', 'No transpose', N2, M1, P1, - $ ONE, B2, LDB2, D1, LDD1, ZERO, B(I2,1), LDB ) -C -C Form the matrix C. -C - IF ( N1.GT.0 ) THEN - IF ( LOVER ) THEN -C -C Workspace: P1*N1. -C - CALL DLACPY( 'F', P1, N1, C1, LDC1, DWORK, LDWP1 ) - CALL DGEMM ( 'No transpose', 'No transpose', P2, N1, P1, - $ ONE, D2, LDD2, DWORK, LDWP1, ZERO, C, LDC ) - ELSE - CALL DGEMM ( 'No transpose', 'No transpose', P2, N1, P1, - $ ONE, D2, LDD2, C1, LDC1, ZERO, C, LDC ) - END IF - END IF -C - IF ( MIN( P2, N2 ).GT.0 ) - $ CALL DLACPY( 'F', P2, N2, C2, LDC2, C(1,I2), LDC ) -C -C Now form the matrix D. -C - IF ( LOVER ) THEN -C -C Workspace: P1*M1. -C - CALL DLACPY( 'F', P1, M1, D1, LDD1, DWORK, LDWP1 ) - CALL DGEMM ( 'No transpose', 'No transpose', P2, M1, P1, - $ ONE, D2, LDD2, DWORK, LDWP1, ZERO, D, LDD ) - ELSE - CALL DGEMM ( 'No transpose', 'No transpose', P2, M1, P1, - $ ONE, D2, LDD2, D1, LDD1, ZERO, D, LDD ) - END IF -C - ELSE -C -C Form the matrix B. -C - IF ( LOVER ) THEN -C -C Workspace: N2*P1. -C - CALL DLACPY( 'F', N2, P1, B2, LDB2, DWORK, LDWN2 ) - IF ( MIN( N2, M1 ).GT.0 ) - $ CALL DGEMM ( 'No transpose', 'No transpose', N2, M1, P1, - $ ONE, DWORK, LDWN2, D1, LDD1, ZERO, B(I2,1), - $ LDB ) - ELSE - CALL DGEMM ( 'No transpose', 'No transpose', N2, M1, P1, - $ ONE, B2, LDB2, D1, LDD1, ZERO, B, LDB ) - END IF -C - IF ( MIN( N1, M1 ).GT.0 ) - $ CALL DLACPY( 'F', N1, M1, B1, LDB1, B(I1,1), LDB ) -C -C Form the matrix C. -C - IF ( LOVER .AND. LDC2.LE.LDC ) THEN - IF ( LDC2.LT.LDC ) THEN -C - DO 80 J = N2, 1, -1 - DO 70 I = P2, 1, -1 - C(I,J) = C2(I,J) - 70 CONTINUE - 80 CONTINUE -C - END IF - ELSE - CALL DLACPY( 'F', P2, N2, C2, LDC2, C, LDC ) - END IF -C - IF ( MIN( P2, N1 ).GT.0 ) - $ CALL DGEMM ( 'No transpose', 'No transpose', P2, N1, P1, - $ ONE, D2, LDD2, C1, LDC1, ZERO, C(1,I1), LDC ) -C -C Now form the matrix D. -C - IF ( LOVER ) THEN -C -C Workspace: P2*P1. -C - CALL DLACPY( 'F', P2, P1, D2, LDD2, DWORK, LDWP2 ) - CALL DGEMM ( 'No transpose', 'No transpose', P2, M1, P1, - $ ONE, DWORK, LDWP2, D1, LDD1, ZERO, D, LDD ) - ELSE - CALL DGEMM ( 'No transpose', 'No transpose', P2, M1, P1, - $ ONE, D2, LDD2, D1, LDD1, ZERO, D, LDD ) - END IF - END IF -C - RETURN -C *** Last line of AB05MD *** - END diff --git a/mex/sources/libslicot/AB05ND.f b/mex/sources/libslicot/AB05ND.f deleted file mode 100644 index 507d6ea16..000000000 --- a/mex/sources/libslicot/AB05ND.f +++ /dev/null @@ -1,564 +0,0 @@ - SUBROUTINE AB05ND( OVER, N1, M1, P1, N2, ALPHA, A1, LDA1, B1, - $ LDB1, C1, LDC1, D1, LDD1, A2, LDA2, B2, LDB2, - $ C2, LDC2, D2, LDD2, N, A, LDA, B, LDB, C, LDC, - $ D, LDD, IWORK, DWORK, LDWORK, INFO ) -C -C SLICOT RELEASE 5.0. -C -C Copyright (c) 2002-2009 NICONET e.V. -C -C This program is free software: you can redistribute it and/or -C modify it under the terms of the GNU General Public License as -C published by the Free Software Foundation, either version 2 of -C the License, or (at your option) any later version. -C -C This program is distributed in the hope that it will be useful, -C but WITHOUT ANY WARRANTY; without even the implied warranty of -C MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the -C GNU General Public License for more details. -C -C You should have received a copy of the GNU General Public License -C along with this program. If not, see -C . -C -C PURPOSE -C -C To obtain the state-space model (A,B,C,D) for the feedback -C inter-connection of two systems, each given in state-space form. -C -C ARGUMENTS -C -C Mode Parameters -C -C OVER CHARACTER*1 -C Indicates whether the user wishes to overlap pairs of -C arrays, as follows: -C = 'N': Do not overlap; -C = 'O': Overlap pairs of arrays: A1 and A, B1 and B, -C C1 and C, and D1 and D, i.e. the same name is -C effectively used for each pair (for all pairs) -C in the routine call. In this case, setting -C LDA1 = LDA, LDB1 = LDB, LDC1 = LDC, and LDD1 = LDD -C will give maximum efficiency. -C -C Input/Output Parameters -C -C N1 (input) INTEGER -C The number of state variables in the first system, i.e. -C the order of the matrix A1. N1 >= 0. -C -C M1 (input) INTEGER -C The number of input variables for the first system and the -C number of output variables from the second system. -C M1 >= 0. -C -C P1 (input) INTEGER -C The number of output variables from the first system and -C the number of input variables for the second system. -C P1 >= 0. -C -C N2 (input) INTEGER -C The number of state variables in the second system, i.e. -C the order of the matrix A2. N2 >= 0. -C -C ALPHA (input) DOUBLE PRECISION -C A coefficient multiplying the transfer-function matrix -C (or the output equation) of the second system. -C ALPHA = +1 corresponds to positive feedback, and -C ALPHA = -1 corresponds to negative feedback. -C -C A1 (input) DOUBLE PRECISION array, dimension (LDA1,N1) -C The leading N1-by-N1 part of this array must contain the -C state transition matrix A1 for the first system. -C -C LDA1 INTEGER -C The leading dimension of array A1. LDA1 >= MAX(1,N1). -C -C B1 (input) DOUBLE PRECISION array, dimension (LDB1,M1) -C The leading N1-by-M1 part of this array must contain the -C input/state matrix B1 for the first system. -C -C LDB1 INTEGER -C The leading dimension of array B1. LDB1 >= MAX(1,N1). -C -C C1 (input) DOUBLE PRECISION array, dimension (LDC1,N1) -C The leading P1-by-N1 part of this array must contain the -C state/output matrix C1 for the first system. -C -C LDC1 INTEGER -C The leading dimension of array C1. -C LDC1 >= MAX(1,P1) if N1 > 0. -C LDC1 >= 1 if N1 = 0. -C -C D1 (input) DOUBLE PRECISION array, dimension (LDD1,M1) -C The leading P1-by-M1 part of this array must contain the -C input/output matrix D1 for the first system. -C -C LDD1 INTEGER -C The leading dimension of array D1. LDD1 >= MAX(1,P1). -C -C A2 (input) DOUBLE PRECISION array, dimension (LDA2,N2) -C The leading N2-by-N2 part of this array must contain the -C state transition matrix A2 for the second system. -C -C LDA2 INTEGER -C The leading dimension of array A2. LDA2 >= MAX(1,N2). -C -C B2 (input) DOUBLE PRECISION array, dimension (LDB2,P1) -C The leading N2-by-P1 part of this array must contain the -C input/state matrix B2 for the second system. -C -C LDB2 INTEGER -C The leading dimension of array B2. LDB2 >= MAX(1,N2). -C -C C2 (input) DOUBLE PRECISION array, dimension (LDC2,N2) -C The leading M1-by-N2 part of this array must contain the -C state/output matrix C2 for the second system. -C -C LDC2 INTEGER -C The leading dimension of array C2. -C LDC2 >= MAX(1,M1) if N2 > 0. -C LDC2 >= 1 if N2 = 0. -C -C D2 (input) DOUBLE PRECISION array, dimension (LDD2,P1) -C The leading M1-by-P1 part of this array must contain the -C input/output matrix D2 for the second system. -C -C LDD2 INTEGER -C The leading dimension of array D2. LDD2 >= MAX(1,M1). -C -C N (output) INTEGER -C The number of state variables (N1 + N2) in the connected -C system, i.e. the order of the matrix A, the number of rows -C of B and the number of columns of C. -C -C A (output) DOUBLE PRECISION array, dimension (LDA,N1+N2) -C The leading N-by-N part of this array contains the state -C transition matrix A for the connected system. -C The array A can overlap A1 if OVER = 'O'. -C -C LDA INTEGER -C The leading dimension of array A. LDA >= MAX(1,N1+N2). -C -C B (output) DOUBLE PRECISION array, dimension (LDB,M1) -C The leading N-by-M1 part of this array contains the -C input/state matrix B for the connected system. -C The array B can overlap B1 if OVER = 'O'. -C -C LDB INTEGER -C The leading dimension of array B. LDB >= MAX(1,N1+N2). -C -C C (output) DOUBLE PRECISION array, dimension (LDC,N1+N2) -C The leading P1-by-N part of this array contains the -C state/output matrix C for the connected system. -C The array C can overlap C1 if OVER = 'O'. -C -C LDC INTEGER -C The leading dimension of array C. -C LDC >= MAX(1,P1) if N1+N2 > 0. -C LDC >= 1 if N1+N2 = 0. -C -C D (output) DOUBLE PRECISION array, dimension (LDD,M1) -C The leading P1-by-M1 part of this array contains the -C input/output matrix D for the connected system. -C The array D can overlap D1 if OVER = 'O'. -C -C LDD INTEGER -C The leading dimension of array D. LDD >= MAX(1,P1). -C -C Workspace -C -C IWORK INTEGER array, dimension (P1) -C -C DWORK DOUBLE PRECISION array, dimension (LDWORK) -C -C LDWORK INTEGER -C The length of the array DWORK. If OVER = 'N', -C LDWORK >= MAX(1, P1*P1, M1*M1, N1*P1), and if OVER = 'O', -C LDWORK >= MAX(1, N1*P1 + MAX( P1*P1, M1*M1, N1*P1) ), -C if M1 <= N*N2; -C LDWORK >= MAX(1, N1*P1 + MAX( P1*P1, M1*(M1+1), N1*P1) ), -C if M1 > N*N2. -C -C Error Indicator -C -C INFO INTEGER -C = 0: successful exit; -C < 0: if INFO = -i, the i-th argument had an illegal -C value. -C > 0: if INFO = i, 1 <= i <= P1, the system is not -C completely controllable. That is, the matrix -C (I + ALPHA*D1*D2) is exactly singular (the element -C U(i,i) of the upper triangular factor of LU -C factorization is exactly zero), possibly due to -C rounding errors. -C -C METHOD -C -C After feedback inter-connection of the two systems, -C -C X1' = A1*X1 + B1*U1 -C Y1 = C1*X1 + D1*U1 -C -C X2' = A2*X2 + B2*U2 -C Y2 = C2*X2 + D2*U2 -C -C (where ' denotes differentiation with respect to time) -C -C the following state-space model will be obtained: -C -C X' = A*X + B*U -C Y = C*X + D*U -C -C where U = U1 + alpha*Y2, X = ( X1 ), -C Y = Y1 = U2, ( X2 ) -C -C matrix A has the form -C -C ( A1 - alpha*B1*E12*D2*C1 - alpha*B1*E12*C2 ), -C ( B2*E21*C1 A2 - alpha*B2*E21*D1*C2 ) -C -C matrix B has the form -C -C ( B1*E12 ), -C ( B2*E21*D1 ) -C -C matrix C has the form -C -C ( E21*C1 - alpha*E21*D1*C2 ), -C -C matrix D has the form -C -C ( E21*D1 ), -C -C E21 = ( I + alpha*D1*D2 )-INVERSE and -C E12 = ( I + alpha*D2*D1 )-INVERSE = I - alpha*D2*E21*D1. -C -C Taking N1 = 0 and/or N2 = 0 on the routine call will solve the -C constant plant and/or constant feedback cases. -C -C REFERENCES -C -C None -C -C NUMERICAL ASPECTS -C -C None -C -C CONTRIBUTOR -C -C Release 3.0: V. Sima, Katholieke Univ. Leuven, Belgium, Nov. 1996. -C Supersedes Release 2.0 routine AB05BD by C.J.Benson, Kingston -C Polytechnic, United Kingdom, January 1982. -C -C REVISIONS -C -C V. Sima, Research Institute for Informatics, Bucharest, July 2003, -C Feb. 2004. -C -C KEYWORDS -C -C Continuous-time system, multivariable system, state-space model, -C state-space representation. -C -C ****************************************************************** -C -C .. Parameters .. - DOUBLE PRECISION ZERO, ONE - PARAMETER ( ZERO=0.0D0, ONE=1.0D0 ) -C .. Scalar Arguments .. - CHARACTER OVER - INTEGER INFO, LDA, LDA1, LDA2, LDB, LDB1, LDB2, LDC, - $ LDC1, LDC2, LDD, LDD1, LDD2, LDWORK, M1, N, N1, - $ N2, P1 - DOUBLE PRECISION ALPHA -C .. Array Arguments .. - INTEGER IWORK(*) - DOUBLE PRECISION A(LDA,*), A1(LDA1,*), A2(LDA2,*), B(LDB,*), - $ B1(LDB1,*), B2(LDB2,*), C(LDC,*), C1(LDC1,*), - $ C2(LDC2,*), D(LDD,*), D1(LDD1,*), D2(LDD2,*), - $ DWORK(*) -C .. Local Scalars .. - LOGICAL LOVER - INTEGER I, J, LDW, LDWM1 -C .. External Functions .. - LOGICAL LSAME - EXTERNAL LSAME -C .. External Subroutines .. - EXTERNAL DCOPY, DGEMM, DGEMV, DGETRF, DGETRS, DLACPY, - $ DLASET, XERBLA -C .. Intrinsic Functions .. - INTRINSIC MAX, MIN -C .. Executable Statements .. -C - LOVER = LSAME( OVER, 'O' ) - LDWM1 = MAX( 1, M1 ) - N = N1 + N2 - INFO = 0 -C -C Test the input scalar arguments. -C - IF( .NOT.LOVER .AND. .NOT.LSAME( OVER, 'N' ) ) THEN - INFO = -1 - ELSE IF( N1.LT.0 ) THEN - INFO = -2 - ELSE IF( M1.LT.0 ) THEN - INFO = -3 - ELSE IF( P1.LT.0 ) THEN - INFO = -4 - ELSE IF( N2.LT.0 ) THEN - INFO = -5 - ELSE IF( LDA1.LT.MAX( 1, N1 ) ) THEN - INFO = -8 - ELSE IF( LDB1.LT.MAX( 1, N1 ) ) THEN - INFO = -10 - ELSE IF( ( N1.GT.0 .AND. LDC1.LT.MAX( 1, P1 ) ) .OR. - $ ( N1.EQ.0 .AND. LDC1.LT.1 ) ) THEN - INFO = -12 - ELSE IF( LDD1.LT.MAX( 1, P1 ) ) THEN - INFO = -14 - ELSE IF( LDA2.LT.MAX( 1, N2 ) ) THEN - INFO = -16 - ELSE IF( LDB2.LT.MAX( 1, N2 ) ) THEN - INFO = -18 - ELSE IF( ( N2.GT.0 .AND. LDC2.LT.LDWM1 ) .OR. - $ ( N2.EQ.0 .AND. LDC2.LT.1 ) ) THEN - INFO = -20 - ELSE IF( LDD2.LT.LDWM1 ) THEN - INFO = -22 - ELSE IF( LDA.LT.MAX( 1, N ) ) THEN - INFO = -25 - ELSE IF( LDB.LT.MAX( 1, N ) ) THEN - INFO = -27 - ELSE IF( ( N.GT.0 .AND. LDC.LT.MAX( 1, P1 ) ) .OR. - $ ( N.EQ.0 .AND. LDC.LT.1 ) ) THEN - INFO = -29 - ELSE IF( LDD.LT.MAX( 1, P1 ) ) THEN - INFO = -31 - ELSE - LDW = MAX( P1*P1, M1*M1, N1*P1 ) - IF( LOVER ) THEN - IF( M1.GT.N*N2 ) - $ LDW = MAX( LDW, M1*( M1 + 1 ) ) - LDW = N1*P1 + LDW - END IF - IF( LDWORK.LT.MAX( 1, LDW ) ) - $ INFO = -34 - END IF -C - IF ( INFO.NE.0 ) THEN -C -C Error return. -C - CALL XERBLA( 'AB05ND', -INFO ) - RETURN - END IF -C -C Quick return if possible. -C - IF ( MAX( N, MIN( M1, P1 ) ).EQ.0 ) - $ RETURN -C - IF ( P1.GT.0 ) THEN -C -C Form ( I + alpha * D1 * D2 ). -C - CALL DLASET( 'F', P1, P1, ZERO, ONE, DWORK, P1 ) - CALL DGEMM ( 'No transpose', 'No transpose', P1, P1, M1, ALPHA, - $ D1, LDD1, D2, LDD2, ONE, DWORK, P1 ) -C -C Factorize this matrix. -C - CALL DGETRF( P1, P1, DWORK, P1, IWORK, INFO ) -C - IF ( INFO.NE.0 ) - $ RETURN -C -C Form E21 * D1. -C - IF ( LOVER .AND. LDD1.LE.LDD ) THEN - IF ( LDD1.LT.LDD ) THEN -C - DO 20 J = M1, 1, -1 - DO 10 I = P1, 1, -1 - D(I,J) = D1(I,J) - 10 CONTINUE - 20 CONTINUE -C - END IF - ELSE - CALL DLACPY( 'F', P1, M1, D1, LDD1, D, LDD ) - END IF -C - CALL DGETRS( 'No transpose', P1, M1, DWORK, P1, IWORK, D, LDD, - $ INFO ) - IF ( N1.GT.0 ) THEN -C -C Form E21 * C1. -C - IF ( LOVER ) THEN -C -C First save C1. -C - LDW = LDW - P1*N1 + 1 - CALL DLACPY( 'F', P1, N1, C1, LDC1, DWORK(LDW), P1 ) -C - IF ( LDC1.NE.LDC ) - $ CALL DLACPY( 'F', P1, N1, DWORK(LDW), P1, C, LDC ) - ELSE - CALL DLACPY( 'F', P1, N1, C1, LDC1, C, LDC ) - END IF -C - CALL DGETRS( 'No transpose', P1, N1, DWORK, P1, IWORK, - $ C, LDC, INFO ) - END IF -C -C Form E12 = I - alpha * D2 * ( E21 * D1 ). -C - CALL DLASET( 'F', M1, M1, ZERO, ONE, DWORK, LDWM1 ) - CALL DGEMM ( 'No transpose', 'No transpose', M1, M1, P1, - $ -ALPHA, D2, LDD2, D, LDD, ONE, DWORK, LDWM1 ) -C - ELSE - CALL DLASET( 'F', M1, M1, ZERO, ONE, DWORK, LDWM1 ) - END IF -C - IF ( LOVER .AND. LDA1.LE.LDA ) THEN - IF ( LDA1.LT.LDA ) THEN -C - DO 40 J = N1, 1, -1 - DO 30 I = N1, 1, -1 - A(I,J) = A1(I,J) - 30 CONTINUE - 40 CONTINUE -C - END IF - ELSE - CALL DLACPY( 'F', N1, N1, A1, LDA1, A, LDA ) - END IF -C - IF ( N1.GT.0 .AND. M1.GT.0 ) THEN -C -C Form B1 * E12. -C - IF ( LOVER ) THEN -C -C Use the blocks (1,2) and (2,2) of A as workspace. -C - IF ( N1*M1.LE.N*N2 ) THEN -C -C Use BLAS 3 code. -C - CALL DLACPY( 'F', N1, M1, B1, LDB1, A(1,N1+1), N1 ) - CALL DGEMM ( 'No transpose', 'No transpose', N1, M1, M1, - $ ONE, A(1,N1+1), N1, DWORK, LDWM1, ZERO, B, - $ LDB ) - ELSE IF ( LDB1.LT.LDB ) THEN -C - DO 60 J = M1, 1, -1 - DO 50 I = N1, 1, -1 - B(I,J) = B1(I,J) - 50 CONTINUE - 60 CONTINUE -C - IF ( M1.LE.N*N2 ) THEN -C -C Use BLAS 2 code. -C - DO 70 J = 1, N1 - CALL DCOPY( M1, B(J,1), LDB, A(1,N1+1), 1 ) - CALL DGEMV( 'Transpose', M1, M1, ONE, DWORK, LDWM1, - $ A(1,N1+1), 1, ZERO, B(J,1), LDB ) - 70 CONTINUE -C - ELSE -C -C Use additional workspace. -C - DO 80 J = 1, N1 - CALL DCOPY( M1, B(J,1), LDB, DWORK(M1*M1+1), 1 ) - CALL DGEMV( 'Transpose', M1, M1, ONE, DWORK, LDWM1, - $ DWORK(M1*M1+1), 1, ZERO, B(J,1), LDB ) - 80 CONTINUE -C - END IF -C - ELSE IF ( M1.LE.N*N2 ) THEN -C -C Use BLAS 2 code. -C - DO 90 J = 1, N1 - CALL DCOPY( M1, B1(J,1), LDB1, A(1,N1+1), 1 ) - CALL DGEMV( 'Transpose', M1, M1, ONE, DWORK, LDWM1, - $ A(1,N1+1), 1, ZERO, B(J,1), LDB ) - 90 CONTINUE -C - ELSE -C -C Use additional workspace. -C - DO 100 J = 1, N1 - CALL DCOPY( M1, B1(J,1), LDB1, DWORK(M1*M1+1), 1 ) - CALL DGEMV( 'Transpose', M1, M1, ONE, DWORK, LDWM1, - $ DWORK(M1*M1+1), 1, ZERO, B(J,1), LDB ) - 100 CONTINUE -C - END IF - ELSE - CALL DGEMM ( 'No transpose', 'No transpose', N1, M1, M1, - $ ONE, B1, LDB1, DWORK, LDWM1, ZERO, B, LDB ) - END IF - END IF -C - IF ( N2.GT.0 ) THEN -C -C Complete matrices B and C. -C - IF ( P1.GT.0 ) THEN - CALL DGEMM ( 'No transpose', 'No transpose', N2, M1, P1, - $ ONE, B2, LDB2, D, LDD, ZERO, B(N1+1,1), LDB ) - CALL DGEMM ( 'No transpose', 'No transpose', P1, N2, M1, - $ -ALPHA, D, LDD, C2, LDC2, ZERO, C(1,N1+1), LDC - $ ) - ELSE IF ( M1.GT.0 ) THEN - CALL DLASET( 'F', N2, M1, ZERO, ZERO, B(N1+1,1), LDB ) - END IF - END IF -C - IF ( N1.GT.0 .AND. P1.GT.0 ) THEN -C -C Form upper left quadrant of A. -C - CALL DGEMM ( 'No transpose', 'No transpose', N1, P1, M1, - $ -ALPHA, B, LDB, D2, LDD2, ZERO, DWORK, N1 ) -C - IF ( LOVER ) THEN - CALL DGEMM ( 'No transpose', 'No transpose', N1, N1, P1, - $ ONE, DWORK, N1, DWORK(LDW), P1, ONE, A, LDA ) - ELSE - CALL DGEMM ( 'No transpose', 'No transpose', N1, N1, P1, - $ ONE, DWORK, N1, C1, LDC1, ONE, A, LDA ) - END IF - END IF -C - IF ( N2.GT.0 ) THEN -C -C Form lower right quadrant of A. -C - CALL DLACPY( 'F', N2, N2, A2, LDA2, A(N1+1,N1+1), LDA ) - IF ( M1.GT.0 ) - $ CALL DGEMM ( 'No transpose', 'No transpose', N2, N2, M1, - $ -ALPHA, B(N1+1,1), LDB, C2, LDC2, ONE, - $ A(N1+1,N1+1), LDA ) -C -C Complete the matrix A. -C - CALL DGEMM ( 'No transpose', 'No transpose', N2, N1, P1, - $ ONE, B2, LDB2, C, LDC, ZERO, A(N1+1,1), LDA ) - CALL DGEMM ( 'No transpose', 'No transpose', N1, N2, M1, - $ -ALPHA, B, LDB, C2, LDC2, ZERO, A(1,N1+1), LDA ) - END IF -C - RETURN -C *** Last line of AB05ND *** - END diff --git a/mex/sources/libslicot/AB05OD.f b/mex/sources/libslicot/AB05OD.f deleted file mode 100644 index 6eafa6949..000000000 --- a/mex/sources/libslicot/AB05OD.f +++ /dev/null @@ -1,418 +0,0 @@ - SUBROUTINE AB05OD( OVER, N1, M1, P1, N2, M2, ALPHA, A1, LDA1, B1, - $ LDB1, C1, LDC1, D1, LDD1, A2, LDA2, B2, LDB2, - $ C2, LDC2, D2, LDD2, N, M, A, LDA, B, LDB, C, - $ LDC, D, LDD, INFO ) -C -C SLICOT RELEASE 5.0. -C -C Copyright (c) 2002-2009 NICONET e.V. -C -C This program is free software: you can redistribute it and/or -C modify it under the terms of the GNU General Public License as -C published by the Free Software Foundation, either version 2 of -C the License, or (at your option) any later version. -C -C This program is distributed in the hope that it will be useful, -C but WITHOUT ANY WARRANTY; without even the implied warranty of -C MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the -C GNU General Public License for more details. -C -C You should have received a copy of the GNU General Public License -C along with this program. If not, see -C . -C -C PURPOSE -C -C To obtain the state-space model (A,B,C,D) for rowwise -C concatenation (parallel inter-connection on outputs, with separate -C inputs) of two systems, each given in state-space form. -C -C ARGUMENTS -C -C Mode Parameters -C -C OVER CHARACTER*1 -C Indicates whether the user wishes to overlap pairs of -C arrays, as follows: -C = 'N': Do not overlap; -C = 'O': Overlap pairs of arrays: A1 and A, B1 and B, -C C1 and C, and D1 and D, i.e. the same name is -C effectively used for each pair (for all pairs) -C in the routine call. In this case, setting -C LDA1 = LDA, LDB1 = LDB, LDC1 = LDC, and LDD1 = LDD -C will give maximum efficiency. -C -C Input/Output Parameters -C -C N1 (input) INTEGER -C The number of state variables in the first system, i.e. -C the order of the matrix A1. N1 >= 0. -C -C M1 (input) INTEGER -C The number of input variables for the first system. -C M1 >= 0. -C -C P1 (input) INTEGER -C The number of output variables from each system. P1 >= 0. -C -C N2 (input) INTEGER -C The number of state variables in the second system, i.e. -C the order of the matrix A2. N2 >= 0. -C -C M2 (input) INTEGER -C The number of input variables for the second system. -C M2 >= 0. -C -C ALPHA (input) DOUBLE PRECISION -C A coefficient multiplying the transfer-function matrix -C (or the output equation) of the second system. -C -C A1 (input) DOUBLE PRECISION array, dimension (LDA1,N1) -C The leading N1-by-N1 part of this array must contain the -C state transition matrix A1 for the first system. -C -C LDA1 INTEGER -C The leading dimension of array A1. LDA1 >= MAX(1,N1). -C -C B1 (input) DOUBLE PRECISION array, dimension (LDB1,M1) -C The leading N1-by-M1 part of this array must contain the -C input/state matrix B1 for the first system. -C -C LDB1 INTEGER -C The leading dimension of array B1. LDB1 >= MAX(1,N1). -C -C C1 (input) DOUBLE PRECISION array, dimension (LDC1,N1) -C The leading P1-by-N1 part of this array must contain the -C state/output matrix C1 for the first system. -C -C LDC1 INTEGER -C The leading dimension of array C1. -C LDC1 >= MAX(1,P1) if N1 > 0. -C LDC1 >= 1 if N1 = 0. -C -C D1 (input) DOUBLE PRECISION array, dimension (LDD1,M1) -C The leading P1-by-M1 part of this array must contain the -C input/output matrix D1 for the first system. -C -C LDD1 INTEGER -C The leading dimension of array D1. LDD1 >= MAX(1,P1). -C -C A2 (input) DOUBLE PRECISION array, dimension (LDA2,N2) -C The leading N2-by-N2 part of this array must contain the -C state transition matrix A2 for the second system. -C -C LDA2 INTEGER -C The leading dimension of array A2. LDA2 >= MAX(1,N2). -C -C B2 (input) DOUBLE PRECISION array, dimension (LDB2,M2) -C The leading N2-by-M2 part of this array must contain the -C input/state matrix B2 for the second system. -C -C LDB2 INTEGER -C The leading dimension of array B2. LDB2 >= MAX(1,N2). -C -C C2 (input) DOUBLE PRECISION array, dimension (LDC2,N2) -C The leading P1-by-N2 part of this array must contain the -C state/output matrix C2 for the second system. -C -C LDC2 INTEGER -C The leading dimension of array C2. -C LDC2 >= MAX(1,P1) if N2 > 0. -C LDC2 >= 1 if N2 = 0. -C -C D2 (input) DOUBLE PRECISION array, dimension (LDD2,M2) -C The leading P1-by-M2 part of this array must contain the -C input/output matrix D2 for the second system. -C -C LDD2 INTEGER -C The leading dimension of array D2. LDD2 >= MAX(1,P1). -C -C N (output) INTEGER -C The number of state variables (N1 + N2) in the connected -C system, i.e. the order of the matrix A, the number of rows -C of B and the number of columns of C. -C -C M (output) INTEGER -C The number of input variables (M1 + M2) for the connected -C system, i.e. the number of columns of B and D. -C -C A (output) DOUBLE PRECISION array, dimension (LDA,N1+N2) -C The leading N-by-N part of this array contains the state -C transition matrix A for the connected system. -C The array A can overlap A1 if OVER = 'O'. -C -C LDA INTEGER -C The leading dimension of array A. LDA >= MAX(1,N1+N2). -C -C B (output) DOUBLE PRECISION array, dimension (LDB,M1+M2) -C The leading N-by-M part of this array contains the -C input/state matrix B for the connected system. -C The array B can overlap B1 if OVER = 'O'. -C -C LDB INTEGER -C The leading dimension of array B. LDB >= MAX(1,N1+N2). -C -C C (output) DOUBLE PRECISION array, dimension (LDC,N1+N2) -C The leading P1-by-N part of this array contains the -C state/output matrix C for the connected system. -C The array C can overlap C1 if OVER = 'O'. -C -C LDC INTEGER -C The leading dimension of array C. -C LDC >= MAX(1,P1) if N1+N2 > 0. -C LDC >= 1 if N1+N2 = 0. -C -C D (output) DOUBLE PRECISION array, dimension (LDD,M1+M2) -C The leading P1-by-M part of this array contains the -C input/output matrix D for the connected system. -C The array D can overlap D1 if OVER = 'O'. -C -C LDD INTEGER -C The leading dimension of array D. LDD >= MAX(1,P1). -C -C Error Indicator -C -C INFO INTEGER -C = 0: successful exit; -C < 0: if INFO = -i, the i-th argument had an illegal -C value. -C -C METHOD -C -C After rowwise concatenation (parallel inter-connection with -C separate inputs) of the two systems, -C -C X1' = A1*X1 + B1*U -C Y1 = C1*X1 + D1*U -C -C X2' = A2*X2 + B2*V -C Y2 = C2*X2 + D2*V -C -C (where ' denotes differentiation with respect to time), -C -C with the output equation for the second system multiplied by a -C scalar alpha, the following state-space model will be obtained: -C -C X' = A*X + B*(U) -C (V) -C -C Y = C*X + D*(U) -C (V) -C -C where matrix A has the form ( A1 0 ), -C ( 0 A2 ) -C -C matrix B has the form ( B1 0 ), -C ( 0 B2 ) -C -C matrix C has the form ( C1 alpha*C2 ) and -C -C matrix D has the form ( D1 alpha*D2 ). -C -C REFERENCES -C -C None -C -C NUMERICAL ASPECTS -C -C None -C -C CONTRIBUTOR -C -C Release 3.0: V. Sima, Katholieke Univ. Leuven, Belgium, Oct. 1996. -C Supersedes Release 2.0 routine AB05CD by C.J.Benson, Kingston -C Polytechnic, United Kingdom, January 1982. -C -C REVISIONS -C -C V. Sima, Research Institute for Informatics, Bucharest, July 2003, -C Feb. 2004. -C -C KEYWORDS -C -C Continuous-time system, multivariable system, state-space model, -C state-space representation. -C -C ****************************************************************** -C -C .. Parameters .. - DOUBLE PRECISION ZERO, ONE - PARAMETER ( ZERO = 0.0D0, ONE = 1.0D0 ) -C .. Scalar Arguments .. - CHARACTER OVER - INTEGER INFO, LDA, LDA1, LDA2, LDB, LDB1, LDB2, LDC, - $ LDC1, LDC2, LDD, LDD1, LDD2, M, M1, M2, N, N1, - $ N2, P1 - DOUBLE PRECISION ALPHA -C .. Array Arguments .. - DOUBLE PRECISION A(LDA,*), A1(LDA1,*), A2(LDA2,*), B(LDB,*), - $ B1(LDB1,*), B2(LDB2,*), C(LDC,*), C1(LDC1,*), - $ C2(LDC2,*), D(LDD,*), D1(LDD1,*), D2(LDD2,*) -C .. Local Scalars .. - LOGICAL LOVER - INTEGER I, J -C .. External Functions .. - LOGICAL LSAME - EXTERNAL LSAME -C .. External Subroutines .. - EXTERNAL DLACPY, DLASCL, DLASET, XERBLA -C .. Intrinsic Functions .. - INTRINSIC MAX, MIN -C .. Executable Statements .. -C - LOVER = LSAME( OVER, 'O' ) - N = N1 + N2 - M = M1 + M2 - INFO = 0 -C -C Test the input scalar arguments. -C - IF( .NOT.LOVER .AND. .NOT.LSAME( OVER, 'N' ) ) THEN - INFO = -1 - ELSE IF( N1.LT.0 ) THEN - INFO = -2 - ELSE IF( M1.LT.0 ) THEN - INFO = -3 - ELSE IF( P1.LT.0 ) THEN - INFO = -4 - ELSE IF( N2.LT.0 ) THEN - INFO = -5 - ELSE IF( M2.LT.0 ) THEN - INFO = -6 - ELSE IF( LDA1.LT.MAX( 1, N1 ) ) THEN - INFO = -9 - ELSE IF( LDB1.LT.MAX( 1, N1 ) ) THEN - INFO = -11 - ELSE IF( ( N1.GT.0 .AND. LDC1.LT.MAX( 1, P1 ) ) .OR. - $ ( N1.EQ.0 .AND. LDC1.LT.1 ) ) THEN - INFO = -13 - ELSE IF( LDD1.LT.MAX( 1, P1 ) ) THEN - INFO = -15 - ELSE IF( LDA2.LT.MAX( 1, N2 ) ) THEN - INFO = -17 - ELSE IF( LDB2.LT.MAX( 1, N2 ) ) THEN - INFO = -19 - ELSE IF( ( N2.GT.0 .AND. LDC2.LT.MAX( 1, P1 ) ) .OR. - $ ( N2.EQ.0 .AND. LDC2.LT.1 ) ) THEN - INFO = -21 - ELSE IF( LDD2.LT.MAX( 1, P1 ) ) THEN - INFO = -23 - ELSE IF( LDA.LT.MAX( 1, N ) ) THEN - INFO = -27 - ELSE IF( LDB.LT.MAX( 1, N ) ) THEN - INFO = -29 - ELSE IF( ( N.GT.0 .AND. LDC.LT.MAX( 1, P1 ) ) .OR. - $ ( N.EQ.0 .AND. LDC.LT.1 ) ) THEN - INFO = -31 - ELSE IF( LDD.LT.MAX( 1, P1 ) ) THEN - INFO = -33 - END IF -C - IF ( INFO.NE.0 ) THEN -C -C Error return. -C - CALL XERBLA( 'AB05OD', -INFO ) - RETURN - END IF -C -C Quick return if possible. -C - IF ( MAX( N, MIN( M, P1 ) ).EQ.0 ) - $ RETURN -C -C First form the matrix A. -C - IF ( LOVER .AND. LDA1.LE.LDA ) THEN - IF ( LDA1.LT.LDA ) THEN -C - DO 20 J = N1, 1, -1 - DO 10 I = N1, 1, -1 - A(I,J) = A1(I,J) - 10 CONTINUE - 20 CONTINUE -C - END IF - ELSE - CALL DLACPY( 'F', N1, N1, A1, LDA1, A, LDA ) - END IF -C - IF ( N2.GT.0 ) THEN - CALL DLACPY( 'F', N2, N2, A2, LDA2, A(N1+1,N1+1), LDA ) - CALL DLASET( 'F', N1, N2, ZERO, ZERO, A(1,N1+1), LDA ) - CALL DLASET( 'F', N2, N1, ZERO, ZERO, A(N1+1,1), LDA ) - END IF -C -C Now form the matrix B. -C - IF ( LOVER .AND. LDB1.LE.LDB ) THEN - IF ( LDB1.LT.LDB ) THEN -C - DO 40 J = M1, 1, -1 - DO 30 I = N1, 1, -1 - B(I,J) = B1(I,J) - 30 CONTINUE - 40 CONTINUE -C - END IF - ELSE - CALL DLACPY( 'F', N1, M1, B1, LDB1, B, LDB ) - END IF -C - IF ( M2.GT.0 ) THEN - IF ( N2.GT.0 ) - $ CALL DLACPY( 'F', N2, M2, B2, LDB2, B(N1+1,M1+1), LDB ) - CALL DLASET( 'F', N1, M2, ZERO, ZERO, B(1,M1+1), LDB ) - END IF - IF ( N2.GT.0 ) - $ CALL DLASET( 'F', N2, M1, ZERO, ZERO, B(N1+1,1), LDB ) -C -C Now form the matrix C. -C - IF ( LOVER .AND. LDC1.LE.LDC ) THEN - IF ( LDC1.LT.LDC ) THEN -C - DO 60 J = N1, 1, -1 - DO 50 I = P1, 1, -1 - C(I,J) = C1(I,J) - 50 CONTINUE - 60 CONTINUE -C - END IF - ELSE - CALL DLACPY( 'F', P1, N1, C1, LDC1, C, LDC ) - END IF -C - IF ( N2.GT.0 ) THEN - CALL DLACPY( 'F', P1, N2, C2, LDC2, C(1,N1+1), LDC ) - IF ( ALPHA.NE.ONE ) - $ CALL DLASCL( 'G', 0, 0, ONE, ALPHA, P1, N2, C(1,N1+1), LDC, - $ INFO ) - END IF -C -C Now form the matrix D. -C - IF ( LOVER .AND. LDD1.LE.LDD ) THEN - IF ( LDD1.LT.LDD ) THEN -C - DO 80 J = M1, 1, -1 - DO 70 I = P1, 1, -1 - D(I,J) = D1(I,J) - 70 CONTINUE - 80 CONTINUE -C - END IF - ELSE - CALL DLACPY( 'F', P1, M1, D1, LDD1, D, LDD ) - END IF -C - IF ( M2.GT.0 ) THEN - CALL DLACPY( 'F', P1, M2, D2, LDD2, D(1,M1+1), LDD ) - IF ( ALPHA.NE.ONE ) - $ CALL DLASCL( 'G', 0, 0, ONE, ALPHA, P1, M2, D(1,M1+1), LDD, - $ INFO ) - END IF -C - RETURN -C *** Last line of AB05OD *** - END diff --git a/mex/sources/libslicot/AB05PD.f b/mex/sources/libslicot/AB05PD.f deleted file mode 100644 index 918aed8a0..000000000 --- a/mex/sources/libslicot/AB05PD.f +++ /dev/null @@ -1,385 +0,0 @@ - SUBROUTINE AB05PD( OVER, N1, M, P, N2, ALPHA, A1, LDA1, B1, LDB1, - $ C1, LDC1, D1, LDD1, A2, LDA2, B2, LDB2, C2, - $ LDC2, D2, LDD2, N, A, LDA, B, LDB, C, LDC, D, - $ LDD, INFO) -C -C SLICOT RELEASE 5.0. -C -C Copyright (c) 2002-2009 NICONET e.V. -C -C This program is free software: you can redistribute it and/or -C modify it under the terms of the GNU General Public License as -C published by the Free Software Foundation, either version 2 of -C the License, or (at your option) any later version. -C -C This program is distributed in the hope that it will be useful, -C but WITHOUT ANY WARRANTY; without even the implied warranty of -C MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the -C GNU General Public License for more details. -C -C You should have received a copy of the GNU General Public License -C along with this program. If not, see -C . -C -C PURPOSE -C -C To compute the state-space model G = (A,B,C,D) corresponding to -C the sum G = G1 + alpha*G2, where G1 = (A1,B1,C1,D1) and -C G2 = (A2,B2,C2,D2). G, G1, and G2 are the transfer-function -C matrices of the corresponding state-space models. -C -C ARGUMENTS -C -C Mode Parameters -C -C OVER CHARACTER*1 -C Indicates whether the user wishes to overlap pairs of -C arrays, as follows: -C = 'N': Do not overlap; -C = 'O': Overlap pairs of arrays: A1 and A, B1 and B, -C C1 and C, and D1 and D, i.e. the same name is -C effectively used for each pair (for all pairs) -C in the routine call. In this case, setting -C LDA1 = LDA, LDB1 = LDB, LDC1 = LDC, and LDD1 = LDD -C will give maximum efficiency. -C -C Input/Output Parameters -C -C N1 (input) INTEGER -C The number of state variables in the first system, i.e. -C the order of the matrix A1, the number of rows of B1 and -C the number of columns of C1. N1 >= 0. -C -C M (input) INTEGER -C The number of input variables of the two systems, i.e. the -C number of columns of matrices B1, D1, B2 and D2. M >= 0. -C -C P (input) INTEGER -C The number of output variables of the two systems, i.e. -C the number of rows of matrices C1, D1, C2 and D2. P >= 0. -C -C N2 (input) INTEGER -C The number of state variables in the second system, i.e. -C the order of the matrix A2, the number of rows of B2 and -C the number of columns of C2. N2 >= 0. -C -C ALPHA (input) DOUBLE PRECISION -C The coefficient multiplying G2. -C -C A1 (input) DOUBLE PRECISION array, dimension (LDA1,N1) -C The leading N1-by-N1 part of this array must contain the -C state transition matrix A1 for the first system. -C -C LDA1 INTEGER -C The leading dimension of array A1. LDA1 >= MAX(1,N1). -C -C B1 (input) DOUBLE PRECISION array, dimension (LDB1,M) -C The leading N1-by-M part of this array must contain the -C input/state matrix B1 for the first system. -C -C LDB1 INTEGER -C The leading dimension of array B1. LDB1 >= MAX(1,N1). -C -C C1 (input) DOUBLE PRECISION array, dimension (LDC1,N1) -C The leading P-by-N1 part of this array must contain the -C state/output matrix C1 for the first system. -C -C LDC1 INTEGER -C The leading dimension of array C1. -C LDC1 >= MAX(1,P) if N1 > 0. -C LDC1 >= 1 if N1 = 0. -C -C D1 (input) DOUBLE PRECISION array, dimension (LDD1,M) -C The leading P-by-M part of this array must contain the -C input/output matrix D1 for the first system. -C -C LDD1 INTEGER -C The leading dimension of array D1. LDD1 >= MAX(1,P). -C -C A2 (input) DOUBLE PRECISION array, dimension (LDA2,N2) -C The leading N2-by-N2 part of this array must contain the -C state transition matrix A2 for the second system. -C -C LDA2 INTEGER -C The leading dimension of array A2. LDA2 >= MAX(1,N2). -C -C B2 (input) DOUBLE PRECISION array, dimension (LDB2,M) -C The leading N2-by-M part of this array must contain the -C input/state matrix B2 for the second system. -C -C LDB2 INTEGER -C The leading dimension of array B2. LDB2 >= MAX(1,N2). -C -C C2 (input) DOUBLE PRECISION array, dimension (LDC2,N2) -C The leading P-by-N2 part of this array must contain the -C state/output matrix C2 for the second system. -C -C LDC2 INTEGER -C The leading dimension of array C2. -C LDC2 >= MAX(1,P) if N2 > 0. -C LDC2 >= 1 if N2 = 0. -C -C D2 (input) DOUBLE PRECISION array, dimension (LDD2,M) -C The leading P-by-M part of this array must contain the -C input/output matrix D2 for the second system. -C -C LDD2 INTEGER -C The leading dimension of array D2. LDD2 >= MAX(1,P). -C -C N (output) INTEGER -C The number of state variables (N1 + N2) in the resulting -C system, i.e. the order of the matrix A, the number of rows -C of B and the number of columns of C. -C -C A (output) DOUBLE PRECISION array, dimension (LDA,N1+N2) -C The leading N-by-N part of this array contains the state -C transition matrix A for the resulting system. -C The array A can overlap A1 if OVER = 'O'. -C -C LDA INTEGER -C The leading dimension of array A. LDA >= MAX(1,N1+N2). -C -C B (output) DOUBLE PRECISION array, dimension (LDB,M) -C The leading N-by-M part of this array contains the -C input/state matrix B for the resulting system. -C The array B can overlap B1 if OVER = 'O'. -C -C LDB INTEGER -C The leading dimension of array B. LDB >= MAX(1,N1+N2). -C -C C (output) DOUBLE PRECISION array, dimension (LDC,N1+N2) -C The leading P-by-N part of this array contains the -C state/output matrix C for the resulting system. -C The array C can overlap C1 if OVER = 'O'. -C -C LDC INTEGER -C The leading dimension of array C. -C LDC >= MAX(1,P) if N1+N2 > 0. -C LDC >= 1 if N1+N2 = 0. -C -C D (output) DOUBLE PRECISION array, dimension (LDD,M) -C The leading P-by-M part of this array contains the -C input/output matrix D for the resulting system. -C The array D can overlap D1 if OVER = 'O'. -C -C LDD INTEGER -C The leading dimension of array D. LDD >= MAX(1,P). -C -C Error Indicator -C -C INFO INTEGER -C = 0: successful exit; -C < 0: if INFO = -i, the i-th argument had an illegal -C value. -C -C METHOD -C -C The matrices of the resulting systems are determined as: -C -C ( A1 0 ) ( B1 ) -C A = ( ) , B = ( ) , -C ( 0 A2 ) ( B2 ) -C -C C = ( C1 alpha*C2 ) , D = D1 + alpha*D2 . -C -C REFERENCES -C -C None -C -C NUMERICAL ASPECTS -C -C None -C -C CONTRIBUTORS -C -C A. Varga, German Aerospace Research Establishment, -C Oberpfaffenhofen, Germany, and V. Sima, Katholieke Univ. Leuven, -C Belgium, Nov. 1996. -C -C REVISIONS -C -C V. Sima, Research Institute for Informatics, Bucharest, July 2003, -C Feb. 2004. -C -C KEYWORDS -C -C Multivariable system, state-space model, state-space -C representation. -C -C ****************************************************************** -C -C .. Parameters .. - DOUBLE PRECISION ZERO, ONE - PARAMETER ( ZERO=0.0D0, ONE = 1.0D0 ) -C .. Scalar Arguments .. - CHARACTER OVER - INTEGER INFO, LDA, LDA1, LDA2, LDB, LDB1, LDB2, LDC, - $ LDC1, LDC2, LDD, LDD1, LDD2, M, N, N1, N2, P - DOUBLE PRECISION ALPHA -C .. Array Arguments .. - DOUBLE PRECISION A(LDA,*), A1(LDA1,*), A2(LDA2,*), B(LDB,*), - $ B1(LDB1,*), B2(LDB2,*), C(LDC,*), C1(LDC1,*), - $ C2(LDC2,*), D(LDD,*), D1(LDD1,*), D2(LDD2,*) -C .. Local Scalars .. - LOGICAL LOVER - INTEGER I, J, N1P1 -C .. External Functions .. - LOGICAL LSAME - EXTERNAL LSAME -C .. External Subroutines .. - EXTERNAL DAXPY, DLACPY, DLASCL, DLASET, XERBLA -C .. Intrinsic Functions .. - INTRINSIC MAX, MIN -C .. Executable Statements .. -C - LOVER = LSAME( OVER, 'O' ) - N = N1 + N2 - INFO = 0 -C -C Test the input scalar arguments. -C - IF( .NOT.LOVER .AND. .NOT.LSAME( OVER, 'N' ) ) THEN - INFO = -1 - ELSE IF( N1.LT.0 ) THEN - INFO = -2 - ELSE IF( M.LT.0 ) THEN - INFO = -3 - ELSE IF( P.LT.0 ) THEN - INFO = -4 - ELSE IF( N2.LT.0 ) THEN - INFO = -5 - ELSE IF( LDA1.LT.MAX( 1, N1 ) ) THEN - INFO = -8 - ELSE IF( LDB1.LT.MAX( 1, N1 ) ) THEN - INFO = -10 - ELSE IF( ( N1.GT.0 .AND. LDC1.LT.MAX( 1, P ) ) .OR. - $ ( N1.EQ.0 .AND. LDC1.LT.1 ) ) THEN - INFO = -12 - ELSE IF( LDD1.LT.MAX( 1, P ) ) THEN - INFO = -14 - ELSE IF( LDA2.LT.MAX( 1, N2 ) ) THEN - INFO = -16 - ELSE IF( LDB2.LT.MAX( 1, N2 ) ) THEN - INFO = -18 - ELSE IF( ( N2.GT.0 .AND. LDC2.LT.MAX( 1, P ) ) .OR. - $ ( N2.EQ.0 .AND. LDC2.LT.1 ) ) THEN - INFO = -20 - ELSE IF( LDD2.LT.MAX( 1, P ) ) THEN - INFO = -22 - ELSE IF( LDA.LT.MAX( 1, N ) ) THEN - INFO = -25 - ELSE IF( LDB.LT.MAX( 1, N ) ) THEN - INFO = -27 - ELSE IF( ( N.GT.0 .AND. LDC.LT.MAX( 1, P ) ) .OR. - $ ( N.EQ.0 .AND. LDC.LT.1 ) ) THEN - INFO = -29 - ELSE IF( LDD.LT.MAX( 1, P ) ) THEN - INFO = -31 - END IF -C - IF ( INFO.NE.0 ) THEN -C -C Error return. -C - CALL XERBLA( 'AB05PD', -INFO ) - RETURN - END IF -C -C Quick return if possible. -C - IF ( MAX( N, MIN( M, P ) ).EQ.0 ) - $ RETURN -C - N1P1 = N1 + 1 -C -C ( A1 0 ) -C Construct A = ( ) . -C ( 0 A2 ) -C - IF ( LOVER .AND. LDA1.LE.LDA ) THEN - IF ( LDA1.LT.LDA ) THEN -C - DO 20 J = N1, 1, -1 - DO 10 I = N1, 1, -1 - A(I,J) = A1(I,J) - 10 CONTINUE - 20 CONTINUE -C - END IF - ELSE - CALL DLACPY( 'F', N1, N1, A1, LDA1, A, LDA ) - END IF -C - IF ( N2.GT.0 ) THEN - CALL DLASET( 'F', N1, N2, ZERO, ZERO, A(1,N1P1), LDA ) - CALL DLASET( 'F', N2, N1, ZERO, ZERO, A(N1P1,1), LDA ) - CALL DLACPY( 'F', N2, N2, A2, LDA2, A(N1P1,N1P1), LDA ) - END IF -C -C ( B1 ) -C Construct B = ( ) . -C ( B2 ) -C - IF ( LOVER .AND. LDB1.LE.LDB ) THEN - IF ( LDB1.LT.LDB ) THEN -C - DO 40 J = M, 1, -1 - DO 30 I = N1, 1, -1 - B(I,J) = B1(I,J) - 30 CONTINUE - 40 CONTINUE -C - END IF - ELSE - CALL DLACPY( 'F', N1, M, B1, LDB1, B, LDB ) - END IF -C - IF ( N2.GT.0 ) - $ CALL DLACPY( 'F', N2, M, B2, LDB2, B(N1P1,1), LDB ) -C -C Construct C = ( C1 alpha*C2 ) . -C - IF ( LOVER .AND. LDC1.LE.LDC ) THEN - IF ( LDC1.LT.LDC ) THEN -C - DO 60 J = N1, 1, -1 - DO 50 I = P, 1, -1 - C(I,J) = C1(I,J) - 50 CONTINUE - 60 CONTINUE -C - END IF - ELSE - CALL DLACPY( 'F', P, N1, C1, LDC1, C, LDC ) - END IF -C - IF ( N2.GT.0 ) THEN - CALL DLACPY( 'F', P, N2, C2, LDC2, C(1,N1P1), LDC ) - IF ( ALPHA.NE.ONE ) - $ CALL DLASCL( 'G', 0, 0, ONE, ALPHA, P, N2, C(1,N1P1), LDC, - $ INFO ) - END IF -C -C Construct D = D1 + alpha*D2 . -C - IF ( LOVER .AND. LDD1.LE.LDD ) THEN - IF ( LDD1.LT.LDD ) THEN -C - DO 80 J = M, 1, -1 - DO 70 I = P, 1, -1 - D(I,J) = D1(I,J) - 70 CONTINUE - 80 CONTINUE -C - END IF - ELSE - CALL DLACPY( 'F', P, M, D1, LDD1, D, LDD ) - END IF -C - DO 90 J = 1, M - CALL DAXPY( P, ALPHA, D2(1,J), 1, D(1,J), 1 ) - 90 CONTINUE -C - RETURN -C *** Last line of AB05PD *** - END diff --git a/mex/sources/libslicot/AB05QD.f b/mex/sources/libslicot/AB05QD.f deleted file mode 100644 index c9f54bcaa..000000000 --- a/mex/sources/libslicot/AB05QD.f +++ /dev/null @@ -1,419 +0,0 @@ - SUBROUTINE AB05QD( OVER, N1, M1, P1, N2, M2, P2, A1, LDA1, B1, - $ LDB1, C1, LDC1, D1, LDD1, A2, LDA2, B2, LDB2, - $ C2, LDC2, D2, LDD2, N, M, P, A, LDA, B, LDB, - $ C, LDC, D, LDD, INFO ) -C -C SLICOT RELEASE 5.0. -C -C Copyright (c) 2002-2009 NICONET e.V. -C -C This program is free software: you can redistribute it and/or -C modify it under the terms of the GNU General Public License as -C published by the Free Software Foundation, either version 2 of -C the License, or (at your option) any later version. -C -C This program is distributed in the hope that it will be useful, -C but WITHOUT ANY WARRANTY; without even the implied warranty of -C MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the -C GNU General Public License for more details. -C -C You should have received a copy of the GNU General Public License -C along with this program. If not, see -C . -C -C PURPOSE -C -C To append two systems G1 and G2 in state-space form together. -C If G1 = (A1,B1,C1,D1) and G2 = (A2,B2,C2,D2) are the state-space -C models of the given two systems having the transfer-function -C matrices G1 and G2, respectively, this subroutine constructs the -C state-space model G = (A,B,C,D) which corresponds to the -C transfer-function matrix -C -C ( G1 0 ) -C G = ( ) -C ( 0 G2 ) -C -C ARGUMENTS -C -C Mode Parameters -C -C OVER CHARACTER*1 -C Indicates whether the user wishes to overlap pairs of -C arrays, as follows: -C = 'N': Do not overlap; -C = 'O': Overlap pairs of arrays: A1 and A, B1 and B, -C C1 and C, and D1 and D, i.e. the same name is -C effectively used for each pair (for all pairs) -C in the routine call. In this case, setting -C LDA1 = LDA, LDB1 = LDB, LDC1 = LDC, and LDD1 = LDD -C will give maximum efficiency. -C -C Input/Output Parameters -C -C N1 (input) INTEGER -C The number of state variables in the first system, i.e. -C the order of the matrix A1, the number of rows of B1 and -C the number of columns of C1. N1 >= 0. -C -C M1 (input) INTEGER -C The number of input variables in the first system, i.e. -C the number of columns of matrices B1 and D1. M1 >= 0. -C -C P1 (input) INTEGER -C The number of output variables in the first system, i.e. -C the number of rows of matrices C1 and D1. P1 >= 0. -C -C N2 (input) INTEGER -C The number of state variables in the second system, i.e. -C the order of the matrix A2, the number of rows of B2 and -C the number of columns of C2. N2 >= 0. -C -C M2 (input) INTEGER -C The number of input variables in the second system, i.e. -C the number of columns of matrices B2 and D2. M2 >= 0. -C -C P2 (input) INTEGER -C The number of output variables in the second system, i.e. -C the number of rows of matrices C2 and D2. P2 >= 0. -C -C A1 (input) DOUBLE PRECISION array, dimension (LDA1,N1) -C The leading N1-by-N1 part of this array must contain the -C state transition matrix A1 for the first system. -C -C LDA1 INTEGER -C The leading dimension of array A1. LDA1 >= MAX(1,N1). -C -C B1 (input) DOUBLE PRECISION array, dimension (LDB1,M1) -C The leading N1-by-M1 part of this array must contain the -C input/state matrix B1 for the first system. -C -C LDB1 INTEGER -C The leading dimension of array B1. LDB1 >= MAX(1,N1). -C -C C1 (input) DOUBLE PRECISION array, dimension (LDC1,N1) -C The leading P1-by-N1 part of this array must contain the -C state/output matrix C1 for the first system. -C -C LDC1 INTEGER -C The leading dimension of array C1. -C LDC1 >= MAX(1,P1) if N1 > 0. -C LDC1 >= 1 if N1 = 0. -C -C D1 (input) DOUBLE PRECISION array, dimension (LDD1,M1) -C The leading P1-by-M1 part of this array must contain the -C input/output matrix D1 for the first system. -C -C LDD1 INTEGER -C The leading dimension of array D1. LDD1 >= MAX(1,P1). -C -C A2 (input) DOUBLE PRECISION array, dimension (LDA2,N2) -C The leading N2-by-N2 part of this array must contain the -C state transition matrix A2 for the second system. -C -C LDA2 INTEGER -C The leading dimension of array A2. LDA2 >= MAX(1,N2). -C -C B2 (input) DOUBLE PRECISION array, dimension (LDB2,M2) -C The leading N2-by-M2 part of this array must contain the -C input/state matrix B2 for the second system. -C -C LDB2 INTEGER -C The leading dimension of array B2. LDB2 >= MAX(1,N2). -C -C C2 (input) DOUBLE PRECISION array, dimension (LDC2,N2) -C The leading P2-by-N2 part of this array must contain the -C state/output matrix C2 for the second system. -C -C LDC2 INTEGER -C The leading dimension of array C2. -C LDC2 >= MAX(1,P2) if N2 > 0. -C LDC2 >= 1 if N2 = 0. -C -C D2 (input) DOUBLE PRECISION array, dimension (LDD2,M2) -C The leading P2-by-M2 part of this array must contain the -C input/output matrix D2 for the second system. -C -C LDD2 INTEGER -C The leading dimension of array D2. LDD2 >= MAX(1,P2). -C -C N (output) INTEGER -C The number of state variables (N1 + N2) in the resulting -C system, i.e. the order of the matrix A, the number of rows -C of B and the number of columns of C. -C -C M (output) INTEGER -C The number of input variables (M1 + M2) in the resulting -C system, i.e. the number of columns of B and D. -C -C P (output) INTEGER -C The number of output variables (P1 + P2) of the resulting -C system, i.e. the number of rows of C and D. -C -C A (output) DOUBLE PRECISION array, dimension (LDA,N1+N2) -C The leading N-by-N part of this array contains the state -C transition matrix A for the resulting system. -C The array A can overlap A1 if OVER = 'O'. -C -C LDA INTEGER -C The leading dimension of array A. LDA >= MAX(1,N1+N2). -C -C B (output) DOUBLE PRECISION array, dimension (LDB,M1+M2) -C The leading N-by-M part of this array contains the -C input/state matrix B for the resulting system. -C The array B can overlap B1 if OVER = 'O'. -C -C LDB INTEGER -C The leading dimension of array B. LDB >= MAX(1,N1+N2). -C -C C (output) DOUBLE PRECISION array, dimension (LDC,N1+N2) -C The leading P-by-N part of this array contains the -C state/output matrix C for the resulting system. -C The array C can overlap C1 if OVER = 'O'. -C -C LDC INTEGER -C The leading dimension of array C. -C LDC >= MAX(1,P1+P2) if N1+N2 > 0. -C LDC >= 1 if N1+N2 = 0. -C -C D (output) DOUBLE PRECISION array, dimension (LDD,M1+M2) -C The leading P-by-M part of this array contains the -C input/output matrix D for the resulting system. -C The array D can overlap D1 if OVER = 'O'. -C -C LDD INTEGER -C The leading dimension of array D. LDD >= MAX(1,P1+P2). -C -C Error Indicator -C -C INFO INTEGER -C = 0: successful exit; -C < 0: if INFO = -i, the i-th argument had an illegal -C value. -C -C METHOD -C -C The matrices of the resulting systems are determined as: -C -C ( A1 0 ) ( B1 0 ) -C A = ( ) , B = ( ) , -C ( 0 A2 ) ( 0 B2 ) -C -C ( C1 0 ) ( D1 0 ) -C C = ( ) , D = ( ) . -C ( 0 C2 ) ( 0 D2 ) -C -C REFERENCES -C -C None -C -C CONTRIBUTORS -C -C A. Varga, German Aerospace Research Establishment, -C Oberpfaffenhofen, Germany, and V. Sima, Katholieke Univ. Leuven, -C Belgium, Nov. 1996. -C -C REVISIONS -C -C V. Sima, Research Institute for Informatics, Bucharest, Feb. 2004. -C -C KEYWORDS -C -C Multivariable system, state-space model, state-space -C representation. -C -C ****************************************************************** -C -C .. Parameters .. - DOUBLE PRECISION ZERO - PARAMETER ( ZERO=0.0D0 ) -C .. Scalar Arguments .. - CHARACTER OVER - INTEGER INFO, LDA, LDA1, LDA2, LDB, LDB1, LDB2, LDC, - $ LDC1, LDC2, LDD, LDD1, LDD2, M, M1, M2, N, N1, - $ N2, P, P1, P2 -C .. Array Arguments .. - DOUBLE PRECISION A(LDA,*), A1(LDA1,*), A2(LDA2,*), B(LDB,*), - $ B1(LDB1,*), B2(LDB2,*), C(LDC,*), C1(LDC1,*), - $ C2(LDC2,*), D(LDD,*), D1(LDD1,*), D2(LDD2,*) -C .. Local Scalars .. - LOGICAL LOVER - INTEGER I, J -C .. External Functions .. - LOGICAL LSAME - EXTERNAL LSAME -C .. External Subroutines .. - EXTERNAL DLACPY, DLASET, XERBLA -C .. Intrinsic Functions .. - INTRINSIC MAX, MIN -C .. Executable Statements .. -C - LOVER = LSAME( OVER, 'O' ) - N = N1 + N2 - M = M1 + M2 - P = P1 + P2 - INFO = 0 -C -C Test the input scalar arguments. -C - IF( .NOT.LOVER .AND. .NOT.LSAME( OVER, 'N' ) ) THEN - INFO = -1 - ELSE IF( N1.LT.0 ) THEN - INFO = -2 - ELSE IF( M1.LT.0 ) THEN - INFO = -3 - ELSE IF( P1.LT.0 ) THEN - INFO = -4 - ELSE IF( N2.LT.0 ) THEN - INFO = -5 - ELSE IF( M2.LT.0 ) THEN - INFO = -6 - ELSE IF( P2.LT.0 ) THEN - INFO = -7 - ELSE IF( LDA1.LT.MAX( 1, N1 ) ) THEN - INFO = -9 - ELSE IF( LDB1.LT.MAX( 1, N1 ) ) THEN - INFO = -11 - ELSE IF( ( N1.GT.0 .AND. LDC1.LT.MAX( 1, P1 ) ) .OR. - $ ( N1.EQ.0 .AND. LDC1.LT.1 ) ) THEN - INFO = -13 - ELSE IF( LDD1.LT.MAX( 1, P1 ) ) THEN - INFO = -15 - ELSE IF( LDA2.LT.MAX( 1, N2 ) ) THEN - INFO = -17 - ELSE IF( LDB2.LT.MAX( 1, N2 ) ) THEN - INFO = -19 - ELSE IF( ( N2.GT.0 .AND. LDC2.LT.MAX( 1, P2 ) ) .OR. - $ ( N2.EQ.0 .AND. LDC2.LT.1 ) ) THEN - INFO = -21 - ELSE IF( LDD2.LT.MAX( 1, P2 ) ) THEN - INFO = -23 - ELSE IF( LDA.LT.MAX( 1, N ) ) THEN - INFO = -28 - ELSE IF( LDB.LT.MAX( 1, N ) ) THEN - INFO = -30 - ELSE IF( ( N.GT.0 .AND. LDC.LT.MAX( 1, P ) ) .OR. - $ ( N.EQ.0 .AND. LDC.LT.1 ) ) THEN - INFO = -32 - ELSE IF( LDD.LT.MAX( 1, P ) ) THEN - INFO = -34 - END IF -C - IF ( INFO.NE.0 ) THEN -C -C Error return. -C - CALL XERBLA( 'AB05QD', -INFO ) - RETURN - END IF -C -C Quick return if possible. -C - IF ( MAX( N, MIN( M, P ) ).EQ.0 ) - $ RETURN -C ( A1 0 ) -C Construct A = ( ) . -C ( 0 A2 ) -C - IF ( LOVER .AND. LDA1.LE.LDA ) THEN - IF ( LDA1.LT.LDA ) THEN -C - DO 20 J = N1, 1, -1 - DO 10 I = N1, 1, -1 - A(I,J) = A1(I,J) - 10 CONTINUE - 20 CONTINUE -C - END IF - ELSE - CALL DLACPY( 'F', N1, N1, A1, LDA1, A, LDA ) - END IF -C - IF ( N2.GT.0 ) THEN - CALL DLASET( 'F', N1, N2, ZERO, ZERO, A(1,N1+1), LDA ) - CALL DLASET( 'F', N2, N1, ZERO, ZERO, A(N1+1,1), LDA ) - CALL DLACPY( 'F', N2, N2, A2, LDA2, A(N1+1,N1+1), LDA ) - END IF -C -C ( B1 0 ) -C Construct B = ( ) . -C ( 0 B2 ) -C - IF ( LOVER .AND. LDB1.LE.LDB ) THEN - IF ( LDB1.LT.LDB ) THEN -C - DO 40 J = M1, 1, -1 - DO 30 I = N1, 1, -1 - B(I,J) = B1(I,J) - 30 CONTINUE - 40 CONTINUE -C - END IF - ELSE - CALL DLACPY( 'F', N1, M1, B1, LDB1, B, LDB ) - END IF -C - IF ( M2.GT.0 ) - $ CALL DLASET( 'F', N1, M2, ZERO, ZERO, B(1,M1+1), LDB ) - IF ( N2.GT.0 ) THEN - CALL DLASET( 'F', N2, M1, ZERO, ZERO, B(N1+1,1), LDB ) - IF ( M2.GT.0 ) - $ CALL DLACPY( 'F', N2, M2, B2, LDB2, B(N1+1,M1+1), LDB ) - END IF -C -C ( C1 0 ) -C Construct C = ( ) . -C ( 0 C2 ) -C - IF ( LOVER .AND. LDC1.LE.LDC ) THEN - IF ( LDC1.LT.LDC ) THEN -C - DO 60 J = N1, 1, -1 - DO 50 I = P1, 1, -1 - C(I,J) = C1(I,J) - 50 CONTINUE - 60 CONTINUE -C - END IF - ELSE - CALL DLACPY( 'F', P1, N1, C1, LDC1, C, LDC ) - END IF -C - IF ( N2.GT.0 ) - $ CALL DLASET( 'F', P1, N2, ZERO, ZERO, C(1,N1+1), LDC ) - IF ( P2.GT.0 ) THEN - IF ( N1.GT.0 ) - $ CALL DLASET( 'F', P2, N1, ZERO, ZERO, C(P1+1,1), LDC ) - IF ( N2.GT.0 ) - $ CALL DLACPY( 'F', P2, N2, C2, LDC2, C(P1+1,N1+1), LDC ) - END IF -C -C ( D1 0 ) -C Construct D = ( ) . -C ( 0 D2 ) -C - IF ( LOVER .AND. LDD1.LE.LDD ) THEN - IF ( LDD1.LT.LDD ) THEN -C - DO 80 J = M1, 1, -1 - DO 70 I = P1, 1, -1 - D(I,J) = D1(I,J) - 70 CONTINUE - 80 CONTINUE -C - END IF - ELSE - CALL DLACPY( 'F', P1, M1, D1, LDD1, D, LDD ) - END IF -C - IF ( M2.GT.0 ) - $ CALL DLASET( 'F', P1, M2, ZERO, ZERO, D(1,M1+1), LDD ) - IF ( P2.GT.0 ) THEN - CALL DLASET( 'F', P2, M1, ZERO, ZERO, D(P1+1,1), LDD ) - IF ( M2.GT.0 ) - $ CALL DLACPY( 'F', P2, M2, D2, LDD2, D(P1+1,M1+1), LDD ) - END IF -C - RETURN -C *** Last line of AB05QD *** - END diff --git a/mex/sources/libslicot/AB05RD.f b/mex/sources/libslicot/AB05RD.f deleted file mode 100644 index 4592f93d3..000000000 --- a/mex/sources/libslicot/AB05RD.f +++ /dev/null @@ -1,393 +0,0 @@ - SUBROUTINE AB05RD( FBTYPE, JOBD, N, M, P, MV, PZ, ALPHA, BETA, A, - $ LDA, B, LDB, C, LDC, D, LDD, F, LDF, K, LDK, - $ G, LDG, H, LDH, RCOND, BC, LDBC, CC, LDCC, - $ DC, LDDC, IWORK, DWORK, LDWORK, INFO ) -C -C SLICOT RELEASE 5.0. -C -C Copyright (c) 2002-2009 NICONET e.V. -C -C This program is free software: you can redistribute it and/or -C modify it under the terms of the GNU General Public License as -C published by the Free Software Foundation, either version 2 of -C the License, or (at your option) any later version. -C -C This program is distributed in the hope that it will be useful, -C but WITHOUT ANY WARRANTY; without even the implied warranty of -C MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the -C GNU General Public License for more details. -C -C You should have received a copy of the GNU General Public License -C along with this program. If not, see -C . -C -C PURPOSE -C -C To construct for a given state space system (A,B,C,D) the closed- -C loop system (Ac,Bc,Cc,Dc) corresponding to the mixed output and -C state feedback control law -C -C u = alpha*F*y + beta*K*x + G*v -C z = H*y. -C -C ARGUMENTS -C -C Mode Parameters -C -C FBTYPE CHARACTER*1 -C Specifies the type of the feedback law as follows: -C = 'I': Unitary output feedback (F = I); -C = 'O': General output feedback. -C -C JOBD CHARACTER*1 -C Specifies whether or not a non-zero matrix D appears -C in the given state space model: -C = 'D': D is present; -C = 'Z': D is assumed a zero matrix. -C -C Input/Output Parameters -C -C N (input) INTEGER -C The dimension of state vector x, i.e. the order of the -C matrix A, the number of rows of B and the number of -C columns of C. N >= 0. -C -C M (input) INTEGER -C The dimension of input vector u, i.e. the number of -C columns of matrices B and D, and the number of rows of F. -C M >= 0. -C -C P (input) INTEGER -C The dimension of output vector y, i.e. the number of rows -C of matrices C and D, and the number of columns of F. -C P >= 0 and P = M if FBTYPE = 'I'. -C -C MV (input) INTEGER -C The dimension of the new input vector v, i.e. the number -C of columns of matrix G. MV >= 0. -C -C PZ (input) INTEGER. -C The dimension of the new output vector z, i.e. the number -C of rows of matrix H. PZ >= 0. -C -C ALPHA (input) DOUBLE PRECISION -C The coefficient alpha in the output feedback law. -C -C BETA (input) DOUBLE PRECISION. -C The coefficient beta in the state feedback law. -C -C A (input/output) DOUBLE PRECISION array, dimension (LDA,N) -C On entry, the leading N-by-N part of this array must -C contain the system state transition matrix A. -C On exit, the leading N-by-N part of this array contains -C the state matrix Ac of the closed-loop system. -C -C LDA INTEGER -C The leading dimension of array A. LDA >= MAX(1,N). -C -C B (input/output) DOUBLE PRECISION array, dimension (LDB,M) -C On entry, the leading N-by-M part of this array must -C contain the system input matrix B. -C On exit, the leading N-by-M part of this array contains -C the intermediary input matrix B1 (see METHOD). -C -C LDB INTEGER -C The leading dimension of array B. LDB >= MAX(1,N). -C -C C (input/output) DOUBLE PRECISION array, dimension (LDC,N) -C On entry, the leading P-by-N part of this array must -C contain the system output matrix C. -C On exit, the leading P-by-N part of this array contains -C the intermediary output matrix C1+BETA*D1*K (see METHOD). -C -C LDC INTEGER -C The leading dimension of array C. -C LDC >= MAX(1,P) if N > 0. -C LDC >= 1 if N = 0. -C -C D (input/output) DOUBLE PRECISION array, dimension (LDD,M) -C On entry, if JOBD = 'D', the leading P-by-M part of this -C array must contain the system direct input/output -C transmission matrix D. -C On exit, the leading P-by-M part of this array contains -C the intermediary direct input/output transmission matrix -C D1 (see METHOD). -C The array D is not referenced if JOBD = 'Z'. -C -C LDD INTEGER -C The leading dimension of array D. -C LDD >= MAX(1,P) if JOBD = 'D'. -C LDD >= 1 if JOBD = 'Z'. -C -C F (input) DOUBLE PRECISION array, dimension (LDF,P) -C If FBTYPE = 'O', the leading M-by-P part of this array -C must contain the output feedback matrix F. -C If FBTYPE = 'I', then the feedback matrix is assumed to be -C an M x M order identity matrix. -C The array F is not referenced if FBTYPE = 'I' or -C ALPHA = 0. -C -C LDF INTEGER -C The leading dimension of array F. -C LDF >= MAX(1,M) if FBTYPE = 'O' and ALPHA <> 0. -C LDF >= 1 if FBTYPE = 'I' or ALPHA = 0. -C -C K (input) DOUBLE PRECISION array, dimension (LDK,N) -C The leading M-by-N part of this array must contain the -C state feedback matrix K. -C The array K is not referenced if BETA = 0. -C -C LDK INTEGER -C The leading dimension of the array K. -C LDK >= MAX(1,M) if BETA <> 0. -C LDK >= 1 if BETA = 0. -C -C G (input) DOUBLE PRECISION array, dimension (LDG,MV) -C The leading M-by-MV part of this array must contain the -C system input scaling matrix G. -C -C LDG INTEGER -C The leading dimension of the array G. LDG >= MAX(1,M). -C -C H (input) DOUBLE PRECISION array, dimension (LDH,P) -C The leading PZ-by-P part of this array must contain the -C system output scaling matrix H. -C -C LDH INTEGER -C The leading dimension of the array H. LDH >= MAX(1,PZ). -C -C RCOND (output) DOUBLE PRECISION -C The reciprocal condition number of the matrix -C I - alpha*D*F. -C -C BC (output) DOUBLE PRECISION array, dimension (LDBC,MV) -C The leading N-by-MV part of this array contains the input -C matrix Bc of the closed-loop system. -C -C LDBC INTEGER -C The leading dimension of array BC. LDBC >= MAX(1,N). -C -C CC (output) DOUBLE PRECISION array, dimension (LDCC,N) -C The leading PZ-by-N part of this array contains the -C system output matrix Cc of the closed-loop system. -C -C LDCC INTEGER -C The leading dimension of array CC. -C LDCC >= MAX(1,PZ) if N > 0. -C LDCC >= 1 if N = 0. -C -C DC (output) DOUBLE PRECISION array, dimension (LDDC,MV) -C If JOBD = 'D', the leading PZ-by-MV part of this array -C contains the direct input/output transmission matrix Dc -C of the closed-loop system. -C The array DC is not referenced if JOBD = 'Z'. -C -C LDDC INTEGER -C The leading dimension of array DC. -C LDDC >= MAX(1,PZ) if JOBD = 'D'. -C LDDC >= 1 if JOBD = 'Z'. -C -C Workspace -C -C IWORK INTEGER array, dimension (LIWORK) -C LIWORK >= MAX(1,2*P) if JOBD = 'D'. -C LIWORK >= 1 if JOBD = 'Z'. -C IWORK is not referenced if JOBD = 'Z'. -C -C DWORK DOUBLE PRECISION array, dimension (LDWORK) -C -C LDWORK INTEGER -C The length of the array DWORK. -C LDWORK >= wspace, where -C wspace = MAX( 1, M, P*MV, P*P + 4*P ) if JOBD = 'D', -C wspace = MAX( 1, M ) if JOBD = 'Z'. -C For best performance, LDWORK >= MAX( wspace, N*M, N*P ). -C -C Error Indicator -C -C INFO INTEGER -C = 0: successful exit; -C < 0: if INFO = -i, the i-th argument had an illegal -C value; -C = 1: if the matrix I - alpha*D*F is numerically singular. -C -C METHOD -C -C The matrices of the closed-loop system have the expressions: -C -C Ac = A1 + beta*B1*K, Bc = B1*G, -C Cc = H*(C1 + beta*D1*K), Dc = H*D1*G, -C -C where -C -C A1 = A + alpha*B*F*E*C, B1 = B + alpha*B*F*E*D, -C C1 = E*C, D1 = E*D, -C -C with E = (I - alpha*D*F)**-1. -C -C NUMERICAL ASPECTS -C -C The accuracy of computations basically depends on the conditioning -C of the matrix I - alpha*D*F. If RCOND is very small, it is likely -C that the computed results are inaccurate. -C -C CONTRIBUTORS -C -C A. Varga, German Aerospace Research Establishment, -C Oberpfaffenhofen, Germany, and V. Sima, Katholieke Univ. Leuven, -C Belgium, Nov. 1996. -C -C REVISIONS -C -C January 14, 1997, February 18, 1998. -C V. Sima, Research Institute for Informatics, Bucharest, July 2003, -C Jan. 2005. -C -C KEYWORDS -C -C Multivariable system, state-space model, state-space -C representation. -C -C ****************************************************************** -C -C .. Parameters .. - DOUBLE PRECISION ZERO, ONE - PARAMETER ( ZERO = 0.0D0, ONE = 1.0D0 ) -C .. Scalar Arguments .. - CHARACTER FBTYPE, JOBD - INTEGER INFO, LDA, LDB, LDBC, LDC, LDCC, LDD, LDDC, - $ LDF, LDG, LDH, LDK, LDWORK, M, MV, N, P, PZ - DOUBLE PRECISION ALPHA, BETA, RCOND -C .. Array Arguments .. - INTEGER IWORK(*) - DOUBLE PRECISION A(LDA,*), B(LDB,*), BC(LDBC,*), C(LDC,*), - $ CC(LDCC,*), D(LDD,*), DC(LDDC,*), DWORK(*), - $ F(LDF,*), G(LDG,*), H(LDH,*), K(LDK,*) -C .. Local Scalars .. - LOGICAL LJOBD, OUTPF, UNITF - INTEGER LDWP -C .. External functions .. - LOGICAL LSAME - EXTERNAL LSAME -C .. External subroutines .. - EXTERNAL AB05SD, DGEMM, XERBLA -C .. Intrinsic Functions .. - INTRINSIC MAX, MIN -C -C .. Executable Statements .. -C -C Check the input scalar arguments. -C - UNITF = LSAME( FBTYPE, 'I' ) - OUTPF = LSAME( FBTYPE, 'O' ) - LJOBD = LSAME( JOBD, 'D' ) -C - INFO = 0 -C - IF( .NOT.UNITF .AND. .NOT.OUTPF ) THEN - INFO = -1 - ELSE IF( .NOT.LJOBD .AND. .NOT.LSAME( JOBD, 'Z' ) ) THEN - INFO = -2 - ELSE IF( N.LT.0 ) THEN - INFO = -3 - ELSE IF( M.LT.0 ) THEN - INFO = -4 - ELSE IF( P.LT.0 .OR. UNITF.AND.P.NE.M ) THEN - INFO = -5 - ELSE IF( MV.LT.0 ) THEN - INFO = -6 - ELSE IF( PZ.LT.0 ) THEN - INFO = -7 - ELSE IF( LDA.LT.MAX( 1, N ) ) THEN - INFO = -11 - ELSE IF( LDB.LT.MAX( 1, N ) ) THEN - INFO = -13 - ELSE IF( ( N.GT.0 .AND. LDC.LT.MAX( 1, P ) ) .OR. - $ ( N.EQ.0 .AND. LDC.LT.1 ) ) THEN - INFO = -15 - ELSE IF( ( LJOBD .AND. LDD.LT.MAX( 1, P ) ) .OR. - $ ( .NOT.LJOBD .AND. LDD.LT.1 ) ) THEN - INFO = -17 - ELSE IF( ( OUTPF .AND. ALPHA.NE.ZERO .AND. LDF.LT.MAX( 1, M ) ) - $ .OR. ( ( UNITF .OR. ALPHA.EQ.ZERO ) .AND. LDF.LT.1 ) ) THEN - INFO = -19 - ELSE IF( ( BETA.NE.ZERO .AND. LDK.LT.MAX( 1, M ) ) .OR. - $ ( BETA.EQ.ZERO .AND. LDK.LT.1 ) ) THEN - INFO = -21 - ELSE IF( LDG.LT.MAX( 1, M ) ) THEN - INFO = -23 - ELSE IF( LDH.LT.MAX( 1, PZ ) ) THEN - INFO = -25 - ELSE IF( LDBC.LT.MAX( 1, N ) ) THEN - INFO = -28 - ELSE IF( ( N.GT.0 .AND. LDCC.LT.MAX( 1, PZ ) ) .OR. - $ ( N.EQ.0 .AND. LDCC.LT.1 ) ) THEN - INFO = -30 - ELSE IF( ( ( LJOBD .AND. LDDC.LT.MAX( 1, PZ ) ) .OR. - $ ( .NOT.LJOBD .AND. LDDC.LT.1 ) ) ) THEN - INFO = -32 - ELSE IF( ( LJOBD .AND. LDWORK.LT.MAX( 1, M, P*MV, P*P + 4*P ) ) - $ .OR. ( .NOT.LJOBD .AND. LDWORK.LT.MAX( 1, M ) ) ) THEN - INFO = -35 - END IF -C - IF ( INFO.NE.0 ) THEN -C -C Error return. -C - CALL XERBLA( 'AB05RD', -INFO ) - RETURN - END IF -C -C Quick return if possible. -C - IF ( MAX( N, MIN( M, P ), MIN( MV, PZ ) ).EQ.0 ) THEN - RCOND = ONE - RETURN - END IF -C -C Apply the partial output feedback u = alpha*F*y + v1 -C - CALL AB05SD( FBTYPE, JOBD, N, M, P, ALPHA, A, LDA, B, LDB, C, - $ LDC, D, LDD, F, LDF, RCOND, IWORK, DWORK, LDWORK, - $ INFO ) - IF ( INFO.NE.0 ) RETURN -C -C Apply the partial state feedback v1 = beta*K*x + v2. -C -C Compute Ac = A1 + beta*B1*K and C1 <- C1 + beta*D1*K. -C - IF( BETA.NE.ZERO .AND. N.GT.0 ) THEN - CALL DGEMM( 'N', 'N', N, N, M, BETA, B, LDB, K, LDK, ONE, A, - $ LDA ) - IF( LJOBD ) - $ CALL DGEMM( 'N', 'N', P, N, M, BETA, D, LDD, K, LDK, ONE, - $ C, LDC ) - END IF -C -C Apply the input and output conversions v2 = G*v, z = H*y. -C -C Compute Bc = B1*G. -C - CALL DGEMM( 'N', 'N', N, MV, M, ONE, B, LDB, G, LDG, ZERO, BC, - $ LDBC ) -C -C Compute Cc = H*C1. -C - IF( N.GT.0 ) - $ CALL DGEMM( 'N', 'N', PZ, N, P, ONE, H, LDH, C, LDC, ZERO, CC, - $ LDCC ) -C -C Compute Dc = H*D1*G. -C - IF( LJOBD ) THEN - LDWP = MAX( 1, P ) - CALL DGEMM( 'N', 'N', P, MV, M, ONE, D, LDD, G, LDG, ZERO, - $ DWORK, LDWP ) - CALL DGEMM( 'N', 'N', PZ, MV, P, ONE, H, LDH, DWORK, LDWP, - $ ZERO, DC, LDDC ) - END IF -C - RETURN -C *** Last line of AB05RD *** - END diff --git a/mex/sources/libslicot/AB05SD.f b/mex/sources/libslicot/AB05SD.f deleted file mode 100644 index 7cc57b5c7..000000000 --- a/mex/sources/libslicot/AB05SD.f +++ /dev/null @@ -1,371 +0,0 @@ - SUBROUTINE AB05SD( FBTYPE, JOBD, N, M, P, ALPHA, A, LDA, B, LDB, - $ C, LDC, D, LDD, F, LDF, RCOND, IWORK, DWORK, - $ LDWORK, INFO) -C -C SLICOT RELEASE 5.0. -C -C Copyright (c) 2002-2009 NICONET e.V. -C -C This program is free software: you can redistribute it and/or -C modify it under the terms of the GNU General Public License as -C published by the Free Software Foundation, either version 2 of -C the License, or (at your option) any later version. -C -C This program is distributed in the hope that it will be useful, -C but WITHOUT ANY WARRANTY; without even the implied warranty of -C MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the -C GNU General Public License for more details. -C -C You should have received a copy of the GNU General Public License -C along with this program. If not, see -C . -C -C PURPOSE -C -C To construct for a given state space system (A,B,C,D) the closed- -C loop system (Ac,Bc,Cc,Dc) corresponding to the output feedback -C control law -C -C u = alpha*F*y + v. -C -C ARGUMENTS -C -C Mode Parameters -C -C FBTYPE CHARACTER*1 -C Specifies the type of the feedback law as follows: -C = 'I': Unitary output feedback (F = I); -C = 'O': General output feedback. -C -C JOBD CHARACTER*1 -C Specifies whether or not a non-zero matrix D appears in -C the given state space model: -C = 'D': D is present; -C = 'Z': D is assumed a zero matrix. -C -C Input/Output Parameters -C -C N (input) INTEGER -C The number of state variables, i.e. the order of the -C matrix A, the number of rows of B and the number of -C columns of C. N >= 0. -C -C M (input) INTEGER -C The number of input variables, i.e. the number of columns -C of matrices B and D, and the number of rows of F. M >= 0. -C -C P (input) INTEGER -C The number of output variables, i.e. the number of rows of -C matrices C and D, and the number of columns of F. P >= 0 -C and P = M if FBTYPE = 'I'. -C -C ALPHA (input) DOUBLE PRECISION -C The coefficient alpha in the output feedback law. -C -C A (input/output) DOUBLE PRECISION array, dimension (LDA,N) -C On entry, the leading N-by-N part of this array must -C contain the system state transition matrix A. -C On exit, the leading N-by-N part of this array contains -C the state matrix Ac of the closed-loop system. -C -C LDA INTEGER -C The leading dimension of array A. LDA >= MAX(1,N). -C -C B (input/output) DOUBLE PRECISION array, dimension (LDB,M) -C On entry, the leading N-by-M part of this array must -C contain the system input matrix B. -C On exit, the leading N-by-M part of this array contains -C the input matrix Bc of the closed-loop system. -C -C LDB INTEGER -C The leading dimension of array B. LDB >= MAX(1,N). -C -C C (input/output) DOUBLE PRECISION array, dimension (LDC,N) -C On entry, the leading P-by-N part of this array must -C contain the system output matrix C. -C On exit, the leading P-by-N part of this array contains -C the output matrix Cc of the closed-loop system. -C -C LDC INTEGER -C The leading dimension of array C. -C LDC >= MAX(1,P) if N > 0. -C LDC >= 1 if N = 0. -C -C D (input/output) DOUBLE PRECISION array, dimension (LDD,M) -C On entry, the leading P-by-M part of this array must -C contain the system direct input/output transmission -C matrix D. -C On exit, if JOBD = 'D', the leading P-by-M part of this -C array contains the direct input/output transmission -C matrix Dc of the closed-loop system. -C The array D is not referenced if JOBD = 'Z'. -C -C LDD INTEGER -C The leading dimension of array D. -C LDD >= MAX(1,P) if JOBD = 'D'. -C LDD >= 1 if JOBD = 'Z'. -C -C F (input) DOUBLE PRECISION array, dimension (LDF,P) -C If FBTYPE = 'O', the leading M-by-P part of this array -C must contain the output feedback matrix F. -C If FBTYPE = 'I', then the feedback matrix is assumed to be -C an M x M order identity matrix. -C The array F is not referenced if FBTYPE = 'I' or -C ALPHA = 0. -C -C LDF INTEGER -C The leading dimension of array F. -C LDF >= MAX(1,M) if FBTYPE = 'O' and ALPHA <> 0. -C LDF >= 1 if FBTYPE = 'I' or ALPHA = 0. -C -C RCOND (output) DOUBLE PRECISION -C The reciprocal condition number of the matrix -C I - alpha*D*F. -C -C Workspace -C -C IWORK INTEGER array, dimension (LIWORK) -C LIWORK >= MAX(1,2*P) if JOBD = 'D'. -C LIWORK >= 1 if JOBD = 'Z'. -C IWORK is not referenced if JOBD = 'Z'. -C -C DWORK DOUBLE PRECISION array, dimension (LDWORK) -C -C LDWORK INTEGER -C The length of the array DWORK. -C LDWORK >= wspace, where -C wspace = MAX( 1, M, P*P + 4*P ) if JOBD = 'D', -C wspace = MAX( 1, M ) if JOBD = 'Z'. -C For best performance, LDWORK >= MAX( wspace, N*M, N*P ). -C -C Error Indicator -C -C INFO INTEGER -C = 0: successful exit; -C < 0: if INFO = -i, the i-th argument had an illegal -C value; -C = 1: if the matrix I - alpha*D*F is numerically singular. -C -C METHOD -C -C The matrices of the closed-loop system have the expressions: -C -C Ac = A + alpha*B*F*E*C, Bc = B + alpha*B*F*E*D, -C Cc = E*C, Dc = E*D, -C -C where E = (I - alpha*D*F)**-1. -C -C NUMERICAL ASPECTS -C -C The accuracy of computations basically depends on the conditioning -C of the matrix I - alpha*D*F. If RCOND is very small, it is likely -C that the computed results are inaccurate. -C -C CONTRIBUTORS -C -C A. Varga, German Aerospace Research Establishment, -C Oberpfaffenhofen, Germany, and V. Sima, Katholieke Univ. Leuven, -C Belgium, Nov. 1996. -C -C REVISIONS -C -C January 14, 1997. -C V. Sima, Research Institute for Informatics, Bucharest, July 2003. -C -C KEYWORDS -C -C Multivariable system, state-space model, state-space -C representation. -C -C ****************************************************************** -C -C .. Parameters .. - DOUBLE PRECISION ZERO, ONE - PARAMETER ( ZERO = 0.0D0, ONE = 1.0D0 ) -C .. Scalar Arguments .. - CHARACTER FBTYPE, JOBD - INTEGER INFO, LDA, LDB, LDC, LDD, LDF, LDWORK, M, N, P - DOUBLE PRECISION ALPHA, RCOND -C .. Array Arguments .. - INTEGER IWORK(*) - DOUBLE PRECISION A(LDA,*), B(LDB,*), C(LDC,*), D(LDD,*), - $ DWORK(*), F(LDF,*) -C .. Local Scalars .. - LOGICAL LJOBD, OUTPF, UNITF - INTEGER I, IW, LDWN, LDWP - DOUBLE PRECISION ENORM -C .. Local Arrays .. - DOUBLE PRECISION DUMMY(1) -C .. External functions .. - LOGICAL LSAME - DOUBLE PRECISION DLAMCH, DLANGE - EXTERNAL DLAMCH, DLANGE, LSAME -C .. External subroutines .. - EXTERNAL DAXPY, DCOPY, DGECON, DGEMM, DGEMV, DGETRF, - $ DGETRS, DLACPY, DLASCL, XERBLA -C .. Intrinsic Functions .. - INTRINSIC MAX, MIN -C -C .. Executable Statements .. -C -C Check the input scalar arguments. -C - UNITF = LSAME( FBTYPE, 'I' ) - OUTPF = LSAME( FBTYPE, 'O' ) - LJOBD = LSAME( JOBD, 'D' ) - LDWN = MAX( 1, N ) - LDWP = MAX( 1, P ) -C - INFO = 0 -C - IF( .NOT.UNITF .AND. .NOT.OUTPF ) THEN - INFO = -1 - ELSE IF( .NOT.LJOBD .AND. .NOT.LSAME( JOBD, 'Z' ) ) THEN - INFO = -2 - ELSE IF( N.LT.0 ) THEN - INFO = -3 - ELSE IF( M.LT.0 ) THEN - INFO = -4 - ELSE IF( P.LT.0 .OR. UNITF.AND.P.NE.M ) THEN - INFO = -5 - ELSE IF( LDA.LT.LDWN ) THEN - INFO = -7 - ELSE IF( LDB.LT.LDWN ) THEN - INFO = -9 - ELSE IF( ( N.GT.0 .AND. LDC.LT.LDWP ) .OR. - $ ( N.EQ.0 .AND. LDC.LT.1 ) ) THEN - INFO = -11 - ELSE IF( ( LJOBD .AND. LDD.LT.LDWP ) .OR. - $ ( .NOT.LJOBD .AND. LDD.LT.1 ) ) THEN - INFO = -13 - ELSE IF( ( OUTPF .AND. ALPHA.NE.ZERO .AND. LDF.LT.MAX( 1, M ) ) - $ .OR. ( ( UNITF .OR. ALPHA.EQ.ZERO ) .AND. LDF.LT.1 ) ) THEN - INFO = -16 - ELSE IF( ( LJOBD .AND. LDWORK.LT.MAX( 1, M, P*P + 4*P ) ) .OR. - $ ( .NOT.LJOBD .AND. LDWORK.LT.MAX( 1, M ) ) ) THEN - INFO = -20 - END IF -C - IF ( INFO.NE.0 ) THEN -C -C Error return. -C - CALL XERBLA( 'AB05SD', -INFO ) - RETURN - END IF -C -C Quick return if possible. -C - RCOND = ONE - IF ( MAX( N, MIN( M, P ) ).EQ.0 .OR. ALPHA.EQ.ZERO ) - $ RETURN -C - IF (LJOBD) THEN - IW = P*P + 1 -C -C Compute I - alpha*D*F. -C - IF( UNITF) THEN - CALL DLACPY( 'F', P, P, D, LDD, DWORK, LDWP ) - IF ( ALPHA.NE.-ONE ) - $ CALL DLASCL( 'G', 0, 0, ONE, -ALPHA, P, P, DWORK, LDWP, - $ INFO ) - ELSE - CALL DGEMM( 'N', 'N', P, P, M, -ALPHA, D, LDD, F, LDF, ZERO, - $ DWORK, LDWP ) - END IF -C - DUMMY(1) = ONE - CALL DAXPY( P, ONE, DUMMY, 0, DWORK, P+1 ) -C -C Compute Cc = E*C, Dc = E*D, where E = (I - alpha*D*F)**-1. -C - ENORM = DLANGE( '1', P, P, DWORK, LDWP, DWORK(IW) ) - CALL DGETRF( P, P, DWORK, LDWP, IWORK, INFO ) - IF( INFO.GT.0 ) THEN -C -C Error return. -C - RCOND = ZERO - INFO = 1 - RETURN - END IF - CALL DGECON( '1', P, DWORK, LDWP, ENORM, RCOND, DWORK(IW), - $ IWORK(P+1), INFO ) - IF( RCOND.LE.DLAMCH('E') ) THEN -C -C Error return. -C - INFO = 1 - RETURN - END IF -C - IF( N.GT.0 ) - $ CALL DGETRS( 'N', P, N, DWORK, LDWP, IWORK, C, LDC, INFO ) - CALL DGETRS( 'N', P, M, DWORK, LDWP, IWORK, D, LDD, INFO ) - END IF -C - IF ( N.EQ.0 ) - $ RETURN -C -C Compute Ac = A + alpha*B*F*Cc and Bc = B + alpha*B*F*Dc. -C - IF( UNITF ) THEN - CALL DGEMM( 'N', 'N', N, N, M, ALPHA, B, LDB, C, LDC, ONE, A, - $ LDA ) - IF( LJOBD ) THEN -C - IF( LDWORK.LT.N*M ) THEN -C -C Not enough working space for using DGEMM. -C - DO 10 I = 1, N - CALL DCOPY( P, B(I,1), LDB, DWORK, 1 ) - CALL DGEMV( 'T', P, P, ALPHA, D, LDD, DWORK, 1, ONE, - $ B(I,1), LDB ) - 10 CONTINUE -C - ELSE - CALL DLACPY( 'F', N, M, B, LDB, DWORK, LDWN ) - CALL DGEMM( 'N', 'N', N, P, M, ALPHA, DWORK, LDWN, D, - $ LDD, ONE, B, LDB ) - END IF - END IF - ELSE -C - IF( LDWORK.LT.N*P ) THEN -C -C Not enough working space for using DGEMM. -C - DO 20 I = 1, N - CALL DGEMV( 'N', M, P, ALPHA, F, LDF, C(1,I), 1, ZERO, - $ DWORK, 1 ) - CALL DGEMV( 'N', N, M, ONE, B, LDB, DWORK, 1, ONE, - $ A(1,I), 1 ) - 20 CONTINUE -C - IF( LJOBD ) THEN -C - DO 30 I = 1, N - CALL DGEMV( 'T', M, P, ALPHA, F, LDF, B(I,1), LDB, - $ ZERO, DWORK, 1 ) - CALL DGEMV( 'T', P, M, ONE, D, LDD, DWORK, 1, ONE, - $ B(I,1), LDB ) - 30 CONTINUE -C - END IF - ELSE -C - CALL DGEMM( 'N', 'N', N, P, M, ALPHA, B, LDB, F, LDF, - $ ZERO, DWORK, LDWN ) - CALL DGEMM( 'N', 'N', N, N, P, ONE, DWORK, LDWN, C, LDC, - $ ONE, A, LDA ) - IF( LJOBD ) - $ CALL DGEMM( 'N', 'N', N, M, P, ONE, DWORK, LDWN, D, LDD, - $ ONE, B, LDB ) - END IF - END IF -C - RETURN -C *** Last line of AB05SD *** - END diff --git a/mex/sources/libslicot/AB07MD.f b/mex/sources/libslicot/AB07MD.f deleted file mode 100644 index da49e2df7..000000000 --- a/mex/sources/libslicot/AB07MD.f +++ /dev/null @@ -1,224 +0,0 @@ - SUBROUTINE AB07MD( JOBD, N, M, P, A, LDA, B, LDB, C, LDC, D, LDD, - $ INFO ) -C -C SLICOT RELEASE 5.0. -C -C Copyright (c) 2002-2009 NICONET e.V. -C -C This program is free software: you can redistribute it and/or -C modify it under the terms of the GNU General Public License as -C published by the Free Software Foundation, either version 2 of -C the License, or (at your option) any later version. -C -C This program is distributed in the hope that it will be useful, -C but WITHOUT ANY WARRANTY; without even the implied warranty of -C MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the -C GNU General Public License for more details. -C -C You should have received a copy of the GNU General Public License -C along with this program. If not, see -C . -C -C PURPOSE -C -C To find the dual of a given state-space representation. -C -C ARGUMENTS -C -C Mode Parameters -C -C JOBD CHARACTER*1 -C Specifies whether or not a non-zero matrix D appears in -C the given state space model: -C = 'D': D is present; -C = 'Z': D is assumed a zero matrix. -C -C Input/Output Parameters -C -C N (input) INTEGER -C The order of the state-space representation. N >= 0. -C -C M (input) INTEGER -C The number of system inputs. M >= 0. -C -C P (input) INTEGER -C The number of system outputs. P >= 0. -C -C A (input/output) DOUBLE PRECISION array, dimension (LDA,N) -C On entry, the leading N-by-N part of this array must -C contain the original state dynamics matrix A. -C On exit, the leading N-by-N part of this array contains -C the dual state dynamics matrix A'. -C -C LDA INTEGER -C The leading dimension of array A. LDA >= MAX(1,N). -C -C B (input/output) DOUBLE PRECISION array, dimension -C (LDB,MAX(M,P)) -C On entry, the leading N-by-M part of this array must -C contain the original input/state matrix B. -C On exit, the leading N-by-P part of this array contains -C the dual input/state matrix C'. -C -C LDB INTEGER -C The leading dimension of array B. LDB >= MAX(1,N). -C -C C (input/output) DOUBLE PRECISION array, dimension (LDC,N) -C On entry, the leading P-by-N part of this array must -C contain the original state/output matrix C. -C On exit, the leading M-by-N part of this array contains -C the dual state/output matrix B'. -C -C LDC INTEGER -C The leading dimension of array C. -C LDC >= MAX(1,M,P) if N > 0. -C LDC >= 1 if N = 0. -C -C D (input/output) DOUBLE PRECISION array, dimension -C (LDD,MAX(M,P)) -C On entry, if JOBD = 'D', the leading P-by-M part of this -C array must contain the original direct transmission -C matrix D. -C On exit, if JOBD = 'D', the leading M-by-P part of this -C array contains the dual direct transmission matrix D'. -C The array D is not referenced if JOBD = 'Z'. -C -C LDD INTEGER -C The leading dimension of array D. -C LDD >= MAX(1,M,P) if JOBD = 'D'. -C LDD >= 1 if JOBD = 'Z'. -C -C Error Indicator -C -C INFO INTEGER -C = 0: successful exit; -C < 0: if INFO = -i, the i-th argument had an illegal -C value. -C -C METHOD -C -C If the given state-space representation is the M-input/P-output -C (A,B,C,D), its dual is simply the P-input/M-output (A',C',B',D'). -C -C REFERENCES -C -C None -C -C NUMERICAL ASPECTS -C -C None -C -C CONTRIBUTOR -C -C Release 3.0: V. Sima, Katholieke Univ. Leuven, Belgium, Dec. 1996. -C Supersedes Release 2.0 routine AB07AD by T.W.C.Williams, Kingston -C Polytechnic, United Kingdom, March 1982. -C -C REVISIONS -C -C V. Sima, Research Institute for Informatics, Bucharest, Feb. 2004. -C -C KEYWORDS -C -C Dual system, state-space model, state-space representation. -C -C ****************************************************************** -C -C .. Scalar Arguments .. - CHARACTER JOBD - INTEGER INFO, LDA, LDB, LDC, LDD, M, N, P -C .. Array Arguments .. - DOUBLE PRECISION A(LDA,*), B(LDB,*), C(LDC,*), D(LDD,*) -C .. Local Scalars .. - LOGICAL LJOBD - INTEGER J, MINMP, MPLIM -C .. External functions .. - LOGICAL LSAME - EXTERNAL LSAME -C .. External subroutines .. - EXTERNAL DCOPY, DSWAP, XERBLA -C .. Intrinsic Functions .. - INTRINSIC MAX, MIN -C .. Executable Statements .. -C - INFO = 0 - LJOBD = LSAME( JOBD, 'D' ) - MPLIM = MAX( M, P ) - MINMP = MIN( M, P ) -C -C Test the input scalar arguments. -C - IF( .NOT.LJOBD .AND. .NOT.LSAME( JOBD, 'Z' ) ) THEN - INFO = -1 - ELSE IF( N.LT.0 ) THEN - INFO = -2 - ELSE IF( M.LT.0 ) THEN - INFO = -3 - ELSE IF( P.LT.0 ) THEN - INFO = -4 - ELSE IF( LDA.LT.MAX( 1, N ) ) THEN - INFO = -6 - ELSE IF( LDB.LT.MAX( 1, N ) ) THEN - INFO = -8 - ELSE IF( ( N.GT.0 .AND. LDC.LT.MAX( 1, MPLIM ) ) .OR. - $ ( N.EQ.0 .AND. LDC.LT.1 ) ) THEN - INFO = -10 - ELSE IF( ( LJOBD .AND. LDD.LT.MAX( 1, MPLIM ) ) .OR. - $ ( .NOT.LJOBD .AND. LDD.LT.1 ) ) THEN - INFO = -12 - END IF -C - IF ( INFO.NE.0 ) THEN -C -C Error return. -C - CALL XERBLA( 'AB07MD', -INFO ) - RETURN - END IF -C -C Quick return if possible. -C - IF ( MAX( N, MINMP ).EQ.0 ) - $ RETURN -C - IF ( N.GT.0 ) THEN -C -C Transpose A, if non-scalar. -C - DO 10 J = 1, N - 1 - CALL DSWAP( N-J, A(J+1,J), 1, A(J,J+1), LDA ) - 10 CONTINUE -C -C Replace B by C' and C by B'. -C - DO 20 J = 1, MPLIM - IF ( J.LE.MINMP ) THEN - CALL DSWAP( N, B(1,J), 1, C(J,1), LDC ) - ELSE IF ( J.GT.P ) THEN - CALL DCOPY( N, B(1,J), 1, C(J,1), LDC ) - ELSE - CALL DCOPY( N, C(J,1), LDC, B(1,J), 1 ) - END IF - 20 CONTINUE -C - END IF -C - IF ( LJOBD .AND. MINMP.GT.0 ) THEN -C -C Transpose D, if non-scalar. -C - DO 30 J = 1, MPLIM - IF ( J.LT.MINMP ) THEN - CALL DSWAP( MINMP-J, D(J+1,J), 1, D(J,J+1), LDD ) - ELSE IF ( J.GT.P ) THEN - CALL DCOPY( P, D(1,J), 1, D(J,1), LDD ) - ELSE IF ( J.GT.M ) THEN - CALL DCOPY( M, D(J,1), LDD, D(1,J), 1 ) - END IF - 30 CONTINUE -C - END IF -C - RETURN -C *** Last line of AB07MD *** - END diff --git a/mex/sources/libslicot/AB07ND.f b/mex/sources/libslicot/AB07ND.f deleted file mode 100644 index 86b26d27a..000000000 --- a/mex/sources/libslicot/AB07ND.f +++ /dev/null @@ -1,303 +0,0 @@ - SUBROUTINE AB07ND( N, M, A, LDA, B, LDB, C, LDC, D, LDD, RCOND, - $ IWORK, DWORK, LDWORK, INFO ) -C -C SLICOT RELEASE 5.0. -C -C Copyright (c) 2002-2009 NICONET e.V. -C -C This program is free software: you can redistribute it and/or -C modify it under the terms of the GNU General Public License as -C published by the Free Software Foundation, either version 2 of -C the License, or (at your option) any later version. -C -C This program is distributed in the hope that it will be useful, -C but WITHOUT ANY WARRANTY; without even the implied warranty of -C MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the -C GNU General Public License for more details. -C -C You should have received a copy of the GNU General Public License -C along with this program. If not, see -C . -C -C PURPOSE -C -C To compute the inverse (Ai,Bi,Ci,Di) of a given system (A,B,C,D). -C -C ARGUMENTS -C -C Input/Output Parameters -C -C N (input) INTEGER -C The order of the state matrix A. N >= 0. -C -C M (input) INTEGER -C The number of system inputs and outputs. M >= 0. -C -C A (input/output) DOUBLE PRECISION array, dimension (LDA,N) -C On entry, the leading N-by-N part of this array must -C contain the state matrix A of the original system. -C On exit, the leading N-by-N part of this array contains -C the state matrix Ai of the inverse system. -C -C LDA INTEGER -C The leading dimension of the array A. LDA >= MAX(1,N). -C -C B (input/output) DOUBLE PRECISION array, dimension (LDB,M) -C On entry, the leading N-by-M part of this array must -C contain the input matrix B of the original system. -C On exit, the leading N-by-M part of this array contains -C the input matrix Bi of the inverse system. -C -C LDB INTEGER -C The leading dimension of the array B. LDB >= MAX(1,N). -C -C C (input/output) DOUBLE PRECISION array, dimension (LDC,N) -C On entry, the leading M-by-N part of this array must -C contain the output matrix C of the original system. -C On exit, the leading M-by-N part of this array contains -C the output matrix Ci of the inverse system. -C -C LDC INTEGER -C The leading dimension of the array C. LDC >= MAX(1,M). -C -C D (input/output) DOUBLE PRECISION array, dimension (LDD,M) -C On entry, the leading M-by-M part of this array must -C contain the feedthrough matrix D of the original system. -C On exit, the leading M-by-M part of this array contains -C the feedthrough matrix Di of the inverse system. -C -C LDD INTEGER -C The leading dimension of the array D. LDD >= MAX(1,M). -C -C RCOND (output) DOUBLE PRECISION -C The estimated reciprocal condition number of the -C feedthrough matrix D of the original system. -C -C Workspace -C -C IWORK INTEGER array, dimension (2*M) -C -C DWORK DOUBLE PRECISION array, dimension (LDWORK) -C On exit, if INFO = 0 or M+1, DWORK(1) returns the optimal -C value of LDWORK. -C -C LDWORK INTEGER -C The length of the array DWORK. LDWORK >= MAX(1,4*M). -C For good performance, LDWORK should be larger. -C -C Error Indicator -C -C INFO INTEGER -C = 0: successful exit; -C < 0: if INFO = -i, the i-th argument had an illegal -C value; -C = i: the matrix D is exactly singular; the (i,i) diagonal -C element is zero, i <= M; RCOND was set to zero; -C = M+1: the matrix D is numerically singular, i.e., RCOND -C is less than the relative machine precision, EPS -C (see LAPACK Library routine DLAMCH). The -C calculations have been completed, but the results -C could be very inaccurate. -C -C METHOD -C -C The matrices of the inverse system are computed with the formulas: -C -1 -1 -1 -1 -C Ai = A - B*D *C, Bi = -B*D , Ci = D *C, Di = D . -C -C NUMERICAL ASPECTS -C -C The accuracy depends mainly on the condition number of the matrix -C D to be inverted. The estimated reciprocal condition number is -C returned in RCOND. -C -C CONTRIBUTORS -C -C A. Varga, German Aerospace Center, Oberpfaffenhofen, March 2000. -C D. Sima, University of Bucharest, April 2000. -C V. Sima, Research Institute for Informatics, Bucharest, Apr. 2000. -C Based on the routine SYSINV, A. Varga, 1992. -C -C REVISIONS -C -C A. Varga, German Aerospace Center, Oberpfaffenhofen, July 2000. -C -C KEYWORDS -C -C Inverse system, state-space model, state-space representation. -C -C ****************************************************************** -C -C .. Parameters .. - DOUBLE PRECISION ZERO, ONE - PARAMETER ( ZERO = 0.0D0, ONE = 1.0D0 ) -C .. Scalar Arguments .. - DOUBLE PRECISION RCOND - INTEGER INFO, LDA, LDB, LDC, LDD, LDWORK, M, N -C .. Array Arguments .. - DOUBLE PRECISION A(LDA,*), B(LDB,*), C(LDC,*), D(LDD,*), - $ DWORK(*) - INTEGER IWORK(*) -C .. Local Scalars .. - DOUBLE PRECISION DNORM - INTEGER BL, CHUNK, I, IERR, J, MAXWRK - LOGICAL BLAS3, BLOCK -C .. External Functions .. - DOUBLE PRECISION DLAMCH, DLANGE - INTEGER ILAENV - EXTERNAL DLAMCH, DLANGE, ILAENV -C .. External Subroutines .. - EXTERNAL DCOPY, DGECON, DGEMM, DGEMV, DGETRF, DGETRI, - $ DLACPY, XERBLA -C .. Intrinsic Functions .. - INTRINSIC DBLE, MAX, MIN -C .. Executable Statements .. -C - INFO = 0 -C -C Test the input scalar arguments. -C - IF( N.LT.0 ) THEN - INFO = -1 - ELSE IF( M.LT.0 ) THEN - INFO = -2 - ELSE IF( LDA.LT.MAX( 1, N ) ) THEN - INFO = -4 - ELSE IF( LDB.LT.MAX( 1, N ) ) THEN - INFO = -6 - ELSE IF( LDC.LT.MAX( 1, M ) ) THEN - INFO = -8 - ELSE IF( LDD.LT.MAX( 1, M ) ) THEN - INFO = -10 - ELSE IF( LDWORK.LT.MAX( 1, 4*M ) ) THEN - INFO = -14 - END IF -C - IF ( INFO.NE.0 ) THEN -C -C Error return. -C - CALL XERBLA( 'AB07ND', -INFO ) - RETURN - END IF -C -C Quick return if possible. -C - IF ( M.EQ.0 ) THEN - RCOND = ONE - DWORK(1) = ONE - RETURN - END IF -C -C Factorize D. -C - CALL DGETRF( M, M, D, LDD, IWORK, INFO ) - IF ( INFO.NE.0 ) THEN - RCOND = ZERO - RETURN - END IF -C -C Compute the reciprocal condition number of the matrix D. -C Workspace: need 4*M. -C (Note: Comments in the code beginning "Workspace:" describe the -C minimal amount of workspace needed at that point in the code, -C as well as the preferred amount for good performance. -C NB refers to the optimal block size for the immediately -C following subroutine, as returned by ILAENV.) -C - DNORM = DLANGE( '1-norm', M, M, D, LDD, DWORK ) - CALL DGECON( '1-norm', M, D, LDD, DNORM, RCOND, DWORK, IWORK(M+1), - $ IERR ) - IF ( RCOND.LT.DLAMCH( 'Epsilon' ) ) - $ INFO = M + 1 -C -1 -C Compute Di = D . -C Workspace: need M; -C prefer M*NB. -C - MAXWRK = MAX( 4*M, M*ILAENV( 1, 'DGETRI', ' ', M, -1, -1, -1 ) ) - CALL DGETRI( M, D, LDD, IWORK, DWORK, LDWORK, IERR ) - IF ( N.GT.0 ) THEN - CHUNK = LDWORK / M - BLAS3 = CHUNK.GE.N .AND. M.GT.1 - BLOCK = MIN( CHUNK, M ).GT.1 -C -1 -C Compute Bi = -B*D . -C - IF ( BLAS3 ) THEN -C -C Enough workspace for a fast BLAS 3 algorithm. -C - CALL DLACPY( 'Full', N, M, B, LDB, DWORK, N ) - CALL DGEMM( 'NoTranspose', 'NoTranspose', N, M, M, -ONE, - $ DWORK, N, D, LDD, ZERO, B, LDB ) -C - ELSE IF( BLOCK ) THEN -C -C Use as many rows of B as possible. -C - DO 10 I = 1, N, CHUNK - BL = MIN( N-I+1, CHUNK ) - CALL DLACPY( 'Full', BL, M, B(I,1), LDB, DWORK, BL ) - CALL DGEMM( 'NoTranspose', 'NoTranspose', BL, M, M, -ONE, - $ DWORK, BL, D, LDD, ZERO, B(I,1), LDB ) - 10 CONTINUE -C - ELSE -C -C Use a BLAS 2 algorithm. -C - DO 20 I = 1, N - CALL DCOPY( M, B(I,1), LDB, DWORK, 1 ) - CALL DGEMV( 'Transpose', M, M, -ONE, D, LDD, DWORK, 1, - $ ZERO, B(I,1), LDB ) - 20 CONTINUE -C - END IF -C -C Compute Ai = A + Bi*C. -C - CALL DGEMM( 'NoTranspose', 'NoTranspose', N, N, M, ONE, B, LDB, - $ C, LDC, ONE, A, LDA ) -C -1 -C Compute C <-- D *C. -C - IF ( BLAS3 ) THEN -C -C Enough workspace for a fast BLAS 3 algorithm. -C - CALL DLACPY( 'Full', M, N, C, LDC, DWORK, M ) - CALL DGEMM( 'NoTranspose', 'NoTranspose', M, N, M, ONE, - $ D, LDD, DWORK, M, ZERO, C, LDC ) -C - ELSE IF( BLOCK ) THEN -C -C Use as many columns of C as possible. -C - DO 30 J = 1, N, CHUNK - BL = MIN( N-J+1, CHUNK ) - CALL DLACPY( 'Full', M, BL, C(1,J), LDC, DWORK, M ) - CALL DGEMM( 'NoTranspose', 'NoTranspose', M, BL, M, ONE, - $ D, LDD, DWORK, M, ZERO, C(1,J), LDC ) - 30 CONTINUE -C - ELSE -C -C Use a BLAS 2 algorithm. -C - DO 40 J = 1, N - CALL DCOPY( M, C(1,J), 1, DWORK, 1 ) - CALL DGEMV( 'NoTranspose', M, M, ONE, D, LDD, DWORK, 1, - $ ZERO, C(1,J), 1 ) - 40 CONTINUE -C - END IF - END IF -C -C Return optimal workspace in DWORK(1). -C - DWORK(1) = DBLE( MAX( MAXWRK, N*M ) ) - RETURN -C -C *** Last line of AB07ND *** - END diff --git a/mex/sources/libslicot/AB08MD.f b/mex/sources/libslicot/AB08MD.f deleted file mode 100644 index bd801a617..000000000 --- a/mex/sources/libslicot/AB08MD.f +++ /dev/null @@ -1,299 +0,0 @@ - SUBROUTINE AB08MD( EQUIL, N, M, P, A, LDA, B, LDB, C, LDC, D, LDD, - $ RANK, TOL, IWORK, DWORK, LDWORK, INFO ) -C -C SLICOT RELEASE 5.0. -C -C Copyright (c) 2002-2009 NICONET e.V. -C -C This program is free software: you can redistribute it and/or -C modify it under the terms of the GNU General Public License as -C published by the Free Software Foundation, either version 2 of -C the License, or (at your option) any later version. -C -C This program is distributed in the hope that it will be useful, -C but WITHOUT ANY WARRANTY; without even the implied warranty of -C MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the -C GNU General Public License for more details. -C -C You should have received a copy of the GNU General Public License -C along with this program. If not, see -C . -C -C PURPOSE -C -C To compute the normal rank of the transfer-function matrix of a -C state-space model (A,B,C,D). -C -C ARGUMENTS -C -C Mode Parameters -C -C EQUIL CHARACTER*1 -C Specifies whether the user wishes to balance the compound -C matrix (see METHOD) as follows: -C = 'S': Perform balancing (scaling); -C = 'N': Do not perform balancing. -C -C Input/Output Parameters -C -C N (input) INTEGER -C The number of state variables, i.e., the order of the -C matrix A. N >= 0. -C -C M (input) INTEGER -C The number of system inputs. M >= 0. -C -C P (input) INTEGER -C The number of system outputs. P >= 0. -C -C A (input) DOUBLE PRECISION array, dimension (LDA,N) -C The leading N-by-N part of this array must contain the -C state dynamics matrix A of the system. -C -C LDA INTEGER -C The leading dimension of array A. LDA >= MAX(1,N). -C -C B (input) DOUBLE PRECISION array, dimension (LDB,M) -C The leading N-by-M part of this array must contain the -C input/state matrix B of the system. -C -C LDB INTEGER -C The leading dimension of array B. LDB >= MAX(1,N). -C -C C (input) DOUBLE PRECISION array, dimension (LDC,N) -C The leading P-by-N part of this array must contain the -C state/output matrix C of the system. -C -C LDC INTEGER -C The leading dimension of array C. LDC >= MAX(1,P). -C -C D (input) DOUBLE PRECISION array, dimension (LDD,M) -C The leading P-by-M part of this array must contain the -C direct transmission matrix D of the system. -C -C LDD INTEGER -C The leading dimension of array D. LDD >= MAX(1,P). -C -C RANK (output) INTEGER -C The normal rank of the transfer-function matrix. -C -C Tolerances -C -C TOL DOUBLE PRECISION -C A tolerance used in rank decisions to determine the -C effective rank, which is defined as the order of the -C largest leading (or trailing) triangular submatrix in the -C QR (or RQ) factorization with column (or row) pivoting -C whose estimated condition number is less than 1/TOL. -C If the user sets TOL to be less than SQRT((N+P)*(N+M))*EPS -C then the tolerance is taken as SQRT((N+P)*(N+M))*EPS, -C where EPS is the machine precision (see LAPACK Library -C Routine DLAMCH). -C -C Workspace -C -C IWORK INTEGER array, dimension (2*N+MAX(M,P)+1) -C -C DWORK DOUBLE PRECISION array, dimension (LDWORK) -C On exit, if INFO = 0, DWORK(1) returns the optimal value -C of LDWORK. -C -C LDWORK INTEGER -C The length of the array DWORK. -C LDWORK >= (N+P)*(N+M) + -C MAX( MIN(P,M) + MAX(3*M-1,N), 1, -C MIN(P,N) + MAX(3*P-1,N+P,N+M) ) -C For optimum performance LDWORK should be larger. -C -C If LDWORK = -1, then a workspace query is assumed; -C the routine only calculates the optimal size of the -C DWORK array, returns this value as the first entry of -C the DWORK array, and no error message related to LDWORK -C is issued by XERBLA. -C -C Error Indicator -C -C INFO INTEGER -C = 0: successful exit; -C < 0: if INFO = -i, the i-th argument had an illegal -C value. -C -C METHOD -C -C The routine reduces the (N+P)-by-(M+N) compound matrix (B A) -C (D C) -C -C to one with the same invariant zeros and with D of full row rank. -C The normal rank of the transfer-function matrix is the rank of D. -C -C REFERENCES -C -C [1] Svaricek, F. -C Computation of the Structural Invariants of Linear -C Multivariable Systems with an Extended Version of -C the Program ZEROS. -C System & Control Letters, 6, pp. 261-266, 1985. -C -C [2] Emami-Naeini, A. and Van Dooren, P. -C Computation of Zeros of Linear Multivariable Systems. -C Automatica, 18, pp. 415-430, 1982. -C -C NUMERICAL ASPECTS -C -C The algorithm is backward stable (see [2] and [1]). -C -C CONTRIBUTOR -C -C A. Varga, German Aerospace Center, Oberpfaffenhofen, May 2001. -C -C REVISIONS -C -C V. Sima, Research Institute for Informatics, Bucharest, June 2001, -C Dec. 2003, Jan. 2009, Mar. 2009, Apr. 2009. -C -C KEYWORDS -C -C Multivariable system, orthogonal transformation, -C structural invariant. -C -C ****************************************************************** -C -C .. Parameters .. - DOUBLE PRECISION ZERO, ONE - PARAMETER ( ZERO = 0.0D0, ONE = 1.0D0 ) -C .. Scalar Arguments .. - CHARACTER EQUIL - INTEGER INFO, LDA, LDB, LDC, LDD, LDWORK, M, N, P, RANK - DOUBLE PRECISION TOL -C .. Array Arguments .. - INTEGER IWORK(*) - DOUBLE PRECISION A(LDA,*), B(LDB,*), C(LDC,*), D(LDD,*), DWORK(*) -C .. Local Scalars .. - LOGICAL LEQUIL, LQUERY - INTEGER I, KW, MU, NB, NINFZ, NKROL, NM, NP, NU, RO, - $ SIGMA, WRKOPT - DOUBLE PRECISION MAXRED, SVLMAX, THRESH, TOLER -C .. External Functions .. - LOGICAL LSAME - DOUBLE PRECISION DLAMCH, DLANGE - EXTERNAL DLAMCH, DLANGE, LSAME -C .. External Subroutines .. - EXTERNAL AB08NX, DLACPY, TB01ID, XERBLA -C .. Intrinsic Functions .. - INTRINSIC DBLE, INT, MAX, MIN, SQRT -C .. Executable Statements .. -C - NP = N + P - NM = N + M - INFO = 0 - LEQUIL = LSAME( EQUIL, 'S' ) - LQUERY = ( LDWORK.EQ.-1 ) - WRKOPT = NP*NM -C -C Test the input scalar arguments. -C - IF( .NOT.LEQUIL .AND. .NOT.LSAME( EQUIL, 'N' ) ) THEN - INFO = -1 - ELSE IF( N.LT.0 ) THEN - INFO = -2 - ELSE IF( M.LT.0 ) THEN - INFO = -3 - ELSE IF( P.LT.0 ) THEN - INFO = -4 - ELSE IF( LDA.LT.MAX( 1, N ) ) THEN - INFO = -6 - ELSE IF( LDB.LT.MAX( 1, N ) ) THEN - INFO = -8 - ELSE IF( LDC.LT.MAX( 1, P ) ) THEN - INFO = -10 - ELSE IF( LDD.LT.MAX( 1, P ) ) THEN - INFO = -12 - ELSE - KW = WRKOPT + MAX( MIN( P, M ) + MAX( 3*M-1, N ), 1, - $ MIN( P, N ) + MAX( 3*P-1, NP, NM ) ) - IF( LQUERY ) THEN - SVLMAX = ZERO - NINFZ = 0 - CALL AB08NX( N, M, P, P, 0, SVLMAX, DWORK, MAX( 1, NP ), - $ NINFZ, IWORK, IWORK, MU, NU, NKROL, TOL, IWORK, - $ DWORK, -1, INFO ) - WRKOPT = MAX( KW, WRKOPT + INT( DWORK(1) ) ) - ELSE IF( LDWORK.LT.KW ) THEN - INFO = -17 - END IF - END IF -C - IF ( INFO.NE.0 ) THEN -C -C Error return. -C - CALL XERBLA( 'AB08MD', -INFO ) - RETURN - ELSE IF( LQUERY ) THEN - DWORK(1) = WRKOPT - RETURN - END IF -C -C Quick return if possible. -C - IF ( MIN( M, P ).EQ.0 ) THEN - RANK = 0 - DWORK(1) = ONE - RETURN - END IF -C - DO 10 I = 1, 2*N+1 - IWORK(I) = 0 - 10 CONTINUE -C -C (Note: Comments in the code beginning "Workspace:" describe the -C minimal amount of real workspace needed at that point in the -C code, as well as the preferred amount for good performance.) -C -C Construct the compound matrix ( B A ), dimension (N+P)-by-(M+N). -C ( D C ) -C Workspace: need (N+P)*(N+M). -C - CALL DLACPY( 'Full', N, M, B, LDB, DWORK, NP ) - CALL DLACPY( 'Full', P, M, D, LDD, DWORK(N+1), NP ) - CALL DLACPY( 'Full', N, N, A, LDA, DWORK(NP*M+1), NP ) - CALL DLACPY( 'Full', P, N, C, LDC, DWORK(NP*M+N+1), NP ) -C -C If required, balance the compound matrix (default MAXRED). -C Workspace: need N. -C - KW = WRKOPT + 1 - IF ( LEQUIL ) THEN - MAXRED = ZERO - CALL TB01ID( 'A', N, M, P, MAXRED, DWORK(NP*M+1), NP, DWORK, - $ NP, DWORK(NP*M+N+1), NP, DWORK(KW), INFO ) - WRKOPT = WRKOPT + N - END IF -C -C If required, set tolerance. -C - THRESH = SQRT( DBLE( NP*NM ) )*DLAMCH( 'Precision' ) - TOLER = TOL - IF ( TOLER.LT.THRESH ) TOLER = THRESH - SVLMAX = DLANGE( 'Frobenius', NP, NM, DWORK, NP, DWORK(KW) ) -C -C Reduce this system to one with the same invariant zeros and with -C D full row rank MU (the normal rank of the original system). -C Real workspace: need (N+P)*(N+M) + -C MAX( 1, MIN(P,M) + MAX(3*M-1,N), -C MIN(P,N) + MAX(3*P-1,N+P,N+M) ); -C prefer larger. -C Integer workspace: 2*N+MAX(M,P)+1. -C - RO = P - SIGMA = 0 - NINFZ = 0 - CALL AB08NX( N, M, P, RO, SIGMA, SVLMAX, DWORK, NP, NINFZ, IWORK, - $ IWORK(N+1), MU, NU, NKROL, TOLER, IWORK(2*N+2), - $ DWORK(KW), LDWORK-KW+1, INFO ) - RANK = MU -C - DWORK(1) = MAX( WRKOPT, INT( DWORK(KW) ) + KW - 1 ) - RETURN -C *** Last line of AB08MD *** - END diff --git a/mex/sources/libslicot/AB08MZ.f b/mex/sources/libslicot/AB08MZ.f deleted file mode 100644 index 89d8005e7..000000000 --- a/mex/sources/libslicot/AB08MZ.f +++ /dev/null @@ -1,303 +0,0 @@ - SUBROUTINE AB08MZ( EQUIL, N, M, P, A, LDA, B, LDB, C, LDC, D, LDD, - $ RANK, TOL, IWORK, DWORK, ZWORK, LZWORK, INFO ) -C -C SLICOT RELEASE 5.0. -C -C Copyright (c) 2002-2009 NICONET e.V. -C -C This program is free software: you can redistribute it and/or -C modify it under the terms of the GNU General Public License as -C published by the Free Software Foundation, either version 2 of -C the License, or (at your option) any later version. -C -C This program is distributed in the hope that it will be useful, -C but WITHOUT ANY WARRANTY; without even the implied warranty of -C MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the -C GNU General Public License for more details. -C -C You should have received a copy of the GNU General Public License -C along with this program. If not, see -C . -C -C PURPOSE -C -C To compute the normal rank of the transfer-function matrix of a -C state-space model (A,B,C,D). -C -C ARGUMENTS -C -C Mode Parameters -C -C EQUIL CHARACTER*1 -C Specifies whether the user wishes to balance the compound -C matrix (see METHOD) as follows: -C = 'S': Perform balancing (scaling); -C = 'N': Do not perform balancing. -C -C Input/Output Parameters -C -C N (input) INTEGER -C The number of state variables, i.e., the order of the -C matrix A. N >= 0. -C -C M (input) INTEGER -C The number of system inputs. M >= 0. -C -C P (input) INTEGER -C The number of system outputs. P >= 0. -C -C A (input) COMPLEX*16 array, dimension (LDA,N) -C The leading N-by-N part of this array must contain the -C state dynamics matrix A of the system. -C -C LDA INTEGER -C The leading dimension of array A. LDA >= MAX(1,N). -C -C B (input) COMPLEX*16 array, dimension (LDB,M) -C The leading N-by-M part of this array must contain the -C input/state matrix B of the system. -C -C LDB INTEGER -C The leading dimension of array B. LDB >= MAX(1,N). -C -C C (input) COMPLEX*16 array, dimension (LDC,N) -C The leading P-by-N part of this array must contain the -C state/output matrix C of the system. -C -C LDC INTEGER -C The leading dimension of array C. LDC >= MAX(1,P). -C -C D (input) COMPLEX*16 array, dimension (LDD,M) -C The leading P-by-M part of this array must contain the -C direct transmission matrix D of the system. -C -C LDD INTEGER -C The leading dimension of array D. LDD >= MAX(1,P). -C -C RANK (output) INTEGER -C The normal rank of the transfer-function matrix. -C -C Tolerances -C -C TOL DOUBLE PRECISION -C A tolerance used in rank decisions to determine the -C effective rank, which is defined as the order of the -C largest leading (or trailing) triangular submatrix in the -C QR (or RQ) factorization with column (or row) pivoting -C whose estimated condition number is less than 1/TOL. -C If the user sets TOL to be less than SQRT((N+P)*(N+M))*EPS -C then the tolerance is taken as SQRT((N+P)*(N+M))*EPS, -C where EPS is the machine precision (see LAPACK Library -C Routine DLAMCH). -C -C Workspace -C -C IWORK INTEGER array, dimension (2*N+MAX(M,P)+1) -C -C DWORK DOUBLE PRECISION array, dimension (2*MAX(M,P)) -C -C ZWORK COMPLEX*16 array, dimension (LZWORK) -C On exit, if INFO = 0, ZWORK(1) returns the optimal value -C of LZWORK. -C -C LZWORK INTEGER -C The length of the array ZWORK. -C LZWORK >= (N+P)*(N+M) + MAX(MIN(P,M) + MAX(3*M-1,N), 1, -C MIN(P,N) + MAX(3*P-1,N+P,N+M)) -C For optimum performance LZWORK should be larger. -C -C If LZWORK = -1, then a workspace query is assumed; -C the routine only calculates the optimal size of the -C ZWORK array, returns this value as the first entry of -C the ZWORK array, and no error message related to LZWORK -C is issued by XERBLA. -C -C Error Indicator -C -C INFO INTEGER -C = 0: successful exit; -C < 0: if INFO = -i, the i-th argument had an illegal -C value. -C -C METHOD -C -C The routine reduces the (N+P)-by-(M+N) compound matrix (B A) -C (D C) -C -C to one with the same invariant zeros and with D of full row rank. -C The normal rank of the transfer-function matrix is the rank of D. -C -C REFERENCES -C -C [1] Svaricek, F. -C Computation of the Structural Invariants of Linear -C Multivariable Systems with an Extended Version of -C the Program ZEROS. -C System & Control Letters, 6, pp. 261-266, 1985. -C -C [2] Emami-Naeini, A. and Van Dooren, P. -C Computation of Zeros of Linear Multivariable Systems. -C Automatica, 18, pp. 415-430, 1982. -C -C NUMERICAL ASPECTS -C -C The algorithm is backward stable (see [2] and [1]). -C -C CONTRIBUTOR -C -C A. Varga, German Aerospace Center, Oberpfaffenhofen, May 2001. -C Complex version: V. Sima, Research Institute for Informatics, -C Bucharest, Dec. 2008. -C -C REVISIONS -C -C V. Sima, Research Institute for Informatics, Bucharest, Mar. 2009, -C Apr. 2009. -C -C KEYWORDS -C -C Multivariable system, unitary transformation, -C structural invariant. -C -C ****************************************************************** -C -C .. Parameters .. - DOUBLE PRECISION ZERO, ONE - PARAMETER ( ZERO = 0.0D0, ONE = 1.0D0 ) -C .. Scalar Arguments .. - CHARACTER EQUIL - INTEGER INFO, LDA, LDB, LDC, LDD, LZWORK, M, N, P, RANK - DOUBLE PRECISION TOL -C .. Array Arguments .. - INTEGER IWORK(*) - COMPLEX*16 A(LDA,*), B(LDB,*), C(LDC,*), D(LDD,*), ZWORK(*) - DOUBLE PRECISION DWORK(*) -C .. Local Scalars .. - LOGICAL LEQUIL, LQUERY - INTEGER I, KW, MU, NB, NINFZ, NKROL, NM, NP, NU, RO, - $ SIGMA, WRKOPT - DOUBLE PRECISION MAXRED, SVLMAX, THRESH, TOLER -C .. External Functions .. - LOGICAL LSAME - DOUBLE PRECISION DLAMCH, ZLANGE - EXTERNAL DLAMCH, LSAME, ZLANGE -C .. External Subroutines .. - EXTERNAL AB8NXZ, TB01IZ, XERBLA, ZLACPY -C .. Intrinsic Functions .. - INTRINSIC DBLE, INT, MAX, MIN, SQRT -C .. Executable Statements .. -C - NP = N + P - NM = N + M - INFO = 0 - LEQUIL = LSAME( EQUIL, 'S' ) - LQUERY = ( LZWORK.EQ.-1 ) - WRKOPT = NP*NM -C -C Test the input scalar arguments. -C - IF( .NOT.LEQUIL .AND. .NOT.LSAME( EQUIL, 'N' ) ) THEN - INFO = -1 - ELSE IF( N.LT.0 ) THEN - INFO = -2 - ELSE IF( M.LT.0 ) THEN - INFO = -3 - ELSE IF( P.LT.0 ) THEN - INFO = -4 - ELSE IF( LDA.LT.MAX( 1, N ) ) THEN - INFO = -6 - ELSE IF( LDB.LT.MAX( 1, N ) ) THEN - INFO = -8 - ELSE IF( LDC.LT.MAX( 1, P ) ) THEN - INFO = -10 - ELSE IF( LDD.LT.MAX( 1, P ) ) THEN - INFO = -12 - ELSE - KW = WRKOPT + MAX( MIN( P, M ) + MAX( 3*M-1, N ), 1, - $ MIN( P, N ) + MAX( 3*P-1, NP, NM ) ) - IF( LQUERY ) THEN - SVLMAX = ZERO - NINFZ = 0 - CALL AB8NXZ( N, M, P, P, 0, SVLMAX, ZWORK, MAX( 1, NP ), - $ NINFZ, IWORK, IWORK, MU, NU, NKROL, TOL, IWORK, - $ DWORK, ZWORK, -1, INFO ) - WRKOPT = MAX( KW, WRKOPT + INT( ZWORK(1) ) ) - ELSE IF( LZWORK.LT.KW ) THEN - INFO = -17 - END IF - END IF -C - IF ( INFO.NE.0 ) THEN -C -C Error return. -C - CALL XERBLA( 'AB08MZ', -INFO ) - RETURN - ELSE IF( LQUERY ) THEN - ZWORK(1) = WRKOPT - RETURN - END IF -C -C Quick return if possible. -C - IF ( MIN( M, P ).EQ.0 ) THEN - RANK = 0 - ZWORK(1) = ONE - RETURN - END IF -C - DO 10 I = 1, 2*N+1 - IWORK(I) = 0 - 10 CONTINUE -C -C (Note: Comments in the code beginning "Workspace:" describe the -C minimal amount of workspace needed at that point in the code, -C as well as the preferred amount for good performance.) -C -C Construct the compound matrix ( B A ), dimension (N+P)-by-(M+N). -C ( D C ) -C Complex workspace: need (N+P)*(N+M). -C - CALL ZLACPY( 'Full', N, M, B, LDB, ZWORK, NP ) - CALL ZLACPY( 'Full', P, M, D, LDD, ZWORK(N+1), NP ) - CALL ZLACPY( 'Full', N, N, A, LDA, ZWORK(NP*M+1), NP ) - CALL ZLACPY( 'Full', P, N, C, LDC, ZWORK(NP*M+N+1), NP ) -C -C If required, balance the compound matrix (default MAXRED). -C Real Workspace: need N. -C - KW = WRKOPT + 1 - IF ( LEQUIL ) THEN - MAXRED = ZERO - CALL TB01IZ( 'A', N, M, P, MAXRED, ZWORK(NP*M+1), NP, ZWORK, - $ NP, ZWORK(NP*M+N+1), NP, DWORK, INFO ) - END IF -C -C If required, set tolerance. -C - THRESH = SQRT( DBLE( NP*NM ) )*DLAMCH( 'Precision' ) - TOLER = TOL - IF ( TOLER.LT.THRESH ) TOLER = THRESH - SVLMAX = ZLANGE( 'Frobenius', NP, NM, ZWORK, NP, DWORK ) -C -C Reduce this system to one with the same invariant zeros and with -C D full row rank MU (the normal rank of the original system). -C Real workspace: need 2*MAX(M,P); -C Complex workspace: need (N+P)*(N+M) + -C MAX( 1, MIN(P,M) + MAX(3*M-1,N), -C MIN(P,N) + MAX(3*P-1,N+P,N+M) ); -C prefer larger. -C Integer workspace: 2*N+MAX(M,P)+1. -C - RO = P - SIGMA = 0 - NINFZ = 0 - CALL AB8NXZ( N, M, P, RO, SIGMA, SVLMAX, ZWORK, NP, NINFZ, IWORK, - $ IWORK(N+1), MU, NU, NKROL, TOLER, IWORK(2*N+2), - $ DWORK, ZWORK(KW), LZWORK-KW+1, INFO ) - RANK = MU -C - ZWORK(1) = MAX( WRKOPT, INT( ZWORK(KW) ) + KW - 1 ) - RETURN -C *** Last line of AB08MZ *** - END diff --git a/mex/sources/libslicot/AB08ND.f b/mex/sources/libslicot/AB08ND.f deleted file mode 100644 index 8fdb139d2..000000000 --- a/mex/sources/libslicot/AB08ND.f +++ /dev/null @@ -1,568 +0,0 @@ - SUBROUTINE AB08ND( EQUIL, N, M, P, A, LDA, B, LDB, C, LDC, D, LDD, - $ NU, RANK, DINFZ, NKROR, NKROL, INFZ, KRONR, - $ KRONL, AF, LDAF, BF, LDBF, TOL, IWORK, DWORK, - $ LDWORK, INFO ) -C -C SLICOT RELEASE 5.0. -C -C Copyright (c) 2002-2009 NICONET e.V. -C -C This program is free software: you can redistribute it and/or -C modify it under the terms of the GNU General Public License as -C published by the Free Software Foundation, either version 2 of -C the License, or (at your option) any later version. -C -C This program is distributed in the hope that it will be useful, -C but WITHOUT ANY WARRANTY; without even the implied warranty of -C MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the -C GNU General Public License for more details. -C -C You should have received a copy of the GNU General Public License -C along with this program. If not, see -C . -C -C PURPOSE -C -C To construct for a linear multivariable system described by a -C state-space model (A,B,C,D) a regular pencil (A - lambda*B ) which -C f f -C has the invariant zeros of the system as generalized eigenvalues. -C The routine also computes the orders of the infinite zeros and the -C right and left Kronecker indices of the system (A,B,C,D). -C -C ARGUMENTS -C -C Mode Parameters -C -C EQUIL CHARACTER*1 -C Specifies whether the user wishes to balance the compound -C matrix (see METHOD) as follows: -C = 'S': Perform balancing (scaling); -C = 'N': Do not perform balancing. -C -C Input/Output Parameters -C -C N (input) INTEGER -C The number of state variables, i.e., the order of the -C matrix A. N >= 0. -C -C M (input) INTEGER -C The number of system inputs. M >= 0. -C -C P (input) INTEGER -C The number of system outputs. P >= 0. -C -C A (input) DOUBLE PRECISION array, dimension (LDA,N) -C The leading N-by-N part of this array must contain the -C state dynamics matrix A of the system. -C -C LDA INTEGER -C The leading dimension of array A. LDA >= MAX(1,N). -C -C B (input) DOUBLE PRECISION array, dimension (LDB,M) -C The leading N-by-M part of this array must contain the -C input/state matrix B of the system. -C -C LDB INTEGER -C The leading dimension of array B. LDB >= MAX(1,N). -C -C C (input) DOUBLE PRECISION array, dimension (LDC,N) -C The leading P-by-N part of this array must contain the -C state/output matrix C of the system. -C -C LDC INTEGER -C The leading dimension of array C. LDC >= MAX(1,P). -C -C D (input) DOUBLE PRECISION array, dimension (LDD,M) -C The leading P-by-M part of this array must contain the -C direct transmission matrix D of the system. -C -C LDD INTEGER -C The leading dimension of array D. LDD >= MAX(1,P). -C -C NU (output) INTEGER -C The number of (finite) invariant zeros. -C -C RANK (output) INTEGER -C The normal rank of the transfer function matrix. -C -C DINFZ (output) INTEGER -C The maximum degree of infinite elementary divisors. -C -C NKROR (output) INTEGER -C The number of right Kronecker indices. -C -C NKROL (output) INTEGER -C The number of left Kronecker indices. -C -C INFZ (output) INTEGER array, dimension (N) -C The leading DINFZ elements of INFZ contain information -C on the infinite elementary divisors as follows: -C the system has INFZ(i) infinite elementary divisors -C of degree i, where i = 1,2,...,DINFZ. -C -C KRONR (output) INTEGER array, dimension (MAX(N,M)+1) -C The leading NKROR elements of this array contain the -C right Kronecker (column) indices. -C -C KRONL (output) INTEGER array, dimension (MAX(N,P)+1) -C The leading NKROL elements of this array contain the -C left Kronecker (row) indices. -C -C AF (output) DOUBLE PRECISION array, dimension -C (LDAF,N+MIN(P,M)) -C The leading NU-by-NU part of this array contains the -C coefficient matrix A of the reduced pencil. The remainder -C f -C of the leading (N+M)-by-(N+MIN(P,M)) part is used as -C internal workspace. -C -C LDAF INTEGER -C The leading dimension of array AF. LDAF >= MAX(1,N+M). -C -C BF (output) DOUBLE PRECISION array, dimension (LDBF,N+M) -C The leading NU-by-NU part of this array contains the -C coefficient matrix B of the reduced pencil. The -C f -C remainder of the leading (N+P)-by-(N+M) part is used as -C internal workspace. -C -C LDBF INTEGER -C The leading dimension of array BF. LDBF >= MAX(1,N+P). -C -C Tolerances -C -C TOL DOUBLE PRECISION -C A tolerance used in rank decisions to determine the -C effective rank, which is defined as the order of the -C largest leading (or trailing) triangular submatrix in the -C QR (or RQ) factorization with column (or row) pivoting -C whose estimated condition number is less than 1/TOL. -C If the user sets TOL to be less than SQRT((N+P)*(N+M))*EPS -C then the tolerance is taken as SQRT((N+P)*(N+M))*EPS, -C where EPS is the machine precision (see LAPACK Library -C Routine DLAMCH). -C -C Workspace -C -C IWORK INTEGER array, dimension (MAX(M,P)) -C -C DWORK DOUBLE PRECISION array, dimension (LDWORK) -C On exit, if INFO = 0, DWORK(1) returns the optimal value -C of LDWORK. -C -C LDWORK INTEGER -C The length of the array DWORK. -C LDWORK >= MAX( 1, MIN(P,M) + MAX(3*M-1,N), -C MIN(P,N) + MAX(3*P-1,N+P,N+M), -C MIN(M,N) + MAX(3*M-1,N+M) ). -C An upper bound is MAX(s,N) + MAX(3*s-1,N+s), with -C s = MAX(M,P). -C For optimum performance LDWORK should be larger. -C -C If LDWORK = -1, then a workspace query is assumed; -C the routine only calculates the optimal size of the -C DWORK array, returns this value as the first entry of -C the DWORK array, and no error message related to LDWORK -C is issued by XERBLA. -C -C Error Indicator -C -C INFO INTEGER -C = 0: successful exit; -C < 0: if INFO = -i, the i-th argument had an illegal -C value. -C -C METHOD -C -C The routine extracts from the system matrix of a state-space -C system (A,B,C,D) a regular pencil A - lambda*B which has the -C f f -C invariant zeros of the system as generalized eigenvalues as -C follows: -C -C (a) construct the (N+P)-by-(N+M) compound matrix (B A); -C (D C) -C -C (b) reduce the above system to one with the same invariant -C zeros and with D of full row rank; -C -C (c) pertranspose the system; -C -C (d) reduce the system to one with the same invariant zeros and -C with D square invertible; -C -C (e) perform a unitary transformation on the columns of -C (A - lambda*I B) in order to reduce it to -C ( C D) -C -C (A - lambda*B X) -C ( f f ), with Y and B square invertible; -C ( 0 Y) f -C -C (f) compute the right and left Kronecker indices of the system -C (A,B,C,D), which together with the orders of the infinite -C zeros (determined by steps (a) - (e)) constitute the -C complete set of structural invariants under strict -C equivalence transformations of a linear system. -C -C REFERENCES -C -C [1] Svaricek, F. -C Computation of the Structural Invariants of Linear -C Multivariable Systems with an Extended Version of -C the Program ZEROS. -C System & Control Letters, 6, pp. 261-266, 1985. -C -C [2] Emami-Naeini, A. and Van Dooren, P. -C Computation of Zeros of Linear Multivariable Systems. -C Automatica, 18, pp. 415-430, 1982. -C -C NUMERICAL ASPECTS -C -C The algorithm is backward stable (see [2] and [1]). -C -C FURTHER COMMENTS -C -C In order to compute the invariant zeros of the system explicitly, -C a call to this routine may be followed by a call to the LAPACK -C Library routine DGGEV with A = A , B = B and N = NU. -C f f -C If RANK = 0, the routine DGEEV can be used (since B = I). -C f -C CONTRIBUTOR -C -C Release 3.0: V. Sima, Katholieke Univ. Leuven, Belgium, Nov. 1996. -C Supersedes Release 2.0 routine AB08BD by F. Svaricek. -C -C REVISIONS -C -C Oct. 1997, Feb. 1998, Dec. 2003, March 2004, Jan. 2009, Mar. 2009, -C Apr. 2009. -C -C KEYWORDS -C -C Generalized eigenvalue problem, Kronecker indices, multivariable -C system, orthogonal transformation, structural invariant. -C -C ****************************************************************** -C -C .. Parameters .. - DOUBLE PRECISION ZERO, ONE - PARAMETER ( ZERO = 0.0D0, ONE = 1.0D0 ) -C .. Scalar Arguments .. - CHARACTER EQUIL - INTEGER DINFZ, INFO, LDA, LDAF, LDB, LDBF, LDC, LDD, - $ LDWORK, M, N, NKROL, NKROR, NU, P, RANK - DOUBLE PRECISION TOL -C .. Array Arguments .. - INTEGER INFZ(*), IWORK(*), KRONL(*), KRONR(*) - DOUBLE PRECISION A(LDA,*), AF(LDAF,*), B(LDB,*), BF(LDBF,*), - $ C(LDC,*), D(LDD,*), DWORK(*) -C .. Local Scalars .. - LOGICAL LEQUIL, LQUERY - INTEGER I, I1, II, J, MM, MNU, MU, NB, NINFZ, NN, NU1, - $ NUMU, NUMU1, PP, RO, SIGMA, WRKOPT - DOUBLE PRECISION MAXRED, SVLMAX, THRESH, TOLER -C .. External Functions .. - LOGICAL LSAME - INTEGER ILAENV - DOUBLE PRECISION DLAMCH, DLANGE - EXTERNAL DLAMCH, DLANGE, ILAENV, LSAME -C .. External Subroutines .. - EXTERNAL AB08NX, DCOPY, DLACPY, DLASET, DORMRZ, DTZRZF, - $ TB01ID, XERBLA -C .. Intrinsic Functions .. - INTRINSIC DBLE, INT, MAX, MIN, SQRT -C .. Executable Statements .. -C - INFO = 0 - LEQUIL = LSAME( EQUIL, 'S' ) - LQUERY = ( LDWORK.EQ.-1 ) -C -C Test the input scalar arguments. -C - IF( .NOT.LEQUIL .AND. .NOT.LSAME( EQUIL, 'N' ) ) THEN - INFO = -1 - ELSE IF( N.LT.0 ) THEN - INFO = -2 - ELSE IF( M.LT.0 ) THEN - INFO = -3 - ELSE IF( P.LT.0 ) THEN - INFO = -4 - ELSE IF( LDA.LT.MAX( 1, N ) ) THEN - INFO = -6 - ELSE IF( LDB.LT.MAX( 1, N ) ) THEN - INFO = -8 - ELSE IF( LDC.LT.MAX( 1, P ) ) THEN - INFO = -10 - ELSE IF( LDD.LT.MAX( 1, P ) ) THEN - INFO = -12 - ELSE IF( LDAF.LT.MAX( 1, N + M ) ) THEN - INFO = -22 - ELSE IF( LDBF.LT.MAX( 1, N + P ) ) THEN - INFO = -24 - ELSE - II = MIN( P, M ) - I = MAX( II + MAX( 3*M - 1, N ), - $ MIN( P, N ) + MAX( 3*P - 1, N+P, N+M ), - $ MIN( M, N ) + MAX( 3*M - 1, N+M ), 1 ) - IF( LQUERY ) THEN - SVLMAX = ZERO - NINFZ = 0 - CALL AB08NX( N, M, P, P, 0, SVLMAX, BF, LDBF, NINFZ, INFZ, - $ KRONL, MU, NU, NKROL, TOL, IWORK, DWORK, -1, - $ INFO ) - WRKOPT = MAX( I, INT( DWORK(1) ) ) - CALL AB08NX( N, II, M, M-II, II, SVLMAX, AF, LDAF, NINFZ, - $ INFZ, KRONL, MU, NU, NKROL, TOL, IWORK, DWORK, - $ -1, INFO ) - WRKOPT = MAX( WRKOPT, INT( DWORK(1) ) ) - NB = ILAENV( 1, 'DGERQF', ' ', II, N+II, -1, -1 ) - WRKOPT = MAX( WRKOPT, II + II*NB ) - NB = MIN( 64, ILAENV( 1, 'DORMRQ', 'RT', N, N+II, II, -1 ) ) - WRKOPT = MAX( WRKOPT, II + N*NB ) - ELSE IF( LDWORK.LT.I ) THEN - INFO = -28 - END IF - END IF -C - IF ( INFO.NE.0 ) THEN -C -C Error return. -C - CALL XERBLA( 'AB08ND', -INFO ) - RETURN - ELSE IF( LQUERY ) THEN - DWORK(1) = WRKOPT - RETURN - END IF -C - DINFZ = 0 - NKROL = 0 - NKROR = 0 -C -C Quick return if possible. -C - IF ( N.EQ.0 ) THEN - IF ( MIN( M, P ).EQ.0 ) THEN - NU = 0 - RANK = 0 - DWORK(1) = ONE - RETURN - END IF - END IF -C - MM = M - NN = N - PP = P -C - DO 20 I = 1, N - INFZ(I) = 0 - 20 CONTINUE -C - IF ( M.GT.0 ) THEN - DO 40 I = 1, N + 1 - KRONR(I) = 0 - 40 CONTINUE - END IF -C - IF ( P.GT.0 ) THEN - DO 60 I = 1, N + 1 - KRONL(I) = 0 - 60 CONTINUE - END IF -C -C (Note: Comments in the code beginning "Workspace:" describe the -C minimal amount of real workspace needed at that point in the -C code, as well as the preferred amount for good performance.) -C - WRKOPT = 1 -C -C Construct the compound matrix ( B A ), dimension (N+P)-by-(M+N). -C ( D C ) -C - CALL DLACPY( 'Full', NN, MM, B, LDB, BF, LDBF ) - IF ( PP.GT.0 ) - $ CALL DLACPY( 'Full', PP, MM, D, LDD, BF(1+NN,1), LDBF ) - IF ( NN.GT.0 ) THEN - CALL DLACPY( 'Full', NN, NN, A, LDA, BF(1,1+MM), LDBF ) - IF ( PP.GT.0 ) - $ CALL DLACPY( 'Full', PP, NN, C, LDC, BF(1+NN,1+MM), LDBF ) - END IF -C -C If required, balance the compound matrix (default MAXRED). -C Workspace: need N. -C - IF ( LEQUIL .AND. NN.GT.0 .AND. PP.GT.0 ) THEN - MAXRED = ZERO - CALL TB01ID( 'A', NN, MM, PP, MAXRED, BF(1,1+MM), LDBF, BF, - $ LDBF, BF(1+NN,1+MM), LDBF, DWORK, INFO ) - WRKOPT = N - END IF -C -C If required, set tolerance. -C - THRESH = SQRT( DBLE( (N + P)*(N + M) ) )*DLAMCH( 'Precision' ) - TOLER = TOL - IF ( TOLER.LT.THRESH ) TOLER = THRESH - SVLMAX = DLANGE( 'Frobenius', NN+PP, NN+MM, BF, LDBF, DWORK ) -C -C Reduce this system to one with the same invariant zeros and with -C D upper triangular of full row rank MU (the normal rank of the -C original system). -C Workspace: need MAX( 1, MIN(P,M) + MAX(3*M-1,N), -C MIN(P,N) + MAX(3*P-1,N+P,N+M) ); -C prefer larger. -C - RO = PP - SIGMA = 0 - NINFZ = 0 - CALL AB08NX( NN, MM, PP, RO, SIGMA, SVLMAX, BF, LDBF, NINFZ, INFZ, - $ KRONL, MU, NU, NKROL, TOLER, IWORK, DWORK, LDWORK, - $ INFO ) - WRKOPT = MAX( WRKOPT, INT( DWORK(1) ) ) - RANK = MU -C -C Pertranspose the system. -C - NUMU = NU + MU - IF ( NUMU.NE.0 ) THEN - MNU = MM + NU - NUMU1 = NUMU + 1 -C - DO 80 I = 1, NUMU - CALL DCOPY( MNU, BF(I,1), LDBF, AF(1,NUMU1-I), -1 ) - 80 CONTINUE -C - IF ( MU.NE.MM ) THEN -C -C Here MU < MM and MM > 0 (since MM = 0 implies MU = 0 = MM). -C - PP = MM - NN = NU - MM = MU -C -C Reduce the system to one with the same invariant zeros and -C with D square invertible. -C Workspace: need MAX( 1, MU + MAX(3*MU-1,N), -C MIN(M,N) + MAX(3*M-1,N+M) ); -C prefer larger. Note that MU <= MIN(P,M). -C - RO = PP - MM - SIGMA = MM - CALL AB08NX( NN, MM, PP, RO, SIGMA, SVLMAX, AF, LDAF, NINFZ, - $ INFZ, KRONR, MU, NU, NKROR, TOLER, IWORK, - $ DWORK, LDWORK, INFO ) - WRKOPT = MAX( WRKOPT, INT( DWORK(1) ) ) - END IF -C - IF ( NU.NE.0 ) THEN -C -C Perform a unitary transformation on the columns of -C ( B A-lambda*I ) -C ( D C ) -C in order to reduce it to -C ( X AF-lambda*BF ) -C ( Y 0 ) -C with Y and BF square invertible. -C - CALL DLASET( 'Full', NU, MU, ZERO, ZERO, BF, LDBF ) - CALL DLASET( 'Full', NU, NU, ZERO, ONE, BF(1,MU+1), LDBF ) -C - IF ( RANK.NE.0 ) THEN - NU1 = NU + 1 - I1 = NU + MU -C -C Workspace: need 2*MIN(M,P); -C prefer MIN(M,P) + MIN(M,P)*NB. -C - CALL DTZRZF( MU, I1, AF(NU1,1), LDAF, DWORK, DWORK(MU+1), - $ LDWORK-MU, INFO ) - WRKOPT = MAX( WRKOPT, INT( DWORK(MU+1) ) + MU ) -C -C Workspace: need MIN(M,P) + N; -C prefer MIN(M,P) + N*NB. -C - CALL DORMRZ( 'Right', 'Transpose', NU, I1, MU, NU, - $ AF(NU1,1), LDAF, DWORK, AF, LDAF, - $ DWORK(MU+1), LDWORK-MU, INFO ) - WRKOPT = MAX( WRKOPT, INT( DWORK(MU+1) ) + MU ) -C - CALL DORMRZ( 'Right', 'Transpose', NU, I1, MU, NU, - $ AF(NU1,1), LDAF, DWORK, BF, LDBF, - $ DWORK(MU+1), LDWORK-MU, INFO ) -C - END IF -C -C Move AF and BF in the first columns. This assumes that -C DLACPY moves column by column. -C - CALL DLACPY( 'Full', NU, NU, AF(1,MU+1), LDAF, AF, LDAF ) - IF ( RANK.NE.0 ) - $ CALL DLACPY( 'Full', NU, NU, BF(1,MU+1), LDBF, BF, LDBF ) -C - END IF - END IF -C -C Set right Kronecker indices (column indices). -C - IF ( NKROR.GT.0 ) THEN - J = 1 -C - DO 120 I = 1, N + 1 -C - DO 100 II = J, J + KRONR(I) - 1 - IWORK(II) = I - 1 - 100 CONTINUE -C - J = J + KRONR(I) - KRONR(I) = 0 - 120 CONTINUE -C - NKROR = J - 1 -C - DO 140 I = 1, NKROR - KRONR(I) = IWORK(I) - 140 CONTINUE -C - END IF -C -C Set left Kronecker indices (row indices). -C - IF ( NKROL.GT.0 ) THEN - J = 1 -C - DO 180 I = 1, N + 1 -C - DO 160 II = J, J + KRONL(I) - 1 - IWORK(II) = I - 1 - 160 CONTINUE -C - J = J + KRONL(I) - KRONL(I) = 0 - 180 CONTINUE -C - NKROL = J - 1 -C - DO 200 I = 1, NKROL - KRONL(I) = IWORK(I) - 200 CONTINUE -C - END IF -C - IF ( N.GT.0 ) THEN - DINFZ = N -C - 220 CONTINUE - IF ( INFZ(DINFZ).EQ.0 ) THEN - DINFZ = DINFZ - 1 - IF ( DINFZ.GT.0 ) - $ GO TO 220 - END IF - END IF -C - DWORK(1) = WRKOPT - RETURN -C *** Last line of AB08ND *** - END diff --git a/mex/sources/libslicot/AB08NX.f b/mex/sources/libslicot/AB08NX.f deleted file mode 100644 index d67f6a193..000000000 --- a/mex/sources/libslicot/AB08NX.f +++ /dev/null @@ -1,446 +0,0 @@ - SUBROUTINE AB08NX( N, M, P, RO, SIGMA, SVLMAX, ABCD, LDABCD, - $ NINFZ, INFZ, KRONL, MU, NU, NKROL, TOL, IWORK, - $ DWORK, LDWORK, INFO ) -C -C SLICOT RELEASE 5.0. -C -C Copyright (c) 2002-2009 NICONET e.V. -C -C This program is free software: you can redistribute it and/or -C modify it under the terms of the GNU General Public License as -C published by the Free Software Foundation, either version 2 of -C the License, or (at your option) any later version. -C -C This program is distributed in the hope that it will be useful, -C but WITHOUT ANY WARRANTY; without even the implied warranty of -C MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the -C GNU General Public License for more details. -C -C You should have received a copy of the GNU General Public License -C along with this program. If not, see -C . -C -C PURPOSE -C -C To extract from the (N+P)-by-(M+N) system -C ( B A ) -C ( D C ) -C an (NU+MU)-by-(M+NU) "reduced" system -C ( B' A') -C ( D' C') -C having the same transmission zeros but with D' of full row rank. -C -C ARGUMENTS -C -C Input/Output Parameters -C -C N (input) INTEGER -C The number of state variables. N >= 0. -C -C M (input) INTEGER -C The number of system inputs. M >= 0. -C -C P (input) INTEGER -C The number of system outputs. P >= 0. -C -C RO (input/output) INTEGER -C On entry, -C = P for the original system; -C = MAX(P-M, 0) for the pertransposed system. -C On exit, RO contains the last computed rank. -C -C SIGMA (input/output) INTEGER -C On entry, -C = 0 for the original system; -C = M for the pertransposed system. -C On exit, SIGMA contains the last computed value sigma in -C the algorithm. -C -C SVLMAX (input) DOUBLE PRECISION -C During each reduction step, the rank-revealing QR -C factorization of a matrix stops when the estimated minimum -C singular value is smaller than TOL * MAX(SVLMAX,EMSV), -C where EMSV is the estimated maximum singular value. -C SVLMAX >= 0. -C -C ABCD (input/output) DOUBLE PRECISION array, dimension -C (LDABCD,M+N) -C On entry, the leading (N+P)-by-(M+N) part of this array -C must contain the compound input matrix of the system. -C On exit, the leading (NU+MU)-by-(M+NU) part of this array -C contains the reduced compound input matrix of the system. -C -C LDABCD INTEGER -C The leading dimension of array ABCD. -C LDABCD >= MAX(1,N+P). -C -C NINFZ (input/output) INTEGER -C On entry, the currently computed number of infinite zeros. -C It should be initialized to zero on the first call. -C NINFZ >= 0. -C On exit, the number of infinite zeros. -C -C INFZ (input/output) INTEGER array, dimension (N) -C On entry, INFZ(i) must contain the current number of -C infinite zeros of degree i, where i = 1,2,...,N, found in -C the previous call(s) of the routine. It should be -C initialized to zero on the first call. -C On exit, INFZ(i) contains the number of infinite zeros of -C degree i, where i = 1,2,...,N. -C -C KRONL (input/output) INTEGER array, dimension (N+1) -C On entry, this array must contain the currently computed -C left Kronecker (row) indices found in the previous call(s) -C of the routine. It should be initialized to zero on the -C first call. -C On exit, the leading NKROL elements of this array contain -C the left Kronecker (row) indices. -C -C MU (output) INTEGER -C The normal rank of the transfer function matrix of the -C original system. -C -C NU (output) INTEGER -C The dimension of the reduced system matrix and the number -C of (finite) invariant zeros if D' is invertible. -C -C NKROL (output) INTEGER -C The number of left Kronecker indices. -C -C Tolerances -C -C TOL DOUBLE PRECISION -C A tolerance used in rank decisions to determine the -C effective rank, which is defined as the order of the -C largest leading (or trailing) triangular submatrix in the -C QR (or RQ) factorization with column (or row) pivoting -C whose estimated condition number is less than 1/TOL. -C NOTE that when SVLMAX > 0, the estimated ranks could be -C less than those defined above (see SVLMAX). -C -C Workspace -C -C IWORK INTEGER array, dimension (MAX(M,P)) -C -C DWORK DOUBLE PRECISION array, dimension (LDWORK) -C On exit, if INFO = 0, DWORK(1) returns the optimal value -C of LDWORK. -C -C LDWORK INTEGER -C The length of the array DWORK. -C LDWORK >= MAX( 1, MIN(P,M) + MAX(3*M-1,N), -C MIN(P,N) + MAX(3*P-1,N+P,N+M) ). -C For optimum performance LDWORK should be larger. -C -C If LDWORK = -1, then a workspace query is assumed; -C the routine only calculates the optimal size of the -C DWORK array, returns this value as the first entry of -C the DWORK array, and no error message related to LDWORK -C is issued by XERBLA. -C -C Error Indicator -C -C INFO INTEGER -C = 0: successful exit; -C < 0: if INFO = -i, the i-th argument had an illegal -C value. -C -C REFERENCES -C -C [1] Svaricek, F. -C Computation of the Structural Invariants of Linear -C Multivariable Systems with an Extended Version of -C the Program ZEROS. -C System & Control Letters, 6, pp. 261-266, 1985. -C -C [2] Emami-Naeini, A. and Van Dooren, P. -C Computation of Zeros of Linear Multivariable Systems. -C Automatica, 18, pp. 415-430, 1982. -C -C NUMERICAL ASPECTS -C -C The algorithm is backward stable. -C -C CONTRIBUTOR -C -C Release 3.0: V. Sima, Katholieke Univ. Leuven, Belgium, Nov. 1996. -C Supersedes Release 2.0 routine AB08BZ by F. Svaricek. -C -C REVISIONS -C -C V. Sima, Oct. 1997; Feb. 1998, Jan. 2009, Apr. 2009. -C A. Varga, May 1999; May 2001. -C -C KEYWORDS -C -C Generalized eigenvalue problem, Kronecker indices, multivariable -C system, orthogonal transformation, structural invariant. -C -C ****************************************************************** -C -C .. Parameters .. - DOUBLE PRECISION ZERO - PARAMETER ( ZERO = 0.0D0 ) -C .. Scalar Arguments .. - INTEGER INFO, LDABCD, LDWORK, M, MU, N, NINFZ, NKROL, - $ NU, P, RO, SIGMA - DOUBLE PRECISION SVLMAX, TOL -C .. Array Arguments .. - INTEGER INFZ(*), IWORK(*), KRONL(*) - DOUBLE PRECISION ABCD(LDABCD,*), DWORK(*) -C .. Local Scalars .. - LOGICAL LQUERY - INTEGER I1, IK, IROW, ITAU, IZ, JWORK, MM1, MNTAU, MNU, - $ MPM, NB, NP, RANK, RO1, TAU, WRKOPT - DOUBLE PRECISION T -C .. Local Arrays .. - DOUBLE PRECISION SVAL(3) -C .. External Functions .. - INTEGER ILAENV - EXTERNAL ILAENV -C .. External Subroutines .. - EXTERNAL DLAPMT, DLARFG, DLASET, DLATZM, DORMQR, DORMRQ, - $ MB03OY, MB03PY, XERBLA -C .. Intrinsic Functions .. - INTRINSIC INT, MAX, MIN -C .. Executable Statements .. -C - NP = N + P - MPM = MIN( P, M ) - INFO = 0 - LQUERY = ( LDWORK.EQ.-1 ) -C -C Test the input scalar arguments. -C - IF( N.LT.0 ) THEN - INFO = -1 - ELSE IF( M.LT.0 ) THEN - INFO = -2 - ELSE IF( P.LT.0 ) THEN - INFO = -3 - ELSE IF( RO.NE.P .AND. RO.NE.MAX( P-M, 0 ) ) THEN - INFO = -4 - ELSE IF( SIGMA.NE.0 .AND. SIGMA.NE.M ) THEN - INFO = -5 - ELSE IF( SVLMAX.LT.ZERO ) THEN - INFO = -6 - ELSE IF( LDABCD.LT.MAX( 1, NP ) ) THEN - INFO = -8 - ELSE IF( NINFZ.LT.0 ) THEN - INFO = -9 - ELSE - JWORK = MAX( 1, MPM + MAX( 3*M - 1, N ), - $ MIN( P, N ) + MAX( 3*P - 1, NP, N+M ) ) - IF( LQUERY ) THEN - IF( M.GT.0 ) THEN - NB = MIN( 64, ILAENV( 1, 'DORMQR', 'LT', P, N, MPM, - $ -1 ) ) - WRKOPT = MAX( JWORK, MPM + MAX( 1, N )*NB ) - ELSE - WRKOPT = JWORK - END IF - NB = MIN( 64, ILAENV( 1, 'DORMRQ', 'RT', NP, N, MIN( P, N ), - $ -1 ) ) - WRKOPT = MAX( WRKOPT, MIN( P, N ) + MAX( 1, NP )*NB ) - NB = MIN( 64, ILAENV( 1, 'DORMRQ', 'LN', N, M+N, - $ MIN( P, N ), -1 ) ) - WRKOPT = MAX( WRKOPT, MIN( P, N ) + MAX( 1, M+N )*NB ) - ELSE IF( LDWORK.LT.JWORK ) THEN - INFO = -18 - END IF - END IF -C - IF ( INFO.NE.0 ) THEN -C -C Error return. -C - CALL XERBLA( 'AB08NX', -INFO ) - RETURN - ELSE IF( LQUERY ) THEN - DWORK(1) = WRKOPT - RETURN - END IF -C - MU = P - NU = N -C - IZ = 0 - IK = 1 - MM1 = M + 1 - ITAU = 1 - NKROL = 0 - WRKOPT = 1 -C -C Main reduction loop: -C -C M NU M NU -C NU [ B A ] NU [ B A ] -C MU [ D C ] --> SIGMA [ RD C1 ] (SIGMA = rank(D) = -C TAU [ 0 C2 ] row size of RD) -C -C M NU-RO RO -C NU-RO [ B1 A11 A12 ] -C --> RO [ B2 A21 A22 ] (RO = rank(C2) = -C SIGMA [ RD C11 C12 ] col size of LC) -C TAU [ 0 0 LC ] -C -C M NU-RO -C NU-RO [ B1 A11 ] NU := NU - RO -C [----------] MU := RO + SIGMA -C --> RO [ B2 A21 ] D := [B2;RD] -C SIGMA [ RD C11 ] C := [A21;C11] -C - 20 IF ( MU.EQ.0 ) - $ GO TO 80 -C -C (Note: Comments in the code beginning "Workspace:" describe the -C minimal amount of real workspace needed at that point in the -C code, as well as the preferred amount for good performance.) -C - RO1 = RO - MNU = M + NU - IF ( M.GT.0 ) THEN - IF ( SIGMA.NE.0 ) THEN - IROW = NU + 1 -C -C Compress rows of D. First exploit triangular shape. -C Workspace: need M+N-1. -C - DO 40 I1 = 1, SIGMA - CALL DLARFG( RO+1, ABCD(IROW,I1), ABCD(IROW+1,I1), 1, T ) - CALL DLATZM( 'L', RO+1, MNU-I1, ABCD(IROW+1,I1), 1, T, - $ ABCD(IROW,I1+1), ABCD(IROW+1,I1+1), LDABCD, - $ DWORK ) - IROW = IROW + 1 - 40 CONTINUE - CALL DLASET( 'Lower', RO+SIGMA-1, SIGMA, ZERO, ZERO, - $ ABCD(NU+2,1), LDABCD ) - END IF -C -C Continue with Householder with column pivoting. -C -C The rank of D is the number of (estimated) singular values -C that are greater than TOL * MAX(SVLMAX,EMSV). This number -C includes the singular values of the first SIGMA columns. -C Integer workspace: need M; -C Workspace: need min(RO1,M) + 3*M - 1. RO1 <= P. -C - IF ( SIGMA.LT.M ) THEN - JWORK = ITAU + MIN( RO1, M ) - I1 = SIGMA + 1 - IROW = NU + I1 - CALL MB03OY( RO1, M-SIGMA, ABCD(IROW,I1), LDABCD, TOL, - $ SVLMAX, RANK, SVAL, IWORK, DWORK(ITAU), - $ DWORK(JWORK), INFO ) - WRKOPT = MAX( WRKOPT, JWORK + 3*M - 2 ) -C -C Apply the column permutations to matrices B and part of D. -C - CALL DLAPMT( .TRUE., NU+SIGMA, M-SIGMA, ABCD(1,I1), LDABCD, - $ IWORK ) -C - IF ( RANK.GT.0 ) THEN -C -C Apply the Householder transformations to the submatrix C. -C Workspace: need min(RO1,M) + NU; -C prefer min(RO1,M) + NU*NB. -C - CALL DORMQR( 'Left', 'Transpose', RO1, NU, RANK, - $ ABCD(IROW,I1), LDABCD, DWORK(ITAU), - $ ABCD(IROW,MM1), LDABCD, DWORK(JWORK), - $ LDWORK-JWORK+1, INFO ) - WRKOPT = MAX( WRKOPT, INT( DWORK(JWORK) ) + JWORK - 1 ) - IF ( RO1.GT.1 ) - $ CALL DLASET( 'Lower', RO1-1, MIN( RO1-1, RANK ), ZERO, - $ ZERO, ABCD(IROW+1,I1), LDABCD ) - RO1 = RO1 - RANK - END IF - END IF - END IF -C - TAU = RO1 - SIGMA = MU - TAU -C -C Determination of the orders of the infinite zeros. -C - IF ( IZ.GT.0 ) THEN - INFZ(IZ) = INFZ(IZ) + RO - TAU - NINFZ = NINFZ + IZ*( RO - TAU ) - END IF - IF ( RO1.EQ.0 ) - $ GO TO 80 - IZ = IZ + 1 -C - IF ( NU.LE.0 ) THEN - MU = SIGMA - NU = 0 - RO = 0 - ELSE -C -C Compress the columns of C2 using RQ factorization with row -C pivoting, P * C2 = R * Q. -C - I1 = NU + SIGMA + 1 - MNTAU = MIN( TAU, NU ) - JWORK = ITAU + MNTAU -C -C The rank of C2 is the number of (estimated) singular values -C greater than TOL * MAX(SVLMAX,EMSV). -C Integer Workspace: need TAU; -C Workspace: need min(TAU,NU) + 3*TAU - 1. -C - CALL MB03PY( TAU, NU, ABCD(I1,MM1), LDABCD, TOL, SVLMAX, RANK, - $ SVAL, IWORK, DWORK(ITAU), DWORK(JWORK), INFO ) - WRKOPT = MAX( WRKOPT, JWORK + 3*TAU - 1 ) - IF ( RANK.GT.0 ) THEN - IROW = I1 + TAU - RANK -C -C Apply Q' to the first NU columns of [A; C1] from the right. -C Workspace: need min(TAU,NU) + NU + SIGMA; SIGMA <= P; -C prefer min(TAU,NU) + (NU + SIGMA)*NB. -C - CALL DORMRQ( 'Right', 'Transpose', I1-1, NU, RANK, - $ ABCD(IROW,MM1), LDABCD, DWORK(MNTAU-RANK+1), - $ ABCD(1,MM1), LDABCD, DWORK(JWORK), - $ LDWORK-JWORK+1, INFO ) - WRKOPT = MAX( WRKOPT, INT( DWORK(JWORK) ) + JWORK - 1 ) -C -C Apply Q to the first NU rows and M + NU columns of [ B A ] -C from the left. -C Workspace: need min(TAU,NU) + M + NU; -C prefer min(TAU,NU) + (M + NU)*NB. -C - CALL DORMRQ( 'Left', 'NoTranspose', NU, MNU, RANK, - $ ABCD(IROW,MM1), LDABCD, DWORK(MNTAU-RANK+1), - $ ABCD, LDABCD, DWORK(JWORK), LDWORK-JWORK+1, - $ INFO ) - WRKOPT = MAX( WRKOPT, INT( DWORK(JWORK) ) + JWORK - 1 ) -C - CALL DLASET( 'Full', RANK, NU-RANK, ZERO, ZERO, - $ ABCD(IROW,MM1), LDABCD ) - IF ( RANK.GT.1 ) - $ CALL DLASET( 'Lower', RANK-1, RANK-1, ZERO, ZERO, - $ ABCD(IROW+1,MM1+NU-RANK), LDABCD ) - END IF -C - RO = RANK - END IF -C -C Determine the left Kronecker indices (row indices). -C - KRONL(IK) = KRONL(IK) + TAU - RO - NKROL = NKROL + KRONL(IK) - IK = IK + 1 -C -C C and D are updated to [A21 ; C11] and [B2 ; RD]. -C - NU = NU - RO - MU = SIGMA + RO - IF ( RO.NE.0 ) - $ GO TO 20 -C - 80 CONTINUE - DWORK(1) = WRKOPT - RETURN -C *** Last line of AB08NX *** - END diff --git a/mex/sources/libslicot/AB08NZ.f b/mex/sources/libslicot/AB08NZ.f deleted file mode 100644 index 9638b4bbb..000000000 --- a/mex/sources/libslicot/AB08NZ.f +++ /dev/null @@ -1,576 +0,0 @@ - SUBROUTINE AB08NZ( EQUIL, N, M, P, A, LDA, B, LDB, C, LDC, D, LDD, - $ NU, RANK, DINFZ, NKROR, NKROL, INFZ, KRONR, - $ KRONL, AF, LDAF, BF, LDBF, TOL, IWORK, DWORK, - $ ZWORK, LZWORK, INFO ) -C -C SLICOT RELEASE 5.0. -C -C Copyright (c) 2002-2009 NICONET e.V. -C -C This program is free software: you can redistribute it and/or -C modify it under the terms of the GNU General Public License as -C published by the Free Software Foundation, either version 2 of -C the License, or (at your option) any later version. -C -C This program is distributed in the hope that it will be useful, -C but WITHOUT ANY WARRANTY; without even the implied warranty of -C MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the -C GNU General Public License for more details. -C -C You should have received a copy of the GNU General Public License -C along with this program. If not, see -C . -C -C PURPOSE -C -C To construct for a linear multivariable system described by a -C state-space model (A,B,C,D) a regular pencil (A - lambda*B ) which -C f f -C has the invariant zeros of the system as generalized eigenvalues. -C The routine also computes the orders of the infinite zeros and the -C right and left Kronecker indices of the system (A,B,C,D). -C -C ARGUMENTS -C -C Mode Parameters -C -C EQUIL CHARACTER*1 -C Specifies whether the user wishes to balance the compound -C matrix (see METHOD) as follows: -C = 'S': Perform balancing (scaling); -C = 'N': Do not perform balancing. -C -C Input/Output Parameters -C -C N (input) INTEGER -C The number of state variables, i.e., the order of the -C matrix A. N >= 0. -C -C M (input) INTEGER -C The number of system inputs. M >= 0. -C -C P (input) INTEGER -C The number of system outputs. P >= 0. -C -C A (input) COMPLEX*16 array, dimension (LDA,N) -C The leading N-by-N part of this array must contain the -C state dynamics matrix A of the system. -C -C LDA INTEGER -C The leading dimension of array A. LDA >= MAX(1,N). -C -C B (input) COMPLEX*16 array, dimension (LDB,M) -C The leading N-by-M part of this array must contain the -C input/state matrix B of the system. -C -C LDB INTEGER -C The leading dimension of array B. LDB >= MAX(1,N). -C -C C (input) COMPLEX*16 array, dimension (LDC,N) -C The leading P-by-N part of this array must contain the -C state/output matrix C of the system. -C -C LDC INTEGER -C The leading dimension of array C. LDC >= MAX(1,P). -C -C D (input) COMPLEX*16 array, dimension (LDD,M) -C The leading P-by-M part of this array must contain the -C direct transmission matrix D of the system. -C -C LDD INTEGER -C The leading dimension of array D. LDD >= MAX(1,P). -C -C NU (output) INTEGER -C The number of (finite) invariant zeros. -C -C RANK (output) INTEGER -C The normal rank of the transfer function matrix. -C -C DINFZ (output) INTEGER -C The maximum degree of infinite elementary divisors. -C -C NKROR (output) INTEGER -C The number of right Kronecker indices. -C -C NKROL (output) INTEGER -C The number of left Kronecker indices. -C -C INFZ (output) INTEGER array, dimension (N) -C The leading DINFZ elements of INFZ contain information -C on the infinite elementary divisors as follows: -C the system has INFZ(i) infinite elementary divisors -C of degree i, where i = 1,2,...,DINFZ. -C -C KRONR (output) INTEGER array, dimension (MAX(N,M)+1) -C The leading NKROR elements of this array contain the -C right Kronecker (column) indices. -C -C KRONL (output) INTEGER array, dimension (MAX(N,P)+1) -C The leading NKROL elements of this array contain the -C left Kronecker (row) indices. -C -C AF (output) COMPLEX*16 array, dimension (LDAF,N+MIN(P,M)) -C The leading NU-by-NU part of this array contains the -C coefficient matrix A of the reduced pencil. The remainder -C f -C of the leading (N+M)-by-(N+MIN(P,M)) part is used as -C internal workspace. -C -C LDAF INTEGER -C The leading dimension of array AF. LDAF >= MAX(1,N+M). -C -C BF (output) COMPLEX*16 array, dimension (LDBF,N+M) -C The leading NU-by-NU part of this array contains the -C coefficient matrix B of the reduced pencil. The -C f -C remainder of the leading (N+P)-by-(N+M) part is used as -C internal workspace. -C -C LDBF INTEGER -C The leading dimension of array BF. LDBF >= MAX(1,N+P). -C -C Tolerances -C -C TOL DOUBLE PRECISION -C A tolerance used in rank decisions to determine the -C effective rank, which is defined as the order of the -C largest leading (or trailing) triangular submatrix in the -C QR (or RQ) factorization with column (or row) pivoting -C whose estimated condition number is less than 1/TOL. -C If the user sets TOL to be less than SQRT((N+P)*(N+M))*EPS -C then the tolerance is taken as SQRT((N+P)*(N+M))*EPS, -C where EPS is the machine precision (see LAPACK Library -C Routine DLAMCH). -C -C Workspace -C -C IWORK INTEGER array, dimension (MAX(M,P)) -C -C DWORK DOUBLE PRECISION array, dimension (MAX(N,2*MAX(P,M))) -C -C ZWORK DOUBLE PRECISION array, dimension (LZWORK) -C On exit, if INFO = 0, ZWORK(1) returns the optimal value -C of LZWORK. -C -C LZWORK INTEGER -C The length of the array ZWORK. -C LZWORK >= MAX( 1, MIN(P,M) + MAX(3*M-1,N), -C MIN(P,N) + MAX(3*P-1,N+P,N+M), -C MIN(M,N) + MAX(3*M-1,N+M) ). -C An upper bound is MAX(s,N) + MAX(3*s-1,N+s), with -C s = MAX(M,P). -C For optimum performance LZWORK should be larger. -C -C If LZWORK = -1, then a workspace query is assumed; -C the routine only calculates the optimal size of the -C ZWORK array, returns this value as the first entry of -C the ZWORK array, and no error message related to LZWORK -C is issued by XERBLA. -C -C Error Indicator -C -C INFO INTEGER -C = 0: successful exit; -C < 0: if INFO = -i, the i-th argument had an illegal -C value. -C -C METHOD -C -C The routine extracts from the system matrix of a state-space -C system (A,B,C,D) a regular pencil A - lambda*B which has the -C f f -C invariant zeros of the system as generalized eigenvalues as -C follows: -C -C (a) construct the (N+P)-by-(N+M) compound matrix (B A); -C (D C) -C -C (b) reduce the above system to one with the same invariant -C zeros and with D of full row rank; -C -C (c) pertranspose the system; -C -C (d) reduce the system to one with the same invariant zeros and -C with D square invertible; -C -C (e) perform a unitary transformation on the columns of -C (A - lambda*I B) in order to reduce it to -C ( C D) -C -C (A - lambda*B X) -C ( f f ), with Y and B square invertible; -C ( 0 Y) f -C -C (f) compute the right and left Kronecker indices of the system -C (A,B,C,D), which together with the orders of the infinite -C zeros (determined by steps (a) - (e)) constitute the -C complete set of structural invariants under strict -C equivalence transformations of a linear system. -C -C REFERENCES -C -C [1] Svaricek, F. -C Computation of the Structural Invariants of Linear -C Multivariable Systems with an Extended Version of -C the Program ZEROS. -C System & Control Letters, 6, pp. 261-266, 1985. -C -C [2] Emami-Naeini, A. and Van Dooren, P. -C Computation of Zeros of Linear Multivariable Systems. -C Automatica, 18, pp. 415-430, 1982. -C -C NUMERICAL ASPECTS -C -C The algorithm is backward stable (see [2] and [1]). -C -C FURTHER COMMENTS -C -C In order to compute the invariant zeros of the system explicitly, -C a call to this routine may be followed by a call to the LAPACK -C Library routine ZGGEV with A = A , B = B and N = NU. -C f f -C If RANK = 0, the routine ZGEEV can be used (since B = I). -C f -C CONTRIBUTOR -C -C V. Sima, Katholieke Univ. Leuven, Belgium, Nov. 1996. -C Complex version: V. Sima, Research Institute for Informatics, -C Bucharest, Nov. 2008. -C -C REVISIONS -C -C V. Sima, Research Institute for Informatics, Bucharest, Mar. 2009, -C Apr. 2009. -C -C KEYWORDS -C -C Generalized eigenvalue problem, Kronecker indices, multivariable -C system, unitary transformation, structural invariant. -C -C ****************************************************************** -C -C .. Parameters .. - COMPLEX*16 ZERO, ONE - PARAMETER ( ZERO = ( 0.0D+0, 0.0D+0 ), - $ ONE = ( 1.0D+0, 0.0D+0 ) ) - DOUBLE PRECISION DZERO - PARAMETER ( DZERO = 0.0D0 ) -C .. Scalar Arguments .. - CHARACTER EQUIL - INTEGER DINFZ, INFO, LDA, LDAF, LDB, LDBF, LDC, LDD, - $ LZWORK, M, N, NKROL, NKROR, NU, P, RANK - DOUBLE PRECISION TOL -C .. Array Arguments .. - INTEGER INFZ(*), IWORK(*), KRONL(*), KRONR(*) - COMPLEX*16 A(LDA,*), AF(LDAF,*), B(LDB,*), BF(LDBF,*), - $ C(LDC,*), D(LDD,*), ZWORK(*) - DOUBLE PRECISION DWORK(*) -C .. Local Scalars .. - LOGICAL LEQUIL, LQUERY - INTEGER I, I1, II, J, MM, MNU, MU, NB, NINFZ, NN, NU1, - $ NUMU, NUMU1, PP, RO, SIGMA, WRKOPT - DOUBLE PRECISION MAXRED, SVLMAX, THRESH, TOLER -C .. External Functions .. - LOGICAL LSAME - INTEGER ILAENV - DOUBLE PRECISION DLAMCH, ZLANGE - EXTERNAL DLAMCH, ILAENV, LSAME, ZLANGE -C .. External Subroutines .. - EXTERNAL AB8NXZ, TB01IZ, XERBLA, ZCOPY, ZLACPY, ZLASET, - $ ZTZRZF, ZUNMRZ -C .. Intrinsic Functions .. - INTRINSIC DBLE, INT, MAX, MIN, SQRT -C .. Executable Statements .. -C - INFO = 0 - LEQUIL = LSAME( EQUIL, 'S' ) - LQUERY = ( LZWORK.EQ.-1 ) -C -C Test the input scalar arguments. -C - IF( .NOT.LEQUIL .AND. .NOT.LSAME( EQUIL, 'N' ) ) THEN - INFO = -1 - ELSE IF( N.LT.0 ) THEN - INFO = -2 - ELSE IF( M.LT.0 ) THEN - INFO = -3 - ELSE IF( P.LT.0 ) THEN - INFO = -4 - ELSE IF( LDA.LT.MAX( 1, N ) ) THEN - INFO = -6 - ELSE IF( LDB.LT.MAX( 1, N ) ) THEN - INFO = -8 - ELSE IF( LDC.LT.MAX( 1, P ) ) THEN - INFO = -10 - ELSE IF( LDD.LT.MAX( 1, P ) ) THEN - INFO = -12 - ELSE IF( LDAF.LT.MAX( 1, N + M ) ) THEN - INFO = -22 - ELSE IF( LDBF.LT.MAX( 1, N + P ) ) THEN - INFO = -24 - ELSE - II = MIN( P, M ) - I = MAX( II + MAX( 3*M - 1, N ), - $ MIN( P, N ) + MAX( 3*P - 1, N+P, N+M ), - $ MIN( M, N ) + MAX( 3*M - 1, N+M ), 1 ) - IF( LQUERY ) THEN - SVLMAX = DZERO - NINFZ = 0 - CALL AB8NXZ( N, M, P, P, 0, SVLMAX, BF, LDBF, NINFZ, INFZ, - $ KRONL, MU, NU, NKROL, TOL, IWORK, DWORK, - $ ZWORK, -1, INFO ) - WRKOPT = MAX( I, INT( ZWORK(1) ) ) - CALL AB8NXZ( N, II, M, M-II, II, SVLMAX, AF, LDAF, NINFZ, - $ INFZ, KRONL, MU, NU, NKROL, TOL, IWORK, DWORK, - $ ZWORK, -1, INFO ) - WRKOPT = MAX( WRKOPT, INT( ZWORK(1) ) ) - NB = ILAENV( 1, 'ZGERQF', ' ', II, N+II, -1, -1 ) - WRKOPT = MAX( WRKOPT, II + II*NB ) - NB = MIN( 64, ILAENV( 1, 'ZUNMRQ', 'RC', N, N+II, II, -1 ) ) - WRKOPT = MAX( WRKOPT, II + N*NB ) - ELSE IF( LZWORK.LT.I ) THEN - INFO = -29 - END IF - END IF -C - IF ( INFO.NE.0 ) THEN -C -C Error return. -C - CALL XERBLA( 'AB08NZ', -INFO ) - RETURN - ELSE IF( LQUERY ) THEN - ZWORK(1) = WRKOPT - RETURN - END IF -C - DINFZ = 0 - NKROL = 0 - NKROR = 0 -C -C Quick return if possible. -C - IF ( N.EQ.0 ) THEN - IF ( MIN( M, P ).EQ.0 ) THEN - NU = 0 - RANK = 0 - ZWORK(1) = ONE - RETURN - END IF - END IF -C - MM = M - NN = N - PP = P -C - DO 20 I = 1, N - INFZ(I) = 0 - 20 CONTINUE -C - IF ( M.GT.0 ) THEN - DO 40 I = 1, N + 1 - KRONR(I) = 0 - 40 CONTINUE - END IF -C - IF ( P.GT.0 ) THEN - DO 60 I = 1, N + 1 - KRONL(I) = 0 - 60 CONTINUE - END IF -C -C (Note: Comments in the code beginning "CWorkspace:" and -C "RWorkspace:" describe the minimal amount of complex and real -C workspace, respectively, needed at that point in the code, as -C well as the preferred amount for good performance.) -C - WRKOPT = 1 -C -C Construct the compound matrix ( B A ), dimension (N+P)-by-(M+N). -C ( D C ) -C - CALL ZLACPY( 'Full', NN, MM, B, LDB, BF, LDBF ) - IF ( PP.GT.0 ) - $ CALL ZLACPY( 'Full', PP, MM, D, LDD, BF(1+NN,1), LDBF ) - IF ( NN.GT.0 ) THEN - CALL ZLACPY( 'Full', NN, NN, A, LDA, BF(1,1+MM), LDBF ) - IF ( PP.GT.0 ) - $ CALL ZLACPY( 'Full', PP, NN, C, LDC, BF(1+NN,1+MM), LDBF ) - END IF -C -C If required, balance the compound matrix (default MAXRED). -C RWorkspace: need N. -C - IF ( LEQUIL .AND. NN.GT.0 .AND. PP.GT.0 ) THEN - MAXRED = DZERO - CALL TB01IZ( 'A', NN, MM, PP, MAXRED, BF(1,1+MM), LDBF, BF, - $ LDBF, BF(1+NN,1+MM), LDBF, DWORK, INFO ) - END IF -C -C If required, set tolerance. -C - THRESH = SQRT( DBLE( (N + P)*(N + M) ) )*DLAMCH( 'Precision' ) - TOLER = TOL - IF ( TOLER.LT.THRESH ) TOLER = THRESH - SVLMAX = ZLANGE( 'Frobenius', NN+PP, NN+MM, BF, LDBF, DWORK ) -C -C Reduce this system to one with the same invariant zeros and with -C D upper triangular of full row rank MU (the normal rank of the -C original system). -C RWorkspace: need 2*MAX(M,P); -C CWorkspace: need MAX( 1, MIN(P,M) + MAX(3*M-1,N), -C MIN(P,N) + MAX(3*P-1,N+P,N+M) ); -C prefer larger. -C - RO = PP - SIGMA = 0 - NINFZ = 0 - CALL AB8NXZ( NN, MM, PP, RO, SIGMA, SVLMAX, BF, LDBF, NINFZ, INFZ, - $ KRONL, MU, NU, NKROL, TOLER, IWORK, DWORK, ZWORK, - $ LZWORK, INFO ) - WRKOPT = MAX( WRKOPT, INT( ZWORK(1) ) ) - RANK = MU -C -C Pertranspose the system. -C - NUMU = NU + MU - IF ( NUMU.NE.0 ) THEN - MNU = MM + NU - NUMU1 = NUMU + 1 -C - DO 80 I = 1, NUMU - CALL ZCOPY( MNU, BF(I,1), LDBF, AF(1,NUMU1-I), -1 ) - 80 CONTINUE -C - IF ( MU.NE.MM ) THEN -C -C Here MU < MM and MM > 0 (since MM = 0 implies MU = 0 = MM). -C - PP = MM - NN = NU - MM = MU -C -C Reduce the system to one with the same invariant zeros and -C with D square invertible. -C RWorkspace: need 2*M. -C CWorkspace: need MAX( 1, MU + MAX(3*MU-1,N), -C MIN(M,N) + MAX(3*M-1,N+M) ); -C prefer larger. Note that MU <= MIN(M,P). -C - RO = PP - MM - SIGMA = MM - CALL AB8NXZ( NN, MM, PP, RO, SIGMA, SVLMAX, AF, LDAF, NINFZ, - $ INFZ, KRONR, MU, NU, NKROR, TOLER, IWORK, - $ DWORK, ZWORK, LZWORK, INFO ) - WRKOPT = MAX( WRKOPT, INT( ZWORK(1) ) ) - END IF -C - IF ( NU.NE.0 ) THEN -C -C Perform a unitary transformation on the columns of -C ( B A-lambda*I ) -C ( D C ) -C in order to reduce it to -C ( X AF-lambda*BF ) -C ( Y 0 ) -C with Y and BF square invertible. -C - CALL ZLASET( 'Full', NU, MU, ZERO, ZERO, BF, LDBF ) - CALL ZLASET( 'Full', NU, NU, ZERO, ONE, BF(1,MU+1), LDBF ) -C - IF ( RANK.NE.0 ) THEN - NU1 = NU + 1 - I1 = NU + MU -C -C CWorkspace: need 2*MIN(M,P); -C prefer MIN(M,P) + MIN(M,P)*NB. -C - CALL ZTZRZF( MU, I1, AF(NU1,1), LDAF, ZWORK, ZWORK(MU+1), - $ LZWORK-MU, INFO ) - WRKOPT = MAX( WRKOPT, INT( ZWORK(MU+1) ) + MU ) -C -C CWorkspace: need MIN(M,P) + N; -C prefer MIN(M,P) + N*NB. -C - CALL ZUNMRZ( 'Right', 'Conjugate transpose', NU, I1, MU, - $ NU, AF(NU1,1), LDAF, ZWORK, AF, LDAF, - $ ZWORK(MU+1), LZWORK-MU, INFO ) - WRKOPT = MAX( WRKOPT, INT( ZWORK(MU+1) ) + MU ) -C - CALL ZUNMRZ( 'Right', 'Conjugate transpose', NU, I1, MU, - $ NU, AF(NU1,1), LDAF, ZWORK, BF, LDBF, - $ ZWORK(MU+1), LZWORK-MU, INFO ) -C - END IF -C -C Move AF and BF in the first columns. This assumes that -C ZLACPY moves column by column. -C - CALL ZLACPY( 'Full', NU, NU, AF(1,MU+1), LDAF, AF, LDAF ) - IF ( RANK.NE.0 ) - $ CALL ZLACPY( 'Full', NU, NU, BF(1,MU+1), LDBF, BF, LDBF ) -C - END IF - END IF -C -C Set right Kronecker indices (column indices). -C - IF ( NKROR.GT.0 ) THEN - J = 1 -C - DO 120 I = 1, N + 1 -C - DO 100 II = J, J + KRONR(I) - 1 - IWORK(II) = I - 1 - 100 CONTINUE -C - J = J + KRONR(I) - KRONR(I) = 0 - 120 CONTINUE -C - NKROR = J - 1 -C - DO 140 I = 1, NKROR - KRONR(I) = IWORK(I) - 140 CONTINUE -C - END IF -C -C Set left Kronecker indices (row indices). -C - IF ( NKROL.GT.0 ) THEN - J = 1 -C - DO 180 I = 1, N + 1 -C - DO 160 II = J, J + KRONL(I) - 1 - IWORK(II) = I - 1 - 160 CONTINUE -C - J = J + KRONL(I) - KRONL(I) = 0 - 180 CONTINUE -C - NKROL = J - 1 -C - DO 200 I = 1, NKROL - KRONL(I) = IWORK(I) - 200 CONTINUE -C - END IF -C - IF ( N.GT.0 ) THEN - DINFZ = N -C - 220 CONTINUE - IF ( INFZ(DINFZ).EQ.0 ) THEN - DINFZ = DINFZ - 1 - IF ( DINFZ.GT.0 ) - $ GO TO 220 - END IF - END IF -C - ZWORK(1) = WRKOPT - RETURN -C *** Last line of AB08NZ *** - END diff --git a/mex/sources/libslicot/AB09AD.f b/mex/sources/libslicot/AB09AD.f deleted file mode 100644 index 8d04fa633..000000000 --- a/mex/sources/libslicot/AB09AD.f +++ /dev/null @@ -1,363 +0,0 @@ - SUBROUTINE AB09AD( DICO, JOB, EQUIL, ORDSEL, N, M, P, NR, A, LDA, - $ B, LDB, C, LDC, HSV, TOL, IWORK, DWORK, LDWORK, - $ IWARN, INFO ) -C -C SLICOT RELEASE 5.0. -C -C Copyright (c) 2002-2009 NICONET e.V. -C -C This program is free software: you can redistribute it and/or -C modify it under the terms of the GNU General Public License as -C published by the Free Software Foundation, either version 2 of -C the License, or (at your option) any later version. -C -C This program is distributed in the hope that it will be useful, -C but WITHOUT ANY WARRANTY; without even the implied warranty of -C MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the -C GNU General Public License for more details. -C -C You should have received a copy of the GNU General Public License -C along with this program. If not, see -C . -C -C PURPOSE -C -C To compute a reduced order model (Ar,Br,Cr) for a stable original -C state-space representation (A,B,C) by using either the square-root -C or the balancing-free square-root Balance & Truncate (B & T) -C model reduction method. -C -C ARGUMENTS -C -C Mode Parameters -C -C DICO CHARACTER*1 -C Specifies the type of the original system as follows: -C = 'C': continuous-time system; -C = 'D': discrete-time system. -C -C JOB CHARACTER*1 -C Specifies the model reduction approach to be used -C as follows: -C = 'B': use the square-root Balance & Truncate method; -C = 'N': use the balancing-free square-root -C Balance & Truncate method. -C -C EQUIL CHARACTER*1 -C Specifies whether the user wishes to preliminarily -C equilibrate the triplet (A,B,C) as follows: -C = 'S': perform equilibration (scaling); -C = 'N': do not perform equilibration. -C -C ORDSEL CHARACTER*1 -C Specifies the order selection method as follows: -C = 'F': the resulting order NR is fixed; -C = 'A': the resulting order NR is automatically determined -C on basis of the given tolerance TOL. -C -C Input/Output Parameters -C -C N (input) INTEGER -C The order of the original state-space representation, i.e. -C the order of the matrix A. N >= 0. -C -C M (input) INTEGER -C The number of system inputs. M >= 0. -C -C P (input) INTEGER -C The number of system outputs. P >= 0. -C -C NR (input/output) INTEGER -C On entry with ORDSEL = 'F', NR is the desired order of the -C resulting reduced order system. 0 <= NR <= N. -C On exit, if INFO = 0, NR is the order of the resulting -C reduced order model. NR is set as follows: -C if ORDSEL = 'F', NR is equal to MIN(NR,NMIN), where NR -C is the desired order on entry and NMIN is the order of a -C minimal realization of the given system; NMIN is -C determined as the number of Hankel singular values greater -C than N*EPS*HNORM(A,B,C), where EPS is the machine -C precision (see LAPACK Library Routine DLAMCH) and -C HNORM(A,B,C) is the Hankel norm of the system (computed -C in HSV(1)); -C if ORDSEL = 'A', NR is equal to the number of Hankel -C singular values greater than MAX(TOL,N*EPS*HNORM(A,B,C)). -C -C A (input/output) DOUBLE PRECISION array, dimension (LDA,N) -C On entry, the leading N-by-N part of this array must -C contain the state dynamics matrix A. -C On exit, if INFO = 0, the leading NR-by-NR part of this -C array contains the state dynamics matrix Ar of the reduced -C order system. -C -C LDA INTEGER -C The leading dimension of array A. LDA >= MAX(1,N). -C -C B (input/output) DOUBLE PRECISION array, dimension (LDB,M) -C On entry, the leading N-by-M part of this array must -C contain the original input/state matrix B. -C On exit, if INFO = 0, the leading NR-by-M part of this -C array contains the input/state matrix Br of the reduced -C order system. -C -C LDB INTEGER -C The leading dimension of array B. LDB >= MAX(1,N). -C -C C (input/output) DOUBLE PRECISION array, dimension (LDC,N) -C On entry, the leading P-by-N part of this array must -C contain the original state/output matrix C. -C On exit, if INFO = 0, the leading P-by-NR part of this -C array contains the state/output matrix Cr of the reduced -C order system. -C -C LDC INTEGER -C The leading dimension of array C. LDC >= MAX(1,P). -C -C HSV (output) DOUBLE PRECISION array, dimension (N) -C If INFO = 0, it contains the Hankel singular values of -C the original system ordered decreasingly. HSV(1) is the -C Hankel norm of the system. -C -C Tolerances -C -C TOL DOUBLE PRECISION -C If ORDSEL = 'A', TOL contains the tolerance for -C determining the order of reduced system. -C For model reduction, the recommended value is -C TOL = c*HNORM(A,B,C), where c is a constant in the -C interval [0.00001,0.001], and HNORM(A,B,C) is the -C Hankel-norm of the given system (computed in HSV(1)). -C For computing a minimal realization, the recommended -C value is TOL = N*EPS*HNORM(A,B,C), where EPS is the -C machine precision (see LAPACK Library Routine DLAMCH). -C This value is used by default if TOL <= 0 on entry. -C If ORDSEL = 'F', the value of TOL is ignored. -C -C Workspace -C -C IWORK INTEGER array, dimension (LIWORK) -C LIWORK = 0, if JOB = 'B'; -C LIWORK = N, if JOB = 'N'. -C -C DWORK DOUBLE PRECISION array, dimension (LDWORK) -C On exit, if INFO = 0, DWORK(1) returns the optimal value -C of LDWORK. -C -C LDWORK INTEGER -C The length of the array DWORK. -C LDWORK >= MAX(1,N*(2*N+MAX(N,M,P)+5)+N*(N+1)/2). -C For optimum performance LDWORK should be larger. -C -C Warning Indicator -C -C IWARN INTEGER -C = 0: no warning; -C = 1: with ORDSEL = 'F', the selected order NR is greater -C than the order of a minimal realization of the -C given system. In this case, the resulting NR is -C set automatically to a value corresponding to the -C order of a minimal realization of the system. -C -C Error Indicator -C -C INFO INTEGER -C = 0: successful exit; -C < 0: if INFO = -i, the i-th argument had an illegal -C value; -C = 1: the reduction of A to the real Schur form failed; -C = 2: the state matrix A is not stable (if DICO = 'C') -C or not convergent (if DICO = 'D'); -C = 3: the computation of Hankel singular values failed. -C -C METHOD -C -C Let be the stable linear system -C -C d[x(t)] = Ax(t) + Bu(t) -C y(t) = Cx(t) (1) -C -C where d[x(t)] is dx(t)/dt for a continuous-time system and x(t+1) -C for a discrete-time system. The subroutine AB09AD determines for -C the given system (1), the matrices of a reduced order system -C -C d[z(t)] = Ar*z(t) + Br*u(t) -C yr(t) = Cr*z(t) (2) -C -C such that -C -C HSV(NR) <= INFNORM(G-Gr) <= 2*[HSV(NR+1) + ... + HSV(N)], -C -C where G and Gr are transfer-function matrices of the systems -C (A,B,C) and (Ar,Br,Cr), respectively, and INFNORM(G) is the -C infinity-norm of G. -C -C If JOB = 'B', the square-root Balance & Truncate method of [1] -C is used and, for DICO = 'C', the resulting model is balanced. -C By setting TOL <= 0, the routine can be used to compute balanced -C minimal state-space realizations of stable systems. -C -C If JOB = 'N', the balancing-free square-root version of the -C Balance & Truncate method [2] is used. -C By setting TOL <= 0, the routine can be used to compute minimal -C state-space realizations of stable systems. -C -C REFERENCES -C -C [1] Tombs M.S. and Postlethwaite I. -C Truncated balanced realization of stable, non-minimal -C state-space systems. -C Int. J. Control, Vol. 46, pp. 1319-1330, 1987. -C -C [2] Varga A. -C Efficient minimal realization procedure based on balancing. -C Proc. of IMACS/IFAC Symp. MCTS, Lille, France, May 1991, -C A. El Moudui, P. Borne, S. G. Tzafestas (Eds.), -C Vol. 2, pp. 42-46. -C -C NUMERICAL ASPECTS -C -C The implemented methods rely on accuracy enhancing square-root or -C balancing-free square-root techniques. -C 3 -C The algorithms require less than 30N floating point operations. -C -C CONTRIBUTOR -C -C C. Oara and A. Varga, German Aerospace Center, -C DLR Oberpfaffenhofen, March 1998. -C Based on the RASP routines SRBT and SRBFT. -C -C REVISIONS -C -C May 2, 1998. -C November 11, 1998, V. Sima, Research Institute for Informatics, -C Bucharest. -C -C KEYWORDS -C -C Balancing, minimal state-space representation, model reduction, -C multivariable system, state-space model. -C -C ****************************************************************** -C -C .. Parameters .. - DOUBLE PRECISION ONE, C100 - PARAMETER ( ONE = 1.0D0, C100 = 100.0D0 ) -C .. Scalar Arguments .. - CHARACTER DICO, EQUIL, JOB, ORDSEL - INTEGER INFO, IWARN, LDA, LDB, LDC, LDWORK, M, N, NR, P - DOUBLE PRECISION TOL -C .. Array Arguments .. - INTEGER IWORK(*) - DOUBLE PRECISION A(LDA,*), B(LDB,*), C(LDC,*), DWORK(*), HSV(*) -C .. Local Scalars .. - LOGICAL FIXORD - INTEGER IERR, KI, KR, KT, KTI, KW, NN - DOUBLE PRECISION MAXRED, WRKOPT -C .. External Functions .. - LOGICAL LSAME - EXTERNAL LSAME -C .. External Subroutines .. - EXTERNAL AB09AX, TB01ID, TB01WD, XERBLA -C .. Intrinsic Functions .. - INTRINSIC DBLE, MAX, MIN -C .. Executable Statements .. -C - INFO = 0 - IWARN = 0 - FIXORD = LSAME( ORDSEL, 'F' ) -C -C Test the input scalar arguments. -C - IF( .NOT. ( LSAME( DICO, 'C' ) .OR. LSAME( DICO, 'D' ) ) ) THEN - INFO = -1 - ELSE IF( .NOT. ( LSAME( JOB, 'B' ) .OR. LSAME( JOB, 'N' ) ) ) THEN - INFO = -2 - ELSE IF( .NOT. ( LSAME( EQUIL, 'S' ) .OR. - $ LSAME( EQUIL, 'N' ) ) ) THEN - INFO = -3 - ELSE IF( .NOT. ( FIXORD .OR. LSAME( ORDSEL, 'A' ) ) ) THEN - INFO = -4 - ELSE IF( N.LT.0 ) THEN - INFO = -5 - ELSE IF( M.LT.0 ) THEN - INFO = -6 - ELSE IF( P.LT.0 ) THEN - INFO = -7 - ELSE IF( FIXORD .AND. ( NR.LT.0 .OR. NR.GT.N ) ) THEN - INFO = -8 - ELSE IF( LDA.LT.MAX( 1, N ) ) THEN - INFO = -10 - ELSE IF( LDB.LT.MAX( 1, N ) ) THEN - INFO = -12 - ELSE IF( LDC.LT.MAX( 1, P ) ) THEN - INFO = -14 - ELSE IF( LDWORK.LT.MAX( 1, N*( 2*N + MAX( N, M, P ) + 5 ) + - $ ( N*( N + 1 ) )/2 ) ) THEN - INFO = -19 - END IF -C - IF( INFO.NE.0 ) THEN -C -C Error return. -C - CALL XERBLA( 'AB09AD', -INFO ) - RETURN - END IF -C -C Quick return if possible. -C - IF( MIN( N, M, P ).EQ.0 .OR. ( FIXORD .AND. NR.EQ.0 ) ) THEN - NR = 0 - DWORK(1) = ONE - RETURN - END IF -C -C Allocate working storage. -C - NN = N*N - KT = 1 - KR = KT + NN - KI = KR + N - KW = KI + N -C - IF( LSAME( EQUIL, 'S' ) ) THEN -C -C Scale simultaneously the matrices A, B and C: -C A <- inv(D)*A*D, B <- inv(D)*B and C <- C*D, where D is a -C diagonal matrix. -C - MAXRED = C100 - CALL TB01ID( 'A', N, M, P, MAXRED, A, LDA, B, LDB, C, LDC, - $ DWORK, INFO ) - END IF -C -C Reduce A to the real Schur form using an orthogonal similarity -C transformation A <- T'*A*T and apply the transformation to -C B and C: B <- T'*B and C <- C*T. -C - CALL TB01WD( N, M, P, A, LDA, B, LDB, C, LDC, DWORK(KT), N, - $ DWORK(KR), DWORK(KI), DWORK(KW), LDWORK-KW+1, IERR ) - IF( IERR.NE.0 ) THEN - INFO = 1 - RETURN - END IF -C - WRKOPT = DWORK(KW) + DBLE( KW-1 ) - KTI = KT + NN - KW = KTI + NN -C - CALL AB09AX( DICO, JOB, ORDSEL, N, M, P, NR, A, LDA, B, LDB, C, - $ LDC, HSV, DWORK(KT), N, DWORK(KTI), N, TOL, IWORK, - $ DWORK(KW), LDWORK-KW+1, IWARN, IERR ) -C - IF( IERR.NE.0 ) THEN - INFO = IERR + 1 - RETURN - END IF -C - DWORK(1) = MAX( WRKOPT, DWORK(KW) + DBLE( KW-1 ) ) -C - RETURN -C *** Last line of AB09AD *** - END diff --git a/mex/sources/libslicot/AB09AX.f b/mex/sources/libslicot/AB09AX.f deleted file mode 100644 index 6d333337a..000000000 --- a/mex/sources/libslicot/AB09AX.f +++ /dev/null @@ -1,564 +0,0 @@ - SUBROUTINE AB09AX( DICO, JOB, ORDSEL, N, M, P, NR, A, LDA, B, LDB, - $ C, LDC, HSV, T, LDT, TI, LDTI, TOL, IWORK, - $ DWORK, LDWORK, IWARN, INFO ) -C -C SLICOT RELEASE 5.0. -C -C Copyright (c) 2002-2009 NICONET e.V. -C -C This program is free software: you can redistribute it and/or -C modify it under the terms of the GNU General Public License as -C published by the Free Software Foundation, either version 2 of -C the License, or (at your option) any later version. -C -C This program is distributed in the hope that it will be useful, -C but WITHOUT ANY WARRANTY; without even the implied warranty of -C MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the -C GNU General Public License for more details. -C -C You should have received a copy of the GNU General Public License -C along with this program. If not, see -C . -C -C PURPOSE -C -C To compute a reduced order model (Ar,Br,Cr) for a stable original -C state-space representation (A,B,C) by using either the square-root -C or the balancing-free square-root Balance & Truncate model -C reduction method. The state dynamics matrix A of the original -C system is an upper quasi-triangular matrix in real Schur canonical -C form. The matrices of the reduced order system are computed using -C the truncation formulas: -C -C Ar = TI * A * T , Br = TI * B , Cr = C * T . -C -C ARGUMENTS -C -C Mode Parameters -C -C DICO CHARACTER*1 -C Specifies the type of the original system as follows: -C = 'C': continuous-time system; -C = 'D': discrete-time system. -C -C JOB CHARACTER*1 -C Specifies the model reduction approach to be used -C as follows: -C = 'B': use the square-root Balance & Truncate method; -C = 'N': use the balancing-free square-root -C Balance & Truncate method. -C -C ORDSEL CHARACTER*1 -C Specifies the order selection method as follows: -C = 'F': the resulting order NR is fixed; -C = 'A': the resulting order NR is automatically determined -C on basis of the given tolerance TOL. -C -C Input/Output Parameters -C -C N (input) INTEGER -C The order of the original state-space representation, i.e. -C the order of the matrix A. N >= 0. -C -C M (input) INTEGER -C The number of system inputs. M >= 0. -C -C P (input) INTEGER -C The number of system outputs. P >= 0. -C -C NR (input/output) INTEGER -C On entry with ORDSEL = 'F', NR is the desired order of the -C resulting reduced order system. 0 <= NR <= N. -C On exit, if INFO = 0, NR is the order of the resulting -C reduced order model. NR is set as follows: -C if ORDSEL = 'F', NR is equal to MIN(NR,NMIN), where NR -C is the desired order on entry and NMIN is the order of a -C minimal realization of the given system; NMIN is -C determined as the number of Hankel singular values greater -C than N*EPS*HNORM(A,B,C), where EPS is the machine -C precision (see LAPACK Library Routine DLAMCH) and -C HNORM(A,B,C) is the Hankel norm of the system (computed -C in HSV(1)); -C if ORDSEL = 'A', NR is equal to the number of Hankel -C singular values greater than MAX(TOL,N*EPS*HNORM(A,B,C)). -C -C A (input/output) DOUBLE PRECISION array, dimension (LDA,N) -C On entry, the leading N-by-N part of this array must -C contain the state dynamics matrix A in a real Schur -C canonical form. -C On exit, if INFO = 0, the leading NR-by-NR part of this -C array contains the state dynamics matrix Ar of the -C reduced order system. -C -C LDA INTEGER -C The leading dimension of array A. LDA >= MAX(1,N). -C -C B (input/output) DOUBLE PRECISION array, dimension (LDB,M) -C On entry, the leading N-by-M part of this array must -C contain the original input/state matrix B. -C On exit, if INFO = 0, the leading NR-by-M part of this -C array contains the input/state matrix Br of the reduced -C order system. -C -C LDB INTEGER -C The leading dimension of array B. LDB >= MAX(1,N). -C -C C (input/output) DOUBLE PRECISION array, dimension (LDC,N) -C On entry, the leading P-by-N part of this array must -C contain the original state/output matrix C. -C On exit, if INFO = 0, the leading P-by-NR part of this -C array contains the state/output matrix Cr of the reduced -C order system. -C -C LDC INTEGER -C The leading dimension of array C. LDC >= MAX(1,P). -C -C HSV (output) DOUBLE PRECISION array, dimension (N) -C If INFO = 0, it contains the Hankel singular values of -C the original system ordered decreasingly. HSV(1) is the -C Hankel norm of the system. -C -C T (output) DOUBLE PRECISION array, dimension (LDT,N) -C If INFO = 0 and NR > 0, the leading N-by-NR part of this -C array contains the right truncation matrix T. -C -C LDT INTEGER -C The leading dimension of array T. LDT >= MAX(1,N). -C -C TI (output) DOUBLE PRECISION array, dimension (LDTI,N) -C If INFO = 0 and NR > 0, the leading NR-by-N part of this -C array contains the left truncation matrix TI. -C -C LDTI INTEGER -C The leading dimension of array TI. LDTI >= MAX(1,N). -C -C Tolerances -C -C TOL DOUBLE PRECISION -C If ORDSEL = 'A', TOL contains the tolerance for -C determining the order of reduced system. -C For model reduction, the recommended value is -C TOL = c*HNORM(A,B,C), where c is a constant in the -C interval [0.00001,0.001], and HNORM(A,B,C) is the -C Hankel-norm of the given system (computed in HSV(1)). -C For computing a minimal realization, the recommended -C value is TOL = N*EPS*HNORM(A,B,C), where EPS is the -C machine precision (see LAPACK Library Routine DLAMCH). -C This value is used by default if TOL <= 0 on entry. -C If ORDSEL = 'F', the value of TOL is ignored. -C -C Workspace -C -C IWORK INTEGER array, dimension (LIWORK) -C LIWORK = 0, if JOB = 'B', or -C LIWORK = N, if JOB = 'N'. -C -C DWORK DOUBLE PRECISION array, dimension (LDWORK) -C On exit, if INFO = 0, DWORK(1) returns the optimal value -C of LDWORK. -C -C LDWORK INTEGER -C The length of the array DWORK. -C LDWORK >= MAX(1,N*(MAX(N,M,P)+5) + N*(N+1)/2). -C For optimum performance LDWORK should be larger. -C -C Warning Indicator -C -C IWARN INTEGER -C = 0: no warning; -C = 1: with ORDSEL = 'F', the selected order NR is greater -C than the order of a minimal realization of the -C given system. In this case, the resulting NR is -C set automatically to a value corresponding to the -C order of a minimal realization of the system. -C -C Error Indicator -C -C INFO INTEGER -C = 0: successful exit; -C < 0: if INFO = -i, the i-th argument had an illegal -C value; -C = 1: the state matrix A is not stable (if DICO = 'C') -C or not convergent (if DICO = 'D'); -C = 2: the computation of Hankel singular values failed. -C -C METHOD -C -C Let be the stable linear system -C -C d[x(t)] = Ax(t) + Bu(t) -C y(t) = Cx(t) (1) -C -C where d[x(t)] is dx(t)/dt for a continuous-time system and x(t+1) -C for a discrete-time system. The subroutine AB09AX determines for -C the given system (1), the matrices of a reduced NR order system -C -C d[z(t)] = Ar*z(t) + Br*u(t) -C yr(t) = Cr*z(t) (2) -C -C such that -C -C HSV(NR) <= INFNORM(G-Gr) <= 2*[HSV(NR+1) + ... + HSV(N)], -C -C where G and Gr are transfer-function matrices of the systems -C (A,B,C) and (Ar,Br,Cr), respectively, and INFNORM(G) is the -C infinity-norm of G. -C -C If JOB = 'B', the square-root Balance & Truncate method of [1] -C is used and, for DICO = 'C', the resulting model is balanced. -C By setting TOL <= 0, the routine can be used to compute balanced -C minimal state-space realizations of stable systems. -C -C If JOB = 'N', the balancing-free square-root version of the -C Balance & Truncate method [2] is used. -C By setting TOL <= 0, the routine can be used to compute minimal -C state-space realizations of stable systems. -C -C REFERENCES -C -C [1] Tombs M.S. and Postlethwaite I. -C Truncated balanced realization of stable, non-minimal -C state-space systems. -C Int. J. Control, Vol. 46, pp. 1319-1330, 1987. -C -C [2] Varga A. -C Efficient minimal realization procedure based on balancing. -C Proc. of IMACS/IFAC Symp. MCTS, Lille, France, May 1991, -C A. El Moudui, P. Borne, S. G. Tzafestas (Eds.), -C Vol. 2, pp. 42-46. -C -C NUMERICAL ASPECTS -C -C The implemented methods rely on accuracy enhancing square-root or -C balancing-free square-root techniques. -C 3 -C The algorithms require less than 30N floating point operations. -C -C CONTRIBUTOR -C -C A. Varga, German Aerospace Center, -C DLR Oberpfaffenhofen, March 1998. -C Based on the RASP routines SRBT1 and SRBFT1. -C -C REVISIONS -C -C May 2, 1998. -C November 11, 1998, V. Sima, Research Institute for Informatics, -C Bucharest. -C December 1998, V. Sima, Katholieke Univ. Leuven, Leuven. -C February 14, 1999, A. Varga, German Aerospace Center. -C February 22, 1999, V. Sima, Research Institute for Informatics. -C February 27, 2000, V. Sima, Research Institute for Informatics. -C -C KEYWORDS -C -C Balancing, minimal state-space representation, model reduction, -C multivariable system, state-space model. -C -C ****************************************************************** -C -C .. Parameters .. - DOUBLE PRECISION ONE, ZERO - PARAMETER ( ONE = 1.0D0, ZERO = 0.0D0 ) -C .. Scalar Arguments .. - CHARACTER DICO, JOB, ORDSEL - INTEGER INFO, IWARN, LDA, LDB, LDC, LDT, LDTI, LDWORK, - $ M, N, NR, P - DOUBLE PRECISION TOL -C .. Array Arguments .. - INTEGER IWORK(*) - DOUBLE PRECISION A(LDA,*), B(LDB,*), C(LDC,*), DWORK(*), HSV(*), - $ T(LDT,*), TI(LDTI,*) -C .. Local Scalars .. - LOGICAL BAL, DISCR, FIXORD, PACKED - INTEGER IERR, IJ, J, K, KTAU, KU, KV, KW, LDW, WRKOPT - DOUBLE PRECISION ATOL, RTOL, SCALEC, SCALEO, TEMP -C .. External Functions .. - LOGICAL LSAME - DOUBLE PRECISION DLAMCH - EXTERNAL DLAMCH, LSAME -C .. External Subroutines .. - EXTERNAL DGEMM, DGEMV, DGEQRF, DGETRF, DGETRS, DLACPY, - $ DORGQR, DSCAL, DTPMV, DTRMM, DTRMV, MA02AD, - $ MA02DD, MB03UD, SB03OU, XERBLA -C .. Intrinsic Functions .. - INTRINSIC DBLE, INT, MAX, MIN, SQRT -C .. Executable Statements .. -C - INFO = 0 - IWARN = 0 - DISCR = LSAME( DICO, 'D' ) - BAL = LSAME( JOB, 'B' ) - FIXORD = LSAME( ORDSEL, 'F' ) -C -C Test the input scalar arguments. -C - IF( .NOT. ( LSAME( DICO, 'C' ) .OR. DISCR ) ) THEN - INFO = -1 - ELSE IF( .NOT. ( BAL .OR. LSAME( JOB, 'N') ) ) THEN - INFO = -2 - ELSE IF( .NOT. ( FIXORD .OR. LSAME( ORDSEL, 'A' ) ) ) THEN - INFO = -3 - ELSE IF( N.LT.0 ) THEN - INFO = -4 - ELSE IF( M.LT.0 ) THEN - INFO = -5 - ELSE IF( P.LT.0 ) THEN - INFO = -6 - ELSE IF( FIXORD .AND. ( NR.LT.0 .OR. NR.GT.N ) ) THEN - INFO = -7 - ELSE IF( LDA.LT.MAX( 1, N ) ) THEN - INFO = -9 - ELSE IF( LDB.LT.MAX( 1, N ) ) THEN - INFO = -11 - ELSE IF( LDC.LT.MAX( 1, P ) ) THEN - INFO = -13 - ELSE IF( LDT.LT.MAX( 1, N ) ) THEN - INFO = -16 - ELSE IF( LDTI.LT.MAX( 1, N ) ) THEN - INFO = -18 - ELSE IF( LDWORK.LT.MAX( 1, N*( MAX( N, M, P ) + 5 ) + - $ ( N*( N + 1 ) )/2 ) ) THEN - INFO = -22 - END IF -C - IF( INFO.NE.0 ) THEN -C -C Error return. -C - CALL XERBLA( 'AB09AX', -INFO ) - RETURN - END IF -C -C Quick return if possible. -C - IF( MIN( N, M, P ).EQ.0 .OR. ( FIXORD .AND. NR.EQ.0 ) ) THEN - NR = 0 - DWORK(1) = ONE - RETURN - END IF -C - RTOL = DBLE( N )*DLAMCH( 'Epsilon' ) -C -C Allocate N*MAX(N,M,P) and N working storage for the matrices U -C and TAU, respectively. -C - KU = 1 - KTAU = KU + N*MAX( N, M, P ) - KW = KTAU + N - LDW = LDWORK - KW + 1 -C -C Copy B in U. -C - CALL DLACPY( 'Full', N, M, B, LDB, DWORK(KU), N ) -C -C If DISCR = .FALSE., solve for Su the Lyapunov equation -C 2 -C A*(Su*Su') + (Su*Su')*A' + scalec *B*B' = 0 . -C -C If DISCR = .TRUE., solve for Su the Lyapunov equation -C 2 -C A*(Su*Su')*A' + scalec *B*B' = Su*Su' . -C -C Workspace: need N*(MAX(N,M,P) + 5); -C prefer larger. -C - CALL SB03OU( DISCR, .TRUE., N, M, A, LDA, DWORK(KU), N, - $ DWORK(KTAU), TI, LDTI, SCALEC, DWORK(KW), LDW, IERR ) - IF( IERR.NE.0 ) THEN - INFO = 1 - RETURN - ENDIF - WRKOPT = INT( DWORK(KW) ) + KW - 1 -C -C Copy C in U. -C - CALL DLACPY( 'Full', P, N, C, LDC, DWORK(KU), P ) -C -C If DISCR = .FALSE., solve for Ru the Lyapunov equation -C 2 -C A'*(Ru'*Ru) + (Ru'*Ru)*A + scaleo * C'*C = 0 . -C -C If DISCR = .TRUE., solve for Ru the Lyapunov equation -C 2 -C A'*(Ru'*Ru)*A + scaleo * C'*C = Ru'*Ru . -C -C Workspace: need N*(MAX(N,M,P) + 5); -C prefer larger. -C - CALL SB03OU( DISCR, .FALSE., N, P, A, LDA, DWORK(KU), P, - $ DWORK(KTAU), T, LDT, SCALEO, DWORK(KW), LDW, IERR ) - WRKOPT = MAX( WRKOPT, INT( DWORK(KW) ) + KW - 1 ) -C -C Allocate N*(N+1)/2 (or, if possible, N*N) working storage for the -C matrix V, a packed (or unpacked) copy of Su, and save Su in V. -C (The locations for TAU are reused here.) -C - KV = KTAU - IF ( LDWORK-KV+1.LT.N*( N + 5 ) ) THEN - PACKED = .TRUE. - CALL MA02DD( 'Pack', 'Upper', N, TI, LDTI, DWORK(KV) ) - KW = KV + ( N*( N + 1 ) )/2 - ELSE - PACKED = .FALSE. - CALL DLACPY( 'Upper', N, N, TI, LDTI, DWORK(KV), N ) - KW = KV + N*N - END IF -C | x x | -C Compute Ru*Su in the form | 0 x | in TI. -C - DO 10 J = 1, N - CALL DTRMV( 'Upper', 'NoTranspose', 'NonUnit', J, T, LDT, - $ TI(1,J), 1 ) - 10 CONTINUE -C -C Compute the singular value decomposition Ru*Su = V*S*UT -C of the upper triangular matrix Ru*Su, with UT in TI and V in U. -C -C Workspace: need N*MAX(N,M,P) + N*(N+1)/2 + 5*N; -C prefer larger. -C - CALL MB03UD( 'Vectors', 'Vectors', N, TI, LDTI, DWORK(KU), N, HSV, - $ DWORK(KW), LDWORK-KW+1, IERR ) - IF( IERR.NE.0 ) THEN - INFO = 2 - RETURN - ENDIF - WRKOPT = MAX( WRKOPT, INT( DWORK(KW) ) + KW - 1 ) -C -C Scale singular values. -C - CALL DSCAL( N, ONE / SCALEC / SCALEO, HSV, 1 ) -C -C Partition S, U and V conformally as: -C -C S = diag(S1,S2), U = [U1,U2] (U' in TI) and V = [V1,V2] (in U). -C -C Compute the order of reduced system, as the order of S1. -C - ATOL = RTOL*HSV(1) - IF( FIXORD ) THEN - IF( NR.GT.0 ) THEN - IF( HSV(NR).LE.ATOL ) THEN - NR = 0 - IWARN = 1 - FIXORD = .FALSE. - ENDIF - ENDIF - ELSE - ATOL = MAX( TOL, ATOL ) - NR = 0 - ENDIF - IF( .NOT.FIXORD ) THEN - DO 20 J = 1, N - IF( HSV(J).LE.ATOL ) GO TO 30 - NR = NR + 1 - 20 CONTINUE - 30 CONTINUE - ENDIF -C - IF( NR.EQ.0 ) THEN - DWORK(1) = WRKOPT - RETURN - END IF -C -C Compute the truncation matrices. -C -C Compute TI' = Ru'*V1 in U. -C - CALL DTRMM( 'Left', 'Upper', 'Transpose', 'NonUnit', N, NR, ONE, - $ T, LDT, DWORK(KU), N ) -C -C Compute T = Su*U1 (with Su packed, if not enough workspace). -C - CALL MA02AD( 'Full', NR, N, TI, LDTI, T, LDT ) - IF ( PACKED ) THEN - DO 40 J = 1, NR - CALL DTPMV( 'Upper', 'NoTranspose', 'NonUnit', N, DWORK(KV), - $ T(1,J), 1 ) - 40 CONTINUE - ELSE - CALL DTRMM( 'Left', 'Upper', 'NoTranspose', 'NonUnit', N, NR, - $ ONE, DWORK(KV), N, T, LDT ) - END IF -C - IF( BAL ) THEN - IJ = KU -C -C Square-Root B & T method. -C -C Compute the truncation matrices for balancing -C -1/2 -1/2 -C T*S1 and TI'*S1 -C - DO 50 J = 1, NR - TEMP = ONE/SQRT( HSV(J) ) - CALL DSCAL( N, TEMP, T(1,J), 1 ) - CALL DSCAL( N, TEMP, DWORK(IJ), 1 ) - IJ = IJ + N - 50 CONTINUE - ELSE -C -C Balancing-Free B & T method. -C -C Compute orthogonal bases for the images of matrices T and TI'. -C -C Workspace: need N*MAX(N,M,P) + 2*NR; -C prefer N*MAX(N,M,P) + NR*(NB+1) -C (NB determined by ILAENV for DGEQRF). -C - KW = KTAU + NR - LDW = LDWORK - KW + 1 - CALL DGEQRF( N, NR, T, LDT, DWORK(KTAU), DWORK(KW), LDW, IERR ) - CALL DORGQR( N, NR, NR, T, LDT, DWORK(KTAU), DWORK(KW), LDW, - $ IERR ) - CALL DGEQRF( N, NR, DWORK(KU), N, DWORK(KTAU), DWORK(KW), LDW, - $ IERR ) - WRKOPT = MAX( WRKOPT, INT( DWORK(KW) ) + KW - 1 ) - CALL DORGQR( N, NR, NR, DWORK(KU), N, DWORK(KTAU), DWORK(KW), - $ LDW, IERR ) - WRKOPT = MAX( WRKOPT, INT( DWORK(KW) ) + KW - 1 ) - END IF -C -C Transpose TI' to obtain TI. -C - CALL MA02AD( 'Full', N, NR, DWORK(KU), N, TI, LDTI ) -C - IF( .NOT.BAL ) THEN -C -1 -C Compute (TI*T) *TI in TI. -C - CALL DGEMM( 'NoTranspose', 'NoTranspose', NR, NR, N, ONE, TI, - $ LDTI, T, LDT, ZERO, DWORK(KU), N ) - CALL DGETRF( NR, NR, DWORK(KU), N, IWORK, IERR ) - CALL DGETRS( 'NoTranspose', NR, N, DWORK(KU), N, IWORK, TI, - $ LDTI, IERR ) - END IF -C -C Compute TI*A*T (A is in RSF). -C - IJ = KU - DO 60 J = 1, N - K = MIN( J+1, N ) - CALL DGEMV( 'NoTranspose', NR, K, ONE, TI, LDTI, A(1,J), 1, - $ ZERO, DWORK(IJ), 1 ) - IJ = IJ + N - 60 CONTINUE - CALL DGEMM( 'NoTranspose', 'NoTranspose', NR, NR, N, ONE, - $ DWORK(KU), N, T, LDT, ZERO, A, LDA ) -C -C Compute TI*B and C*T. -C - CALL DLACPY( 'Full', N, M, B, LDB, DWORK(KU), N ) - CALL DGEMM( 'NoTranspose', 'NoTranspose', NR, M, N, ONE, TI, LDTI, - $ DWORK(KU), N, ZERO, B, LDB ) -C - CALL DLACPY( 'Full', P, N, C, LDC, DWORK(KU), P ) - CALL DGEMM( 'NoTranspose', 'NoTranspose', P, NR, N, ONE, - $ DWORK(KU), P, T, LDT, ZERO, C, LDC ) -C - DWORK(1) = WRKOPT -C - RETURN -C *** Last line of AB09AX *** - END diff --git a/mex/sources/libslicot/AB09BD.f b/mex/sources/libslicot/AB09BD.f deleted file mode 100644 index 0aa01b394..000000000 --- a/mex/sources/libslicot/AB09BD.f +++ /dev/null @@ -1,385 +0,0 @@ - SUBROUTINE AB09BD( DICO, JOB, EQUIL, ORDSEL, N, M, P, NR, A, LDA, - $ B, LDB, C, LDC, D, LDD, HSV, TOL1, TOL2, IWORK, - $ DWORK, LDWORK, IWARN, INFO ) -C -C SLICOT RELEASE 5.0. -C -C Copyright (c) 2002-2009 NICONET e.V. -C -C This program is free software: you can redistribute it and/or -C modify it under the terms of the GNU General Public License as -C published by the Free Software Foundation, either version 2 of -C the License, or (at your option) any later version. -C -C This program is distributed in the hope that it will be useful, -C but WITHOUT ANY WARRANTY; without even the implied warranty of -C MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the -C GNU General Public License for more details. -C -C You should have received a copy of the GNU General Public License -C along with this program. If not, see -C . -C -C PURPOSE -C -C To compute a reduced order model (Ar,Br,Cr,Dr) for a stable -C original state-space representation (A,B,C,D) by using either the -C square-root or the balancing-free square-root Singular -C Perturbation Approximation (SPA) model reduction method. -C -C ARGUMENTS -C -C Mode Parameters -C -C DICO CHARACTER*1 -C Specifies the type of the original system as follows: -C = 'C': continuous-time system; -C = 'D': discrete-time system. -C -C JOB CHARACTER*1 -C Specifies the model reduction approach to be used -C as follows: -C = 'B': use the square-root SPA method; -C = 'N': use the balancing-free square-root SPA method. -C -C EQUIL CHARACTER*1 -C Specifies whether the user wishes to preliminarily -C equilibrate the triplet (A,B,C) as follows: -C = 'S': perform equilibration (scaling); -C = 'N': do not perform equilibration. -C -C ORDSEL CHARACTER*1 -C Specifies the order selection method as follows: -C = 'F': the resulting order NR is fixed; -C = 'A': the resulting order NR is automatically determined -C on basis of the given tolerance TOL1. -C -C Input/Output Parameters -C -C N (input) INTEGER -C The order of the original state-space representation, i.e. -C the order of the matrix A. N >= 0. -C -C M (input) INTEGER -C The number of system inputs. M >= 0. -C -C P (input) INTEGER -C The number of system outputs. P >= 0. -C -C NR (input/output) INTEGER -C On entry with ORDSEL = 'F', NR is the desired order of -C the resulting reduced order system. 0 <= NR <= N. -C On exit, if INFO = 0, NR is the order of the resulting -C reduced order model. NR is set as follows: -C if ORDSEL = 'F', NR is equal to MIN(NR,NMIN), where NR -C is the desired order on entry and NMIN is the order of a -C minimal realization of the given system; NMIN is -C determined as the number of Hankel singular values greater -C than N*EPS*HNORM(A,B,C), where EPS is the machine -C precision (see LAPACK Library Routine DLAMCH) and -C HNORM(A,B,C) is the Hankel norm of the system (computed -C in HSV(1)); -C if ORDSEL = 'A', NR is equal to the number of Hankel -C singular values greater than MAX(TOL1,N*EPS*HNORM(A,B,C)). -C -C A (input/output) DOUBLE PRECISION array, dimension (LDA,N) -C On entry, the leading N-by-N part of this array must -C contain the state dynamics matrix A. -C On exit, if INFO = 0, the leading NR-by-NR part of this -C array contains the state dynamics matrix Ar of the -C reduced order system. -C -C LDA INTEGER -C The leading dimension of array A. LDA >= MAX(1,N). -C -C B (input/output) DOUBLE PRECISION array, dimension (LDB,M) -C On entry, the leading N-by-M part of this array must -C contain the original input/state matrix B. -C On exit, if INFO = 0, the leading NR-by-M part of this -C array contains the input/state matrix Br of the reduced -C order system. -C -C LDB INTEGER -C The leading dimension of array B. LDB >= MAX(1,N). -C -C C (input/output) DOUBLE PRECISION array, dimension (LDC,N) -C On entry, the leading P-by-N part of this array must -C contain the original state/output matrix C. -C On exit, if INFO = 0, the leading P-by-NR part of this -C array contains the state/output matrix Cr of the reduced -C order system. -C -C LDC INTEGER -C The leading dimension of array C. LDC >= MAX(1,P). -C -C D (input/output) DOUBLE PRECISION array, dimension (LDD,M) -C On entry, the leading P-by-M part of this array must -C contain the original input/output matrix D. -C On exit, if INFO = 0, the leading P-by-M part of this -C array contains the input/output matrix Dr of the reduced -C order system. -C -C LDD INTEGER -C The leading dimension of array D. LDD >= MAX(1,P). -C -C HSV (output) DOUBLE PRECISION array, dimension (N) -C If INFO = 0, it contains the Hankel singular values of -C the original system ordered decreasingly. HSV(1) is the -C Hankel norm of the system. -C -C Tolerances -C -C TOL1 DOUBLE PRECISION -C If ORDSEL = 'A', TOL1 contains the tolerance for -C determining the order of reduced system. -C For model reduction, the recommended value is -C TOL1 = c*HNORM(A,B,C), where c is a constant in the -C interval [0.00001,0.001], and HNORM(A,B,C) is the -C Hankel-norm of the given system (computed in HSV(1)). -C For computing a minimal realization, the recommended -C value is TOL1 = N*EPS*HNORM(A,B,C), where EPS is the -C machine precision (see LAPACK Library Routine DLAMCH). -C This value is used by default if TOL1 <= 0 on entry. -C If ORDSEL = 'F', the value of TOL1 is ignored. -C -C TOL2 DOUBLE PRECISION -C The tolerance for determining the order of a minimal -C realization of the given system. The recommended value is -C TOL2 = N*EPS*HNORM(A,B,C). This value is used by default -C if TOL2 <= 0 on entry. -C If TOL2 > 0, then TOL2 <= TOL1. -C -C Workspace -C -C IWORK INTEGER array, dimension MAX(1,2*N) -C On exit with INFO = 0, IWORK(1) contains the order of the -C minimal realization of the system. -C -C DWORK DOUBLE PRECISION array, dimension (LDWORK) -C On exit, if INFO = 0, DWORK(1) returns the optimal value -C of LDWORK. -C -C LDWORK INTEGER -C The length of the array DWORK. -C LDWORK >= MAX(1,N*(2*N+MAX(N,M,P)+5)+N*(N+1)/2). -C For optimum performance LDWORK should be larger. -C -C Warning Indicator -C -C IWARN INTEGER -C = 0: no warning; -C = 1: with ORDSEL = 'F', the selected order NR is greater -C than the order of a minimal realization of the -C given system. In this case, the resulting NR is -C set automatically to a value corresponding to the -C order of a minimal realization of the system. -C -C Error Indicator -C -C INFO INTEGER -C = 0: successful exit; -C < 0: if INFO = -i, the i-th argument had an illegal -C value; -C = 1: the reduction of A to the real Schur form failed; -C = 2: the state matrix A is not stable (if DICO = 'C') -C or not convergent (if DICO = 'D'); -C = 3: the computation of Hankel singular values failed. -C -C METHOD -C -C Let be the stable linear system -C -C d[x(t)] = Ax(t) + Bu(t) -C y(t) = Cx(t) + Du(t) (1) -C -C where d[x(t)] is dx(t)/dt for a continuous-time system and x(t+1) -C for a discrete-time system. The subroutine AB09BD determines for -C the given system (1), the matrices of a reduced order system -C -C d[z(t)] = Ar*z(t) + Br*u(t) -C yr(t) = Cr*z(t) + Dr*u(t) (2) -C -C such that -C -C HSV(NR) <= INFNORM(G-Gr) <= 2*[HSV(NR+1) + ... + HSV(N)], -C -C where G and Gr are transfer-function matrices of the systems -C (A,B,C,D) and (Ar,Br,Cr,Dr), respectively, and INFNORM(G) is the -C infinity-norm of G. -C -C If JOB = 'B', the balancing-based square-root SPA method of [1] -C is used and the resulting model is balanced. -C -C If JOB = 'N', the balancing-free square-root SPA method of [2] -C is used. -C By setting TOL1 = TOL2, the routine can be used to compute -C Balance & Truncate approximations. -C -C REFERENCES -C -C [1] Liu Y. and Anderson B.D.O. -C Singular Perturbation Approximation of Balanced Systems, -C Int. J. Control, Vol. 50, pp. 1379-1405, 1989. -C -C [2] Varga A. -C Balancing-free square-root algorithm for computing singular -C perturbation approximations. -C Proc. 30-th IEEE CDC, Brighton, Dec. 11-13, 1991, -C Vol. 2, pp. 1062-1065. -C -C NUMERICAL ASPECTS -C -C The implemented methods rely on accuracy enhancing square-root or -C balancing-free square-root techniques. -C 3 -C The algorithms require less than 30N floating point operations. -C -C CONTRIBUTOR -C -C C. Oara and A. Varga, German Aerospace Center, -C DLR Oberpfaffenhofen, March 1998. -C Based on the RASP routine SRBFSP. -C -C REVISIONS -C -C May 2, 1998. -C November 11, 1998, V. Sima, Research Institute for Informatics, -C Bucharest. -C -C KEYWORDS -C -C Balancing, minimal state-space representation, model reduction, -C multivariable system, singular perturbation approximation, -C state-space model. -C -C ****************************************************************** -C -C .. Parameters .. - DOUBLE PRECISION ZERO, ONE, C100 - PARAMETER ( ZERO = 0.0D0, ONE = 1.0D0, C100 = 100.0D0 ) -C .. Scalar Arguments .. - CHARACTER DICO, EQUIL, JOB, ORDSEL - INTEGER INFO, IWARN, LDA, LDB, LDC, LDD, LDWORK, - $ M, N, NR, P - DOUBLE PRECISION TOL1, TOL2 -C .. Array Arguments .. - INTEGER IWORK(*) - DOUBLE PRECISION A(LDA,*), B(LDB,*), C(LDC,*), D(LDD,*), - $ DWORK(*), HSV(*) -C .. Local Scalars .. - LOGICAL FIXORD - INTEGER IERR, KI, KR, KT, KTI, KW, NN - DOUBLE PRECISION MAXRED, WRKOPT -C .. External Functions .. - LOGICAL LSAME - EXTERNAL LSAME -C .. External Subroutines .. - EXTERNAL AB09BX, TB01ID, TB01WD, XERBLA -C .. Intrinsic Functions .. - INTRINSIC DBLE, MAX, MIN -C .. Executable Statements .. -C - INFO = 0 - IWARN = 0 - FIXORD = LSAME( ORDSEL, 'F' ) -C -C Test the input scalar arguments. -C - IF( .NOT. ( LSAME( DICO, 'C' ) .OR. LSAME( DICO, 'D' ) ) ) THEN - INFO = -1 - ELSE IF( .NOT. ( LSAME( JOB, 'B' ) .OR. LSAME( JOB, 'N' ) ) ) THEN - INFO = -2 - ELSE IF( .NOT. ( LSAME( EQUIL, 'S' ) .OR. - $ LSAME( EQUIL, 'N' ) ) ) THEN - INFO = -3 - ELSE IF( .NOT. ( FIXORD .OR. LSAME( ORDSEL, 'A' ) ) ) THEN - INFO = -4 - ELSE IF( N.LT.0 ) THEN - INFO = -5 - ELSE IF( M.LT.0 ) THEN - INFO = -6 - ELSE IF( P.LT.0 ) THEN - INFO = -7 - ELSE IF( FIXORD .AND. ( NR.LT.0 .OR. NR.GT.N ) ) THEN - INFO = -8 - ELSE IF( LDA.LT.MAX( 1, N ) ) THEN - INFO = -10 - ELSE IF( LDB.LT.MAX( 1, N ) ) THEN - INFO = -12 - ELSE IF( LDC.LT.MAX( 1, P ) ) THEN - INFO = -14 - ELSE IF( LDD.LT.MAX( 1, P ) ) THEN - INFO = -16 - ELSE IF( TOL2.GT.ZERO .AND. TOL2.GT.TOL1 ) THEN - INFO = -19 - ELSE IF( LDWORK.LT.MAX( 1, N*( 2*N + MAX( N, M, P ) + 5 ) + - $ ( N*( N + 1 ) )/2 ) ) THEN - INFO = -22 - END IF -C - IF( INFO.NE.0 ) THEN -C -C Error return. -C - CALL XERBLA( 'AB09BD', -INFO ) - RETURN - END IF -C -C Quick return if possible. -C - IF( MIN( N, M, P ).EQ.0 ) THEN - NR = 0 - IWORK(1) = 0 - DWORK(1) = ONE - RETURN - END IF -C -C Allocate working storage. -C - NN = N*N - KT = 1 - KR = KT + NN - KI = KR + N - KW = KI + N -C - IF( LSAME( EQUIL, 'S' ) ) THEN -C -C Scale simultaneously the matrices A, B and C: -C A <- inv(D)*A*D, B <- inv(D)*B and C <- C*D, where D is a -C diagonal matrix. -C - MAXRED = C100 - CALL TB01ID( 'All', N, M, P, MAXRED, A, LDA, B, LDB, C, LDC, - $ DWORK, INFO ) - END IF -C -C Reduce A to the real Schur form using an orthogonal similarity -C transformation A <- T'*A*T and apply the transformation to -C B and C: B <- T'*B and C <- C*T. -C - CALL TB01WD( N, M, P, A, LDA, B, LDB, C, LDC, DWORK(KT), N, - $ DWORK(KR), DWORK(KI), DWORK(KW), LDWORK-KW+1, IERR ) - IF( IERR.NE.0 ) THEN - INFO = 1 - RETURN - END IF -C - WRKOPT = DWORK(KW) + DBLE( KW-1 ) -C - KTI = KT + NN - KW = KTI + NN - CALL AB09BX( DICO, JOB, ORDSEL, N, M, P, NR, A, LDA, B, LDB, - $ C, LDC, D, LDD, HSV, DWORK(KT), N, DWORK(KTI), N, - $ TOL1, TOL2, IWORK, DWORK(KW), LDWORK-KW+1, IWARN, - $ IERR ) -C - IF( IERR.NE.0 ) THEN - INFO = IERR + 1 - RETURN - END IF -C - DWORK(1) = MAX( WRKOPT, DWORK(KW) + DBLE( KW-1 ) ) -C - RETURN -C *** Last line of AB09BD *** - END diff --git a/mex/sources/libslicot/AB09BX.f b/mex/sources/libslicot/AB09BX.f deleted file mode 100644 index 438babc5d..000000000 --- a/mex/sources/libslicot/AB09BX.f +++ /dev/null @@ -1,662 +0,0 @@ - SUBROUTINE AB09BX( DICO, JOB, ORDSEL, N, M, P, NR, A, LDA, B, LDB, - $ C, LDC, D, LDD, HSV, T, LDT, TI, LDTI, TOL1, - $ TOL2, IWORK, DWORK, LDWORK, IWARN, INFO ) -C -C SLICOT RELEASE 5.0. -C -C Copyright (c) 2002-2009 NICONET e.V. -C -C This program is free software: you can redistribute it and/or -C modify it under the terms of the GNU General Public License as -C published by the Free Software Foundation, either version 2 of -C the License, or (at your option) any later version. -C -C This program is distributed in the hope that it will be useful, -C but WITHOUT ANY WARRANTY; without even the implied warranty of -C MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the -C GNU General Public License for more details. -C -C You should have received a copy of the GNU General Public License -C along with this program. If not, see -C . -C -C PURPOSE -C -C To compute a reduced order model (Ar,Br,Cr,Dr) for a stable -C original state-space representation (A,B,C,D) by using either the -C square-root or the balancing-free square-root -C Singular Perturbation Approximation (SPA) model reduction method. -C The state dynamics matrix A of the original system is an upper -C quasi-triangular matrix in real Schur canonical form. The matrices -C of a minimal realization are computed using the truncation -C formulas: -C -C Am = TI * A * T , Bm = TI * B , Cm = C * T . (1) -C -C Am, Bm, Cm and D serve further for computing the SPA of the given -C system. -C -C ARGUMENTS -C -C Mode Parameters -C -C DICO CHARACTER*1 -C Specifies the type of the original system as follows: -C = 'C': continuous-time system; -C = 'D': discrete-time system. -C -C JOB CHARACTER*1 -C Specifies the model reduction approach to be used -C as follows: -C = 'B': use the square-root SPA method; -C = 'N': use the balancing-free square-root SPA method. -C -C ORDSEL CHARACTER*1 -C Specifies the order selection method as follows: -C = 'F': the resulting order NR is fixed; -C = 'A': the resulting order NR is automatically determined -C on basis of the given tolerance TOL1. -C -C Input/Output Parameters -C -C N (input) INTEGER -C The order of the original state-space representation, i.e. -C the order of the matrix A. N >= 0. -C -C M (input) INTEGER -C The number of system inputs. M >= 0. -C -C P (input) INTEGER -C The number of system outputs. P >= 0. -C -C NR (input/output) INTEGER -C On entry with ORDSEL = 'F', NR is the desired order of -C the resulting reduced order system. 0 <= NR <= N. -C On exit, if INFO = 0, NR is the order of the resulting -C reduced order model. NR is set as follows: -C if ORDSEL = 'F', NR is equal to MIN(NR,NMIN), where NR -C is the desired order on entry and NMIN is the order of a -C minimal realization of the given system; NMIN is -C determined as the number of Hankel singular values greater -C than N*EPS*HNORM(A,B,C), where EPS is the machine -C precision (see LAPACK Library Routine DLAMCH) and -C HNORM(A,B,C) is the Hankel norm of the system (computed -C in HSV(1)); -C if ORDSEL = 'A', NR is equal to the number of Hankel -C singular values greater than MAX(TOL1,N*EPS*HNORM(A,B,C)). -C -C A (input/output) DOUBLE PRECISION array, dimension (LDA,N) -C On entry, the leading N-by-N part of this array must -C contain the state dynamics matrix A in a real Schur -C canonical form. -C On exit, if INFO = 0, the leading NR-by-NR part of this -C array contains the state dynamics matrix Ar of the -C reduced order system. -C -C LDA INTEGER -C The leading dimension of array A. LDA >= MAX(1,N). -C -C B (input/output) DOUBLE PRECISION array, dimension (LDB,M) -C On entry, the leading N-by-M part of this array must -C contain the original input/state matrix B. -C On exit, if INFO = 0, the leading NR-by-M part of this -C array contains the input/state matrix Br of the reduced -C order system. -C -C LDB INTEGER -C The leading dimension of array B. LDB >= MAX(1,N). -C -C C (input/output) DOUBLE PRECISION array, dimension (LDC,N) -C On entry, the leading P-by-N part of this array must -C contain the original state/output matrix C. -C On exit, if INFO = 0, the leading P-by-NR part of this -C array contains the state/output matrix Cr of the reduced -C order system. -C -C LDC INTEGER -C The leading dimension of array C. LDC >= MAX(1,P). -C -C D (input/output) DOUBLE PRECISION array, dimension (LDD,M) -C On entry, the leading P-by-M part of this array must -C contain the original input/output matrix D. -C On exit, if INFO = 0, the leading P-by-M part of this -C array contains the input/output matrix Dr of the reduced -C order system. -C -C LDD INTEGER -C The leading dimension of array D. LDD >= MAX(1,P). -C -C HSV (output) DOUBLE PRECISION array, dimension (N) -C If INFO = 0, it contains the Hankel singular values of -C the original system ordered decreasingly. HSV(1) is the -C Hankel norm of the system. -C -C T (output) DOUBLE PRECISION array, dimension (LDT,N) -C If INFO = 0 and NR > 0, the leading N-by-NR part of this -C array contains the right truncation matrix T in (1). -C -C LDT INTEGER -C The leading dimension of array T. LDT >= MAX(1,N). -C -C TI (output) DOUBLE PRECISION array, dimension (LDTI,N) -C If INFO = 0 and NR > 0, the leading NR-by-N part of this -C array contains the left truncation matrix TI in (1). -C -C LDTI INTEGER -C The leading dimension of array TI. LDTI >= MAX(1,N). -C -C Tolerances -C -C TOL1 DOUBLE PRECISION -C If ORDSEL = 'A', TOL1 contains the tolerance for -C determining the order of reduced system. -C For model reduction, the recommended value is -C TOL1 = c*HNORM(A,B,C), where c is a constant in the -C interval [0.00001,0.001], and HNORM(A,B,C) is the -C Hankel-norm of the given system (computed in HSV(1)). -C For computing a minimal realization, the recommended -C value is TOL1 = N*EPS*HNORM(A,B,C), where EPS is the -C machine precision (see LAPACK Library Routine DLAMCH). -C This value is used by default if TOL1 <= 0 on entry. -C If ORDSEL = 'F', the value of TOL1 is ignored. -C -C TOL2 DOUBLE PRECISION -C The tolerance for determining the order of a minimal -C realization of the given system. The recommended value is -C TOL2 = N*EPS*HNORM(A,B,C). This value is used by default -C if TOL2 <= 0 on entry. -C If TOL2 > 0, then TOL2 <= TOL1. -C -C Workspace -C -C IWORK INTEGER array, dimension MAX(1,2*N) -C On exit with INFO = 0, IWORK(1) contains the order of the -C minimal realization of the system. -C -C DWORK DOUBLE PRECISION array, dimension (LDWORK) -C On exit, if INFO = 0, DWORK(1) returns the optimal value -C of LDWORK. -C -C LDWORK INTEGER -C The length of the array DWORK. -C LDWORK >= MAX(1,N*(MAX(N,M,P)+5) + N*(N+1)/2). -C For optimum performance LDWORK should be larger. -C -C Warning Indicator -C -C IWARN INTEGER -C = 0: no warning; -C = 1: with ORDSEL = 'F', the selected order NR is greater -C than the order of a minimal realization of the -C given system. In this case, the resulting NR is -C set automatically to a value corresponding to the -C order of a minimal realization of the system. -C -C Error Indicator -C -C INFO INTEGER -C = 0: successful exit; -C < 0: if INFO = -i, the i-th argument had an illegal -C value; -C = 1: the state matrix A is not stable (if DICO = 'C') -C or not convergent (if DICO = 'D'); -C = 2: the computation of Hankel singular values failed. -C -C METHOD -C -C Let be the stable linear system -C -C d[x(t)] = Ax(t) + Bu(t) -C y(t) = Cx(t) + Du(t) (2) -C -C where d[x(t)] is dx(t)/dt for a continuous-time system and x(t+1) -C for a discrete-time system. The subroutine AB09BX determines for -C the given system (1), the matrices of a reduced NR order system -C -C d[z(t)] = Ar*z(t) + Br*u(t) -C yr(t) = Cr*z(t) + Dr*u(t) (3) -C -C such that -C -C HSV(NR) <= INFNORM(G-Gr) <= 2*[HSV(NR+1) + ... + HSV(N)], -C -C where G and Gr are transfer-function matrices of the systems -C (A,B,C,D) and (Ar,Br,Cr,Dr), respectively, and INFNORM(G) is the -C infinity-norm of G. -C -C If JOB = 'B', the balancing-based square-root SPA method of [1] -C is used and the resulting model is balanced. -C -C If JOB = 'N', the balancing-free square-root SPA method of [2] -C is used. -C By setting TOL1 = TOL2, the routine can be also used to compute -C Balance & Truncate approximations. -C -C REFERENCES -C -C [1] Liu Y. and Anderson B.D.O. -C Singular Perturbation Approximation of Balanced Systems, -C Int. J. Control, Vol. 50, pp. 1379-1405, 1989. -C -C [2] Varga A. -C Balancing-free square-root algorithm for computing singular -C perturbation approximations. -C Proc. 30-th IEEE CDC, Brighton, Dec. 11-13, 1991, -C Vol. 2, pp. 1062-1065. -C -C NUMERICAL ASPECTS -C -C The implemented methods rely on accuracy enhancing square-root or -C balancing-free square-root techniques. -C 3 -C The algorithms require less than 30N floating point operations. -C -C CONTRIBUTOR -C -C A. Varga, German Aerospace Center, -C DLR Oberpfaffenhofen, March 1998. -C Based on the RASP routine SRBFP1. -C -C REVISIONS -C -C May 2, 1998. -C November 11, 1998, V. Sima, Research Institute for Informatics, -C Bucharest. -C December 1998, V. Sima, Katholieke Univ. Leuven, Leuven. -C February 14, 1999, A. Varga, German Aerospace Center. -C February 22, 1999, V. Sima, Research Institute for Informatics. -C February 27, 2000, V. Sima, Research Institute for Informatics. -C May 26, 2000, A. Varga, German Aerospace Center. -C -C KEYWORDS -C -C Balancing, minimal state-space representation, model reduction, -C multivariable system, singular perturbation approximation, -C state-space model. -C -C ****************************************************************** -C -C .. Parameters .. - DOUBLE PRECISION ONE, ZERO - PARAMETER ( ONE = 1.0D0, ZERO = 0.0D0 ) -C .. Scalar Arguments .. - CHARACTER DICO, JOB, ORDSEL - INTEGER INFO, IWARN, LDA, LDB, LDC, LDD, LDT, LDTI, - $ LDWORK, M, N, NR, P - DOUBLE PRECISION TOL1, TOL2 -C .. Array Arguments .. - INTEGER IWORK(*) - DOUBLE PRECISION A(LDA,*), B(LDB,*), C(LDC,*), D(LDD,*), - $ DWORK(*), HSV(*), T(LDT,*), TI(LDTI,*) -C .. Local Scalars .. - LOGICAL BAL, DISCR, FIXORD, PACKED - INTEGER IERR, IJ, J, K, KTAU, KU, KV, KW, LDW, NMINR, - $ NR1, NS, WRKOPT - DOUBLE PRECISION ATOL, RCOND, RTOL, SCALEC, SCALEO, TEMP -C .. External Functions .. - LOGICAL LSAME - DOUBLE PRECISION DLAMCH - EXTERNAL DLAMCH, LSAME -C .. External Subroutines .. - EXTERNAL AB09DD, DGEMM, DGEMV, DGEQRF, DGETRF, DGETRS, - $ DLACPY, DORGQR, DSCAL, DTPMV, DTRMM, DTRMV, - $ MA02AD, MA02DD, MB03UD, SB03OU, XERBLA -C .. Intrinsic Functions .. - INTRINSIC DBLE, INT, MAX, MIN, SQRT -C .. Executable Statements .. -C - INFO = 0 - IWARN = 0 - DISCR = LSAME( DICO, 'D' ) - BAL = LSAME( JOB, 'B' ) - FIXORD = LSAME( ORDSEL, 'F' ) -C -C Test the input scalar arguments. -C - IF( .NOT. ( LSAME( DICO, 'C' ) .OR. DISCR ) ) THEN - INFO = -1 - ELSE IF( .NOT. ( BAL .OR. LSAME( JOB, 'N') ) ) THEN - INFO = -2 - ELSE IF( .NOT. ( FIXORD .OR. LSAME( ORDSEL, 'A' ) ) ) THEN - INFO = -3 - ELSE IF( N.LT.0 ) THEN - INFO = -4 - ELSE IF( M.LT.0 ) THEN - INFO = -5 - ELSE IF( P.LT.0 ) THEN - INFO = -6 - ELSE IF( FIXORD .AND. ( NR.LT.0 .OR. NR.GT.N ) ) THEN - INFO = -7 - ELSE IF( LDA.LT.MAX( 1, N ) ) THEN - INFO = -9 - ELSE IF( LDB.LT.MAX( 1, N ) ) THEN - INFO = -11 - ELSE IF( LDC.LT.MAX( 1, P ) ) THEN - INFO = -13 - ELSE IF( LDD.LT.MAX( 1, P ) ) THEN - INFO = -15 - ELSE IF( LDT.LT.MAX( 1, N ) ) THEN - INFO = -18 - ELSE IF( LDTI.LT.MAX( 1, N ) ) THEN - INFO = -20 - ELSE IF( TOL2.GT.ZERO .AND. TOL2.GT.TOL1 ) THEN - INFO = -22 - ELSE IF( LDWORK.LT.MAX( 1, N*( MAX( N, M, P ) + 5 ) + - $ ( N*( N + 1 ) )/2 ) ) THEN - INFO = -25 - END IF -C - IF( INFO.NE.0 ) THEN -C -C Error return. -C - CALL XERBLA( 'AB09BX', -INFO ) - RETURN - END IF -C -C Quick return if possible. -C - IF( MIN( N, M, P ).EQ.0 ) THEN - NR = 0 - IWORK(1) = 0 - DWORK(1) = ONE - RETURN - END IF -C - RTOL = DBLE( N )*DLAMCH( 'Epsilon' ) -C -C Allocate N*MAX(N,M,P) and N working storage for the matrices U -C and TAU, respectively. -C - KU = 1 - KTAU = KU + N*MAX( N, M, P ) - KW = KTAU + N - LDW = LDWORK - KW + 1 -C -C Copy B in U. -C - CALL DLACPY( 'Full', N, M, B, LDB, DWORK(KU), N ) -C -C If DISCR = .FALSE., solve for Su the Lyapunov equation -C 2 -C A*(Su*Su') + (Su*Su')*A' + scalec *B*B' = 0 . -C -C If DISCR = .TRUE., solve for Su the Lyapunov equation -C 2 -C A*(Su*Su')*A' + scalec *B*B' = Su*Su' . -C -C Workspace: need N*(MAX(N,M,P) + 5); -C prefer larger. -C - CALL SB03OU( DISCR, .TRUE., N, M, A, LDA, DWORK(KU), N, - $ DWORK(KTAU), TI, LDTI, SCALEC, DWORK(KW), LDW, IERR ) - IF( IERR.NE.0 ) THEN - INFO = 1 - RETURN - ENDIF - WRKOPT = INT( DWORK(KW) ) + KW - 1 -C -C Copy C in U. -C - CALL DLACPY( 'Full', P, N, C, LDC, DWORK(KU), P ) -C -C If DISCR = .FALSE., solve for Ru the Lyapunov equation -C 2 -C A'*(Ru'*Ru) + (Ru'*Ru)*A + scaleo * C'*C = 0 . -C -C If DISCR = .TRUE., solve for Ru the Lyapunov equation -C 2 -C A'*(Ru'*Ru)*A + scaleo * C'*C = Ru'*Ru . -C -C Workspace: need N*(MAX(N,M,P) + 5); -C prefer larger. -C - CALL SB03OU( DISCR, .FALSE., N, P, A, LDA, DWORK(KU), P, - $ DWORK(KTAU), T, LDT, SCALEO, DWORK(KW), LDW, IERR ) - WRKOPT = MAX( WRKOPT, INT( DWORK(KW) ) + KW - 1 ) -C -C Allocate N*(N+1)/2 (or, if possible, N*N) working storage for the -C matrix V, a packed (or unpacked) copy of Su, and save Su in V. -C (The locations for TAU are reused here.) -C - KV = KTAU - IF ( LDWORK-KV+1.LT.N*( N + 5 ) ) THEN - PACKED = .TRUE. - CALL MA02DD( 'Pack', 'Upper', N, TI, LDTI, DWORK(KV) ) - KW = KV + ( N*( N + 1 ) )/2 - ELSE - PACKED = .FALSE. - CALL DLACPY( 'Upper', N, N, TI, LDTI, DWORK(KV), N ) - KW = KV + N*N - END IF -C | x x | -C Compute Ru*Su in the form | 0 x | in TI. -C - DO 10 J = 1, N - CALL DTRMV( 'Upper', 'NoTranspose', 'NonUnit', J, T, LDT, - $ TI(1,J), 1 ) - 10 CONTINUE -C -C Compute the singular value decomposition Ru*Su = V*S*UT -C of the upper triangular matrix Ru*Su, with UT in TI and V in U. -C -C Workspace: need N*MAX(N,M,P) + N*(N+1)/2 + 5*N; -C prefer larger. -C - CALL MB03UD( 'Vectors', 'Vectors', N, TI, LDTI, DWORK(KU), N, HSV, - $ DWORK(KW), LDWORK-KW+1, IERR ) - IF( IERR.NE.0 ) THEN - INFO = 2 - RETURN - ENDIF - WRKOPT = MAX( WRKOPT, INT( DWORK(KW) ) + KW - 1 ) -C -C Scale singular values. -C - CALL DSCAL( N, ONE / SCALEC / SCALEO, HSV, 1 ) -C -C Partition S, U and V conformally as: -C -C S = diag(S1,S2,S3), U = [U1,U2,U3] (U' in TI) and V = [V1,V2,V3] -C (in U). -C -C Compute the order NR of reduced system, as the order of S1. -C - ATOL = RTOL*HSV(1) - IF( FIXORD ) THEN - IF( NR.GT.0 ) THEN - IF( HSV(NR).LE.ATOL ) THEN - NR = 0 - IWARN = 1 - FIXORD = .FALSE. - ENDIF - ENDIF - ELSE - ATOL = MAX( TOL1, ATOL ) - NR = 0 - ENDIF - IF( .NOT.FIXORD ) THEN - DO 20 J = 1, N - IF( HSV(J).LE.ATOL ) GO TO 30 - NR = NR + 1 - 20 CONTINUE - 30 CONTINUE - ENDIF -C -C Finish if the order of the reduced model is zero. -C - IF( NR.EQ.0 ) THEN -C -C Compute only Dr using singular perturbation formulas. -C Workspace: need real 4*N; -C need integer 2*N. -C - CALL AB09DD( DICO, N, M, P, NR, A, LDA, B, LDB, C, LDC, D, - $ LDD, RCOND, IWORK, DWORK, IERR ) - IWORK(1) = 0 - DWORK(1) = WRKOPT - RETURN - END IF -C -C Compute the order of minimal realization as the order of [S1 S2]. -C - NR1 = NR + 1 - NMINR = NR - IF( NR.LT.N ) THEN - ATOL = MAX( TOL2, RTOL*HSV(1) ) - DO 40 J = NR1, N - IF( HSV(J).LE.ATOL ) GO TO 50 - NMINR = NMINR + 1 - 40 CONTINUE - 50 CONTINUE - END IF -C -C Compute the order of S2. -C - NS = NMINR - NR -C -C Compute the truncation matrices. -C -C Compute TI' = | TI1' TI2' | = Ru'*| V1 V2 | in U. -C - CALL DTRMM( 'Left', 'Upper', 'Transpose', 'NonUnit', N, NMINR, - $ ONE, T, LDT, DWORK(KU), N ) -C -C Compute T = | T1 T2 | = Su*| U1 U2 | -C (with Su packed, if not enough workspace). -C - CALL MA02AD( 'Full', NMINR, N, TI, LDTI, T, LDT ) - IF ( PACKED ) THEN - DO 60 J = 1, NMINR - CALL DTPMV( 'Upper', 'NoTranspose', 'NonUnit', N, DWORK(KV), - $ T(1,J), 1 ) - 60 CONTINUE - ELSE - CALL DTRMM( 'Left', 'Upper', 'NoTranspose', 'NonUnit', N, - $ NMINR, ONE, DWORK(KV), N, T, LDT ) - END IF -C - IF( BAL ) THEN - IJ = KU -C -C Square-Root SPA method. -C -C Compute the truncation matrices for balancing -C -1/2 -1/2 -C T1*S1 and TI1'*S1 -C - DO 70 J = 1, NR - TEMP = ONE/SQRT( HSV(J) ) - CALL DSCAL( N, TEMP, T(1,J), 1 ) - CALL DSCAL( N, TEMP, DWORK(IJ), 1 ) - IJ = IJ + N - 70 CONTINUE - ELSE -C -C Balancing-Free SPA method. -C -C Compute orthogonal bases for the images of matrices T1 and -C TI1'. -C -C Workspace: need N*MAX(N,M,P) + 2*NR; -C prefer N*MAX(N,M,P) + NR*(NB+1) -C (NB determined by ILAENV for DGEQRF). -C - KW = KTAU + NR - LDW = LDWORK - KW + 1 - CALL DGEQRF( N, NR, T, LDT, DWORK(KTAU), DWORK(KW), LDW, IERR ) - CALL DORGQR( N, NR, NR, T, LDT, DWORK(KTAU), DWORK(KW), LDW, - $ IERR ) - CALL DGEQRF( N, NR, DWORK(KU), N, DWORK(KTAU), DWORK(KW), LDW, - $ IERR ) - WRKOPT = MAX( WRKOPT, INT( DWORK(KW) ) + KW - 1 ) - CALL DORGQR( N, NR, NR, DWORK(KU), N, DWORK(KTAU), DWORK(KW), - $ LDW, IERR ) - WRKOPT = MAX( WRKOPT, INT( DWORK(KW) ) + KW - 1 ) - ENDIF - IF( NS.GT.0 ) THEN -C -C Compute orthogonal bases for the images of matrices T2 and -C TI2'. -C -C Workspace: need N*MAX(N,M,P) + 2*NS; -C prefer N*MAX(N,M,P) + NS*(NB+1) -C (NB determined by ILAENV for DGEQRF). - KW = KTAU + NS - LDW = LDWORK - KW + 1 - CALL DGEQRF( N, NS, T(1,NR1), LDT, DWORK(KTAU), DWORK(KW), LDW, - $ IERR ) - CALL DORGQR( N, NS, NS, T(1,NR1), LDT, DWORK(KTAU), DWORK(KW), - $ LDW, IERR ) - CALL DGEQRF( N, NS, DWORK(KU+N*NR), N, DWORK(KTAU), DWORK(KW), - $ LDW, IERR ) - WRKOPT = MAX( WRKOPT, INT( DWORK(KW) ) + KW - 1 ) - CALL DORGQR( N, NS, NS, DWORK(KU+N*NR), N, DWORK(KTAU), - $ DWORK(KW), LDW, IERR ) - WRKOPT = MAX( WRKOPT, INT( DWORK(KW) ) + KW - 1 ) - ENDIF -C -C Transpose TI' in TI. -C - CALL MA02AD( 'Full', N, NMINR, DWORK(KU), N, TI, LDTI ) -C - IF( .NOT.BAL ) THEN -C -1 -C Compute (TI1*T1) *TI1 in TI. -C - CALL DGEMM( 'NoTranspose', 'NoTranspose', NR, NR, N, ONE, TI, - $ LDTI, T, LDT, ZERO, DWORK(KU), N ) - CALL DGETRF( NR, NR, DWORK(KU), N, IWORK, IERR ) - CALL DGETRS( 'NoTranspose', NR, N, DWORK(KU), N, IWORK, TI, - $ LDTI, IERR ) -C - IF( NS.GT.0 ) THEN -C -1 -C Compute (TI2*T2) *TI2 in TI2. -C - CALL DGEMM( 'NoTranspose', 'NoTranspose', NS, NS, N, ONE, - $ TI(NR1,1), LDTI, T(1,NR1), LDT, ZERO, DWORK(KU), - $ N ) - CALL DGETRF( NS, NS, DWORK(KU), N, IWORK, IERR ) - CALL DGETRS( 'NoTranspose', NS, N, DWORK(KU), N, IWORK, - $ TI(NR1,1), LDTI, IERR ) - END IF - END IF -C -C Compute TI*A*T (A is in RSF). -C - IJ = KU - DO 80 J = 1, N - K = MIN( J+1, N ) - CALL DGEMV( 'NoTranspose', NMINR, K, ONE, TI, LDTI, A(1,J), 1, - $ ZERO, DWORK(IJ), 1 ) - IJ = IJ + N - 80 CONTINUE - CALL DGEMM( 'NoTranspose', 'NoTranspose', NMINR, NMINR, N, ONE, - $ DWORK(KU), N, T, LDT, ZERO, A, LDA ) -C -C Compute TI*B and C*T. -C - CALL DLACPY( 'Full', N, M, B, LDB, DWORK(KU), N ) - CALL DGEMM( 'NoTranspose', 'NoTranspose', NMINR, M, N, ONE, TI, - $ LDTI, DWORK(KU), N, ZERO, B, LDB ) -C - CALL DLACPY( 'Full', P, N, C, LDC, DWORK(KU), P ) - CALL DGEMM( 'NoTranspose', 'NoTranspose', P, NMINR, N, ONE, - $ DWORK(KU), P, T, LDT, ZERO, C, LDC ) -C -C Compute the singular perturbation approximation if possible. -C Note that IERR = 1 on exit from AB09DD cannot appear here. -C -C Workspace: need real 4*(NMINR-NR); -C need integer 2*(NMINR-NR). -C - CALL AB09DD( DICO, NMINR, M, P, NR, A, LDA, B, LDB, C, LDC, D, - $ LDD, RCOND, IWORK, DWORK, IERR ) -C - IWORK(1) = NMINR - DWORK(1) = WRKOPT -C - RETURN -C *** Last line of AB09BX *** - END diff --git a/mex/sources/libslicot/AB09CD.f b/mex/sources/libslicot/AB09CD.f deleted file mode 100644 index 01567db21..000000000 --- a/mex/sources/libslicot/AB09CD.f +++ /dev/null @@ -1,375 +0,0 @@ - SUBROUTINE AB09CD( DICO, EQUIL, ORDSEL, N, M, P, NR, A, LDA, B, - $ LDB, C, LDC, D, LDD, HSV, TOL1, TOL2, IWORK, - $ DWORK, LDWORK, IWARN, INFO ) -C -C SLICOT RELEASE 5.0. -C -C Copyright (c) 2002-2009 NICONET e.V. -C -C This program is free software: you can redistribute it and/or -C modify it under the terms of the GNU General Public License as -C published by the Free Software Foundation, either version 2 of -C the License, or (at your option) any later version. -C -C This program is distributed in the hope that it will be useful, -C but WITHOUT ANY WARRANTY; without even the implied warranty of -C MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the -C GNU General Public License for more details. -C -C You should have received a copy of the GNU General Public License -C along with this program. If not, see -C . -C -C PURPOSE -C -C To compute a reduced order model (Ar,Br,Cr,Dr) for a stable -C original state-space representation (A,B,C,D) by using the -C optimal Hankel-norm approximation method in conjunction with -C square-root balancing. -C -C ARGUMENTS -C -C Mode Parameters -C -C DICO CHARACTER*1 -C Specifies the type of the original system as follows: -C = 'C': continuous-time system; -C = 'D': discrete-time system. -C -C EQUIL CHARACTER*1 -C Specifies whether the user wishes to preliminarily -C equilibrate the triplet (A,B,C) as follows: -C = 'S': perform equilibration (scaling); -C = 'N': do not perform equilibration. -C -C ORDSEL CHARACTER*1 -C Specifies the order selection method as follows: -C = 'F': the resulting order NR is fixed; -C = 'A': the resulting order NR is automatically determined -C on basis of the given tolerance TOL1. -C -C Input/Output Parameters -C -C N (input) INTEGER -C The order of the original state-space representation, i.e. -C the order of the matrix A. N >= 0. -C -C M (input) INTEGER -C The number of system inputs. M >= 0. -C -C P (input) INTEGER -C The number of system outputs. P >= 0. -C -C NR (input/output) INTEGER -C On entry with ORDSEL = 'F', NR is the desired order of -C the resulting reduced order system. 0 <= NR <= N. -C On exit, if INFO = 0, NR is the order of the resulting -C reduced order model. NR is set as follows: -C if ORDSEL = 'F', NR is equal to MIN(MAX(0,NR-KR+1),NMIN), -C where KR is the multiplicity of the Hankel singular value -C HSV(NR+1), NR is the desired order on entry, and NMIN is -C the order of a minimal realization of the given system; -C NMIN is determined as the number of Hankel singular values -C greater than N*EPS*HNORM(A,B,C), where EPS is the machine -C precision (see LAPACK Library Routine DLAMCH) and -C HNORM(A,B,C) is the Hankel norm of the system (computed -C in HSV(1)); -C if ORDSEL = 'A', NR is equal to the number of Hankel -C singular values greater than MAX(TOL1,N*EPS*HNORM(A,B,C)). -C -C A (input/output) DOUBLE PRECISION array, dimension (LDA,N) -C On entry, the leading N-by-N part of this array must -C contain the state dynamics matrix A. -C On exit, if INFO = 0, the leading NR-by-NR part of this -C array contains the state dynamics matrix Ar of the -C reduced order system in a real Schur form. -C -C LDA INTEGER -C The leading dimension of array A. LDA >= MAX(1,N). -C -C B (input/output) DOUBLE PRECISION array, dimension (LDB,M) -C On entry, the leading N-by-M part of this array must -C contain the original input/state matrix B. -C On exit, if INFO = 0, the leading NR-by-M part of this -C array contains the input/state matrix Br of the reduced -C order system. -C -C LDB INTEGER -C The leading dimension of array B. LDB >= MAX(1,N). -C -C C (input/output) DOUBLE PRECISION array, dimension (LDC,N) -C On entry, the leading P-by-N part of this array must -C contain the original state/output matrix C. -C On exit, if INFO = 0, the leading P-by-NR part of this -C array contains the state/output matrix Cr of the reduced -C order system. -C -C LDC INTEGER -C The leading dimension of array C. LDC >= MAX(1,P). -C -C D (input/output) DOUBLE PRECISION array, dimension (LDD,M) -C On entry, the leading P-by-M part of this array must -C contain the original input/output matrix D. -C On exit, if INFO = 0, the leading P-by-M part of this -C array contains the input/output matrix Dr of the reduced -C order system. -C -C LDD INTEGER -C The leading dimension of array D. LDD >= MAX(1,P). -C -C HSV (output) DOUBLE PRECISION array, dimension (N) -C If INFO = 0, it contains the Hankel singular values of -C the original system ordered decreasingly. HSV(1) is the -C Hankel norm of the system. -C -C Tolerances -C -C TOL1 DOUBLE PRECISION -C If ORDSEL = 'A', TOL1 contains the tolerance for -C determining the order of reduced system. -C For model reduction, the recommended value is -C TOL1 = c*HNORM(A,B,C), where c is a constant in the -C interval [0.00001,0.001], and HNORM(A,B,C) is the -C Hankel-norm of the given system (computed in HSV(1)). -C For computing a minimal realization, the recommended -C value is TOL1 = N*EPS*HNORM(A,B,C), where EPS is the -C machine precision (see LAPACK Library Routine DLAMCH). -C This value is used by default if TOL1 <= 0 on entry. -C If ORDSEL = 'F', the value of TOL1 is ignored. -C -C TOL2 DOUBLE PRECISION -C The tolerance for determining the order of a minimal -C realization of the given system. The recommended value is -C TOL2 = N*EPS*HNORM(A,B,C). This value is used by default -C if TOL2 <= 0 on entry. -C If TOL2 > 0, then TOL2 <= TOL1. -C -C Workspace -C -C IWORK INTEGER array, dimension (LIWORK) -C LIWORK = MAX(1,M), if DICO = 'C'; -C LIWORK = MAX(1,N,M), if DICO = 'D'. -C On exit, if INFO = 0, IWORK(1) contains NMIN, the order of -C the computed minimal realization. -C -C DWORK DOUBLE PRECISION array, dimension (LDWORK) -C On exit, if INFO = 0, DWORK(1) returns the optimal value -C of LDWORK. -C -C LDWORK INTEGER -C The length of the array DWORK. -C LDWORK >= MAX( LDW1, LDW2 ), where -C LDW1 = N*(2*N+MAX(N,M,P)+5) + N*(N+1)/2, -C LDW2 = N*(M+P+2) + 2*M*P + MIN(N,M) + -C MAX( 3*M+1, MIN(N,M)+P ). -C For optimum performance LDWORK should be larger. -C -C Warning Indicator -C -C IWARN INTEGER -C = 0: no warning; -C = 1: with ORDSEL = 'F', the selected order NR is greater -C than the order of a minimal realization of the -C given system. In this case, the resulting NR is set -C automatically to a value corresponding to the order -C of a minimal realization of the system. -C -C Error Indicator -C -C INFO INTEGER -C = 0: successful exit; -C < 0: if INFO = -i, the i-th argument had an illegal -C value; -C = 1: the reduction of A to the real Schur form failed; -C = 2: the state matrix A is not stable (if DICO = 'C') -C or not convergent (if DICO = 'D'); -C = 3: the computation of Hankel singular values failed; -C = 4: the computation of stable projection failed; -C = 5: the order of computed stable projection differs -C from the order of Hankel-norm approximation. -C -C METHOD -C -C Let be the stable linear system -C -C d[x(t)] = Ax(t) + Bu(t) -C y(t) = Cx(t) + Du(t) (1) -C -C where d[x(t)] is dx(t)/dt for a continuous-time system and x(t+1) -C for a discrete-time system. The subroutine AB09CD determines for -C the given system (1), the matrices of a reduced order system -C -C d[z(t)] = Ar*z(t) + Br*u(t) -C yr(t) = Cr*z(t) + Dr*u(t) (2) -C -C such that -C -C HSV(NR) <= INFNORM(G-Gr) <= 2*[HSV(NR+1) + ... + HSV(N)], -C -C where G and Gr are transfer-function matrices of the systems -C (A,B,C,D) and (Ar,Br,Cr,Dr), respectively, and INFNORM(G) is the -C infinity-norm of G. -C -C The optimal Hankel-norm approximation method of [1], based on the -C square-root balancing projection formulas of [2], is employed. -C -C REFERENCES -C -C [1] Glover, K. -C All optimal Hankel norm approximation of linear -C multivariable systems and their L-infinity error bounds. -C Int. J. Control, Vol. 36, pp. 1145-1193, 1984. -C -C [2] Tombs M.S. and Postlethwaite I. -C Truncated balanced realization of stable, non-minimal -C state-space systems. -C Int. J. Control, Vol. 46, pp. 1319-1330, 1987. -C -C NUMERICAL ASPECTS -C -C The implemented methods rely on an accuracy enhancing square-root -C technique. -C 3 -C The algorithms require less than 30N floating point operations. -C -C CONTRIBUTOR -C -C C. Oara and A. Varga, German Aerospace Center, -C DLR Oberpfaffenhofen, April 1998. -C Based on the RASP routine OHNAP. -C -C REVISIONS -C -C November 11, 1998, V. Sima, Research Institute for Informatics, -C Bucharest. -C March 26, 2005, V. Sima, Research Institute for Informatics. -C -C KEYWORDS -C -C Balancing, Hankel-norm approximation, model reduction, -C multivariable system, state-space model. -C -C ****************************************************************** -C -C .. Parameters .. - DOUBLE PRECISION ZERO, ONE, C100 - PARAMETER ( ZERO = 0.0D0, ONE = 1.0D0, C100 = 100.0D0 ) -C .. Scalar Arguments .. - CHARACTER DICO, EQUIL, ORDSEL - INTEGER INFO, IWARN, LDA, LDB, LDC, LDD, LDWORK, - $ M, N, NR, P - DOUBLE PRECISION TOL1, TOL2 -C .. Array Arguments .. - INTEGER IWORK(*) - DOUBLE PRECISION A(LDA,*), B(LDB,*), C(LDC,*), D(LDD,*), - $ DWORK(*), HSV(*) -C .. Local Scalars .. - LOGICAL FIXORD - INTEGER IERR, KI, KL, KT, KW - DOUBLE PRECISION MAXRED, WRKOPT -C .. External Functions .. - LOGICAL LSAME - EXTERNAL LSAME -C .. External Subroutines .. - EXTERNAL AB09CX, TB01ID, TB01WD, XERBLA -C .. Intrinsic Functions .. - INTRINSIC DBLE, MAX, MIN -C .. Executable Statements .. -C - INFO = 0 - IWARN = 0 - FIXORD = LSAME( ORDSEL, 'F' ) -C -C Check the input scalar arguments. -C - IF( .NOT. ( LSAME( DICO, 'C' ) .OR. LSAME( DICO, 'D' ) ) ) THEN - INFO = -1 - ELSE IF( .NOT. ( LSAME( EQUIL, 'S' ) .OR. - $ LSAME( EQUIL, 'N' ) ) ) THEN - INFO = -2 - ELSE IF( .NOT. ( FIXORD .OR. LSAME( ORDSEL, 'A' ) ) ) THEN - INFO = -3 - ELSE IF( N.LT.0 ) THEN - INFO = -4 - ELSE IF( M.LT.0 ) THEN - INFO = -5 - ELSE IF( P.LT.0 ) THEN - INFO = -6 - ELSE IF( FIXORD .AND. ( NR.LT.0 .OR. NR.GT.N ) ) THEN - INFO = -7 - ELSE IF( LDA.LT.MAX( 1, N ) ) THEN - INFO = -9 - ELSE IF( LDB.LT.MAX( 1, N ) ) THEN - INFO = -11 - ELSE IF( LDC.LT.MAX( 1, P ) ) THEN - INFO = -13 - ELSE IF( LDD.LT.MAX( 1, P ) ) THEN - INFO = -15 - ELSE IF( TOL2.GT.ZERO .AND. TOL2.GT.TOL1 ) THEN - INFO = -18 - ELSE IF( LDWORK.LT.MAX( N*( 2*N + MAX( N, M, P ) + 5 ) + - $ ( N*( N + 1 ) )/2, - $ N*( M + P + 2 ) + 2*M*P + MIN( N, M ) + - $ MAX ( 3*M + 1, MIN( N, M ) + P ) ) ) THEN - INFO = -21 - END IF -C - IF( INFO.NE.0 ) THEN -C -C Error return. -C - CALL XERBLA( 'AB09CD', -INFO ) - RETURN - END IF -C -C Quick return if possible. -C - IF( MIN( N, M, P ).EQ.0 ) THEN - NR = 0 - IWORK(1) = 0 - DWORK(1) = ONE - RETURN - END IF -C - IF( LSAME( EQUIL, 'S' ) ) THEN -C -C Scale simultaneously the matrices A, B and C: -C A <- inv(D)*A*D, B <- inv(D)*B and C <- C*D, where D is a -C diagonal matrix. -C - MAXRED = C100 - CALL TB01ID( 'All', N, M, P, MAXRED, A, LDA, B, LDB, C, LDC, - $ DWORK, INFO ) - END IF -C -C Reduce A to the real Schur form using an orthogonal similarity -C transformation A <- T'*A*T and apply the transformation to B -C and C: B <- T'*B and C <- C*T. -C - KT = 1 - KL = KT + N*N - KI = KL + N - KW = KI + N - CALL TB01WD( N, M, P, A, LDA, B, LDB, C, LDC, DWORK(KT), N, - $ DWORK(KL), DWORK(KI), DWORK(KW), LDWORK-KW+1, IERR ) - IF( IERR.NE.0 ) THEN - INFO = 1 - RETURN - END IF -C - WRKOPT = DWORK(KW) + DBLE( KW-1 ) -C - CALL AB09CX( DICO, ORDSEL, N, M, P, NR, A, LDA, B, LDB, C, LDC, - $ D, LDD, HSV, TOL1, TOL2, IWORK, DWORK, LDWORK, - $ IWARN, IERR ) -C - IF( IERR.NE.0 ) THEN - INFO = IERR + 1 - RETURN - END IF -C - DWORK(1) = MAX( WRKOPT, DWORK(1) ) -C - RETURN -C *** Last line of AB09CD *** - END diff --git a/mex/sources/libslicot/AB09CX.f b/mex/sources/libslicot/AB09CX.f deleted file mode 100644 index 7644d7992..000000000 --- a/mex/sources/libslicot/AB09CX.f +++ /dev/null @@ -1,558 +0,0 @@ - SUBROUTINE AB09CX( DICO, ORDSEL, N, M, P, NR, A, LDA, B, LDB, - $ C, LDC, D, LDD, HSV, TOL1, TOL2, IWORK, - $ DWORK, LDWORK, IWARN, INFO ) -C -C SLICOT RELEASE 5.0. -C -C Copyright (c) 2002-2009 NICONET e.V. -C -C This program is free software: you can redistribute it and/or -C modify it under the terms of the GNU General Public License as -C published by the Free Software Foundation, either version 2 of -C the License, or (at your option) any later version. -C -C This program is distributed in the hope that it will be useful, -C but WITHOUT ANY WARRANTY; without even the implied warranty of -C MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the -C GNU General Public License for more details. -C -C You should have received a copy of the GNU General Public License -C along with this program. If not, see -C . -C -C PURPOSE -C -C To compute a reduced order model (Ar,Br,Cr,Dr) for a stable -C original state-space representation (A,B,C,D) by using the optimal -C Hankel-norm approximation method in conjunction with square-root -C balancing. The state dynamics matrix A of the original system is -C an upper quasi-triangular matrix in real Schur canonical form. -C -C ARGUMENTS -C -C Mode Parameters -C -C DICO CHARACTER*1 -C Specifies the type of the original system as follows: -C = 'C': continuous-time system; -C = 'D': discrete-time system. -C -C ORDSEL CHARACTER*1 -C Specifies the order selection method as follows: -C = 'F': the resulting order NR is fixed; -C = 'A': the resulting order NR is automatically determined -C on basis of the given tolerance TOL1. -C -C Input/Output Parameters -C -C N (input) INTEGER -C The order of the original state-space representation, i.e. -C the order of the matrix A. N >= 0. -C -C M (input) INTEGER -C The number of system inputs. M >= 0. -C -C P (input) INTEGER -C The number of system outputs. P >= 0. -C -C NR (input/output) INTEGER -C On entry with ORDSEL = 'F', NR is the desired order of -C the resulting reduced order system. 0 <= NR <= N. -C On exit, if INFO = 0, NR is the order of the resulting -C reduced order model. NR is set as follows: -C if ORDSEL = 'F', NR is equal to MIN(MAX(0,NR-KR+1),NMIN), -C where KR is the multiplicity of the Hankel singular value -C HSV(NR+1), NR is the desired order on entry, and NMIN is -C the order of a minimal realization of the given system; -C NMIN is determined as the number of Hankel singular values -C greater than N*EPS*HNORM(A,B,C), where EPS is the machine -C precision (see LAPACK Library Routine DLAMCH) and -C HNORM(A,B,C) is the Hankel norm of the system (computed -C in HSV(1)); -C if ORDSEL = 'A', NR is equal to the number of Hankel -C singular values greater than MAX(TOL1,N*EPS*HNORM(A,B,C)). -C -C A (input/output) DOUBLE PRECISION array, dimension (LDA,N) -C On entry, the leading N-by-N part of this array must -C contain the state dynamics matrix A in a real Schur -C canonical form. -C On exit, if INFO = 0, the leading NR-by-NR part of this -C array contains the state dynamics matrix Ar of the -C reduced order system in a real Schur form. -C -C LDA INTEGER -C The leading dimension of array A. LDA >= MAX(1,N). -C -C B (input/output) DOUBLE PRECISION array, dimension (LDB,M) -C On entry, the leading N-by-M part of this array must -C contain the original input/state matrix B. -C On exit, if INFO = 0, the leading NR-by-M part of this -C array contains the input/state matrix Br of the reduced -C order system. -C -C LDB INTEGER -C The leading dimension of array B. LDB >= MAX(1,N). -C -C C (input/output) DOUBLE PRECISION array, dimension (LDC,N) -C On entry, the leading P-by-N part of this array must -C contain the original state/output matrix C. -C On exit, if INFO = 0, the leading P-by-NR part of this -C array contains the state/output matrix Cr of the reduced -C order system. -C -C LDC INTEGER -C The leading dimension of array C. LDC >= MAX(1,P). -C -C D (input/output) DOUBLE PRECISION array, dimension (LDD,M) -C On entry, the leading P-by-M part of this array must -C contain the original input/output matrix D. -C On exit, if INFO = 0, the leading P-by-M part of this -C array contains the input/output matrix Dr of the reduced -C order system. -C -C LDD INTEGER -C The leading dimension of array D. LDD >= MAX(1,P). -C -C HSV (output) DOUBLE PRECISION array, dimension (N) -C If INFO = 0, it contains the Hankel singular values of -C the original system ordered decreasingly. HSV(1) is the -C Hankel norm of the system. -C -C Tolerances -C -C TOL1 DOUBLE PRECISION -C If ORDSEL = 'A', TOL1 contains the tolerance for -C determining the order of reduced system. -C For model reduction, the recommended value is -C TOL1 = c*HNORM(A,B,C), where c is a constant in the -C interval [0.00001,0.001], and HNORM(A,B,C) is the -C Hankel-norm of the given system (computed in HSV(1)). -C For computing a minimal realization, the recommended -C value is TOL1 = N*EPS*HNORM(A,B,C), where EPS is the -C machine precision (see LAPACK Library Routine DLAMCH). -C This value is used by default if TOL1 <= 0 on entry. -C If ORDSEL = 'F', the value of TOL1 is ignored. -C -C TOL2 DOUBLE PRECISION -C The tolerance for determining the order of a minimal -C realization of the given system. The recommended value is -C TOL2 = N*EPS*HNORM(A,B,C). This value is used by default -C if TOL2 <= 0 on entry. -C If TOL2 > 0, then TOL2 <= TOL1. -C -C Workspace -C -C IWORK INTEGER array, dimension (LIWORK) -C LIWORK = MAX(1,M), if DICO = 'C'; -C LIWORK = MAX(1,N,M), if DICO = 'D'. -C On exit, if INFO = 0, IWORK(1) contains NMIN, the order of -C the computed minimal realization. -C -C DWORK DOUBLE PRECISION array, dimension (LDWORK) -C On exit, if INFO = 0, DWORK(1) returns the optimal value -C of LDWORK. -C -C LDWORK INTEGER -C The length of the array DWORK. -C LDWORK >= MAX( LDW1,LDW2 ), where -C LDW1 = N*(2*N+MAX(N,M,P)+5) + N*(N+1)/2, -C LDW2 = N*(M+P+2) + 2*M*P + MIN(N,M) + -C MAX( 3*M+1, MIN(N,M)+P ). -C For optimum performance LDWORK should be larger. -C -C Warning Indicator -C -C IWARN INTEGER -C = 0: no warning; -C = 1: with ORDSEL = 'F', the selected order NR is greater -C than the order of a minimal realization of the -C given system. In this case, the resulting NR is set -C automatically to a value corresponding to the order -C of a minimal realization of the system. -C -C Error Indicator -C -C INFO INTEGER -C = 0: successful exit; -C < 0: if INFO = -i, the i-th argument had an illegal -C value; -C = 1: the state matrix A is not stable (if DICO = 'C') -C or not convergent (if DICO = 'D'); -C = 2: the computation of Hankel singular values failed; -C = 3: the computation of stable projection failed; -C = 4: the order of computed stable projection differs -C from the order of Hankel-norm approximation. -C -C METHOD -C -C Let be the stable linear system -C -C d[x(t)] = Ax(t) + Bu(t) -C y(t) = Cx(t) + Du(t) (1) -C -C where d[x(t)] is dx(t)/dt for a continuous-time system and x(t+1) -C for a discrete-time system. The subroutine AB09CX determines for -C the given system (1), the matrices of a reduced order system -C -C d[z(t)] = Ar*z(t) + Br*u(t) -C yr(t) = Cr*z(t) + Dr*u(t) (2) -C -C such that -C -C HSV(NR) <= INFNORM(G-Gr) <= 2*[HSV(NR+1) + ... + HSV(N)], -C -C where G and Gr are transfer-function matrices of the systems -C (A,B,C,D) and (Ar,Br,Cr,Dr), respectively, and INFNORM(G) is the -C infinity-norm of G. -C -C The optimal Hankel-norm approximation method of [1], based on the -C square-root balancing projection formulas of [2], is employed. -C -C REFERENCES -C -C [1] Glover, K. -C All optimal Hankel norm approximation of linear -C multivariable systems and their L-infinity error bounds. -C Int. J. Control, Vol. 36, pp. 1145-1193, 1984. -C -C [2] Tombs M.S. and Postlethwaite I. -C Truncated balanced realization of stable, non-minimal -C state-space systems. -C Int. J. Control, Vol. 46, pp. 1319-1330, 1987. -C -C NUMERICAL ASPECTS -C -C The implemented methods rely on an accuracy enhancing square-root -C technique. -C 3 -C The algorithms require less than 30N floating point operations. -C -C CONTRIBUTOR -C -C A. Varga, German Aerospace Center, -C DLR Oberpfaffenhofen, April 1998. -C Based on the RASP routine OHNAP1. -C -C REVISIONS -C -C November 11, 1998, V. Sima, Research Institute for Informatics, -C Bucharest. -C April 24, 2000, A. Varga, DLR Oberpfaffenhofen. -C April 8, 2001, A. Varga, DLR Oberpfaffenhofen. -C March 26, 2005, V. Sima, Research Institute for Informatics. -C -C KEYWORDS -C -C Balancing, Hankel-norm approximation, model reduction, -C multivariable system, state-space model. -C -C ****************************************************************** -C -C .. Parameters .. - DOUBLE PRECISION ONE, ZERO - PARAMETER ( ONE = 1.0D0, ZERO = 0.0D0 ) -C .. Scalar Arguments .. - CHARACTER DICO, ORDSEL - INTEGER INFO, IWARN, LDA, LDB, LDC, LDD, LDWORK, - $ M, N, NR, P - DOUBLE PRECISION TOL1, TOL2 -C .. Array Arguments .. - INTEGER IWORK(*) - DOUBLE PRECISION A(LDA,*), B(LDB,*), C(LDC,*), D(LDD,*), - $ DWORK(*), HSV(*) -C .. Local Scalars - LOGICAL DISCR, FIXORD - INTEGER I, I1, IERR, IRANK, J, KB1, KB2, KC1, KC2T, - $ KHSVP, KHSVP2, KR, KT, KTI, KU, KW, KW1, KW2, - $ LDB1, LDB2, LDC1, LDC2T, NA, NDIM, NKR1, NMINR, - $ NR1, NU, WRKOPT - DOUBLE PRECISION ATOL, RTOL, SKP, SKP2, SRRTOL -C .. External Functions .. - LOGICAL LSAME - DOUBLE PRECISION DLAMCH - EXTERNAL DLAMCH, LSAME -C .. External Subroutines .. - EXTERNAL AB04MD, AB09AX, DAXPY, DCOPY, DGELSY, DGEMM, - $ DLACPY, DSWAP, MA02AD, MB01SD, TB01KD, TB01WD, - $ XERBLA -C .. Intrinsic Functions .. - INTRINSIC ABS, DBLE, INT, MAX, MIN, SQRT -C .. Executable Statements .. -C - INFO = 0 - IWARN = 0 - DISCR = LSAME( DICO, 'D' ) - FIXORD = LSAME( ORDSEL, 'F' ) -C -C Check the input scalar arguments. -C - IF( .NOT. ( LSAME( DICO, 'C' ) .OR. DISCR ) ) THEN - INFO = -1 - ELSE IF( .NOT. ( FIXORD .OR. LSAME( ORDSEL, 'A' ) ) ) THEN - INFO = -2 - ELSE IF( N.LT.0 ) THEN - INFO = -3 - ELSE IF( M.LT.0 ) THEN - INFO = -4 - ELSE IF( P.LT.0 ) THEN - INFO = -5 - ELSE IF( FIXORD .AND. ( NR.LT.0 .OR. NR.GT.N ) ) THEN - INFO = -6 - ELSE IF( LDA.LT.MAX( 1, N ) ) THEN - INFO = -8 - ELSE IF( LDB.LT.MAX( 1, N ) ) THEN - INFO = -10 - ELSE IF( LDC.LT.MAX( 1, P ) ) THEN - INFO = -12 - ELSE IF( LDD.LT.MAX( 1, P ) ) THEN - INFO = -14 - ELSE IF( TOL2.GT.ZERO .AND. TOL2.GT.TOL1 ) THEN - INFO = -17 - ELSE IF( LDWORK.LT.MAX( N*( 2*N + MAX( N, M, P ) + 5 ) + - $ ( N*( N + 1 ) )/2, - $ N*( M + P + 2 ) + 2*M*P + MIN( N, M ) + - $ MAX ( 3*M + 1, MIN( N, M ) + P ) ) ) THEN - INFO = -20 - END IF -C - IF( INFO.NE.0 ) THEN -C -C Error return. -C - CALL XERBLA( 'AB09CX', -INFO ) - RETURN - END IF -C -C Quick return if possible. -C - IF( MIN( N, M, P ).EQ.0 ) THEN - NR = 0 - IWORK(1) = 0 - DWORK(1) = ONE - RETURN - END IF -C - RTOL = DBLE( N )*DLAMCH( 'Epsilon' ) - SRRTOL = SQRT( RTOL ) -C -C Allocate working storage. -C - KT = 1 - KTI = KT + N*N - KW = KTI + N*N -C -C Compute a minimal order balanced realization of the given system. -C Workspace: need N*(2*N+MAX(N,M,P)+5) + N*(N+1)/2; -C prefer larger. -C - CALL AB09AX( DICO, 'Balanced', 'Automatic', N, M, P, NMINR, A, - $ LDA, B, LDB, C, LDC, HSV, DWORK(KT), N, DWORK(KTI), - $ N, TOL2, IWORK, DWORK(KW), LDWORK-KW+1, IWARN, INFO ) -C - IF( INFO.NE.0 ) - $ RETURN - WRKOPT = INT( DWORK(KW) ) + KW - 1 -C -C Compute the order of reduced system. -C - ATOL = RTOL*HSV(1) - IF( FIXORD ) THEN - IF( NR.GT.0 ) THEN - IF( NR.GT.NMINR ) THEN - NR = NMINR - IWARN = 1 - ENDIF - ENDIF - ELSE - ATOL = MAX( TOL1, ATOL ) - NR = 0 - DO 10 I = 1, NMINR - IF( HSV(I).LE.ATOL ) GO TO 20 - NR = NR + 1 - 10 CONTINUE - 20 CONTINUE - ENDIF -C - IF( NR.EQ.NMINR ) THEN - IWORK(1) = NMINR - DWORK(1) = WRKOPT - KW = N*(N+2)+1 -C -C Reduce Ar to a real Schur form. -C - CALL TB01WD( NMINR, M, P, A, LDA, B, LDB, C, LDC, - $ DWORK(2*N+1), N, DWORK, DWORK(N+1), DWORK(KW), - $ LDWORK-KW+1, IERR ) - IF( IERR.NE.0 ) THEN - INFO = 3 - RETURN - END IF - RETURN - END IF - SKP = HSV(NR+1) -C -C If necessary, reduce the order such that HSV(NR) > HSV(NR+1). -C - 30 IF( NR.GT.0 ) THEN - IF( ABS( HSV(NR)-SKP ).LE.SRRTOL*SKP ) THEN - NR = NR - 1 - GO TO 30 - END IF - END IF -C -C Determine KR, the multiplicity of HSV(NR+1). -C - KR = 1 - DO 40 I = NR+2, NMINR - IF( ABS( HSV(I)-SKP ).GT.SRRTOL*SKP ) GO TO 50 - KR = KR + 1 - 40 CONTINUE - 50 CONTINUE -C -C For discrete-time case, apply the discrete-to-continuous bilinear -C transformation. -C - IF( DISCR ) THEN -C -C Workspace: need N; -C prefer larger. -C - CALL AB04MD( 'Discrete', NMINR, M, P, ONE, ONE, A, LDA, B, LDB, - $ C, LDC, D, LDD, IWORK, DWORK, LDWORK, INFO ) - WRKOPT = MAX( WRKOPT, INT( DWORK(1) ) ) - END IF -C -C Define leading dimensions and offsets for temporary data. -C - NU = NMINR - NR - KR - NA = NR + NU - LDB1 = NA - LDC1 = P - LDB2 = KR - LDC2T = MAX( KR, M ) - NR1 = NR + 1 - NKR1 = MIN( NMINR, NR1 + KR ) -C - KHSVP = 1 - KHSVP2 = KHSVP + NA - KU = KHSVP2 + NA - KB1 = KU + P*M - KB2 = KB1 + LDB1*M - KC1 = KB2 + LDB2*M - KC2T = KC1 + LDC1*NA - KW = KC2T + LDC2T*P -C -C Save B2 and C2'. -C - CALL DLACPY( 'Full', KR, M, B(NR1,1), LDB, DWORK(KB2), LDB2 ) - CALL MA02AD( 'Full', P, KR, C(1,NR1), LDC, DWORK(KC2T), LDC2T ) - IF( NR.GT.0 ) THEN -C -C Permute the elements of HSV and of matrices A, B, C. -C - CALL DCOPY( NR, HSV(1), 1, DWORK(KHSVP), 1 ) - CALL DCOPY( NU, HSV(NKR1), 1, DWORK(KHSVP+NR), 1 ) - CALL DLACPY( 'Full', NMINR, NU, A(1,NKR1), LDA, A(1,NR1), LDA ) - CALL DLACPY( 'Full', NU, NA, A(NKR1,1), LDA, A(NR1,1), LDA ) - CALL DLACPY( 'Full', NU, M, B(NKR1,1), LDB, B(NR1,1), LDB ) - CALL DLACPY( 'Full', P, NU, C(1,NKR1), LDC, C(1,NR1), LDC ) -C -C Save B1 and C1. -C - CALL DLACPY( 'Full', NA, M, B, LDB, DWORK(KB1), LDB1 ) - CALL DLACPY( 'Full', P, NA, C, LDC, DWORK(KC1), LDC1 ) - END IF -C -C Compute U = C2*pinv(B2'). -C Workspace: need N*(M+P+2) + 2*M*P + -C max(min(KR,M)+3*M+1,2*min(KR,M)+P); -C prefer N*(M+P+2) + 2*M*P + -C max(min(KR,M)+2*M+(M+1)*NB,2*min(KR,M)+P*NB), -C where NB is the maximum of the block sizes for -C DGEQP3, DTZRZF, DTZRQF, DORMQR, and DORMRZ. -C - DO 55 J = 1, M - IWORK(J) = 0 - 55 CONTINUE - CALL DGELSY( KR, M, P, DWORK(KB2), LDB2, DWORK(KC2T), LDC2T, - $ IWORK, RTOL, IRANK, DWORK(KW), LDWORK-KW+1, IERR ) - WRKOPT = MAX( WRKOPT, INT( DWORK(KW) ) + KW - 1 ) - CALL MA02AD( 'Full', M, P, DWORK(KC2T), LDC2T, DWORK(KU), P ) -C -C Compute D <- D + HSV(NR+1)*U. -C - I = KU - DO 60 J = 1, M - CALL DAXPY( P, SKP, DWORK(I), 1, D(1,J), 1 ) - I = I + P - 60 CONTINUE -C - IF( NR.GT.0 ) THEN - SKP2 = SKP*SKP -C -C Compute G = inv(S1*S1-skp*skp*I), where S1 is the diagonal -C matrix of relevant singular values (of order NMINR - KR). -C - I1 = KHSVP2 - DO 70 I = KHSVP, KHSVP+NA-1 - DWORK(I1) = ONE / ( DWORK(I)*DWORK(I) - SKP2 ) - I1 = I1 + 1 - 70 CONTINUE -C -C Compute C <- C1*S1-skp*U*B1'. -C - CALL MB01SD( 'Column', P, NA, C, LDC, DWORK, DWORK(KHSVP) ) - CALL DGEMM( 'NoTranspose', 'Transpose', P, NA, M, -SKP, - $ DWORK(KU), P, DWORK(KB1), LDB1, ONE, C, LDC ) -C -C Compute B <- G*(S1*B1-skp*C1'*U). -C - CALL MB01SD( 'Row', NA, M, B, LDB, DWORK(KHSVP), DWORK ) - CALL DGEMM( 'Transpose', 'NoTranspose', NA, M, P, -SKP, - $ DWORK(KC1), LDC1, DWORK(KU), P, ONE, B, LDB ) - CALL MB01SD( 'Row', NA, M, B, LDB, DWORK(KHSVP2), DWORK ) -C -C Compute A <- -A1' - B*B1'. -C - DO 80 J = 2, NA - CALL DSWAP( J-1, A(1,J), 1, A(J,1), LDA ) - 80 CONTINUE - CALL DGEMM( 'NoTranspose', 'Transpose', NA, NA, M, -ONE, B, - $ LDB, DWORK(KB1), LDB1, -ONE, A, LDA ) -C -C Extract stable part. -C Workspace: need N*N+5*N; -C prefer larger. -C - KW1 = NA*NA + 1 - KW2 = KW1 + NA - KW = KW2 + NA - CALL TB01KD( 'Continuous', 'Stability', 'General', NA, M, P, - $ ZERO, A, LDA, B, LDB, C, LDC, NDIM, DWORK, NA, - $ DWORK(KW1), DWORK(KW2), DWORK(KW), LDWORK-KW+1, - $ IERR ) - IF( IERR.NE.0 ) THEN - INFO = 3 - RETURN - END IF -C - IF( NDIM.NE.NR ) THEN - INFO = 4 - RETURN - END IF - WRKOPT = MAX( WRKOPT, INT( DWORK(KW) ) + KW - 1 ) -C -C For discrete-time case, apply the continuous-to-discrete -C bilinear transformation. -C - IF( DISCR ) - $ CALL AB04MD( 'Continuous', NR, M, P, ONE, ONE, A, LDA, B, - $ LDB, C, LDC, D, LDD, IWORK, DWORK, LDWORK, - $ INFO ) - END IF - IWORK(1) = NMINR - DWORK(1) = WRKOPT -C - RETURN -C *** Last line of AB09CX *** - END diff --git a/mex/sources/libslicot/AB09DD.f b/mex/sources/libslicot/AB09DD.f deleted file mode 100644 index 0ba78924c..000000000 --- a/mex/sources/libslicot/AB09DD.f +++ /dev/null @@ -1,278 +0,0 @@ - SUBROUTINE AB09DD( DICO, N, M, P, NR, A, LDA, B, LDB, C, LDC, - $ D, LDD, RCOND, IWORK, DWORK, INFO ) -C -C SLICOT RELEASE 5.0. -C -C Copyright (c) 2002-2009 NICONET e.V. -C -C This program is free software: you can redistribute it and/or -C modify it under the terms of the GNU General Public License as -C published by the Free Software Foundation, either version 2 of -C the License, or (at your option) any later version. -C -C This program is distributed in the hope that it will be useful, -C but WITHOUT ANY WARRANTY; without even the implied warranty of -C MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the -C GNU General Public License for more details. -C -C You should have received a copy of the GNU General Public License -C along with this program. If not, see -C . -C -C PURPOSE -C -C To compute a reduced order model by using singular perturbation -C approximation formulas. -C -C ARGUMENTS -C -C Mode Parameters -C -C DICO CHARACTER*1 -C Specifies the type of the original system as follows: -C = 'C': continuous-time system; -C = 'D': discrete-time system. -C -C Input/Output Parameters -C -C N (input) INTEGER -C The dimension of the state vector, i.e. the order of the -C matrix A; also the number of rows of matrix B and the -C number of columns of the matrix C. N >= 0. -C -C M (input) INTEGER -C The dimension of input vector, i.e. the number of columns -C of matrices B and D. M >= 0. -C -C P (input) INTEGER -C The dimension of output vector, i.e. the number of rows of -C matrices C and D. P >= 0. -C -C NR (input) INTEGER -C The order of the reduced order system. N >= NR >= 0. -C -C A (input/output) DOUBLE PRECISION array, dimension (LDA,N) -C On entry, the leading N-by-N part of this array must -C contain the state dynamics matrix of the original system. -C On exit, the leading NR-by-NR part of this array contains -C the state dynamics matrix Ar of the reduced order system. -C -C LDA INTEGER -C The leading dimension of array A. LDA >= MAX(1,N). -C -C B (input/output) DOUBLE PRECISION array, dimension (LDB,M) -C On entry, the leading N-by-M part of this array must -C contain the input/state matrix of the original system. -C On exit, the leading NR-by-M part of this array contains -C the input/state matrix Br of the reduced order system. -C -C LDB INTEGER -C The leading dimension of array B. LDB >= MAX(1,N). -C -C C (input/output) DOUBLE PRECISION array, dimension (LDC,N) -C On entry, the leading P-by-N part of this array must -C contain the state/output matrix of the original system. -C On exit, the leading P-by-NR part of this array contains -C the state/output matrix Cr of the reduced order system. -C -C LDC INTEGER -C The leading dimension of array C. LDC >= MAX(1,P). -C -C D (input/output) DOUBLE PRECISION array, dimension (LDD,M) -C On entry, the leading P-by-M part of this array must -C contain the input/output matrix of the original system. -C On exit, the leading P-by-M part of this array contains -C the input/output matrix Dr of the reduced order system. -C If NR = 0 and the given system is stable, then D contains -C the steady state gain of the system. -C -C LDD INTEGER -C The leading dimension of array D. LDD >= MAX(1,P). -C -C RCOND (output) DOUBLE PRECISION -C The reciprocal condition number of the matrix A22-g*I -C (see METHOD). -C -C Workspace -C -C IWORK INTEGER array, dimension 2*(N-NR) -C -C DWORK DOUBLE PRECISION array, dimension 4*(N-NR) -C -C Error Indicator -C -C INFO INTEGER -C = 0: successful exit; -C < 0: if INFO = -i, the i-th argument had an illegal -C value; -C = 1: if the matrix A22-g*I (see METHOD) is numerically -C singular. -C -C METHOD -C -C Given the system (A,B,C,D), partition the system matrices as -C -C ( A11 A12 ) ( B1 ) -C A = ( ) , B = ( ) , C = ( C1 C2 ), -C ( A21 A22 ) ( B2 ) -C -C where A11 is NR-by-NR, B1 is NR-by-M, C1 is P-by-NR, and the other -C submatrices have appropriate dimensions. -C -C The matrices of the reduced order system (Ar,Br,Cr,Dr) are -C computed according to the following residualization formulas: -C -1 -1 -C Ar = A11 + A12*(g*I-A22) *A21 , Br = B1 + A12*(g*I-A22) *B2 -C -1 -1 -C Cr = C1 + C2*(g*I-A22) *A21 , Dr = D + C2*(g*I-A22) *B2 -C -C where g = 0 if DICO = 'C' and g = 1 if DICO = 'D'. -C -C CONTRIBUTOR -C -C C. Oara and A. Varga, German Aerospace Center, -C DLR Oberpfaffenhofen, March 1998. -C Based on the RASP routine SRESID. -C -C REVISIONS -C -C - -C -C KEYWORDS -C -C Model reduction, multivariable system, state-space model. -C -C ****************************************************************** -C -C .. Parameters .. - DOUBLE PRECISION ONE, ZERO - PARAMETER ( ONE = 1.0D0, ZERO = 0.0D0 ) -C .. Scalar Arguments .. - CHARACTER DICO - INTEGER INFO, LDA, LDB, LDC, LDD, M, N, NR, P - DOUBLE PRECISION RCOND -C .. Array Arguments .. - DOUBLE PRECISION A(LDA,*), B(LDB,*), C(LDC,*), D(LDD,*), DWORK(*) - INTEGER IWORK(*) -C .. Local Scalars - LOGICAL DISCR - INTEGER I, J, K, NS - DOUBLE PRECISION A22NRM -C .. External Functions .. - LOGICAL LSAME - DOUBLE PRECISION DLAMCH, DLANGE - EXTERNAL DLAMCH, DLANGE, LSAME -C .. External Subroutines .. - EXTERNAL DGECON, DGEMM, DGETRF, DGETRS, XERBLA -C .. Intrinsic Functions .. - INTRINSIC MAX -C .. Executable Statements .. -C -C Check the input scalar arguments. -C - INFO = 0 - DISCR = LSAME( DICO, 'D' ) - IF( .NOT. ( LSAME( DICO, 'C' ) .OR. DISCR ) ) THEN - INFO = -1 - ELSE IF( N.LT.0 ) THEN - INFO = -2 - ELSE IF( M.LT.0 ) THEN - INFO = -3 - ELSE IF( P.LT.0 ) THEN - INFO = -4 - ELSE IF( NR.LT.0 .OR. NR.GT.N ) THEN - INFO = -5 - ELSE IF( LDA.LT.MAX( 1, N ) ) THEN - INFO = -7 - ELSE IF( LDB.LT.MAX( 1, N ) ) THEN - INFO = -9 - ELSE IF( LDC.LT.MAX( 1, P ) ) THEN - INFO = -11 - ELSE IF( LDD.LT.MAX( 1, P ) ) THEN - INFO = -13 - END IF -C - IF( INFO.NE.0 ) THEN -C -C Error return. -C - CALL XERBLA( 'AB09DD', -INFO ) - RETURN - END IF -C -C Quick return if possible. -C - IF( NR.EQ.N ) THEN - RCOND = ONE - RETURN - END IF -C - K = NR + 1 - NS = N - NR -C -C Compute: T = -A22 if DICO = 'C' and -C T = -A22+I if DICO = 'D'. -C - DO 20 J = K, N - DO 10 I = K, N - A(I,J) = -A(I,J) - 10 CONTINUE - IF( DISCR ) A(J,J) = A(J,J) + ONE - 20 CONTINUE -C -C Compute the LU decomposition of T. -C - A22NRM = DLANGE( '1-norm', NS, NS, A(K,K), LDA, DWORK ) - CALL DGETRF( NS, NS, A(K,K), LDA, IWORK, INFO ) - IF( INFO.GT.0 ) THEN -C -C Error return. -C - RCOND = ZERO - INFO = 1 - RETURN - END IF - CALL DGECON( '1-norm', NS, A(K,K), LDA, A22NRM, RCOND, DWORK, - $ IWORK(NS+1), INFO ) - IF( RCOND.LE.DLAMCH('E') ) THEN -C -C Error return. -C - INFO = 1 - RETURN - END IF -C -C Compute A21 <- INV(T)*A21. -C - CALL DGETRS( 'NoTranspose', NS, NR, A(K,K), LDA, IWORK, A(K,1), - $ LDA, INFO ) -C -C Compute B2 <- INV(T)*B2. -C - CALL DGETRS( 'NoTranspose', NS, M, A(K,K), LDA, IWORK, B(K,1), - $ LDB, INFO ) -C -C Compute the residualized systems matrices. -C Ar = A11 + A12*INV(T)*A21. -C - CALL DGEMM( 'NoTranspose', 'NoTranspose', NR, NR, NS, ONE, A(1,K), - $ LDA, A(K,1), LDA, ONE, A, LDA ) -C -C Br = B1 + A12*INV(T)*B2. -C - CALL DGEMM( 'NoTranspose', 'NoTranspose', NR, M, NS, ONE, A(1,K), - $ LDA, B(K,1), LDB, ONE, B, LDB ) -C -C Cr = C1 + C2*INV(T)*A21. -C - CALL DGEMM( 'NoTranspose', 'NoTranspose', P, NR, NS, ONE, C(1,K), - $ LDC, A(K,1), LDA, ONE, C, LDC ) -C -C Dr = D + C2*INV(T)*B2. -C - CALL DGEMM( 'NoTranspose', 'NoTranspose', P, M, NS, ONE, C(1,K), - $ LDC, B(K,1), LDB, ONE, D, LDD ) -C - RETURN -C *** Last line of AB09DD *** - END diff --git a/mex/sources/libslicot/AB09ED.f b/mex/sources/libslicot/AB09ED.f deleted file mode 100644 index 7c3afb8e4..000000000 --- a/mex/sources/libslicot/AB09ED.f +++ /dev/null @@ -1,493 +0,0 @@ - SUBROUTINE AB09ED( DICO, EQUIL, ORDSEL, N, M, P, NR, ALPHA, - $ A, LDA, B, LDB, C, LDC, D, LDD, NS, HSV, TOL1, - $ TOL2, IWORK, DWORK, LDWORK, IWARN, INFO ) -C -C SLICOT RELEASE 5.0. -C -C Copyright (c) 2002-2009 NICONET e.V. -C -C This program is free software: you can redistribute it and/or -C modify it under the terms of the GNU General Public License as -C published by the Free Software Foundation, either version 2 of -C the License, or (at your option) any later version. -C -C This program is distributed in the hope that it will be useful, -C but WITHOUT ANY WARRANTY; without even the implied warranty of -C MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the -C GNU General Public License for more details. -C -C You should have received a copy of the GNU General Public License -C along with this program. If not, see -C . -C -C PURPOSE -C -C To compute a reduced order model (Ar,Br,Cr,Dr) for an original -C state-space representation (A,B,C,D) by using the optimal -C Hankel-norm approximation method in conjunction with square-root -C balancing for the ALPHA-stable part of the system. -C -C ARGUMENTS -C -C Mode Parameters -C -C DICO CHARACTER*1 -C Specifies the type of the original system as follows: -C = 'C': continuous-time system; -C = 'D': discrete-time system. -C -C EQUIL CHARACTER*1 -C Specifies whether the user wishes to preliminarily -C equilibrate the triplet (A,B,C) as follows: -C = 'S': perform equilibration (scaling); -C = 'N': do not perform equilibration. -C -C ORDSEL CHARACTER*1 -C Specifies the order selection method as follows: -C = 'F': the resulting order NR is fixed; -C = 'A': the resulting order NR is automatically determined -C on basis of the given tolerance TOL1. -C -C Input/Output Parameters -C -C N (input) INTEGER -C The order of the original state-space representation, i.e. -C the order of the matrix A. N >= 0. -C -C M (input) INTEGER -C The number of system inputs. M >= 0. -C -C P (input) INTEGER -C The number of system outputs. P >= 0. -C -C NR (input/output) INTEGER -C On entry with ORDSEL = 'F', NR is the desired order of -C the resulting reduced order system. 0 <= NR <= N. -C On exit, if INFO = 0, NR is the order of the resulting -C reduced order model. For a system with NU ALPHA-unstable -C eigenvalues and NS ALPHA-stable eigenvalues (NU+NS = N), -C NR is set as follows: if ORDSEL = 'F', NR is equal to -C NU+MIN(MAX(0,NR-NU-KR+1),NMIN), where KR is the -C multiplicity of the Hankel singular value HSV(NR-NU+1), -C NR is the desired order on entry, and NMIN is the order -C of a minimal realization of the ALPHA-stable part of the -C given system; NMIN is determined as the number of Hankel -C singular values greater than NS*EPS*HNORM(As,Bs,Cs), where -C EPS is the machine precision (see LAPACK Library Routine -C DLAMCH) and HNORM(As,Bs,Cs) is the Hankel norm of the -C ALPHA-stable part of the given system (computed in -C HSV(1)); -C if ORDSEL = 'A', NR is the sum of NU and the number of -C Hankel singular values greater than -C MAX(TOL1,NS*EPS*HNORM(As,Bs,Cs)). -C -C ALPHA (input) DOUBLE PRECISION -C Specifies the ALPHA-stability boundary for the eigenvalues -C of the state dynamics matrix A. For a continuous-time -C system (DICO = 'C'), ALPHA <= 0 is the boundary value for -C the real parts of eigenvalues, while for a discrete-time -C system (DICO = 'D'), 0 <= ALPHA <= 1 represents the -C boundary value for the moduli of eigenvalues. -C The ALPHA-stability domain does not include the boundary. -C -C A (input/output) DOUBLE PRECISION array, dimension (LDA,N) -C On entry, the leading N-by-N part of this array must -C contain the state dynamics matrix A. -C On exit, if INFO = 0, the leading NR-by-NR part of this -C array contains the state dynamics matrix Ar of the -C reduced order system in a real Schur form. -C The resulting A has a block-diagonal form with two blocks. -C For a system with NU ALPHA-unstable eigenvalues and -C NS ALPHA-stable eigenvalues (NU+NS = N), the leading -C NU-by-NU block contains the unreduced part of A -C corresponding to ALPHA-unstable eigenvalues. -C The trailing (NR+NS-N)-by-(NR+NS-N) block contains -C the reduced part of A corresponding to ALPHA-stable -C eigenvalues. -C -C LDA INTEGER -C The leading dimension of array A. LDA >= MAX(1,N). -C -C B (input/output) DOUBLE PRECISION array, dimension (LDB,M) -C On entry, the leading N-by-M part of this array must -C contain the original input/state matrix B. -C On exit, if INFO = 0, the leading NR-by-M part of this -C array contains the input/state matrix Br of the reduced -C order system. -C -C LDB INTEGER -C The leading dimension of array B. LDB >= MAX(1,N). -C -C C (input/output) DOUBLE PRECISION array, dimension (LDC,N) -C On entry, the leading P-by-N part of this array must -C contain the original state/output matrix C. -C On exit, if INFO = 0, the leading P-by-NR part of this -C array contains the state/output matrix Cr of the reduced -C order system. -C -C LDC INTEGER -C The leading dimension of array C. LDC >= MAX(1,P). -C -C D (input/output) DOUBLE PRECISION array, dimension (LDD,M) -C On entry, the leading P-by-M part of this array must -C contain the original input/output matrix D. -C On exit, if INFO = 0, the leading P-by-M part of this -C array contains the input/output matrix Dr of the reduced -C order system. -C -C LDD INTEGER -C The leading dimension of array D. LDD >= MAX(1,P). -C -C NS (output) INTEGER -C The dimension of the ALPHA-stable subsystem. -C -C HSV (output) DOUBLE PRECISION array, dimension (N) -C If INFO = 0, the leading NS elements of HSV contain the -C Hankel singular values of the ALPHA-stable part of the -C original system ordered decreasingly. -C HSV(1) is the Hankel norm of the ALPHA-stable subsystem. -C -C Tolerances -C -C TOL1 DOUBLE PRECISION -C If ORDSEL = 'A', TOL1 contains the tolerance for -C determining the order of reduced system. -C For model reduction, the recommended value is -C TOL1 = c*HNORM(As,Bs,Cs), where c is a constant in the -C interval [0.00001,0.001], and HNORM(As,Bs,Cs) is the -C Hankel-norm of the ALPHA-stable part of the given system -C (computed in HSV(1)). -C If TOL1 <= 0 on entry, the used default value is -C TOL1 = NS*EPS*HNORM(As,Bs,Cs), where NS is the number of -C ALPHA-stable eigenvalues of A and EPS is the machine -C precision (see LAPACK Library Routine DLAMCH). -C This value is appropriate to compute a minimal realization -C of the ALPHA-stable part. -C If ORDSEL = 'F', the value of TOL1 is ignored. -C -C TOL2 DOUBLE PRECISION -C The tolerance for determining the order of a minimal -C realization of the ALPHA-stable part of the given system. -C The recommended value is TOL2 = NS*EPS*HNORM(As,Bs,Cs). -C This value is used by default if TOL2 <= 0 on entry. -C If TOL2 > 0, then TOL2 <= TOL1. -C -C Workspace -C -C IWORK INTEGER array, dimension (LIWORK) -C LIWORK = MAX(1,M), if DICO = 'C'; -C LIWORK = MAX(1,N,M), if DICO = 'D'. -C On exit, if INFO = 0, IWORK(1) contains NMIN, the order of -C the computed minimal realization. -C -C DWORK DOUBLE PRECISION array, dimension (LDWORK) -C On exit, if INFO = 0, DWORK(1) returns the optimal value -C of LDWORK. -C -C LDWORK INTEGER -C The length of the array DWORK. -C LDWORK >= MAX( LDW1, LDW2 ), where -C LDW1 = N*(2*N + MAX(N,M,P) + 5) + N*(N+1)/2, -C LDW2 = N*(M+P+2) + 2*M*P + MIN(N,M) + -C MAX( 3*M+1, MIN(N,M)+P ). -C For optimum performance LDWORK should be larger. -C -C Warning Indicator -C -C IWARN INTEGER -C = 0: no warning; -C = 1: with ORDSEL = 'F', the selected order NR is greater -C than NSMIN, the sum of the order of the -C ALPHA-unstable part and the order of a minimal -C realization of the ALPHA-stable part of the given -C system. In this case, the resulting NR is set equal -C to NSMIN. -C = 2: with ORDSEL = 'F', the selected order NR is less -C than the order of the ALPHA-unstable part of the -C given system. In this case NR is set equal to the -C order of the ALPHA-unstable part. -C -C Error Indicator -C -C INFO INTEGER -C = 0: successful exit; -C < 0: if INFO = -i, the i-th argument had an illegal -C value; -C = 1: the computation of the ordered real Schur form of A -C failed; -C = 2: the separation of the ALPHA-stable/unstable diagonal -C blocks failed because of very close eigenvalues; -C = 3: the computed ALPHA-stable part is just stable, -C having stable eigenvalues very near to the imaginary -C axis (if DICO = 'C') or to the unit circle -C (if DICO = 'D'); -C = 4: the computation of Hankel singular values failed; -C = 5: the computation of stable projection in the -C Hankel-norm approximation algorithm failed; -C = 6: the order of computed stable projection in the -C Hankel-norm approximation algorithm differs -C from the order of Hankel-norm approximation. -C -C METHOD -C -C Let be the following linear system -C -C d[x(t)] = Ax(t) + Bu(t) -C y(t) = Cx(t) + Du(t) (1) -C -C where d[x(t)] is dx(t)/dt for a continuous-time system and x(t+1) -C for a discrete-time system. The subroutine AB09ED determines for -C the given system (1), the matrices of a reduced order system -C -C d[z(t)] = Ar*z(t) + Br*u(t) -C yr(t) = Cr*z(t) + Dr*u(t) (2) -C -C such that -C -C HSV(NR+NS-N) <= INFNORM(G-Gr) <= 2*[HSV(NR+NS-N+1)+...+HSV(NS)], -C -C where G and Gr are transfer-function matrices of the systems -C (A,B,C,D) and (Ar,Br,Cr,Dr), respectively, and INFNORM(G) is the -C infinity-norm of G. -C -C The following procedure is used to reduce a given G: -C -C 1) Decompose additively G as -C -C G = G1 + G2 -C -C such that G1 = (As,Bs,Cs,D) has only ALPHA-stable poles and -C G2 = (Au,Bu,Cu,0) has only ALPHA-unstable poles. -C -C 2) Determine G1r, a reduced order approximation of the -C ALPHA-stable part G1. -C -C 3) Assemble the reduced model Gr as -C -C Gr = G1r + G2. -C -C To reduce the ALPHA-stable part G1, the optimal Hankel-norm -C approximation method of [1], based on the square-root -C balancing projection formulas of [2], is employed. -C -C REFERENCES -C -C [1] Glover, K. -C All optimal Hankel norm approximation of linear -C multivariable systems and their L-infinity error bounds. -C Int. J. Control, Vol. 36, pp. 1145-1193, 1984. -C -C [2] Tombs M.S. and Postlethwaite I. -C Truncated balanced realization of stable, non-minimal -C state-space systems. -C Int. J. Control, Vol. 46, pp. 1319-1330, 1987. -C -C NUMERICAL ASPECTS -C -C The implemented methods rely on an accuracy enhancing square-root -C technique. -C 3 -C The algorithms require less than 30N floating point operations. -C -C CONTRIBUTOR -C -C C. Oara and A. Varga, German Aerospace Center, -C DLR Oberpfaffenhofen, July 1998. -C Based on the RASP routines SADSDC and OHNAP. -C -C REVISIONS -C -C Nov. 1998, V. Sima, Research Institute for Informatics, Bucharest. -C Dec. 1998, V. Sima, Katholieke Univ. Leuven, Leuven. -C Nov. 2000, A. Varga, DLR Oberpfaffenhofen. -C March 26, 2005, V. Sima, Research Institute for Informatics. -C -C KEYWORDS -C -C Balancing, Hankel-norm approximation, model reduction, -C multivariable system, state-space model. -C -C ****************************************************************** -C -C .. Parameters .. - DOUBLE PRECISION C100, ONE, ZERO - PARAMETER ( C100 = 100.0D0, ONE = 1.0D0, ZERO = 0.0D0 ) -C .. Scalar Arguments .. - CHARACTER DICO, EQUIL, ORDSEL - INTEGER INFO, IWARN, LDA, LDB, LDC, LDD, LDWORK, - $ M, N, NR, NS, P - DOUBLE PRECISION ALPHA, TOL1, TOL2 -C .. Array Arguments .. - INTEGER IWORK(*) - DOUBLE PRECISION A(LDA,*), B(LDB,*), C(LDC,*), D(LDD,*), - $ DWORK(*), HSV(*) -C .. Local Scalars .. - LOGICAL DISCR, FIXORD - INTEGER IERR, IWARNL, KI, KL, KU, KW, NRA, NU, NU1 - DOUBLE PRECISION ALPWRK, MAXRED, WRKOPT -C .. External Functions .. - LOGICAL LSAME - DOUBLE PRECISION DLAMCH - EXTERNAL DLAMCH, LSAME -C .. External Subroutines .. - EXTERNAL AB09CX, TB01ID, TB01KD, XERBLA -C .. Intrinsic Functions .. - INTRINSIC MAX, MIN, SQRT -C .. Executable Statements .. -C - INFO = 0 - IWARN = 0 - DISCR = LSAME( DICO, 'D' ) - FIXORD = LSAME( ORDSEL, 'F' ) -C -C Check the input scalar arguments. -C - IF( .NOT. ( LSAME( DICO, 'C' ) .OR. DISCR ) ) THEN - INFO = -1 - ELSE IF( .NOT. ( LSAME( EQUIL, 'S' ) .OR. - $ LSAME( EQUIL, 'N' ) ) ) THEN - INFO = -2 - ELSE IF( .NOT. ( FIXORD .OR. LSAME( ORDSEL, 'A' ) ) ) THEN - INFO = -3 - ELSE IF( N.LT.0 ) THEN - INFO = -4 - ELSE IF( M.LT.0 ) THEN - INFO = -5 - ELSE IF( P.LT.0 ) THEN - INFO = -6 - ELSE IF( FIXORD .AND. ( NR.LT.0 .OR. NR.GT.N ) ) THEN - INFO = -7 - ELSE IF( ( DISCR .AND. ( ALPHA.LT.ZERO .OR. ALPHA.GT.ONE ) ) .OR. - $ ( .NOT.DISCR .AND. ALPHA.GT.ZERO ) ) THEN - INFO = -8 - ELSE IF( LDA.LT.MAX( 1, N ) ) THEN - INFO = -10 - ELSE IF( LDB.LT.MAX( 1, N ) ) THEN - INFO = -12 - ELSE IF( LDC.LT.MAX( 1, P ) ) THEN - INFO = -14 - ELSE IF( LDD.LT.MAX( 1, P ) ) THEN - INFO = -16 - ELSE IF( TOL2.GT.ZERO .AND. TOL2.GT.TOL1 ) THEN - INFO = -20 - ELSE IF( LDWORK.LT.MAX( N*( 2*N + MAX( N, M, P ) + 5 ) + - $ ( N*( N + 1 ) )/2, - $ N*( M + P + 2 ) + 2*M*P + MIN( N, M ) + - $ MAX ( 3*M + 1, MIN( N, M ) + P ) ) ) THEN - INFO = -23 - END IF -C - IF( INFO.NE.0 ) THEN -C -C Error return. -C - CALL XERBLA( 'AB09ED', -INFO ) - RETURN - END IF -C -C Quick return if possible. -C - IF( MIN( N, M, P ).EQ.0 ) THEN - NR = 0 - NS = 0 - IWORK(1) = 0 - DWORK(1) = ONE - RETURN - END IF -C - IF( LSAME( EQUIL, 'S' ) ) THEN -C -C Scale simultaneously the matrices A, B and C: -C A <- inv(D)*A*D, B <- inv(D)*B and C <- C*D, where D is a -C diagonal matrix. -C Workspace: N. -C - MAXRED = C100 - CALL TB01ID( 'All', N, M, P, MAXRED, A, LDA, B, LDB, C, LDC, - $ DWORK, INFO ) - END IF -C -C Correct the value of ALPHA to ensure stability. -C - ALPWRK = ALPHA - IF( DISCR ) THEN - IF( ALPHA.EQ.ONE ) ALPWRK = ONE - SQRT( DLAMCH( 'E' ) ) - ELSE - IF( ALPHA.EQ.ZERO ) ALPWRK = -SQRT( DLAMCH( 'E' ) ) - END IF -C -C Allocate working storage. -C - KU = 1 - KL = KU + N*N - KI = KL + N - KW = KI + N -C -C Reduce A to a block-diagonal real Schur form, with the -C ALPHA-unstable part in the leading diagonal position, using a -C non-orthogonal similarity transformation A <- inv(T)*A*T and -C apply the transformation to B and C: B <- inv(T)*B and C <- C*T. -C -C Workspace needed: N*(N+2); -C Additional workspace: need 3*N; -C prefer larger. -C - CALL TB01KD( DICO, 'Unstable', 'General', N, M, P, ALPWRK, A, LDA, - $ B, LDB, C, LDC, NU, DWORK(KU), N, DWORK(KL), - $ DWORK(KI), DWORK(KW), LDWORK-KW+1, IERR ) -C - IF( IERR.NE.0 ) THEN - IF( IERR.NE.3 ) THEN - INFO = 1 - ELSE - INFO = 2 - END IF - RETURN - END IF -C - WRKOPT = DWORK(KW) + DBLE( KW-1 ) -C -C Determine a reduced order approximation of the ALPHA-stable part. -C -C Workspace: need MAX( LDW1, LDW2 ), -C LDW1 = N*(2*N + MAX(N,M,P) + 5) + N*(N+1)/2, -C LDW2 = N*(M+P+2) + 2*M*P + MIN(N,M) + -C MAX( 3*M+1, MIN(N,M)+P ); -C prefer larger. -C - IWARNL = 0 - NS = N - NU - IF( FIXORD ) THEN - NRA = MAX( 0, NR-NU ) - IF( NR.LT.NU ) - $ IWARNL = 2 - ELSE - NRA = 0 - END IF -C -C Finish if only unstable part is present. -C - IF( NS.EQ.0 ) THEN - NR = NU - DWORK(1) = WRKOPT - RETURN - END IF -C - NU1 = NU + 1 - CALL AB09CX( DICO, ORDSEL, NS, M, P, NRA, A(NU1,NU1), LDA, - $ B(NU1,1), LDB, C(1,NU1), LDC, D, LDD, HSV, TOL1, - $ TOL2, IWORK, DWORK, LDWORK, IWARN, IERR ) -C - IWARN = MAX( IWARN, IWARNL ) - IF( IERR.NE.0 ) THEN - INFO = IERR + 2 - RETURN - END IF -C - NR = NRA + NU -C - DWORK(1) = MAX( WRKOPT, DWORK(1) ) -C - RETURN -C *** Last line of AB09ED *** - END diff --git a/mex/sources/libslicot/AB09FD.f b/mex/sources/libslicot/AB09FD.f deleted file mode 100644 index cb954ba15..000000000 --- a/mex/sources/libslicot/AB09FD.f +++ /dev/null @@ -1,649 +0,0 @@ - SUBROUTINE AB09FD( DICO, JOBCF, FACT, JOBMR, EQUIL, ORDSEL, N, M, - $ P, NR, ALPHA, A, LDA, B, LDB, C, LDC, NQ, HSV, - $ TOL1, TOL2, IWORK, DWORK, LDWORK, IWARN, INFO ) -C -C SLICOT RELEASE 5.0. -C -C Copyright (c) 2002-2009 NICONET e.V. -C -C This program is free software: you can redistribute it and/or -C modify it under the terms of the GNU General Public License as -C published by the Free Software Foundation, either version 2 of -C the License, or (at your option) any later version. -C -C This program is distributed in the hope that it will be useful, -C but WITHOUT ANY WARRANTY; without even the implied warranty of -C MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the -C GNU General Public License for more details. -C -C You should have received a copy of the GNU General Public License -C along with this program. If not, see -C . -C -C PURPOSE -C -C To compute a reduced order model (Ar,Br,Cr) for an original -C state-space representation (A,B,C) by using either the square-root -C or the balancing-free square-root Balance & Truncate (B & T) -C model reduction method in conjunction with stable coprime -C factorization techniques. -C -C ARGUMENTS -C -C Mode Parameters -C -C DICO CHARACTER*1 -C Specifies the type of the original system as follows: -C = 'C': continuous-time system; -C = 'D': discrete-time system. -C -C JOBCF CHARACTER*1 -C Specifies whether left or right coprime factorization is -C to be used as follows: -C = 'L': use left coprime factorization; -C = 'R': use right coprime factorization. -C -C FACT CHARACTER*1 -C Specifies the type of coprime factorization to be computed -C as follows: -C = 'S': compute a coprime factorization with prescribed -C stability degree ALPHA; -C = 'I': compute a coprime factorization with inner -C denominator. -C -C JOBMR CHARACTER*1 -C Specifies the model reduction approach to be used -C as follows: -C = 'B': use the square-root Balance & Truncate method; -C = 'N': use the balancing-free square-root -C Balance & Truncate method. -C -C EQUIL CHARACTER*1 -C Specifies whether the user wishes to preliminarily -C equilibrate the triplet (A,B,C) as follows: -C = 'S': perform equilibration (scaling); -C = 'N': do not perform equilibration. -C -C ORDSEL CHARACTER*1 -C Specifies the order selection method as follows: -C = 'F': the resulting order NR is fixed; -C = 'A': the resulting order NR is automatically determined -C on basis of the given tolerance TOL1. -C -C Input/Output Parameters -C -C N (input) INTEGER -C The order of the original state-space representation, i.e. -C the order of the matrix A. N >= 0. -C -C M (input) INTEGER -C The number of system inputs. M >= 0. -C -C P (input) INTEGER -C The number of system outputs. P >= 0. -C -C NR (input/output) INTEGER -C On entry with ORDSEL = 'F', NR is the desired order of the -C resulting reduced order system. 0 <= NR <= N. -C On exit, if INFO = 0, NR is the order of the resulting -C reduced order model. NR is set as follows: -C if ORDSEL = 'F', NR is equal to MIN(NR,NQ,NMIN), where NR -C is the desired order on entry, NQ is the order of the -C computed coprime factorization of the given system, and -C NMIN is the order of a minimal realization of the extended -C system (see METHOD); NMIN is determined as the number of -C Hankel singular values greater than NQ*EPS*HNORM(Ge), -C where EPS is the machine precision (see LAPACK Library -C Routine DLAMCH) and HNORM(Ge) is the Hankel norm of the -C extended system (computed in HSV(1)); -C if ORDSEL = 'A', NR is equal to the number of Hankel -C singular values greater than MAX(TOL1,NQ*EPS*HNORM(Ge)). -C -C ALPHA (input) DOUBLE PRECISION -C If FACT = 'S', the desired stability degree for the -C factors of the coprime factorization (see SLICOT Library -C routines SB08ED/SB08FD). -C ALPHA < 0 for a continuous-time system (DICO = 'C'), and -C 0 <= ALPHA < 1 for a discrete-time system (DICO = 'D'). -C If FACT = 'I', ALPHA is not used. -C -C A (input/output) DOUBLE PRECISION array, dimension (LDA,N) -C On entry, the leading N-by-N part of this array must -C contain the original state dynamics matrix A. -C On exit, if INFO = 0, the leading NR-by-NR part of this -C array contains the state dynamics matrix Ar of the reduced -C order system. -C -C LDA INTEGER -C The leading dimension of array A. LDA >= MAX(1,N). -C -C B (input/output) DOUBLE PRECISION array, dimension (LDB,M) -C On entry, the leading N-by-M part of this array must -C contain the original input/state matrix B. -C On exit, if INFO = 0, the leading NR-by-M part of this -C array contains the input/state matrix Br of the reduced -C order system. -C -C LDB INTEGER -C The leading dimension of array B. LDB >= MAX(1,N). -C -C C (input/output) DOUBLE PRECISION array, dimension (LDC,N) -C On entry, the leading P-by-N part of this array must -C contain the original state/output matrix C. -C On exit, if INFO = 0, the leading P-by-NR part of this -C array contains the state/output matrix Cr of the reduced -C order system. -C -C LDC INTEGER -C The leading dimension of array C. LDC >= MAX(1,P). -C -C NQ (output) INTEGER -C The order of the computed extended system Ge (see METHOD). -C -C HSV (output) DOUBLE PRECISION array, dimension (N) -C If INFO = 0, it contains the NQ Hankel singular values of -C the extended system Ge ordered decreasingly (see METHOD). -C -C Tolerances -C -C TOL1 DOUBLE PRECISION -C If ORDSEL = 'A', TOL1 contains the tolerance for -C determining the order of reduced extended system. -C For model reduction, the recommended value is -C TOL1 = c*HNORM(Ge), where c is a constant in the -C interval [0.00001,0.001], and HNORM(Ge) is the -C Hankel-norm of the extended system (computed in HSV(1)). -C The value TOL1 = NQ*EPS*HNORM(Ge) is used by default if -C TOL1 <= 0 on entry, where EPS is the machine precision -C (see LAPACK Library Routine DLAMCH). -C If ORDSEL = 'F', the value of TOL1 is ignored. -C -C TOL2 DOUBLE PRECISION -C The absolute tolerance level below which the elements of -C B or C are considered zero (used for controllability or -C observability tests). -C If the user sets TOL2 <= 0, then an implicitly computed, -C default tolerance TOLDEF is used: -C TOLDEF = N*EPS*NORM(C'), if JOBCF = 'L', or -C TOLDEF = N*EPS*NORM(B), if JOBCF = 'R', -C where EPS is the machine precision, and NORM(.) denotes -C the 1-norm of a matrix. -C -C Workspace -C -C IWORK INTEGER array, dimension (LIWORK) -C LIWORK = PM, if JOBMR = 'B', -C LIWORK = MAX(N,PM), if JOBMR = 'N', where -C PM = P, if JOBCF = 'L', -C PM = M, if JOBCF = 'R'. -C -C DWORK DOUBLE PRECISION array, dimension (LDWORK) -C On exit, if INFO = 0, DWORK(1) returns the optimal value -C of LDWORK. -C -C LDWORK INTEGER -C The length of the array DWORK. -C LDWORK >= MAX(1,LW1) if JOBCF = 'L' and FACT = 'S', -C LDWORK >= MAX(1,LW2) if JOBCF = 'L' and FACT = 'I', -C LDWORK >= MAX(1,LW3) if JOBCF = 'R' and FACT = 'S', -C LDWORK >= MAX(1,LW4) if JOBCF = 'R' and FACT = 'I', where -C LW1 = N*(2*MAX(M,P) + P) + MAX(M,P)*(MAX(M,P) + P) + -C MAX( N*P+MAX(N*(N+5), 5*P, 4*M), LWR ), -C LW2 = N*(2*MAX(M,P) + P) + MAX(M,P)*(MAX(M,P) + P) + -C MAX( N*P+MAX(N*(N+5), P*(P+2), 4*P, 4*M), LWR ), -C LW3 = (N+M)*(M+P) + MAX( 5*M, 4*P, LWR ), -C LW4 = (N+M)*(M+P) + MAX( M*(M+2), 4*M, 4*P, LWR ), and -C LWR = 2*N*N + N*(MAX(N,M+P)+5) + N*(N+1)/2. -C For optimum performance LDWORK should be larger. -C -C Warning Indicator -C -C IWARN INTEGER -C = 0: no warning; -C = 10*K+I: -C I = 1: with ORDSEL = 'F', the selected order NR is -C greater than the order of the computed coprime -C factorization of the given system. In this case, -C the resulting NR is set automatically to a value -C corresponding to the order of a minimal -C realization of the system; -C K > 0: K violations of the numerical stability -C condition occured when computing the coprime -C factorization using pole assignment (see SLICOT -C Library routines SB08CD/SB08ED, SB08DD/SB08FD). -C -C Error Indicator -C -C INFO INTEGER -C = 0: successful exit; -C < 0: if INFO = -i, the i-th argument had an illegal -C value; -C = 1: the reduction of A to a real Schur form failed; -C = 2: a failure was detected during the ordering of the -C real Schur form of A, or in the iterative process -C for reordering the eigenvalues of Z'*(A + H*C)*Z -C (or Z'*(A + B*F)*Z) along the diagonal; see SLICOT -C Library routines SB08CD/SB08ED (or SB08DD/SB08FD); -C = 3: the matrix A has an observable or controllable -C eigenvalue on the imaginary axis if DICO = 'C' or -C on the unit circle if DICO = 'D'; -C = 4: the computation of Hankel singular values failed. -C -C METHOD -C -C Let be the linear system -C -C d[x(t)] = Ax(t) + Bu(t) -C y(t) = Cx(t) (1) -C -C where d[x(t)] is dx(t)/dt for a continuous-time system and x(t+1) -C for a discrete-time system, and let G be the corresponding -C transfer-function matrix. The subroutine AB09FD determines -C the matrices of a reduced order system -C -C d[z(t)] = Ar*z(t) + Br*u(t) -C yr(t) = Cr*z(t) (2) -C -C with the transfer-function matrix Gr, by using the -C balanced-truncation model reduction method in conjunction with -C a left coprime factorization (LCF) or a right coprime -C factorization (RCF) technique: -C -C 1. Compute the appropriate stable coprime factorization of G: -C -1 -1 -C G = R *Q (LCF) or G = Q*R (RCF). -C -C 2. Perform the model reduction algorithm on the extended system -C ( Q ) -C Ge = ( Q R ) (LCF) or Ge = ( R ) (RCF) -C -C to obtain a reduced extended system with reduced factors -C ( Qr ) -C Ger = ( Qr Rr ) (LCF) or Ger = ( Rr ) (RCF). -C -C 3. Recover the reduced system from the reduced factors as -C -1 -1 -C Gr = Rr *Qr (LCF) or Gr = Qr*Rr (RCF). -C -C The approximation error for the extended system satisfies -C -C HSV(NR) <= INFNORM(Ge-Ger) <= 2*[HSV(NR+1) + ... + HSV(NQ)], -C -C where INFNORM(G) is the infinity-norm of G. -C -C If JOBMR = 'B', the square-root Balance & Truncate method of [1] -C is used for model reduction. -C If JOBMR = 'N', the balancing-free square-root version of the -C Balance & Truncate method [2] is used for model reduction. -C -C If FACT = 'S', the stable coprime factorization with prescribed -C stability degree ALPHA is computed by using the algorithm of [3]. -C If FACT = 'I', the stable coprime factorization with inner -C denominator is computed by using the algorithm of [4]. -C -C REFERENCES -C -C [1] Tombs M.S. and Postlethwaite I. -C Truncated balanced realization of stable, non-minimal -C state-space systems. -C Int. J. Control, Vol. 46, pp. 1319-1330, 1987. -C -C [2] Varga A. -C Efficient minimal realization procedure based on balancing. -C Proc. of IMACS/IFAC Symp. MCTS, Lille, France, May 1991, -C A. El Moudui, P. Borne, S. G. Tzafestas (Eds.), Vol. 2, -C pp. 42-46, 1991. -C -C [3] Varga A. -C Coprime factors model reduction method based on square-root -C balancing-free techniques. -C System Analysis, Modelling and Simulation, Vol. 11, -C pp. 303-311, 1993. -C -C [4] Varga A. -C A Schur method for computing coprime factorizations with -C inner denominators and applications in model reduction. -C Proc. ACC'93, San Francisco, CA, pp. 2130-2131, 1993. -C -C NUMERICAL ASPECTS -C -C The implemented methods rely on accuracy enhancing square-root or -C balancing-free square-root techniques. -C 3 -C The algorithms require less than 30N floating point operations. -C -C CONTRIBUTOR -C -C C. Oara and A. Varga, German Aerospace Center, -C DLR Oberpfaffenhofen, August 1998. -C -C REVISIONS -C -C Nov. 1998, V. Sima, Research Institute for Informatics, Bucharest. -C Dec. 1998, V. Sima, Katholieke Univ. Leuven, Leuven. -C -C KEYWORDS -C -C Balancing, coprime factorization, minimal realization, -C model reduction, multivariable system, state-space model. -C -C ****************************************************************** -C -C .. Parameters .. - DOUBLE PRECISION C100, ONE, ZERO - PARAMETER ( C100 = 100.0D0, ONE = 1.0D0, ZERO = 0.0D0 ) -C .. Scalar Arguments .. - CHARACTER DICO, EQUIL, FACT, JOBCF, JOBMR, ORDSEL - INTEGER INFO, IWARN, LDA, LDB, LDC, LDWORK, M, N, NQ, - $ NR, P - DOUBLE PRECISION ALPHA, TOL1, TOL2 -C .. Array Arguments .. - INTEGER IWORK(*) - DOUBLE PRECISION A(LDA,*), B(LDB,*), C(LDC,*), DWORK(*), HSV(*) -C .. Local Scalars .. - LOGICAL DISCR, FIXORD, LEFT, STABD - INTEGER IERR, IWARNK, KB, KBR, KBT, KC, KCR, KD, KDR, - $ KDT, KT, KTI, KW, LW1, LW2, LW3, LW4, LWR, - $ MAXMP, MP, NDR, PM, WRKOPT - DOUBLE PRECISION MAXRED -C .. External Functions .. - LOGICAL LSAME - EXTERNAL LSAME -C .. External Subroutines .. - EXTERNAL AB09AX, DLACPY, DLASET, SB08CD, SB08DD, SB08ED, - $ SB08FD, SB08GD, SB08HD, TB01ID, XERBLA -C .. Intrinsic Functions .. - INTRINSIC INT, MAX, MIN -C .. Executable Statements .. -C - INFO = 0 - IWARN = 0 - DISCR = LSAME( DICO, 'D' ) - FIXORD = LSAME( ORDSEL, 'F' ) - LEFT = LSAME( JOBCF, 'L' ) - STABD = LSAME( FACT, 'S' ) - MAXMP = MAX( M, P ) -C - LWR = 2*N*N + N*( MAX( N, M + P ) + 5 ) + ( N*( N + 1 ) )/2 - LW1 = N*( 2*MAXMP + P ) + MAXMP*( MAXMP + P ) - LW2 = LW1 + - $ MAX( N*P + MAX( N*( N + 5 ), P*( P+2 ), 4*P, 4*M ), LWR ) - LW1 = LW1 + MAX( N*P + MAX( N*( N + 5 ), 5*P, 4*M ), LWR ) - LW3 = ( N + M )*( M + P ) + MAX( 5*M, 4*P, LWR ) - LW4 = ( N + M )*( M + P ) + MAX( M*( M + 2 ), 4*M, 4*P, LWR ) -C -C Test the input scalar arguments. -C - IF( .NOT. ( LSAME( DICO, 'C' ) .OR. DISCR ) ) THEN - INFO = -1 - ELSE IF( .NOT. ( LEFT .OR. LSAME( JOBCF, 'R' ) ) ) THEN - INFO = -2 - ELSE IF( .NOT. ( STABD .OR. LSAME( FACT, 'I' ) ) ) THEN - INFO = -3 - ELSE IF( .NOT. ( LSAME( JOBMR, 'B' ) .OR. - $ LSAME( JOBMR, 'N' ) ) ) THEN - INFO = -4 - ELSE IF( .NOT. ( LSAME( EQUIL, 'S' ) .OR. - $ LSAME( EQUIL, 'N' ) ) ) THEN - INFO = -5 - ELSE IF( .NOT. ( FIXORD .OR. LSAME( ORDSEL, 'A' ) ) ) THEN - INFO = -6 - ELSE IF( STABD .AND. ( ( .NOT.DISCR .AND. ALPHA.GE.ZERO ) .OR. - $ ( DISCR .AND. ( ALPHA.LT.ZERO .OR. ALPHA.GE.ONE ) ) ) ) - $ THEN - INFO = -7 - ELSE IF( N.LT.0 ) THEN - INFO = -8 - ELSE IF( M.LT.0 ) THEN - INFO = -9 - ELSE IF( P.LT.0 ) THEN - INFO = -10 - ELSE IF( FIXORD .AND. ( NR.LT.0 .OR. NR.GT.N ) ) THEN - INFO = -11 - ELSE IF( LDA.LT.MAX( 1, N ) ) THEN - INFO = -13 - ELSE IF( LDB.LT.MAX( 1, N ) ) THEN - INFO = -15 - ELSE IF( LDC.LT.MAX( 1, P ) ) THEN - INFO = -17 - ELSE IF( ( LDWORK.LT.1 ) .OR. - $ ( STABD .AND. LEFT .AND. LDWORK.LT.LW1 ) .OR. - $ ( .NOT.STABD .AND. LEFT .AND. LDWORK.LT.LW2 ) .OR. - $ ( STABD .AND. .NOT.LEFT .AND. LDWORK.LT.LW3 ) .OR. - $ ( .NOT.STABD .AND. .NOT.LEFT .AND. LDWORK.LT.LW4 ) ) THEN - INFO = -24 - END IF -C - IF( INFO.NE.0 ) THEN -C -C Error return. -C - CALL XERBLA( 'AB09FD', -INFO ) - RETURN - END IF -C -C Quick return if possible. -C - IF( MIN( N, M, P ).EQ.0 .OR. ( FIXORD .AND. NR.EQ.0 ) ) THEN - NR = 0 - NQ = 0 - DWORK(1) = ONE - RETURN - END IF -C - IF( LSAME( EQUIL, 'S' ) ) THEN -C -C Scale simultaneously the matrices A, B and C: -C A <- inv(D)*A*D, B <- inv(D)*B and C <- C*D, where D is a -C diagonal matrix. -C - MAXRED = C100 - CALL TB01ID( 'A', N, M, P, MAXRED, A, LDA, B, LDB, C, LDC, - $ DWORK, INFO ) - END IF -C -C Perform the coprime factor model reduction procedure. -C - KD = 1 - IF( LEFT ) THEN -C -1 -C Compute a LCF G = R *Q. -C - MP = M + P - KDR = KD + MAXMP*MAXMP - KC = KDR + MAXMP*P - KB = KC + MAXMP*N - KBR = KB + N*MAXMP - KW = KBR + N*P - LWR = LDWORK - KW + 1 - CALL DLACPY( 'Full', N, M, B, LDB, DWORK(KB), N ) - CALL DLACPY( 'Full', P, N, C, LDC, DWORK(KC), MAXMP ) - CALL DLASET( 'Full', P, M, ZERO, ZERO, DWORK(KD), MAXMP ) -C - IF( STABD ) THEN -C -C Compute a LCF with prescribed stability degree. -C -C Workspace needed: N*(2*MAX(M,P)+P) + -C MAX(M,P)*(MAX(M,P)+P); -C Additional workspace: need N*P+MAX(N*(N+5),5*P,4*M); -C prefer larger. -C - CALL SB08ED( DICO, N, M, P, ALPHA, A, LDA, DWORK(KB), N, - $ DWORK(KC), MAXMP, DWORK(KD), MAXMP, NQ, NDR, - $ DWORK(KBR), N, DWORK(KDR), MAXMP, TOL2, - $ DWORK(KW), LWR, IWARN, INFO ) - ELSE -C -C Compute a LCF with inner denominator. -C -C Workspace needed: N*(2*MAX(M,P)+P) + -C MAX(M,P)*(MAX(M,P)+P); -C Additional workspace: need N*P + -C MAX(N*(N+5),P*(P+2),4*P,4*M). -C prefer larger; -C - CALL SB08CD( DICO, N, M, P, A, LDA, DWORK(KB), N, - $ DWORK(KC), MAXMP, DWORK(KD), MAXMP, NQ, NDR, - $ DWORK(KBR), N, DWORK(KDR), MAXMP, TOL2, - $ DWORK(KW), LWR, IWARN, INFO ) - END IF -C - IWARN = 10*IWARN - IF( INFO.NE.0 ) - $ RETURN -C - WRKOPT = INT( DWORK(KW) ) + KW - 1 -C - IF( NQ.EQ.0 ) THEN - NR = 0 - DWORK(1) = WRKOPT - RETURN - END IF -C - IF( MAXMP.GT.M ) THEN -C -C Form the matrices ( BQ, BR ) and ( DQ, DR ) in consecutive -C columns (see SLICOT Library routines SB08CD/SB08ED). -C - KBT = KBR - KBR = KB + N*M - KDT = KDR - KDR = KD + MAXMP*M - CALL DLACPY( 'Full', NQ, P, DWORK(KBT), N, DWORK(KBR), N ) - CALL DLACPY( 'Full', P, P, DWORK(KDT), MAXMP, DWORK(KDR), - $ MAXMP ) - END IF -C -C Perform model reduction on ( Q, R ) to determine ( Qr, Rr ). -C -C Workspace needed: N*(2*MAX(M,P)+P) + -C MAX(M,P)*(MAX(M,P)+P) + 2*N*N; -C Additional workspace: need N*(MAX(N,M+P)+5) + N*(N+1)/2; -C prefer larger. -C - KT = KW - KTI = KT + NQ*NQ - KW = KTI + NQ*NQ - CALL AB09AX( DICO, JOBMR, ORDSEL, NQ, MP, P, NR, A, LDA, - $ DWORK(KB), N, DWORK(KC), MAXMP, HSV, DWORK(KT), - $ N, DWORK(KTI), N, TOL1, IWORK, DWORK(KW), - $ LDWORK-KW+1, IWARNK, IERR ) -C - IWARN = IWARN + IWARNK - IF( IERR.NE.0 ) THEN - INFO = 4 - RETURN - END IF -C - WRKOPT = MAX( WRKOPT, INT( DWORK(KW) ) + KW - 1 ) -C -1 -C Compute the reduced order system Gr = Rr *Qr. -C -C Workspace needed: N*(2*MAX(M,P)+P) + -C MAX(M,P)*(MAX(M,P)+P); -C Additional workspace: need 4*P. -C - KW = KT - CALL SB08GD( NR, M, P, A, LDA, DWORK(KB), N, DWORK(KC), MAXMP, - $ DWORK(KD), MAXMP, DWORK(KBR), N, DWORK(KDR), - $ MAXMP, IWORK, DWORK(KW), INFO ) -C -C Copy the reduced system matrices Br and Cr to B and C. -C - CALL DLACPY( 'Full', NR, M, DWORK(KB), N, B, LDB ) - CALL DLACPY( 'Full', P, NR, DWORK(KC), MAXMP, C, LDC ) -C - ELSE -C -1 -C Compute a RCF G = Q*R . -C - PM = P + M - KDR = KD + P - KC = KD + PM*M - KCR = KC + P - KW = KC + PM*N - LWR = LDWORK - KW + 1 - CALL DLACPY( 'Full', P, N, C, LDC, DWORK(KC), PM ) - CALL DLASET( 'Full', P, M, ZERO, ZERO, DWORK(KD), PM ) -C - IF( STABD ) THEN -C -C Compute a RCF with prescribed stability degree. -C -C Workspace needed: (N+M)*(M+P); -C Additional workspace: need MAX( N*(N+5), 5*M, 4*P ); -C prefer larger. -C - CALL SB08FD( DICO, N, M, P, ALPHA, A, LDA, B, LDB, - $ DWORK(KC), PM, DWORK(KD), PM, NQ, NDR, - $ DWORK(KCR), PM, DWORK(KDR), PM, TOL2, - $ DWORK(KW), LWR, IWARN, INFO ) - ELSE -C -C Compute a RCF with inner denominator. -C -C Workspace needed: (N+M)*(M+P); -C Additional workspace: need MAX(N*(N+5),M*(M+2),4*M,4*P); -C prefer larger. -C - CALL SB08DD( DICO, N, M, P, A, LDA, B, LDB, - $ DWORK(KC), PM, DWORK(KD), PM, NQ, NDR, - $ DWORK(KCR), PM, DWORK(KDR), PM, TOL2, - $ DWORK(KW), LWR, IWARN, INFO ) - END IF -C - IWARN = 10*IWARN - IF( INFO.NE.0 ) - $ RETURN -C - WRKOPT = INT( DWORK(KW) ) + KW - 1 -C - IF( NQ.EQ.0 ) THEN - NR = 0 - DWORK(1) = WRKOPT - RETURN - END IF -C ( Q ) ( Qr ) -C Perform model reduction on ( R ) to determine ( Rr ). -C -C Workspace needed: (N+M)*(M+P) + 2*N*N; -C Additional workspace: need N*(MAX(N,M+P)+5) + N*(N+1)/2; -C prefer larger. -C - KT = KW - KTI = KT + NQ*NQ - KW = KTI + NQ*NQ - CALL AB09AX( DICO, JOBMR, ORDSEL, NQ, M, PM, NR, A, LDA, B, - $ LDB, DWORK(KC), PM, HSV, DWORK(KT), N, DWORK(KTI), - $ N, TOL1, IWORK, DWORK(KW), LDWORK-KW+1, IWARNK, - $ IERR ) -C - IWARN = IWARN + IWARNK - IF( IERR.NE.0 ) THEN - INFO = 4 - RETURN - END IF -C - WRKOPT = MAX( WRKOPT, INT( DWORK(KW) ) + KW - 1 ) -C -1 -C Compute the reduced order system Gr = Qr*Rr . -C -C Workspace needed: (N+M)*(M+P); -C Additional workspace: need 4*M. -C - KW = KT - CALL SB08HD( NR, M, P, A, LDA, B, LDB, DWORK(KC), PM, - $ DWORK(KD), PM, DWORK(KCR), PM, DWORK(KDR), PM, - $ IWORK, DWORK(KW), INFO ) -C -C Copy the reduced system matrix Cr to C. -C - CALL DLACPY( 'Full', P, NR, DWORK(KC), PM, C, LDC ) - END IF -C - DWORK(1) = WRKOPT -C - RETURN -C *** Last line of AB09FD *** - END diff --git a/mex/sources/libslicot/AB09GD.f b/mex/sources/libslicot/AB09GD.f deleted file mode 100644 index c55160369..000000000 --- a/mex/sources/libslicot/AB09GD.f +++ /dev/null @@ -1,681 +0,0 @@ - SUBROUTINE AB09GD( DICO, JOBCF, FACT, JOBMR, EQUIL, ORDSEL, N, M, - $ P, NR, ALPHA, A, LDA, B, LDB, C, LDC, D, LDD, - $ NQ, HSV, TOL1, TOL2, TOL3, IWORK, DWORK, - $ LDWORK, IWARN, INFO ) -C -C SLICOT RELEASE 5.0. -C -C Copyright (c) 2002-2009 NICONET e.V. -C -C This program is free software: you can redistribute it and/or -C modify it under the terms of the GNU General Public License as -C published by the Free Software Foundation, either version 2 of -C the License, or (at your option) any later version. -C -C This program is distributed in the hope that it will be useful, -C but WITHOUT ANY WARRANTY; without even the implied warranty of -C MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the -C GNU General Public License for more details. -C -C You should have received a copy of the GNU General Public License -C along with this program. If not, see -C . -C -C PURPOSE -C -C To compute a reduced order model (Ar,Br,Cr,Dr) for an original -C state-space representation (A,B,C,D) by using either the -C square-root or the balancing-free square-root Singular -C Perturbation Approximation (SPA) model reduction method in -C conjunction with stable coprime factorization techniques. -C -C ARGUMENTS -C -C Mode Parameters -C -C DICO CHARACTER*1 -C Specifies the type of the original system as follows: -C = 'C': continuous-time system; -C = 'D': discrete-time system. -C -C JOBCF CHARACTER*1 -C Specifies whether left or right coprime factorization is -C to be used as follows: -C = 'L': use left coprime factorization; -C = 'R': use right coprime factorization. -C -C FACT CHARACTER*1 -C Specifies the type of coprime factorization to be computed -C as follows: -C = 'S': compute a coprime factorization with prescribed -C stability degree ALPHA; -C = 'I': compute a coprime factorization with inner -C denominator. -C -C JOBMR CHARACTER*1 -C Specifies the model reduction approach to be used -C as follows: -C = 'B': use the square-root Balance & Truncate method; -C = 'N': use the balancing-free square-root -C Balance & Truncate method. -C -C EQUIL CHARACTER*1 -C Specifies whether the user wishes to preliminarily -C equilibrate the triplet (A,B,C) as follows: -C = 'S': perform equilibration (scaling); -C = 'N': do not perform equilibration. -C -C ORDSEL CHARACTER*1 -C Specifies the order selection method as follows: -C = 'F': the resulting order NR is fixed; -C = 'A': the resulting order NR is automatically determined -C on basis of the given tolerance TOL1. -C -C Input/Output Parameters -C -C N (input) INTEGER -C The order of the original state-space representation, i.e. -C the order of the matrix A. N >= 0. -C -C M (input) INTEGER -C The number of system inputs. M >= 0. -C -C P (input) INTEGER -C The number of system outputs. P >= 0. -C -C NR (input/output) INTEGER -C On entry with ORDSEL = 'F', NR is the desired order of the -C resulting reduced order system. 0 <= NR <= N. -C On exit, if INFO = 0, NR is the order of the resulting -C reduced order model. NR is set as follows: -C if ORDSEL = 'F', NR is equal to MIN(NR,NQ,NMIN), where NR -C is the desired order on entry, NQ is the order of the -C computed coprime factorization of the given system, and -C NMIN is the order of a minimal realization of the extended -C system (see METHOD); NMIN is determined as the number of -C Hankel singular values greater than NQ*EPS*HNORM(Ge), -C where EPS is the machine precision (see LAPACK Library -C Routine DLAMCH) and HNORM(Ge) is the Hankel norm of the -C extended system (computed in HSV(1)); -C if ORDSEL = 'A', NR is equal to the number of Hankel -C singular values greater than MAX(TOL1,NQ*EPS*HNORM(Ge)). -C -C ALPHA (input) DOUBLE PRECISION -C If FACT = 'S', the desired stability degree for the -C factors of the coprime factorization (see SLICOT Library -C routines SB08ED/SB08FD). -C ALPHA < 0 for a continuous-time system (DICO = 'C'), and -C 0 <= ALPHA < 1 for a discrete-time system (DICO = 'D'). -C If FACT = 'I', ALPHA is not used. -C -C A (input/output) DOUBLE PRECISION array, dimension (LDA,N) -C On entry, the leading N-by-N part of this array must -C contain the original state dynamics matrix A. -C On exit, if INFO = 0, the leading NR-by-NR part of this -C array contains the state dynamics matrix Ar of the reduced -C order system. -C -C LDA INTEGER -C The leading dimension of array A. LDA >= MAX(1,N). -C -C B (input/output) DOUBLE PRECISION array, dimension (LDB,M) -C On entry, the leading N-by-M part of this array must -C contain the original input/state matrix B. -C On exit, if INFO = 0, the leading NR-by-M part of this -C array contains the input/state matrix Br of the reduced -C order system. -C -C LDB INTEGER -C The leading dimension of array B. LDB >= MAX(1,N). -C -C C (input/output) DOUBLE PRECISION array, dimension (LDC,N) -C On entry, the leading P-by-N part of this array must -C contain the original state/output matrix C. -C On exit, if INFO = 0, the leading P-by-NR part of this -C array contains the state/output matrix Cr of the reduced -C order system. -C -C LDC INTEGER -C The leading dimension of array C. LDC >= MAX(1,P). -C -C D (input/output) DOUBLE PRECISION array, dimension (LDD,M) -C On entry, the leading P-by-M part of this array must -C contain the original input/output matrix D. -C On exit, if INFO = 0, the leading P-by-M part of this -C array contains the input/output matrix Dr of the reduced -C order system. -C -C LDD INTEGER -C The leading dimension of array D. LDD >= MAX(1,P). -C -C NQ (output) INTEGER -C The order of the computed extended system Ge (see METHOD). -C -C HSV (output) DOUBLE PRECISION array, dimension (N) -C If INFO = 0, it contains the NQ Hankel singular values of -C the extended system Ge ordered decreasingly (see METHOD). -C -C Tolerances -C -C TOL1 DOUBLE PRECISION -C If ORDSEL = 'A', TOL1 contains the tolerance for -C determining the order of reduced extended system. -C For model reduction, the recommended value is -C TOL1 = c*HNORM(Ge), where c is a constant in the -C interval [0.00001,0.001], and HNORM(Ge) is the -C Hankel-norm of the extended system (computed in HSV(1)). -C The value TOL1 = NQ*EPS*HNORM(Ge) is used by default if -C TOL1 <= 0 on entry, where EPS is the machine precision -C (see LAPACK Library Routine DLAMCH). -C If ORDSEL = 'F', the value of TOL1 is ignored. -C -C TOL2 DOUBLE PRECISION -C The tolerance for determining the order of a minimal -C realization of the extended system Ge (see METHOD). -C The recommended value is TOL2 = NQ*EPS*HNORM(Ge). -C This value is used by default if TOL2 <= 0 on entry. -C If TOL2 > 0, then TOL2 <= TOL1. -C -C TOL3 DOUBLE PRECISION -C The absolute tolerance level below which the elements of -C B or C are considered zero (used for controllability or -C observability tests by the coprime factorization method). -C If the user sets TOL3 <= 0, then an implicitly computed, -C default tolerance TOLDEF is used: -C TOLDEF = N*EPS*NORM(C'), if JOBCF = 'L', or -C TOLDEF = N*EPS*NORM(B), if JOBCF = 'R', -C where EPS is the machine precision, and NORM(.) denotes -C the 1-norm of a matrix. -C -C Workspace -C -C IWORK INTEGER array, dimension (MAX(1,2*N,PM)) -C where PM = P, if JOBCF = 'L', -C PM = M, if JOBCF = 'R'. -C On exit with INFO = 0, IWORK(1) contains the order of the -C minimal realization of the system. -C -C DWORK DOUBLE PRECISION array, dimension (LDWORK) -C On exit, if INFO = 0, DWORK(1) returns the optimal value -C of LDWORK. -C -C LDWORK INTEGER -C The length of the array DWORK. -C LDWORK >= MAX(1,LW1) if JOBCF = 'L' and FACT = 'S', -C LDWORK >= MAX(1,LW2) if JOBCF = 'L' and FACT = 'I', -C LDWORK >= MAX(1,LW3) if JOBCF = 'R' and FACT = 'S', -C LDWORK >= MAX(1,LW4) if JOBCF = 'R' and FACT = 'I', where -C LW1 = N*(2*MAX(M,P) + P) + MAX(M,P)*(MAX(M,P) + P) + -C MAX( N*P+MAX(N*(N+5), 5*P, 4*M), LWR ), -C LW2 = N*(2*MAX(M,P) + P) + MAX(M,P)*(MAX(M,P) + P) + -C MAX( N*P+MAX(N*(N+5), P*(P+2), 4*P, 4*M), LWR ), -C LW3 = (N+M)*(M+P) + MAX( 5*M, 4*P, LWR ), -C LW4 = (N+M)*(M+P) + MAX( M*(M+2), 4*M, 4*P, LWR ), and -C LWR = 2*N*N + N*(MAX(N,M+P)+5) + N*(N+1)/2. -C For optimum performance LDWORK should be larger. -C -C Warning Indicator -C -C IWARN INTEGER -C = 0: no warning; -C = 10*K+I: -C I = 1: with ORDSEL = 'F', the selected order NR is -C greater than the order of the computed coprime -C factorization of the given system. In this case, -C the resulting NR is set automatically to a value -C corresponding to the order of a minimal -C realization of the system; -C K > 0: K violations of the numerical stability -C condition occured when computing the coprime -C factorization using pole assignment (see SLICOT -C Library routines SB08CD/SB08ED, SB08DD/SB08FD). -C -C Error Indicator -C -C INFO INTEGER -C = 0: successful exit; -C < 0: if INFO = -i, the i-th argument had an illegal -C value; -C = 1: the reduction of A to a real Schur form failed; -C = 2: a failure was detected during the ordering of the -C real Schur form of A, or in the iterative process -C for reordering the eigenvalues of Z'*(A + H*C)*Z -C (or Z'*(A + B*F)*Z) along the diagonal; see SLICOT -C Library routines SB08CD/SB08ED (or SB08DD/SB08FD); -C = 3: the matrix A has an observable or controllable -C eigenvalue on the imaginary axis if DICO = 'C' or -C on the unit circle if DICO = 'D'; -C = 4: the computation of Hankel singular values failed. -C -C METHOD -C -C Let be the linear system -C -C d[x(t)] = Ax(t) + Bu(t) -C y(t) = Cx(t) + Du(t) (1) -C -C where d[x(t)] is dx(t)/dt for a continuous-time system and x(t+1) -C for a discrete-time system, and let G be the corresponding -C transfer-function matrix. The subroutine AB09GD determines -C the matrices of a reduced order system -C -C d[z(t)] = Ar*z(t) + Br*u(t) -C yr(t) = Cr*z(t) + Dr*u(t) (2) -C -C with the transfer-function matrix Gr, by using the -C singular perturbation approximation (SPA) method in conjunction -C with a left coprime factorization (LCF) or a right coprime -C factorization (RCF) technique: -C -C 1. Compute the appropriate stable coprime factorization of G: -C -1 -1 -C G = R *Q (LCF) or G = Q*R (RCF). -C -C 2. Perform the model reduction algorithm on the extended system -C ( Q ) -C Ge = ( Q R ) (LCF) or Ge = ( R ) (RCF) -C -C to obtain a reduced extended system with reduced factors -C ( Qr ) -C Ger = ( Qr Rr ) (LCF) or Ger = ( Rr ) (RCF). -C -C 3. Recover the reduced system from the reduced factors as -C -1 -1 -C Gr = Rr *Qr (LCF) or Gr = Qr*Rr (RCF). -C -C The approximation error for the extended system satisfies -C -C HSV(NR) <= INFNORM(Ge-Ger) <= 2*[HSV(NR+1) + ... + HSV(NQ)], -C -C where INFNORM(G) is the infinity-norm of G. -C -C If JOBMR = 'B', the balancing-based square-root SPA method of [1] -C is used for model reduction. -C If JOBMR = 'N', the balancing-free square-root SPA method of [2] -C is used for model reduction. -C By setting TOL1 = TOL2, the routine can be used to compute -C Balance & Truncate approximations. -C -C If FACT = 'S', the stable coprime factorization with prescribed -C stability degree ALPHA is computed by using the algorithm of [3]. -C If FACT = 'I', the stable coprime factorization with inner -C denominator is computed by using the algorithm of [4]. -C -C REFERENCES -C -C [1] Liu Y. and Anderson B.D.O. -C Singular Perturbation Approximation of Balanced Systems. -C Int. J. Control, Vol. 50, pp. 1379-1405, 1989. -C -C [2] Varga A. -C Balancing-free square-root algorithm for computing singular -C perturbation approximations. -C Proc. 30-th IEEE CDC, Brighton, Dec. 11-13, 1991, Vol. 2, -C pp. 1062-1065. -C -C [3] Varga A. -C Coprime factors model reduction method based on square-root -C balancing-free techniques. -C System Analysis, Modelling and Simulation, Vol. 11, -C pp. 303-311, 1993. -C -C [4] Varga A. -C A Schur method for computing coprime factorizations with -C inner denominators and applications in model reduction. -C Proc. ACC'93, San Francisco, CA, pp. 2130-2131, 1993. -C -C NUMERICAL ASPECTS -C -C The implemented methods rely on accuracy enhancing square-root or -C balancing-free square-root techniques. -C 3 -C The algorithms require less than 30N floating point operations. -C -C CONTRIBUTOR -C -C C. Oara and A. Varga, German Aerospace Center, -C DLR Oberpfaffenhofen, August 1998. -C -C REVISIONS -C -C Nov. 1998, V. Sima, Research Institute for Informatics, Bucharest. -C Dec. 1998, V. Sima, Katholieke Univ. Leuven, Leuven. -C -C KEYWORDS -C -C Balancing, coprime factorization, minimal realization, -C model reduction, multivariable system, state-space model. -C -C ****************************************************************** -C -C .. Parameters .. - DOUBLE PRECISION ONE, C100, ZERO - PARAMETER ( ONE = 1.0D0, C100 = 100.0D0, ZERO = 0.0D0 ) -C .. Scalar Arguments .. - CHARACTER DICO, EQUIL, FACT, JOBCF, JOBMR, ORDSEL - INTEGER INFO, IWARN, LDA, LDB, LDC, LDD, LDWORK, M, N, - $ NQ, NR, P - DOUBLE PRECISION ALPHA, TOL1, TOL2, TOL3 -C .. Array Arguments .. - INTEGER IWORK(*) - DOUBLE PRECISION A(LDA,*), B(LDB,*), C(LDC,*), D(LDD,*), - $ DWORK(*), HSV(*) -C .. Local Scalars .. - LOGICAL DISCR, FIXORD, LEFT, STABD - INTEGER IERR, IWARNK, KB, KBR, KBT, KC, KCR, KD, KDR, - $ KDT, KT, KTI, KW, LW1, LW2, LW3, LW4, LWR, - $ MAXMP, MP, NDR, NMINR, PM, WRKOPT - DOUBLE PRECISION MAXRED -C .. External Functions .. - LOGICAL LSAME - EXTERNAL LSAME -C .. External Subroutines .. - EXTERNAL AB09BX, DLACPY, SB08CD, SB08DD, SB08ED, SB08FD, - $ SB08GD, SB08HD, TB01ID, XERBLA -C .. Intrinsic Functions .. - INTRINSIC INT, MAX, MIN -C .. Executable Statements .. -C - INFO = 0 - IWARN = 0 - DISCR = LSAME( DICO, 'D' ) - FIXORD = LSAME( ORDSEL, 'F' ) - LEFT = LSAME( JOBCF, 'L' ) - STABD = LSAME( FACT, 'S' ) - MAXMP = MAX( M, P ) -C - LWR = 2*N*N + N*( MAX( N, M + P ) + 5 ) + ( N*( N + 1 ) )/2 - LW1 = N*( 2*MAXMP + P ) + MAXMP*( MAXMP + P ) - LW2 = LW1 + - $ MAX( N*P + MAX( N*( N + 5 ), P*( P+2 ), 4*P, 4*M ), LWR ) - LW1 = LW1 + MAX( N*P + MAX( N*( N + 5 ), 5*P, 4*M ), LWR ) - LW3 = ( N + M )*( M + P ) + MAX( 5*M, 4*P, LWR ) - LW4 = ( N + M )*( M + P ) + MAX( M*( M + 2 ), 4*M, 4*P, LWR ) -C -C Test the input scalar arguments. -C - IF( .NOT. ( LSAME( DICO, 'C' ) .OR. DISCR ) ) THEN - INFO = -1 - ELSE IF( .NOT. ( LEFT .OR. LSAME( JOBCF, 'R' ) ) ) THEN - INFO = -2 - ELSE IF( .NOT. ( STABD .OR. LSAME( FACT, 'I' ) ) ) THEN - INFO = -3 - ELSE IF( .NOT. ( LSAME( JOBMR, 'B' ) .OR. - $ LSAME( JOBMR, 'N' ) ) ) THEN - INFO = -4 - ELSE IF( .NOT. ( LSAME( EQUIL, 'S' ) .OR. - $ LSAME( EQUIL, 'N' ) ) ) THEN - INFO = -5 - ELSE IF( .NOT. ( FIXORD .OR. LSAME( ORDSEL, 'A' ) ) ) THEN - INFO = -6 - ELSE IF( STABD .AND. ( ( .NOT.DISCR .AND. ALPHA.GE.ZERO ) .OR. - $ ( DISCR .AND. ( ALPHA.LT.ZERO .OR. ALPHA.GE.ONE ) ) ) ) - $ THEN - INFO = -7 - ELSE IF( N.LT.0 ) THEN - INFO = -8 - ELSE IF( M.LT.0 ) THEN - INFO = -9 - ELSE IF( P.LT.0 ) THEN - INFO = -10 - ELSE IF( FIXORD .AND. ( NR.LT.0 .OR. NR.GT.N ) ) THEN - INFO = -11 - ELSE IF( LDA.LT.MAX( 1, N ) ) THEN - INFO = -13 - ELSE IF( LDB.LT.MAX( 1, N ) ) THEN - INFO = -15 - ELSE IF( LDC.LT.MAX( 1, P ) ) THEN - INFO = -17 - ELSE IF( LDD.LT.MAX( 1, P ) ) THEN - INFO = -19 - ELSE IF( TOL2.GT.ZERO .AND. TOL2.GT.TOL1 ) THEN - INFO = -23 - ELSE IF( ( LDWORK.LT.1 ) .OR. - $ ( STABD .AND. LEFT .AND. LDWORK.LT.LW1 ) .OR. - $ ( .NOT.STABD .AND. LEFT .AND. LDWORK.LT.LW2 ) .OR. - $ ( STABD .AND. .NOT.LEFT .AND. LDWORK.LT.LW3 ) .OR. - $ ( .NOT.STABD .AND. .NOT.LEFT .AND. LDWORK.LT.LW4 ) ) THEN - INFO = -27 - END IF -C - IF( INFO.NE.0 ) THEN -C -C Error return. -C - CALL XERBLA( 'AB09GD', -INFO ) - RETURN - END IF -C -C Quick return if possible. -C - IF( MIN( N, M, P ).EQ.0 ) THEN - NR = 0 - NQ = 0 - IWORK(1) = 0 - DWORK(1) = ONE - RETURN - END IF -C - IF( LSAME( EQUIL, 'S' ) ) THEN -C -C Scale simultaneously the matrices A, B and C: -C A <- inv(D)*A*D, B <- inv(D)*B and C <- C*D, where D is a -C diagonal matrix. -C - MAXRED = C100 - CALL TB01ID( 'A', N, M, P, MAXRED, A, LDA, B, LDB, C, LDC, - $ DWORK, INFO ) - END IF -C -C Perform the coprime factor model reduction procedure. -C - KD = 1 - IF( LEFT ) THEN -C -1 -C Compute a LCF G = R *Q. -C - MP = M + P - KDR = KD + MAXMP*MAXMP - KC = KDR + MAXMP*P - KB = KC + MAXMP*N - KBR = KB + N*MAXMP - KW = KBR + N*P - LWR = LDWORK - KW + 1 - CALL DLACPY( 'Full', N, M, B, LDB, DWORK(KB), N ) - CALL DLACPY( 'Full', P, N, C, LDC, DWORK(KC), MAXMP ) - CALL DLACPY( 'Full', P, M, D, LDD, DWORK(KD), MAXMP ) -C - IF( STABD ) THEN -C -C Compute a LCF with prescribed stability degree. -C -C Workspace needed: N*(2*MAX(M,P)+P) + -C MAX(M,P)*(MAX(M,P)+P); -C Additional workspace: need N*P+MAX(N*(N+5),5*P,4*M); -C prefer larger. -C - CALL SB08ED( DICO, N, M, P, ALPHA, A, LDA, DWORK(KB), N, - $ DWORK(KC), MAXMP, DWORK(KD), MAXMP, NQ, NDR, - $ DWORK(KBR), N, DWORK(KDR), MAXMP, TOL3, - $ DWORK(KW), LWR, IWARN, INFO ) - ELSE -C -C Compute a LCF with inner denominator. -C -C Workspace needed: N*(2*MAX(M,P)+P) + -C MAX(M,P)*(MAX(M,P)+P); -C Additional workspace: need N*P + -C MAX(N*(N+5),P*(P+2),4*P,4*M); -C prefer larger. -C - CALL SB08CD( DICO, N, M, P, A, LDA, DWORK(KB), N, - $ DWORK(KC), MAXMP, DWORK(KD), MAXMP, NQ, NDR, - $ DWORK(KBR), N, DWORK(KDR), MAXMP, TOL3, - $ DWORK(KW), LWR, IWARN, INFO ) - END IF -C - IWARN = 10*IWARN - IF( INFO.NE.0 ) - $ RETURN -C - WRKOPT = INT( DWORK(KW) ) + KW - 1 -C - IF( NQ.EQ.0 ) THEN - NR = 0 - IWORK(1) = 0 - DWORK(1) = WRKOPT - RETURN - END IF -C - IF( MAXMP.GT.M ) THEN -C -C Form the matrices ( BQ, BR ) and ( DQ, DR ) in consecutive -C columns (see SLICOT Library routines SB08CD/SB08ED). -C - KBT = KBR - KBR = KB + N*M - KDT = KDR - KDR = KD + MAXMP*M - CALL DLACPY( 'Full', NQ, P, DWORK(KBT), N, DWORK(KBR), N ) - CALL DLACPY( 'Full', P, P, DWORK(KDT), MAXMP, DWORK(KDR), - $ MAXMP ) - END IF -C -C Perform model reduction on ( Q, R ) to determine ( Qr, Rr ). -C -C Workspace needed: N*(2*MAX(M,P)+P) + -C MAX(M,P)*(MAX(M,P)+P) + 2*N*N; -C Additional workspace: need N*(MAX(N,M+P)+5) + N*(N+1)/2; -C prefer larger. -C - KT = KW - KTI = KT + NQ*NQ - KW = KTI + NQ*NQ - CALL AB09BX( DICO, JOBMR, ORDSEL, NQ, MP, P, NR, A, LDA, - $ DWORK(KB), N, DWORK(KC), MAXMP, DWORK(KD), MAXMP, - $ HSV, DWORK(KT), N, DWORK(KTI), N, TOL1, TOL2, - $ IWORK, DWORK(KW), LDWORK-KW+1, IWARNK, IERR ) -C - IWARN = IWARN + IWARNK - IF( IERR.NE.0 ) THEN - INFO = 4 - RETURN - END IF -C - NMINR = IWORK(1) - WRKOPT = MAX( WRKOPT, INT( DWORK(KW) ) + KW - 1 ) -C -1 -C Compute the reduced order system Gr = Rr *Qr. -C -C Workspace needed: N*(2*MAX(M,P)+P) + -C MAX(M,P)*(MAX(M,P)+P); -C Additional workspace: need 4*P. -C - KW = KT - CALL SB08GD( NR, M, P, A, LDA, DWORK(KB), N, DWORK(KC), MAXMP, - $ DWORK(KD), MAXMP, DWORK(KBR), N, DWORK(KDR), - $ MAXMP, IWORK, DWORK(KW), INFO ) -C -C Copy the reduced system matrices Br, Cr, and Dr to B, C, and D, -C respectively. -C - CALL DLACPY( 'Full', NR, M, DWORK(KB), N, B, LDB ) - CALL DLACPY( 'Full', P, NR, DWORK(KC), MAXMP, C, LDC ) - CALL DLACPY( 'Full', P, M, DWORK(KD), MAXMP, D, LDD ) - ELSE -C -1 -C Compute a RCF G = Q*R . -C - PM = P + M - KDR = KD + P - KC = KD + PM*M - KCR = KC + P - KW = KC + PM*N - LWR = LDWORK - KW + 1 - CALL DLACPY( 'Full', P, N, C, LDC, DWORK(KC), PM ) - CALL DLACPY( 'Full', P, M, D, LDD, DWORK(KD), PM ) -C - IF( STABD ) THEN -C -C Compute a RCF with prescribed stability degree. -C -C Workspace needed: (N+M)*(M+P); -C Additional workspace: need MAX( N*(N+5), 5*M, 4*P ); -C prefer larger. -C - CALL SB08FD( DICO, N, M, P, ALPHA, A, LDA, B, LDB, - $ DWORK(KC), PM, DWORK(KD), PM, NQ, NDR, - $ DWORK(KCR), PM, DWORK(KDR), PM, TOL3, - $ DWORK(KW), LWR, IWARN, INFO) - ELSE -C -C Compute a RCF with inner denominator. -C -C Workspace needed: (N+M)*(M+P); -C Additional workspace: need MAX(N*(N+5),M*(M+2),4*M,4*P); -C prefer larger. -C - CALL SB08DD( DICO, N, M, P, A, LDA, B, LDB, - $ DWORK(KC), PM, DWORK(KD), PM, NQ, NDR, - $ DWORK(KCR), PM, DWORK(KDR), PM, TOL3, - $ DWORK(KW), LWR, IWARN, INFO) - END IF -C - IWARN = 10*IWARN - IF( INFO.NE.0 ) - $ RETURN -C - WRKOPT = INT( DWORK(KW) ) + KW - 1 -C - IF( NQ.EQ.0 ) THEN - NR = 0 - IWORK(1) = 0 - DWORK(1) = WRKOPT - RETURN - END IF -C ( Q ) ( Qr ) -C Perform model reduction on ( R ) to determine ( Rr ). -C -C Workspace needed: (N+M)*(M+P) + 2*N*N; -C Additional workspace: need N*(MAX(N,M+P)+5) + N*(N+1)/2; -C prefer larger. -C - KT = KW - KTI = KT + NQ*NQ - KW = KTI + NQ*NQ - CALL AB09BX( DICO, JOBMR, ORDSEL, NQ, M, PM, NR, A, LDA, - $ B, LDB, DWORK(KC), PM, DWORK(KD), PM, HSV, - $ DWORK(KT), N, DWORK(KTI), N, TOL1, TOL2, IWORK, - $ DWORK(KW), LDWORK-KW+1, IWARNK, IERR ) -C - IWARN = IWARN + IWARNK - IF( IERR.NE.0 ) THEN - INFO = 4 - RETURN - END IF -C - NMINR = IWORK(1) - WRKOPT = MAX( WRKOPT, INT( DWORK(KW) ) + KW - 1 ) -C -1 -C Compute the reduced order system Gr = Qr*Rr . -C -C Workspace needed: (N+M)*(M+P); -C Additional workspace: need 4*M. -C - KW = KT - CALL SB08HD( NR, M, P, A, LDA, B, LDB, DWORK(KC), PM, - $ DWORK(KD), PM, DWORK(KCR), PM, DWORK(KDR), PM, - $ IWORK, DWORK(KW), INFO ) -C -C Copy the reduced system matrices Cr and Dr to C and D. -C - CALL DLACPY( 'Full', P, NR, DWORK(KC), PM, C, LDC ) - CALL DLACPY( 'Full', P, M, DWORK(KD), PM, D, LDD ) - END IF -C - IWORK(1) = NMINR - DWORK(1) = WRKOPT -C - RETURN -C *** Last line of AB09GD *** - END diff --git a/mex/sources/libslicot/AB09HD.f b/mex/sources/libslicot/AB09HD.f deleted file mode 100644 index 1468accc6..000000000 --- a/mex/sources/libslicot/AB09HD.f +++ /dev/null @@ -1,671 +0,0 @@ - SUBROUTINE AB09HD( DICO, JOB, EQUIL, ORDSEL, N, M, P, NR, ALPHA, - $ BETA, A, LDA, B, LDB, C, LDC, D, LDD, NS, HSV, - $ TOL1, TOL2, IWORK, DWORK, LDWORK, BWORK, IWARN, - $ INFO ) -C -C SLICOT RELEASE 5.0. -C -C Copyright (c) 2002-2009 NICONET e.V. -C -C This program is free software: you can redistribute it and/or -C modify it under the terms of the GNU General Public License as -C published by the Free Software Foundation, either version 2 of -C the License, or (at your option) any later version. -C -C This program is distributed in the hope that it will be useful, -C but WITHOUT ANY WARRANTY; without even the implied warranty of -C MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the -C GNU General Public License for more details. -C -C You should have received a copy of the GNU General Public License -C along with this program. If not, see -C . -C -C PURPOSE -C -C To compute a reduced order model (Ar,Br,Cr,Dr) for an original -C state-space representation (A,B,C,D) by using the stochastic -C balancing approach in conjunction with the square-root or -C the balancing-free square-root Balance & Truncate (B&T) -C or Singular Perturbation Approximation (SPA) model reduction -C methods for the ALPHA-stable part of the system. -C -C ARGUMENTS -C -C Mode Parameters -C -C DICO CHARACTER*1 -C Specifies the type of the original system as follows: -C = 'C': continuous-time system; -C = 'D': discrete-time system. -C -C JOB CHARACTER*1 -C Specifies the model reduction approach to be used -C as follows: -C = 'B': use the square-root Balance & Truncate method; -C = 'F': use the balancing-free square-root -C Balance & Truncate method; -C = 'S': use the square-root Singular Perturbation -C Approximation method; -C = 'P': use the balancing-free square-root -C Singular Perturbation Approximation method. -C -C EQUIL CHARACTER*1 -C Specifies whether the user wishes to preliminarily -C equilibrate the triplet (A,B,C) as follows: -C = 'S': perform equilibration (scaling); -C = 'N': do not perform equilibration. -C -C ORDSEL CHARACTER*1 -C Specifies the order selection method as follows: -C = 'F': the resulting order NR is fixed; -C = 'A': the resulting order NR is automatically determined -C on basis of the given tolerance TOL1. -C -C Input/Output Parameters -C -C N (input) INTEGER -C The order of the original state-space representation, -C i.e., the order of the matrix A. N >= 0. -C -C M (input) INTEGER -C The number of system inputs. M >= 0. -C -C P (input) INTEGER -C The number of system outputs. P >= 0. -C P <= M if BETA = 0. -C -C NR (input/output) INTEGER -C On entry with ORDSEL = 'F', NR is the desired order of the -C resulting reduced order system. 0 <= NR <= N. -C On exit, if INFO = 0, NR is the order of the resulting -C reduced order model. For a system with NU ALPHA-unstable -C eigenvalues and NS ALPHA-stable eigenvalues (NU+NS = N), -C NR is set as follows: if ORDSEL = 'F', NR is equal to -C NU+MIN(MAX(0,NR-NU),NMIN), where NR is the desired order -C on entry, and NMIN is the order of a minimal realization -C of the ALPHA-stable part of the given system; NMIN is -C determined as the number of Hankel singular values greater -C than NS*EPS, where EPS is the machine precision -C (see LAPACK Library Routine DLAMCH); -C if ORDSEL = 'A', NR is the sum of NU and the number of -C Hankel singular values greater than MAX(TOL1,NS*EPS); -C NR can be further reduced to ensure that -C HSV(NR-NU) > HSV(NR+1-NU). -C -C ALPHA (input) DOUBLE PRECISION -C Specifies the ALPHA-stability boundary for the eigenvalues -C of the state dynamics matrix A. For a continuous-time -C system (DICO = 'C'), ALPHA <= 0 is the boundary value for -C the real parts of eigenvalues, while for a discrete-time -C system (DICO = 'D'), 0 <= ALPHA <= 1 represents the -C boundary value for the moduli of eigenvalues. -C The ALPHA-stability domain does not include the boundary. -C -C BETA (input) DOUBLE PRECISION -C BETA > 0 specifies the absolute/relative error weighting -C parameter. A large positive value of BETA favours the -C minimization of the absolute approximation error, while a -C small value of BETA is appropriate for the minimization -C of the relative error. -C BETA = 0 means a pure relative error method and can be -C used only if rank(D) = P. -C -C A (input/output) DOUBLE PRECISION array, dimension (LDA,N) -C On entry, the leading N-by-N part of this array must -C contain the state dynamics matrix A. -C On exit, if INFO = 0, the leading NR-by-NR part of this -C array contains the state dynamics matrix Ar of the reduced -C order system. -C The resulting A has a block-diagonal form with two blocks. -C For a system with NU ALPHA-unstable eigenvalues and -C NS ALPHA-stable eigenvalues (NU+NS = N), the leading -C NU-by-NU block contains the unreduced part of A -C corresponding to ALPHA-unstable eigenvalues in an -C upper real Schur form. -C The trailing (NR+NS-N)-by-(NR+NS-N) block contains -C the reduced part of A corresponding to ALPHA-stable -C eigenvalues. -C -C LDA INTEGER -C The leading dimension of array A. LDA >= MAX(1,N). -C -C B (input/output) DOUBLE PRECISION array, dimension (LDB,M) -C On entry, the leading N-by-M part of this array must -C contain the original input/state matrix B. -C On exit, if INFO = 0, the leading NR-by-M part of this -C array contains the input/state matrix Br of the reduced -C order system. -C -C LDB INTEGER -C The leading dimension of array B. LDB >= MAX(1,N). -C -C C (input/output) DOUBLE PRECISION array, dimension (LDC,N) -C On entry, the leading P-by-N part of this array must -C contain the original state/output matrix C. -C On exit, if INFO = 0, the leading P-by-NR part of this -C array contains the state/output matrix Cr of the reduced -C order system. -C -C LDC INTEGER -C The leading dimension of array C. LDC >= MAX(1,P). -C -C D (input/output) DOUBLE PRECISION array, dimension (LDD,M) -C On entry, the leading P-by-M part of this array must -C contain the original input/output matrix D. -C On exit, if INFO = 0, the leading P-by-M part of this -C array contains the input/output matrix Dr of the reduced -C order system. -C -C LDD INTEGER -C The leading dimension of array D. LDD >= MAX(1,P). -C -C NS (output) INTEGER -C The dimension of the ALPHA-stable subsystem. -C -C HSV (output) DOUBLE PRECISION array, dimension (N) -C If INFO = 0, the leading NS elements of HSV contain the -C Hankel singular values of the phase system corresponding -C to the ALPHA-stable part of the original system. -C The Hankel singular values are ordered decreasingly. -C -C Tolerances -C -C TOL1 DOUBLE PRECISION -C If ORDSEL = 'A', TOL1 contains the tolerance for -C determining the order of reduced system. -C For model reduction, the recommended value of TOL1 lies -C in the interval [0.00001,0.001]. -C If TOL1 <= 0 on entry, the used default value is -C TOL1 = NS*EPS, where NS is the number of -C ALPHA-stable eigenvalues of A and EPS is the machine -C precision (see LAPACK Library Routine DLAMCH). -C If ORDSEL = 'F', the value of TOL1 is ignored. -C TOL1 < 1. -C -C TOL2 DOUBLE PRECISION -C The tolerance for determining the order of a minimal -C realization of the phase system (see METHOD) corresponding -C to the ALPHA-stable part of the given system. -C The recommended value is TOL2 = NS*EPS. -C This value is used by default if TOL2 <= 0 on entry. -C If TOL2 > 0 and ORDSEL = 'A', then TOL2 <= TOL1. -C TOL2 < 1. -C -C Workspace -C -C IWORK INTEGER array, dimension MAX(1,2*N) -C On exit with INFO = 0, IWORK(1) contains the order of the -C minimal realization of the system. -C -C DWORK DOUBLE PRECISION array, dimension (LDWORK) -C On exit, if INFO = 0, DWORK(1) returns the optimal value -C of LDWORK and DWORK(2) contains RCOND, the reciprocal -C condition number of the U11 matrix from the expression -C used to compute the solution X = U21*inv(U11) of the -C Riccati equation for spectral factorization. -C A small value RCOND indicates possible ill-conditioning -C of the respective Riccati equation. -C -C LDWORK INTEGER -C The length of the array DWORK. -C LDWORK >= 2*N*N + MB*(N+P) + MAX( 2, N*(MAX(N,MB,P)+5), -C 2*N*P+MAX(P*(MB+2),10*N*(N+1) ) ), -C where MB = M if BETA = 0 and MB = M+P if BETA > 0. -C For optimum performance LDWORK should be larger. -C -C BWORK LOGICAL array, dimension 2*N -C -C Warning Indicator -C -C IWARN INTEGER -C = 0: no warning; -C = 1: with ORDSEL = 'F', the selected order NR is greater -C than NSMIN, the sum of the order of the -C ALPHA-unstable part and the order of a minimal -C realization of the ALPHA-stable part of the given -C system; in this case, the resulting NR is set equal -C to NSMIN; -C = 2: with ORDSEL = 'F', the selected order NR corresponds -C to repeated singular values for the ALPHA-stable -C part, which are neither all included nor all -C excluded from the reduced model; in this case, the -C resulting NR is automatically decreased to exclude -C all repeated singular values; -C = 3: with ORDSEL = 'F', the selected order NR is less -C than the order of the ALPHA-unstable part of the -C given system; in this case NR is set equal to the -C order of the ALPHA-unstable part. -C -C Error Indicator -C -C INFO INTEGER -C = 0: successful exit; -C < 0: if INFO = -i, the i-th argument had an illegal -C value; -C = 1: the computation of the ordered real Schur form of A -C failed; -C = 2: the reduction of the Hamiltonian matrix to real -C Schur form failed; -C = 3: the reordering of the real Schur form of the -C Hamiltonian matrix failed; -C = 4: the Hamiltonian matrix has less than N stable -C eigenvalues; -C = 5: the coefficient matrix U11 in the linear system -C X*U11 = U21 to determine X is singular to working -C precision; -C = 6: BETA = 0 and D has not a maximal row rank; -C = 7: the computation of Hankel singular values failed; -C = 8: the separation of the ALPHA-stable/unstable diagonal -C blocks failed because of very close eigenvalues; -C = 9: the resulting order of reduced stable part is less -C than the number of unstable zeros of the stable -C part. -C METHOD -C -C Let be the following linear system -C -C d[x(t)] = Ax(t) + Bu(t) -C y(t) = Cx(t) + Du(t), (1) -C -C where d[x(t)] is dx(t)/dt for a continuous-time system and x(t+1) -C for a discrete-time system. The subroutine AB09HD determines for -C the given system (1), the matrices of a reduced order system -C -C d[z(t)] = Ar*z(t) + Br*u(t) -C yr(t) = Cr*z(t) + Dr*u(t), (2) -C -C such that -C -C INFNORM[inv(conj(W))*(G-Gr)] <= -C (1+HSV(NR+NS-N+1)) / (1-HSV(NR+NS-N+1)) + ... -C + (1+HSV(NS)) / (1-HSV(NS)) - 1, -C -C where G and Gr are transfer-function matrices of the systems -C (A,B,C,D) and (Ar,Br,Cr,Dr), respectively, W is the right, minimum -C phase spectral factor satisfying -C -C G1*conj(G1) = conj(W)* W, (3) -C -C G1 is the NS-order ALPHA-stable part of G, and INFNORM(G) is the -C infinity-norm of G. HSV(1), ... , HSV(NS) are the Hankel-singular -C values of the stable part of the phase system (Ap,Bp,Cp) -C with the transfer-function matrix -C -C P = inv(conj(W))*G1. -C -C If BETA > 0, then the model reduction is performed on [G BETA*I] -C instead of G. This is the recommended approach to be used when D -C has not a maximal row rank or when a certain balance between -C relative and absolute approximation errors is desired. For -C increasingly large values of BETA, the obtained reduced system -C assymptotically approaches that computed by using the -C Balance & Truncate or Singular Perturbation Approximation methods. -C -C Note: conj(G) denotes either G'(-s) for a continuous-time system -C or G'(1/z) for a discrete-time system. -C inv(G) is the inverse of G. -C -C The following procedure is used to reduce a given G: -C -C 1) Decompose additively G as -C -C G = G1 + G2, -C -C such that G1 = (As,Bs,Cs,D) has only ALPHA-stable poles and -C G2 = (Au,Bu,Cu) has only ALPHA-unstable poles. -C -C 2) Determine G1r, a reduced order approximation of the -C ALPHA-stable part G1 using the balancing stochastic method -C in conjunction with either the B&T [1,2] or SPA methods [3]. -C -C 3) Assemble the reduced model Gr as -C -C Gr = G1r + G2. -C -C Note: The employed stochastic truncation algorithm [2,3] has the -C property that right half plane zeros of G1 remain as right half -C plane zeros of G1r. Thus, the order can not be chosen smaller than -C the sum of the number of unstable poles of G and the number of -C unstable zeros of G1. -C -C The reduction of the ALPHA-stable part G1 is done as follows. -C -C If JOB = 'B', the square-root stochastic Balance & Truncate -C method of [1] is used. -C For an ALPHA-stable continuous-time system (DICO = 'C'), -C the resulting reduced model is stochastically balanced. -C -C If JOB = 'F', the balancing-free square-root version of the -C stochastic Balance & Truncate method [1] is used to reduce -C the ALPHA-stable part G1. -C -C If JOB = 'S', the stochastic balancing method is used to reduce -C the ALPHA-stable part G1, in conjunction with the square-root -C version of the Singular Perturbation Approximation method [3,4]. -C -C If JOB = 'P', the stochastic balancing method is used to reduce -C the ALPHA-stable part G1, in conjunction with the balancing-free -C square-root version of the Singular Perturbation Approximation -C method [3,4]. -C -C REFERENCES -C -C [1] Varga A. and Fasol K.H. -C A new square-root balancing-free stochastic truncation model -C reduction algorithm. -C Proc. 12th IFAC World Congress, Sydney, 1993. -C -C [2] Safonov M. G. and Chiang R. Y. -C Model reduction for robust control: a Schur relative error -C method. -C Int. J. Adapt. Contr. Sign. Proc., vol. 2, pp. 259-272, 1988. -C -C [3] Green M. and Anderson B. D. O. -C Generalized balanced stochastic truncation. -C Proc. 29-th CDC, Honolulu, Hawaii, pp. 476-481, 1990. -C -C [4] Varga A. -C Balancing-free square-root algorithm for computing -C singular perturbation approximations. -C Proc. 30-th IEEE CDC, Brighton, Dec. 11-13, 1991, -C Vol. 2, pp. 1062-1065. -C -C NUMERICAL ASPECTS -C -C The implemented methods rely on accuracy enhancing square-root or -C balancing-free square-root techniques. The effectiveness of the -C accuracy enhancing technique depends on the accuracy of the -C solution of a Riccati equation. An ill-conditioned Riccati -C solution typically results when [D BETA*I] is nearly -C rank deficient. -C 3 -C The algorithm requires about 100N floating point operations. -C -C CONTRIBUTORS -C -C A. Varga, German Aerospace Center, Oberpfaffenhofen, May 2000. -C D. Sima, University of Bucharest, May 2000. -C V. Sima, Research Institute for Informatics, Bucharest, May 2000. -C Partly based on the RASP routine SRBFS, by A. Varga, 1992. -C -C REVISIONS -C -C A. Varga, Australian National University, Canberra, November 2000. -C V. Sima, Research Institute for Informatics, Bucharest, Dec. 2000. -C Oct. 2001. -C -C KEYWORDS -C -C Minimal realization, model reduction, multivariable system, -C state-space model, state-space representation, -C stochastic balancing. -C -C ****************************************************************** -C -C .. Parameters .. - DOUBLE PRECISION ZERO, ONE, TWO, TWOBY3, C100 - PARAMETER ( ZERO = 0.0D0, ONE = 1.0D0, TWO = 2.0D0, - $ TWOBY3 = TWO/3.0D0, C100 = 100.0D0 ) -C .. Scalar Arguments .. - CHARACTER DICO, EQUIL, JOB, ORDSEL - INTEGER INFO, IWARN, LDA, LDB, LDC, LDD, LDWORK, - $ M, N, NR, NS, P - DOUBLE PRECISION ALPHA, BETA, TOL1, TOL2 -C .. Array Arguments .. - INTEGER IWORK(*) - DOUBLE PRECISION A(LDA,*), B(LDB,*), C(LDC,*), D(LDD,*), - $ DWORK(*), HSV(*) - LOGICAL BWORK(*) -C .. Local Scalars .. - LOGICAL BTA, DISCR, FIXORD, LEQUIL, SPA - INTEGER IERR, IWARNL, KB, KD, KT, KTI, KU, KW, KWI, KWR, - $ LW, LWR, MB, N2, NMR, NN, NRA, NU, NU1, WRKOPT - DOUBLE PRECISION EPSM, MAXRED, RICOND, SCALEC, SCALEO -C .. External Functions .. - LOGICAL LSAME - DOUBLE PRECISION DLAMCH - EXTERNAL DLAMCH, LSAME -C .. External Subroutines .. - EXTERNAL AB04MD, AB09HY, AB09IX, DLACPY, DLASET, TB01ID, - $ TB01KD, XERBLA -C .. Intrinsic Functions .. - INTRINSIC INT, MAX, MIN -C .. Executable Statements .. -C - INFO = 0 - IWARN = 0 - DISCR = LSAME( DICO, 'D' ) - FIXORD = LSAME( ORDSEL, 'F' ) - LEQUIL = LSAME( EQUIL, 'S' ) - BTA = LSAME( JOB, 'B' ) .OR. LSAME( JOB, 'F' ) - SPA = LSAME( JOB, 'S' ) .OR. LSAME( JOB, 'P' ) - MB = M - IF( BETA.GT.ZERO ) MB = M + P - LW = 2*N*N + MB*(N+P) + MAX( 2, N*(MAX( N, MB, P )+5), - $ 2*N*P+MAX( P*(MB+2), 10*N*(N+1) ) ) -C -C Test the input scalar arguments. -C - IF( .NOT. ( LSAME( DICO, 'C' ) .OR. DISCR ) ) THEN - INFO = -1 - ELSE IF( .NOT. ( BTA .OR. SPA ) ) THEN - INFO = -2 - ELSE IF( .NOT. ( LEQUIL .OR. LSAME( EQUIL, 'N' ) ) ) THEN - INFO = -3 - ELSE IF( .NOT. ( FIXORD .OR. LSAME( ORDSEL, 'A' ) ) ) THEN - INFO = -4 - ELSE IF( N.LT.0 ) THEN - INFO = -5 - ELSE IF( M.LT.0 ) THEN - INFO = -6 - ELSE IF( P.LT.0 .OR. ( BETA.EQ.ZERO .AND. P.GT.M ) ) THEN - INFO = -7 - ELSE IF( FIXORD .AND. ( NR.LT.0 .OR. NR.GT.N ) ) THEN - INFO = -8 - ELSE IF( ( DISCR .AND. ( ALPHA.LT.ZERO .OR. ALPHA.GT.ONE ) ) .OR. - $ ( .NOT.DISCR .AND. ALPHA.GT.ZERO ) ) THEN - INFO = -9 - ELSE IF( BETA.LT.ZERO ) THEN - INFO = -10 - ELSE IF( LDA.LT.MAX( 1, N ) ) THEN - INFO = -12 - ELSE IF( LDB.LT.MAX( 1, N ) ) THEN - INFO = -14 - ELSE IF( LDC.LT.MAX( 1, P ) ) THEN - INFO = -16 - ELSE IF( LDD.LT.MAX( 1, P ) ) THEN - INFO = -18 - ELSE IF( TOL1.GE.ONE ) THEN - INFO = -21 - ELSE IF( ( TOL2.GT.ZERO .AND. .NOT.FIXORD .AND. TOL2.GT.TOL1 ) - $ .OR. TOL2.GE.ONE ) THEN - INFO = -22 - ELSE IF( LDWORK.LT.LW ) THEN - INFO = -25 - END IF -C - IF( INFO.NE.0 ) THEN -C -C Error return. -C - CALL XERBLA( 'AB09HD', -INFO ) - RETURN - END IF -C -C Quick return if possible. -C - IF( MIN( N, M, P ).EQ.0 .OR. - $ ( BTA .AND. FIXORD .AND. NR.EQ.0 ) ) THEN - NR = 0 - NS = 0 - IWORK(1) = 0 - DWORK(1) = TWO - DWORK(2) = ONE - RETURN - END IF -C - IF( LEQUIL ) THEN -C -C Scale simultaneously the matrices A, B and C: -C A <- inv(D)*A*D, B <- inv(D)*B and C <- C*D, where D is a -C diagonal matrix. -C Workspace: N. -C - MAXRED = C100 - CALL TB01ID( 'All', N, M, P, MAXRED, A, LDA, B, LDB, C, LDC, - $ DWORK, INFO ) - END IF -C -C Allocate working storage. -C - NN = N*N - KU = 1 - KWR = KU + NN - KWI = KWR + N - KW = KWI + N - LWR = LDWORK - KW + 1 -C -C Reduce A to a block-diagonal real Schur form, with the -C ALPHA-unstable part in the leading diagonal position, using a -C non-orthogonal similarity transformation A <- inv(T)*A*T and -C apply the transformation to B and C: B <- inv(T)*B and C <- C*T. -C -C Workspace needed: N*(N+2); -C Additional workspace: need 3*N; -C prefer larger. -C - CALL TB01KD( DICO, 'Unstable', 'General', N, M, P, ALPHA, A, LDA, - $ B, LDB, C, LDC, NU, DWORK(KU), N, DWORK(KWR), - $ DWORK(KWI), DWORK(KW), LWR, IERR ) -C - IF( IERR.NE.0 ) THEN - IF( IERR.NE.3 ) THEN - INFO = 1 - ELSE - INFO = 8 - END IF - RETURN - END IF -C - WRKOPT = INT( DWORK(KW) ) + KW - 1 -C - IWARNL = 0 - NS = N - NU - IF( FIXORD ) THEN - NRA = MAX( 0, NR-NU ) - IF( NR.LT.NU ) - $ IWARNL = 3 - ELSE - NRA = 0 - END IF -C -C Finish if the system is completely unstable. -C - IF( NS.EQ.0 ) THEN - NR = NU - IWORK(1) = NS - DWORK(1) = WRKOPT - DWORK(2) = ONE - RETURN - END IF -C - NU1 = NU + 1 -C -C Allocate working storage. -C - N2 = N + N - KB = 1 - KD = KB + N*MB - KT = KD + P*MB - KTI = KT + N*N - KW = KTI + N*N -C -C Form [B 0] and [D BETA*I]. -C - CALL DLACPY( 'F', NS, M, B(NU1,1), LDB, DWORK(KB), N ) - CALL DLACPY( 'F', P, M, D, LDD, DWORK(KD), P ) - IF( BETA.GT.ZERO ) THEN - CALL DLASET( 'F', NS, P, ZERO, ZERO, DWORK(KB+N*M), N ) - CALL DLASET( 'F', P, P, ZERO, BETA, DWORK(KD+P*M), P ) - END IF -C -C For discrete-time case, apply the discrete-to-continuous bilinear -C transformation to the stable part. -C - IF( DISCR ) THEN -C -C Real workspace: need N, prefer larger; -C Integer workspace: need N. -C - CALL AB04MD( 'Discrete', NS, MB, P, ONE, ONE, A(NU1,NU1), LDA, - $ DWORK(KB), N, C(1,NU1), LDC, DWORK(KD), P, - $ IWORK, DWORK(KT), LDWORK-KT+1, IERR ) - WRKOPT = MAX( WRKOPT, INT( DWORK(KT) ) + KT - 1 ) - END IF -C -C Compute in DWORK(KTI) and DWORK(KT) the Cholesky factors S and R -C of the controllability and observability Grammians, respectively. -C Real workspace: need 2*N*N + MB*(N+P)+ -C MAX( 2, N*(MAX(N,MB,P)+5), -C 2*N*P+MAX(P*(MB+2), 10*N*(N+1) ) ); -C prefer larger. -C Integer workspace: need 2*N. -C - CALL AB09HY( NS, MB, P, A(NU1,NU1), LDA, DWORK(KB), N, - $ C(1,NU1), LDC, DWORK(KD), P, SCALEC, SCALEO, - $ DWORK(KTI), N, DWORK(KT), N, IWORK, DWORK(KW), - $ LDWORK-KW+1, BWORK, INFO ) - IF( INFO.NE.0 ) - $ RETURN - WRKOPT = MAX( WRKOPT, INT( DWORK(KW) ) + KW - 1 ) - RICOND = DWORK(KW+1) -C -C Compute a BTA or SPA of the stable part. -C Real workspace: need 2*N*N + MB*(N+P)+ -C MAX( 1, 2*N*N+5*N, N*MAX(MB,P) ). -C - EPSM = DLAMCH( 'Epsilon' ) - CALL AB09IX( 'C', JOB, 'Schur', ORDSEL, NS, MB, P, NRA, SCALEC, - $ SCALEO, A(NU1,NU1), LDA, DWORK(KB), N, C(1,NU1), LDC, - $ DWORK(KD), P, DWORK(KTI), N, DWORK(KT), N, NMR, HSV, - $ MAX( TOL1, N*EPSM ), TOL2, IWORK, DWORK(KW), - $ LDWORK-KW+1, IWARN, IERR ) - IWARN = MAX( IWARN, IWARNL ) - IF( IERR.NE.0 ) THEN - INFO = 7 - RETURN - END IF - WRKOPT = MAX( WRKOPT, INT( DWORK(KW) ) + KW - 1 ) -C -C Check if the resulting order is greater than the number of -C unstable zeros (this check is implicit by looking at Hankel -C singular values equal to 1). -C - IF( NRA.LT.NS .AND. HSV(NRA+1).GE.ONE-EPSM**TWOBY3 ) THEN - INFO = 9 - RETURN - END IF -C -C For discrete-time case, apply the continuous-to-discrete -C bilinear transformation. -C - IF( DISCR ) THEN - CALL AB04MD( 'Continuous', NRA, MB, P, ONE, ONE, - $ A(NU1,NU1), LDA, DWORK(KB), N, C(1,NU1), LDC, - $ DWORK(KD), P, IWORK, DWORK, LDWORK, IERR ) - WRKOPT = MAX( WRKOPT, INT( DWORK(1) ) ) - END IF -C - CALL DLACPY( 'F', NRA, M, DWORK(KB), N, B(NU1,1), LDB ) - CALL DLACPY( 'F', P, M, DWORK(KD), P, D, LDD ) -C - NR = NRA + NU -C - IWORK(1) = NMR - DWORK(1) = WRKOPT - DWORK(2) = RICOND -C - RETURN -C *** Last line of AB09HD *** - END diff --git a/mex/sources/libslicot/AB09HX.f b/mex/sources/libslicot/AB09HX.f deleted file mode 100644 index 4bba6fe3b..000000000 --- a/mex/sources/libslicot/AB09HX.f +++ /dev/null @@ -1,690 +0,0 @@ - SUBROUTINE AB09HX( DICO, JOB, ORDSEL, N, M, P, NR, A, LDA, B, LDB, - $ C, LDC, D, LDD, HSV, T, LDT, TI, LDTI, TOL1, - $ TOL2, IWORK, DWORK, LDWORK, BWORK, IWARN, - $ INFO ) -C -C SLICOT RELEASE 5.0. -C -C Copyright (c) 2002-2009 NICONET e.V. -C -C This program is free software: you can redistribute it and/or -C modify it under the terms of the GNU General Public License as -C published by the Free Software Foundation, either version 2 of -C the License, or (at your option) any later version. -C -C This program is distributed in the hope that it will be useful, -C but WITHOUT ANY WARRANTY; without even the implied warranty of -C MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the -C GNU General Public License for more details. -C -C You should have received a copy of the GNU General Public License -C along with this program. If not, see -C . -C -C PURPOSE -C -C To compute a reduced order model (Ar,Br,Cr,Dr) for an original -C stable state-space representation (A,B,C,D) by using the -C stochastic balancing approach in conjunction with the square-root -C or the balancing-free square-root Balance & Truncate (B&T) or -C Singular Perturbation Approximation (SPA) model reduction methods. -C The state dynamics matrix A of the original system is an upper -C quasi-triangular matrix in real Schur canonical form and D must be -C full row rank. -C -C For the B&T approach, the matrices of the reduced order system -C are computed using the truncation formulas: -C -C Ar = TI * A * T , Br = TI * B , Cr = C * T . (1) -C -C For the SPA approach, the matrices of a minimal realization -C (Am,Bm,Cm) are computed using the truncation formulas: -C -C Am = TI * A * T , Bm = TI * B , Cm = C * T . (2) -C -C Am, Bm, Cm and D serve further for computing the SPA of the given -C system. -C -C ARGUMENTS -C -C Mode Parameters -C -C DICO CHARACTER*1 -C Specifies the type of the original system as follows: -C = 'C': continuous-time system; -C = 'D': discrete-time system. -C -C JOB CHARACTER*1 -C Specifies the model reduction approach to be used -C as follows: -C = 'B': use the square-root Balance & Truncate method; -C = 'F': use the balancing-free square-root -C Balance & Truncate method; -C = 'S': use the square-root Singular Perturbation -C Approximation method; -C = 'P': use the balancing-free square-root -C Singular Perturbation Approximation method. -C -C ORDSEL CHARACTER*1 -C Specifies the order selection method as follows: -C = 'F': the resulting order NR is fixed; -C = 'A': the resulting order NR is automatically determined -C on basis of the given tolerance TOL1. -C -C Input/Output Parameters -C -C N (input) INTEGER -C The order of the original state-space representation, -C i.e., the order of the matrix A. N >= 0. -C -C M (input) INTEGER -C The number of system inputs. M >= 0. -C -C P (input) INTEGER -C The number of system outputs. M >= P >= 0. -C -C NR (input/output) INTEGER -C On entry with ORDSEL = 'F', NR is the desired order of -C the resulting reduced order system. 0 <= NR <= N. -C On exit, if INFO = 0, NR is the order of the resulting -C reduced order model. NR is set as follows: -C if ORDSEL = 'F', NR is equal to MIN(NR,NMIN), where NR -C is the desired order on entry and NMIN is the order of a -C minimal realization of the given system; NMIN is -C determined as the number of Hankel singular values greater -C than N*EPS, where EPS is the machine precision -C (see LAPACK Library Routine DLAMCH); -C if ORDSEL = 'A', NR is equal to the number of Hankel -C singular values greater than MAX(TOL1,N*EPS). -C -C A (input/output) DOUBLE PRECISION array, dimension (LDA,N) -C On entry, the leading N-by-N part of this array must -C contain the state dynamics matrix A in a real Schur -C canonical form. -C On exit, if INFO = 0, the leading NR-by-NR part of this -C array contains the state dynamics matrix Ar of the -C reduced order system. -C -C LDA INTEGER -C The leading dimension of array A. LDA >= MAX(1,N). -C -C B (input/output) DOUBLE PRECISION array, dimension (LDB,M) -C On entry, the leading N-by-M part of this array must -C contain the original input/state matrix B. -C On exit, if INFO = 0, the leading NR-by-M part of this -C array contains the input/state matrix Br of the reduced -C order system. -C -C LDB INTEGER -C The leading dimension of array B. LDB >= MAX(1,N). -C -C C (input/output) DOUBLE PRECISION array, dimension (LDC,N) -C On entry, the leading P-by-N part of this array must -C contain the original state/output matrix C. -C On exit, if INFO = 0, the leading P-by-NR part of this -C array contains the state/output matrix Cr of the reduced -C order system. -C -C LDC INTEGER -C The leading dimension of array C. LDC >= MAX(1,P). -C -C D (input/output) DOUBLE PRECISION array, dimension (LDD,M) -C On entry, the leading P-by-M part of this array must -C contain the original input/output matrix D. -C On exit, if INFO = 0, the leading P-by-M part of this -C array contains the input/output matrix Dr of the reduced -C order system. -C -C LDD INTEGER -C The leading dimension of array D. LDD >= MAX(1,P). -C -C HSV (output) DOUBLE PRECISION array, dimension (N) -C If INFO = 0, it contains the Hankel singular values, -C ordered decreasingly, of the phase system. All singular -C values are less than or equal to 1. -C -C T (output) DOUBLE PRECISION array, dimension (LDT,N) -C If INFO = 0 and NR > 0, the leading N-by-NR part of this -C array contains the right truncation matrix T in (1), for -C the B&T approach, or in (2), for the SPA approach. -C -C LDT INTEGER -C The leading dimension of array T. LDT >= MAX(1,N). -C -C TI (output) DOUBLE PRECISION array, dimension (LDTI,N) -C If INFO = 0 and NR > 0, the leading NR-by-N part of this -C array contains the left truncation matrix TI in (1), for -C the B&T approach, or in (2), for the SPA approach. -C -C LDTI INTEGER -C The leading dimension of array TI. LDTI >= MAX(1,N). -C -C Tolerances -C -C TOL1 DOUBLE PRECISION -C If ORDSEL = 'A', TOL1 contains the tolerance for -C determining the order of reduced system. -C For model reduction, the recommended value lies in the -C interval [0.00001,0.001]. -C If TOL1 <= 0 on entry, the used default value is -C TOL1 = N*EPS, where EPS is the machine -C precision (see LAPACK Library Routine DLAMCH). -C If ORDSEL = 'F', the value of TOL1 is ignored. -C -C TOL2 DOUBLE PRECISION -C The tolerance for determining the order of a minimal -C realization of the phase system (see METHOD) corresponding -C to the given system. -C The recommended value is TOL2 = N*EPS. -C This value is used by default if TOL2 <= 0 on entry. -C If TOL2 > 0 and ORDSEL = 'A', then TOL2 <= TOL1. -C -C Workspace -C -C IWORK INTEGER array, dimension MAX(1,2*N) -C On exit with INFO = 0, IWORK(1) contains the order of the -C minimal realization of the system. -C -C DWORK DOUBLE PRECISION array, dimension (LDWORK) -C On exit, if INFO = 0, DWORK(1) returns the optimal value -C of LDWORK and DWORK(2) contains RCOND, the reciprocal -C condition number of the U11 matrix from the expression -C used to compute the solution X = U21*inv(U11) of the -C Riccati equation for spectral factorization. -C A small value RCOND indicates possible ill-conditioning -C of the respective Riccati equation. -C -C LDWORK INTEGER -C The length of the array DWORK. -C LDWORK >= MAX( 2, N*(MAX(N,M,P)+5), -C 2*N*P+MAX(P*(M+2),10*N*(N+1) ) ). -C For optimum performance LDWORK should be larger. -C -C BWORK LOGICAL array, dimension 2*N -C -C Warning Indicator -C -C IWARN INTEGER -C = 0: no warning; -C = 1: with ORDSEL = 'F', the selected order NR is greater -C than the order of a minimal realization of the -C given system. In this case, the resulting NR is -C set automatically to a value corresponding to the -C order of a minimal realization of the system. -C -C Error Indicator -C -C INFO INTEGER -C = 0: successful exit; -C < 0: if INFO = -i, the i-th argument had an illegal -C value; -C = 1: the state matrix A is not stable (if DICO = 'C') -C or not convergent (if DICO = 'D'), or it is not in -C a real Schur form; -C = 2: the reduction of Hamiltonian matrix to real -C Schur form failed; -C = 3: the reordering of the real Schur form of the -C Hamiltonian matrix failed; -C = 4: the Hamiltonian matrix has less than N stable -C eigenvalues; -C = 5: the coefficient matrix U11 in the linear system -C X*U11 = U21, used to determine X, is singular to -C working precision; -C = 6: the feedthrough matrix D has not a full row rank P; -C = 7: the computation of Hankel singular values failed. -C -C METHOD -C -C Let be the stable linear system -C -C d[x(t)] = Ax(t) + Bu(t) -C y(t) = Cx(t) + Du(t), (3) -C -C where d[x(t)] is dx(t)/dt for a continuous-time system and x(t+1) -C for a discrete-time system. The subroutine AB09HX determines for -C the given system (3), the matrices of a reduced NR-rder system -C -C d[z(t)] = Ar*z(t) + Br*u(t) -C yr(t) = Cr*z(t) + Dr*u(t), (4) -C -C such that -C -C HSV(NR) <= INFNORM(G-Gr) <= 2*[HSV(NR+1) + ... + HSV(N)], -C -C where G and Gr are transfer-function matrices of the systems -C (A,B,C,D) and (Ar,Br,Cr,Dr), respectively, and INFNORM(G) is the -C infinity-norm of G. -C -C If JOB = 'B', the square-root stochastic Balance & Truncate -C method of [1] is used and the resulting model is balanced. -C -C If JOB = 'F', the balancing-free square-root version of the -C stochastic Balance & Truncate method [1] is used. -C -C If JOB = 'S', the stochastic balancing method, in conjunction -C with the square-root version of the Singular Perturbation -C Approximation method [2,3] is used. -C -C If JOB = 'P', the stochastic balancing method, in conjunction -C with the balancing-free square-root version of the Singular -C Perturbation Approximation method [2,3] is used. -C -C By setting TOL1 = TOL2, the routine can be also used to compute -C Balance & Truncate approximations. -C -C REFERENCES -C -C [1] Varga A. and Fasol K.H. -C A new square-root balancing-free stochastic truncation -C model reduction algorithm. -C Proc. of 12th IFAC World Congress, Sydney, 1993. -C -C [2] Liu Y. and Anderson B.D.O. -C Singular Perturbation Approximation of balanced systems. -C Int. J. Control, Vol. 50, pp. 1379-1405, 1989. -C -C [3] Varga A. -C Balancing-free square-root algorithm for computing singular -C perturbation approximations. -C Proc. 30-th IEEE CDC, Brighton, Dec. 11-13, 1991, -C Vol. 2, pp. 1062-1065. -C -C NUMERICAL ASPECTS -C -C The implemented method relies on accuracy enhancing square-root -C or balancing-free square-root methods. The effectiveness of the -C accuracy enhancing technique depends on the accuracy of the -C solution of a Riccati equation. Ill-conditioned Riccati solution -C typically results when D is nearly rank deficient. -C 3 -C The algorithm requires about 100N floating point operations. -C -C CONTRIBUTORS -C -C A. Varga, German Aerospace Center, Oberpfaffenhofen, May 2000. -C D. Sima, University of Bucharest, May 2000. -C V. Sima, Research Institute for Informatics, Bucharest, May 2000. -C Partly based on the RASP routine SRBFS1, by A. Varga, 1992. -C -C REVISIONS -C -C V. Sima, Research Institute for Informatics, Bucharest, Oct. 2001. -C -C KEYWORDS -C -C Balance and truncate, minimal state-space representation, -C model reduction, multivariable system, -C singular perturbation approximation, state-space model, -C stochastic balancing. -C -C ****************************************************************** -C -C .. Parameters .. - DOUBLE PRECISION ONE, TWO, ZERO - PARAMETER ( ONE = 1.0D0, TWO = 2.0D0, ZERO = 0.0D0 ) -C .. Scalar Arguments .. - CHARACTER DICO, JOB, ORDSEL - INTEGER INFO, IWARN, LDA, LDB, LDC, LDD, LDT, LDTI, - $ LDWORK, M, N, NR, P - DOUBLE PRECISION TOL1, TOL2 -C .. Array Arguments .. - INTEGER IWORK(*) - DOUBLE PRECISION A(LDA,*), B(LDB,*), C(LDC,*), D(LDD,*), - $ DWORK(*), HSV(*), T(LDT,*), TI(LDTI,*) - LOGICAL BWORK(*) -C .. Local Scalars .. - LOGICAL BAL, BTA, DISCR, FIXORD, SPA - INTEGER IERR, IJ, J, K, KTAU, KU, KV, KW, LDW, LW, - $ NMINR, NR1, NS, WRKOPT - DOUBLE PRECISION ATOL, RCOND, RICOND, SCALEC, SCALEO, TEMP, - $ TOLDEF -C .. External Functions .. - LOGICAL LSAME - DOUBLE PRECISION DLAMCH - EXTERNAL DLAMCH, LSAME -C .. External Subroutines .. - EXTERNAL AB04MD, AB09DD, AB09HY, DGEMM, DGEMV, DGEQRF, - $ DGETRF, DGETRS, DLACPY, DORGQR, DSCAL, DTRMM, - $ DTRMV, MA02AD, MB03UD, XERBLA -C .. Intrinsic Functions .. - INTRINSIC DBLE, INT, MAX, MIN, SQRT -C .. Executable Statements .. -C - INFO = 0 - IWARN = 0 - DISCR = LSAME( DICO, 'D' ) - BTA = LSAME( JOB, 'B' ) .OR. LSAME( JOB, 'F' ) - SPA = LSAME( JOB, 'S' ) .OR. LSAME( JOB, 'P' ) - BAL = LSAME( JOB, 'B' ) .OR. LSAME( JOB, 'S' ) - FIXORD = LSAME( ORDSEL, 'F' ) - LW = MAX( 2, N*(MAX( N, M, P )+5), - $ 2*N*P+MAX( P*(M+2), 10*N*(N+1) ) ) -C -C Test the input scalar arguments. -C - IF( .NOT. ( LSAME( DICO, 'C' ) .OR. DISCR ) ) THEN - INFO = -1 - ELSE IF( .NOT. ( BTA .OR. SPA ) ) THEN - INFO = -2 - ELSE IF( .NOT. ( FIXORD .OR. LSAME( ORDSEL, 'A' ) ) ) THEN - INFO = -3 - ELSE IF( N.LT.0 ) THEN - INFO = -4 - ELSE IF( M.LT.0 ) THEN - INFO = -5 - ELSE IF( P.LT.0 .OR. P.GT.M ) THEN - INFO = -6 - ELSE IF( FIXORD .AND. ( NR.LT.0 .OR. NR.GT.N ) ) THEN - INFO = -7 - ELSE IF( LDA.LT.MAX( 1, N ) ) THEN - INFO = -9 - ELSE IF( LDB.LT.MAX( 1, N ) ) THEN - INFO = -11 - ELSE IF( LDC.LT.MAX( 1, P ) ) THEN - INFO = -13 - ELSE IF( LDD.LT.MAX( 1, P ) ) THEN - INFO = -15 - ELSE IF( LDT.LT.MAX( 1, N ) ) THEN - INFO = -18 - ELSE IF( LDTI.LT.MAX( 1, N ) ) THEN - INFO = -20 - ELSE IF( TOL2.GT.ZERO .AND. .NOT.FIXORD .AND. TOL2.GT.TOL1 ) THEN - INFO = -22 - ELSE IF( LDWORK.LT.LW ) THEN - INFO = -25 - END IF -C - IF( INFO.NE.0 ) THEN -C -C Error return. -C - CALL XERBLA( 'AB09HX', -INFO ) - RETURN - END IF -C -C Quick return if possible. -C - IF( MIN( N, M, P ).EQ.0 ) THEN - NR = 0 - IWORK(1) = 0 - DWORK(1) = TWO - DWORK(2) = ONE - RETURN - END IF -C -C For discrete-time case, apply the discrete-to-continuous bilinear -C transformation. -C - IF( DISCR ) THEN -C -C Real workspace: need N, prefer larger; -C Integer workspace: need N. -C - CALL AB04MD( 'Discrete', N, M, P, ONE, ONE, A, LDA, B, LDB, - $ C, LDC, D, LDD, IWORK, DWORK, LDWORK, IERR ) - IF( IERR.NE.0 ) THEN - INFO = 1 - RETURN - END IF - WRKOPT = MAX( N, INT( DWORK(1) ) ) - ELSE - WRKOPT = 0 - END IF -C -C Compute in TI and T the Cholesky factors Su and Ru of the -C controllability and observability Grammians, respectively. -C Real workspace: need MAX( 2, N*(MAX(N,M,P)+5), -C 2*N*P+MAX(P*(M+2),10*N*(N+1) ) ); -C prefer larger. -C Integer workspace: need 2*N. -C - CALL AB09HY( N, M, P, A, LDA, B, LDB, C, LDC, D, LDD, - $ SCALEC, SCALEO, TI, LDTI, T, LDT, IWORK, - $ DWORK, LDWORK, BWORK, INFO ) - IF( INFO.NE.0) - $ RETURN - WRKOPT = MAX( WRKOPT, INT( DWORK(1) ) ) - RICOND = DWORK(2) -C -C Save Su in V. -C - KU = 1 - KV = KU + N*N - KW = KV + N*N - CALL DLACPY( 'Upper', N, N, TI, LDTI, DWORK(KV), N ) -C | x x | -C Compute Ru*Su in the form | 0 x | in TI. -C - DO 10 J = 1, N - CALL DTRMV( 'Upper', 'NoTranspose', 'NonUnit', J, T, LDT, - $ TI(1,J), 1 ) - 10 CONTINUE -C -C Compute the singular value decomposition Ru*Su = V*S*UT -C of the upper triangular matrix Ru*Su, with UT in TI and V in U. -C -C Workspace: need 2*N*N + 5*N; -C prefer larger. -C - CALL MB03UD( 'Vectors', 'Vectors', N, TI, LDTI, DWORK(KU), N, HSV, - $ DWORK(KW), LDWORK-KW+1, IERR ) - IF( IERR.NE.0 ) THEN - INFO = 7 - RETURN - ENDIF - WRKOPT = MAX( WRKOPT, INT( DWORK(KW) ) + KW - 1 ) -C -C Scale the singular values. -C - CALL DSCAL( N, ONE / SCALEC / SCALEO, HSV, 1 ) -C -C Partition S, U and V conformally as: -C -C S = diag(S1,S2,S3), U = [U1,U2,U3] (U' in TI) and V = [V1,V2,V3] -C (in U). -C -C Compute the order NR of reduced system, as the order of S1. -C - TOLDEF = DBLE( N )*DLAMCH( 'Epsilon' ) - ATOL = TOLDEF - IF( FIXORD ) THEN - IF( NR.GT.0 ) THEN - IF( HSV(NR).LE.ATOL ) THEN - NR = 0 - IWARN = 1 - FIXORD = .FALSE. - ENDIF - ENDIF - ELSE - ATOL = MAX( TOL1, ATOL ) - NR = 0 - ENDIF - IF( .NOT.FIXORD ) THEN - DO 20 J = 1, N - IF( HSV(J).LE.ATOL ) GO TO 30 - NR = NR + 1 - 20 CONTINUE - 30 CONTINUE - ENDIF -C -C Compute the order of minimal realization as the order of [S1 S2]. -C - NR1 = NR + 1 - NMINR = NR - IF( NR.LT.N ) THEN - IF( SPA ) ATOL = MAX( TOL2, TOLDEF ) - DO 40 J = NR1, N - IF( HSV(J).LE.ATOL ) GO TO 50 - NMINR = NMINR + 1 - 40 CONTINUE - 50 CONTINUE - END IF -C -C Finish if the order is zero. -C - IF( NR.EQ.0 ) THEN - IF( SPA ) THEN - CALL AB09DD( 'Continuous', N, M, P, NR, A, LDA, B, LDB, - $ C, LDC, D, LDD, RCOND, IWORK, DWORK, IERR ) - IWORK(1) = NMINR - ELSE - IWORK(1) = 0 - END IF - DWORK(1) = WRKOPT - DWORK(2) = RICOND - RETURN - END IF -C -C Compute NS, the order of S2. -C Note: For BTA, NS is always zero, because NMINR = NR. -C - NS = NMINR - NR -C -C Compute the truncation matrices. -C -C Compute TI' = | TI1' TI2' | = Ru'*| V1 V2 | in U. -C - CALL DTRMM( 'Left', 'Upper', 'Transpose', 'NonUnit', N, NMINR, - $ ONE, T, LDT, DWORK(KU), N ) -C -C Compute T = | T1 T2 | = Su*| U1 U2 | . -C - CALL MA02AD( 'Full', NMINR, N, TI, LDTI, T, LDT ) - CALL DTRMM( 'Left', 'Upper', 'NoTranspose', 'NonUnit', N, - $ NMINR, ONE, DWORK(KV), N, T, LDT ) - KTAU = KV -C - IF( BAL ) THEN - IJ = KU -C -C Square-Root B&T/SPA method. -C -C Compute the truncation matrices for balancing -C -1/2 -1/2 -C T1*S1 and TI1'*S1 . -C - DO 70 J = 1, NR - TEMP = ONE/SQRT( HSV(J) ) - CALL DSCAL( N, TEMP, T(1,J), 1 ) - CALL DSCAL( N, TEMP, DWORK(IJ), 1 ) - IJ = IJ + N - 70 CONTINUE - ELSE -C -C Balancing-Free B&T/SPA method. -C -C Compute orthogonal bases for the images of matrices T1 and -C TI1'. -C -C Workspace: need N*MAX(N,M,P) + 2*NR; -C prefer N*MAX(N,M,P) + NR*(NB+1) -C (NB determined by ILAENV for DGEQRF). -C - KW = KTAU + NR - LDW = LDWORK - KW + 1 - CALL DGEQRF( N, NR, T, LDT, DWORK(KTAU), DWORK(KW), LDW, IERR ) - CALL DORGQR( N, NR, NR, T, LDT, DWORK(KTAU), DWORK(KW), LDW, - $ IERR ) - CALL DGEQRF( N, NR, DWORK(KU), N, DWORK(KTAU), DWORK(KW), LDW, - $ IERR ) - WRKOPT = MAX( WRKOPT, INT( DWORK(KW) ) + KW - 1 ) - CALL DORGQR( N, NR, NR, DWORK(KU), N, DWORK(KTAU), DWORK(KW), - $ LDW, IERR ) - WRKOPT = MAX( WRKOPT, INT( DWORK(KW) ) + KW - 1 ) - ENDIF - IF( NS.GT.0 ) THEN -C -C Compute orthogonal bases for the images of matrices T2 and -C TI2'. -C -C Workspace: need N*MAX(N,M,P) + 2*NS; -C prefer N*MAX(N,M,P) + NS*(NB+1) -C (NB determined by ILAENV for DGEQRF). - KW = KTAU + NS - LDW = LDWORK - KW + 1 - CALL DGEQRF( N, NS, T(1,NR1), LDT, DWORK(KTAU), DWORK(KW), LDW, - $ IERR ) - CALL DORGQR( N, NS, NS, T(1,NR1), LDT, DWORK(KTAU), DWORK(KW), - $ LDW, IERR ) - CALL DGEQRF( N, NS, DWORK(KU+N*NR), N, DWORK(KTAU), DWORK(KW), - $ LDW, IERR ) - WRKOPT = MAX( WRKOPT, INT( DWORK(KW) ) + KW - 1 ) - CALL DORGQR( N, NS, NS, DWORK(KU+N*NR), N, DWORK(KTAU), - $ DWORK(KW), LDW, IERR ) - WRKOPT = MAX( WRKOPT, INT( DWORK(KW) ) + KW - 1 ) - ENDIF -C -C Transpose TI' in TI. -C - CALL MA02AD( 'Full', N, NMINR, DWORK(KU), N, TI, LDTI ) -C - IF( .NOT.BAL ) THEN -C -1 -C Compute (TI1*T1) *TI1 in TI. -C - CALL DGEMM( 'NoTranspose', 'NoTranspose', NR, NR, N, ONE, TI, - $ LDTI, T, LDT, ZERO, DWORK(KU), N ) - CALL DGETRF( NR, NR, DWORK(KU), N, IWORK, IERR ) - CALL DGETRS( 'NoTranspose', NR, N, DWORK(KU), N, IWORK, TI, - $ LDTI, IERR ) -C - IF( NS.GT.0 ) THEN -C -1 -C Compute (TI2*T2) *TI2 in TI2. -C - CALL DGEMM( 'NoTranspose', 'NoTranspose', NS, NS, N, ONE, - $ TI(NR1,1), LDTI, T(1,NR1), LDT, ZERO, DWORK(KU), - $ N ) - CALL DGETRF( NS, NS, DWORK(KU), N, IWORK, IERR ) - CALL DGETRS( 'NoTranspose', NS, N, DWORK(KU), N, IWORK, - $ TI(NR1,1), LDTI, IERR ) - END IF - END IF -C -C Compute TI*A*T (A is in RSF). -C - IJ = KU - DO 80 J = 1, N - K = MIN( J+1, N ) - CALL DGEMV( 'NoTranspose', NMINR, K, ONE, TI, LDTI, A(1,J), 1, - $ ZERO, DWORK(IJ), 1 ) - IJ = IJ + N - 80 CONTINUE - CALL DGEMM( 'NoTranspose', 'NoTranspose', NMINR, NMINR, N, ONE, - $ DWORK(KU), N, T, LDT, ZERO, A, LDA ) -C -C Compute TI*B and C*T. -C - CALL DLACPY( 'Full', N, M, B, LDB, DWORK(KU), N ) - CALL DGEMM( 'NoTranspose', 'NoTranspose', NMINR, M, N, ONE, TI, - $ LDTI, DWORK(KU), N, ZERO, B, LDB ) -C - CALL DLACPY( 'Full', P, N, C, LDC, DWORK(KU), P ) - CALL DGEMM( 'NoTranspose', 'NoTranspose', P, NMINR, N, ONE, - $ DWORK(KU), P, T, LDT, ZERO, C, LDC ) -C -C Compute the singular perturbation approximation if possible. -C Note that IERR = 1 on exit from AB09DD cannot appear here. -C -C Workspace: need real 4*(NMINR-NR); -C need integer 2*(NMINR-NR). -C - CALL AB09DD( 'Continuous', NMINR, M, P, NR, A, LDA, B, LDB, - $ C, LDC, D, LDD, RCOND, IWORK, DWORK, IERR ) -C -C For discrete-time case, apply the continuous-to-discrete -C bilinear transformation. -C - IF( DISCR ) THEN - CALL AB04MD( 'Continuous', NR, M, P, ONE, ONE, A, LDA, B, LDB, - $ C, LDC, D, LDD, IWORK, DWORK, LDWORK, IERR ) -C - WRKOPT = MAX( WRKOPT, INT( DWORK(1) ) ) - END IF - IWORK(1) = NMINR - DWORK(1) = WRKOPT - DWORK(2) = RICOND -C - RETURN -C *** Last line of AB09HX *** - END diff --git a/mex/sources/libslicot/AB09HY.f b/mex/sources/libslicot/AB09HY.f deleted file mode 100644 index 78a1093e6..000000000 --- a/mex/sources/libslicot/AB09HY.f +++ /dev/null @@ -1,396 +0,0 @@ - SUBROUTINE AB09HY( N, M, P, A, LDA, B, LDB, C, LDC, D, LDD, - $ SCALEC, SCALEO, S, LDS, R, LDR, IWORK, - $ DWORK, LDWORK, BWORK, INFO ) -C -C SLICOT RELEASE 5.0. -C -C Copyright (c) 2002-2009 NICONET e.V. -C -C This program is free software: you can redistribute it and/or -C modify it under the terms of the GNU General Public License as -C published by the Free Software Foundation, either version 2 of -C the License, or (at your option) any later version. -C -C This program is distributed in the hope that it will be useful, -C but WITHOUT ANY WARRANTY; without even the implied warranty of -C MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the -C GNU General Public License for more details. -C -C You should have received a copy of the GNU General Public License -C along with this program. If not, see -C . -C -C PURPOSE -C -C To compute the Cholesky factors Su and Ru of the controllability -C Grammian P = Su*Su' and observability Grammian Q = Ru'*Ru, -C respectively, satisfying -C -C A*P + P*A' + scalec^2*B*B' = 0, (1) -C -C A'*Q + Q*A + scaleo^2*Cw'*Cw = 0, (2) -C -C where -C Cw = Hw - Bw'*X, -C Hw = inv(Dw)*C, -C Bw = (B*D' + P*C')*inv(Dw'), -C D*D' = Dw*Dw' (Dw upper triangular), -C -C and, with Aw = A - Bw*Hw, X is the stabilizing solution of the -C Riccati equation -C -C Aw'*X + X*Aw + Hw'*Hw + X*Bw*Bw'*X = 0. (3) -C -C The P-by-M matrix D must have full row rank. Matrix A must be -C stable and in a real Schur form. -C -C ARGUMENTS -C -C Input/Output Parameters -C -C N (input) INTEGER -C The order of state-space representation, i.e., -C the order of the matrix A. N >= 0. -C -C M (input) INTEGER -C The number of system inputs. M >= 0. -C -C P (input) INTEGER -C The number of system outputs. M >= P >= 0. -C -C A (input) DOUBLE PRECISION array, dimension (LDA,N) -C The leading N-by-N part of this array must contain the -C stable state dynamics matrix A in a real Schur canonical -C form. -C -C LDA INTEGER -C The leading dimension of array A. LDA >= MAX(1,N). -C -C B (input) DOUBLE PRECISION array, dimension (LDB,M) -C The leading N-by-M part of this array must contain the -C input/state matrix B, corresponding to the Schur matrix A. -C -C LDB INTEGER -C The leading dimension of array B. LDB >= MAX(1,N). -C -C C (input) DOUBLE PRECISION array, dimension (LDC,N) -C The leading P-by-N part of this array must contain the -C state/output matrix C, corresponding to the Schur -C matrix A. -C -C LDC INTEGER -C The leading dimension of array C. LDC >= MAX(1,P). -C -C D (input) DOUBLE PRECISION array, dimension (LDD,M) -C The leading P-by-M part of this array must -C contain the full row rank input/output matrix D. -C -C LDD INTEGER -C The leading dimension of array D. LDD >= MAX(1,P). -C -C SCALEC (output) DOUBLE PRECISION -C Scaling factor for the controllability Grammian in (1). -C -C SCALEO (output) DOUBLE PRECISION -C Scaling factor for the observability Grammian in (2). -C -C S (output) DOUBLE PRECISION array, dimension (LDS,N) -C The leading N-by-N upper triangular part of this array -C contains the Cholesky factor Su of the cotrollability -C Grammian P = Su*Su' satisfying (1). -C -C LDS INTEGER -C The leading dimension of array S. LDS >= MAX(1,N). -C -C R (output) DOUBLE PRECISION array, dimension (LDR,N) -C The leading N-by-N upper triangular part of this array -C contains the Cholesky factor Ru of the observability -C Grammian Q = Ru'*Ru satisfying (2). -C -C LDR INTEGER -C The leading dimension of array R. LDR >= MAX(1,N). -C -C Workspace -C -C IWORK INTEGER array, dimension 2*N -C -C DWORK DOUBLE PRECISION array, dimension (LDWORK) -C On exit, if INFO = 0, DWORK(1) returns the optimal value -C of LDWORK and DWORK(2) contains RCOND, the reciprocal -C condition number of the U11 matrix from the expression -C used to compute X = U21*inv(U11). A small value RCOND -C indicates possible ill-conditioning of the Riccati -C equation (3). -C -C LDWORK INTEGER -C The length of the array DWORK. -C LDWORK >= MAX( 2, N*(MAX(N,M,P)+5), -C 2*N*P+MAX(P*(M+2),10*N*(N+1) ) ). -C For optimum performance LDWORK should be larger. -C -C BWORK LOGICAL array, dimension 2*N -C -C Error Indicator -C -C INFO INTEGER -C = 0: successful exit; -C < 0: if INFO = -i, the i-th argument had an illegal -C value; -C = 1: the state matrix A is not stable or is not in a -C real Schur form; -C = 2: the reduction of Hamiltonian matrix to real Schur -C form failed; -C = 3: the reordering of the real Schur form of the -C Hamiltonian matrix failed; -C = 4: the Hamiltonian matrix has less than N stable -C eigenvalues; -C = 5: the coefficient matrix U11 in the linear system -C X*U11 = U21, used to determine X, is singular to -C working precision; -C = 6: the feedthrough matrix D has not a full row rank P. -C -C CONTRIBUTORS -C -C A. Varga, German Aerospace Center, Oberpfaffenhofen, May 2000. -C D. Sima, University of Bucharest, May 2000. -C V. Sima, Research Institute for Informatics, Bucharest, May 2000. -C Based on the RASP routines SRGRO and SRGRO1, by A. Varga, 1992. -C -C REVISIONS -C -C V. Sima, Research Institute for Informatics, Bucharest, Oct. 2001. -C -C KEYWORDS -C -C Minimal realization, model reduction, multivariable system, -C state-space model, state-space representation, -C stochastic balancing. -C -C ****************************************************************** -C -C .. Parameters .. - DOUBLE PRECISION ZERO, ONE, TWO - PARAMETER ( ZERO = 0.0D0, ONE = 1.0D0, TWO = 2.0D0 ) -C .. Scalar Arguments .. - INTEGER INFO, LDA, LDB, LDC, LDD, LDR, LDS, LDWORK, M, N, - $ P - DOUBLE PRECISION SCALEC, SCALEO -C .. Array Arguments .. - INTEGER IWORK(*) - DOUBLE PRECISION A(LDA,*), B(LDB,*), C(LDC,*), D(LDD,*), - $ DWORK(*), R(LDR,*), S(LDS,*) - LOGICAL BWORK(*) -C .. Local Scalars .. - INTEGER I, IERR, KBW, KCW, KD, KDW, KG, KQ, KS, KTAU, KU, - $ KW, KWI, KWR, LW, N2, WRKOPT - DOUBLE PRECISION RCOND, RTOL -C .. External Functions .. - DOUBLE PRECISION DLANGE, DLAMCH - EXTERNAL DLANGE, DLAMCH -C .. External Subroutines .. - EXTERNAL DGEMM, DGERQF, DLACPY, DORGRQ, DSYRK, DTRMM, - $ DTRSM, SB02MD, SB03OU, XERBLA -C .. Intrinsic Functions .. - INTRINSIC ABS, DBLE, INT, MAX, MIN -C .. Executable Statements .. -C - INFO = 0 - LW = MAX( 2, N*( MAX( N, M, P ) + 5 ), - $ 2*N*P + MAX( P*(M + 2), 10*N*(N + 1) ) ) -C - IF( N.LT.0 ) THEN - INFO = -1 - ELSE IF( M.LT.0 ) THEN - INFO = -2 - ELSE IF( P.LT.0 .OR. P.GT.M ) THEN - INFO = -3 - ELSE IF( LDA.LT.MAX( 1, N ) ) THEN - INFO = -5 - ELSE IF( LDB.LT.MAX( 1, N ) ) THEN - INFO = -7 - ELSE IF( LDC.LT.MAX( 1, P ) ) THEN - INFO = -9 - ELSE IF( LDD.LT.MAX( 1, P ) ) THEN - INFO = -11 - ELSE IF( LDS.LT.MAX( 1, N ) ) THEN - INFO = -15 - ELSE IF( LDR.LT.MAX( 1, N ) ) THEN - INFO = -17 - ELSE IF( LDWORK.LT.LW ) THEN - INFO = -20 - END IF -C - IF( INFO.NE.0 ) THEN -C -C Error return. -C - CALL XERBLA( 'AB09HY', -INFO ) - RETURN - END IF -C -C Quick return if possible. -C - SCALEC = ONE - SCALEO = ONE - IF( MIN( N, M, P ).EQ.0 ) THEN - DWORK(1) = TWO - DWORK(2) = ONE - RETURN - END IF -C -C Solve for Su the Lyapunov equation -C 2 -C A*(Su*Su') + (Su*Su')*A' + scalec *B*B' = 0 . -C -C Workspace: need N*(MAX(N,M) + 5); -C prefer larger. -C - KU = 1 - KTAU = KU + N*MAX( N, M ) - KW = KTAU + N -C - CALL DLACPY( 'Full', N, M, B, LDB, DWORK(KU), N ) - CALL SB03OU( .FALSE., .TRUE., N, M, A, LDA, DWORK(KU), N, - $ DWORK(KTAU), S, LDS, SCALEC, DWORK(KW), - $ LDWORK - KW + 1, IERR ) - IF( IERR.NE.0 ) THEN - INFO = 1 - RETURN - ENDIF - WRKOPT = INT( DWORK(KW) ) + KW - 1 -C -C Allocate workspace for Bw' (P*N), Cw (P*N), Q2 (P*M), -C where Q2 = inv(Dw)*D. -C Workspace: need 2*N*P + P*M. -C - KBW = 1 - KCW = KBW + P*N - KD = KCW + P*N - KDW = KD + P*(M - P) - KTAU = KD + P*M - KW = KTAU + P -C -C Compute an upper-triangular Dw such that D*D' = Dw*Dw', using -C the RQ-decomposition of D: D = [0 Dw]*( Q1 ). -C ( Q2 ) -C Additional workspace: need 2*P; prefer P + P*NB. -C - CALL DLACPY( 'F', P, M, D, LDD, DWORK(KD), P ) - CALL DGERQF( P, M, DWORK(KD), P, DWORK(KTAU), DWORK(KW), - $ LDWORK-KW+1, IERR ) - WRKOPT = MAX( WRKOPT, INT( DWORK(KW) ) + KW - 1 ) -C -C Check the full row rank of D. -C - RTOL = DBLE( M ) * DLAMCH( 'E' ) * - $ DLANGE( '1', P, M, D, LDD, DWORK ) - DO 10 I = KDW, KDW+P*P-1, P+1 - IF( ABS( DWORK(I) ).LE.RTOL ) THEN - INFO = 6 - RETURN - END IF - 10 CONTINUE -C -1 -C Compute Hw = Dw *C. -C - CALL DLACPY( 'F', P, N, C, LDC, DWORK(KCW), P ) - CALL DTRSM( 'Left', 'Upper', 'No-transpose', 'Non-unit', P, N, - $ ONE, DWORK(KDW), P, DWORK(KCW), P ) -C -C Compute Bw' = inv(Dw)*(D*B' + C*Su*Su'). -C -C Compute first Hw*Su*Su' in Bw'. -C - CALL DLACPY( 'F', P, N, DWORK(KCW), P, DWORK(KBW), P ) - CALL DTRMM( 'Right', 'Upper', 'No-transpose', 'Non-unit', P, N, - $ ONE, S, LDS, DWORK(KBW), P ) - CALL DTRMM( 'Right', 'Upper', 'Transpose', 'Non-unit', P, N, - $ ONE, S, LDS, DWORK(KBW), P ) -C -C Compute Q2 = inv(Dw)*D, as the last P lines of the orthogonal -C matrix ( Q1 ) from the RQ decomposition of D. -C ( Q2 ) -C Additional workspace: need P; prefer P*NB. -C - CALL DORGRQ( P, M, P, DWORK(KD), P, DWORK(KTAU), DWORK(KW), - $ LDWORK-KW+1, IERR ) - WRKOPT = MAX( WRKOPT, INT( DWORK(KW) ) + KW - 1 ) -C -C Compute Bw' <- Bw' + Q2*B'. -C - CALL DGEMM( 'No-transpose', 'Transpose', P, N, M, ONE, - $ DWORK(KD), P, B, LDB, ONE, DWORK(KBW), P ) -C -C Compute Aw = A - Bw*Hw in R. -C - CALL DLACPY( 'F', N, N, A, LDA, R, LDR ) - CALL DGEMM( 'Transpose', 'No-transpose', N, N, P, -ONE, - $ DWORK(KBW), P, DWORK(KCW), P, ONE, R, LDR ) -C -C Allocate storage to solve the Riccati equation (3) for -C G(N*N), Q(N*N), WR(2N), WI(2N), S(2N*2N), U(2N*2N). -C - N2 = N + N - KG = KD - KQ = KG + N*N - KWR = KQ + N*N - KWI = KWR + N2 - KS = KWI + N2 - KU = KS + N2*N2 - KW = KU + N2*N2 -C -C Compute G = -Bw*Bw'. -C - CALL DSYRK( 'Upper', 'Transpose', N, P, -ONE, DWORK(KBW), P, ZERO, - $ DWORK(KG), N ) -C -C Compute Q = Hw'*Hw. -C - CALL DSYRK( 'Upper', 'Transpose', N, P, ONE, DWORK(KCW), P, ZERO, - $ DWORK(KQ), N ) -C -C Solve -C -C Aw'*X + X*Aw + Q - X*G*X = 0, -C -C with Q = Hw'*Hw and G = -Bw*Bw'. -C Additional workspace: need 6*N; -C prefer larger. -C - CALL SB02MD( 'Continuous', 'None', 'Upper', 'General', 'Stable', - $ N, R, LDR, DWORK(KG), N, DWORK(KQ), N, RCOND, - $ DWORK(KWR), DWORK(KWI), DWORK(KS), N2, - $ DWORK(KU), N2, IWORK, DWORK(KW), LDWORK-KW+1, - $ BWORK, INFO ) - IF( INFO.NE.0 ) - $ RETURN - WRKOPT = MAX( WRKOPT, INT( DWORK(KW) ) + KW - 1 ) -C -C Compute Cw = Hw - Bw'*X. -C - CALL DGEMM ( 'No-transpose', 'No-transpose', P, N, N, -ONE, - $ DWORK(KBW), P, DWORK(KQ), N, ONE, DWORK(KCW), P ) -C -C Solve for Ru the Lyapunov equation -C 2 -C A'*(Ru'*Ru) + (Ru'*Ru)*A + scaleo * Cw'*Cw = 0 . -C -C Workspace: need N*(MAX(N,P) + 5); -C prefer larger. -C - KTAU = KCW + N*MAX( N, P ) - KW = KTAU + N -C - CALL SB03OU( .FALSE., .FALSE., N, P, A, LDA, DWORK(KCW), P, - $ DWORK(KTAU), R, LDR, SCALEO, DWORK(KW), - $ LDWORK - KW + 1, IERR ) - WRKOPT = MAX( WRKOPT, INT( DWORK(KW) ) + KW - 1 ) -C -C Save optimal workspace and RCOND. -C - DWORK(1) = WRKOPT - DWORK(2) = RCOND -C - RETURN -C *** Last line of AB09HY *** - END diff --git a/mex/sources/libslicot/AB09ID.f b/mex/sources/libslicot/AB09ID.f deleted file mode 100644 index 2448d4660..000000000 --- a/mex/sources/libslicot/AB09ID.f +++ /dev/null @@ -1,1048 +0,0 @@ - SUBROUTINE AB09ID( DICO, JOBC, JOBO, JOB, WEIGHT, EQUIL, ORDSEL, - $ N, M, P, NV, PV, NW, MW, NR, ALPHA, ALPHAC, - $ ALPHAO, A, LDA, B, LDB, C, LDC, D, LDD, - $ AV, LDAV, BV, LDBV, CV, LDCV, DV, LDDV, - $ AW, LDAW, BW, LDBW, CW, LDCW, DW, LDDW, - $ NS, HSV, TOL1, TOL2, IWORK, DWORK, LDWORK, - $ IWARN, INFO ) -C -C SLICOT RELEASE 5.0. -C -C Copyright (c) 2002-2009 NICONET e.V. -C -C This program is free software: you can redistribute it and/or -C modify it under the terms of the GNU General Public License as -C published by the Free Software Foundation, either version 2 of -C the License, or (at your option) any later version. -C -C This program is distributed in the hope that it will be useful, -C but WITHOUT ANY WARRANTY; without even the implied warranty of -C MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the -C GNU General Public License for more details. -C -C You should have received a copy of the GNU General Public License -C along with this program. If not, see -C . -C -C PURPOSE -C -C To compute a reduced order model (Ar,Br,Cr,Dr) for an original -C state-space representation (A,B,C,D) by using the frequency -C weighted square-root or balancing-free square-root -C Balance & Truncate (B&T) or Singular Perturbation Approximation -C (SPA) model reduction methods. The algorithm tries to minimize -C the norm of the frequency-weighted error -C -C ||V*(G-Gr)*W|| -C -C where G and Gr are the transfer-function matrices of the original -C and reduced order models, respectively, and V and W are -C frequency-weighting transfer-function matrices. V and W must not -C have poles on the imaginary axis for a continuous-time -C system or on the unit circle for a discrete-time system. -C If G is unstable, only the ALPHA-stable part of G is reduced. -C In case of possible pole-zero cancellations in V*G and/or G*W, -C the absolute values of parameters ALPHAO and/or ALPHAC must be -C different from 1. -C -C ARGUMENTS -C -C Mode Parameters -C -C DICO CHARACTER*1 -C Specifies the type of the original system as follows: -C = 'C': continuous-time system; -C = 'D': discrete-time system. -C -C JOBC CHARACTER*1 -C Specifies the choice of frequency-weighted controllability -C Grammian as follows: -C = 'S': choice corresponding to a combination method [4] -C of the approaches of Enns [1] and Lin-Chiu [2,3]; -C = 'E': choice corresponding to the stability enhanced -C modified combination method of [4]. -C -C JOBO CHARACTER*1 -C Specifies the choice of frequency-weighted observability -C Grammian as follows: -C = 'S': choice corresponding to a combination method [4] -C of the approaches of Enns [1] and Lin-Chiu [2,3]; -C = 'E': choice corresponding to the stability enhanced -C modified combination method of [4]. -C -C JOB CHARACTER*1 -C Specifies the model reduction approach to be used -C as follows: -C = 'B': use the square-root Balance & Truncate method; -C = 'F': use the balancing-free square-root -C Balance & Truncate method; -C = 'S': use the square-root Singular Perturbation -C Approximation method; -C = 'P': use the balancing-free square-root -C Singular Perturbation Approximation method. -C -C WEIGHT CHARACTER*1 -C Specifies the type of frequency weighting, as follows: -C = 'N': no weightings are used (V = I, W = I); -C = 'L': only left weighting V is used (W = I); -C = 'R': only right weighting W is used (V = I); -C = 'B': both left and right weightings V and W are used. -C -C EQUIL CHARACTER*1 -C Specifies whether the user wishes to preliminarily -C equilibrate the triplet (A,B,C) as follows: -C = 'S': perform equilibration (scaling); -C = 'N': do not perform equilibration. -C -C ORDSEL CHARACTER*1 -C Specifies the order selection method as follows: -C = 'F': the resulting order NR is fixed; -C = 'A': the resulting order NR is automatically determined -C on basis of the given tolerance TOL1. -C -C Input/Output Parameters -C -C N (input) INTEGER -C The order of the original state-space representation, -C i.e., the order of the matrix A. N >= 0. -C -C M (input) INTEGER -C The number of system inputs. M >= 0. -C -C P (input) INTEGER -C The number of system outputs. P >= 0. -C -C NV (input) INTEGER -C The order of the matrix AV. Also the number of rows of -C the matrix BV and the number of columns of the matrix CV. -C NV represents the dimension of the state vector of the -C system with the transfer-function matrix V. NV >= 0. -C -C PV (input) INTEGER -C The number of rows of the matrices CV and DV. PV >= 0. -C PV represents the dimension of the output vector of the -C system with the transfer-function matrix V. -C -C NW (input) INTEGER -C The order of the matrix AW. Also the number of rows of -C the matrix BW and the number of columns of the matrix CW. -C NW represents the dimension of the state vector of the -C system with the transfer-function matrix W. NW >= 0. -C -C MW (input) INTEGER -C The number of columns of the matrices BW and DW. MW >= 0. -C MW represents the dimension of the input vector of the -C system with the transfer-function matrix W. -C -C NR (input/output) INTEGER -C On entry with ORDSEL = 'F', NR is the desired order of the -C resulting reduced order system. 0 <= NR <= N. -C On exit, if INFO = 0, NR is the order of the resulting -C reduced order model. For a system with NU ALPHA-unstable -C eigenvalues and NS ALPHA-stable eigenvalues (NU+NS = N), -C NR is set as follows: if ORDSEL = 'F', NR is equal to -C NU+MIN(MAX(0,NR-NU),NMIN), where NR is the desired order -C on entry, NMIN is the number of frequency-weighted Hankel -C singular values greater than NS*EPS*S1, EPS is the -C machine precision (see LAPACK Library Routine DLAMCH) -C and S1 is the largest Hankel singular value (computed -C in HSV(1)); NR can be further reduced to ensure -C HSV(NR-NU) > HSV(NR+1-NU); -C if ORDSEL = 'A', NR is the sum of NU and the number of -C Hankel singular values greater than MAX(TOL1,NS*EPS*S1). -C -C ALPHA (input) DOUBLE PRECISION -C Specifies the ALPHA-stability boundary for the eigenvalues -C of the state dynamics matrix A. For a continuous-time -C system (DICO = 'C'), ALPHA <= 0 is the boundary value for -C the real parts of eigenvalues, while for a discrete-time -C system (DICO = 'D'), 0 <= ALPHA <= 1 represents the -C boundary value for the moduli of eigenvalues. -C The ALPHA-stability domain does not include the boundary. -C -C ALPHAC (input) DOUBLE PRECISION -C Combination method parameter for defining the -C frequency-weighted controllability Grammian (see METHOD); -C ABS(ALPHAC) <= 1. -C -C ALPHAO (input) DOUBLE PRECISION -C Combination method parameter for defining the -C frequency-weighted observability Grammian (see METHOD); -C ABS(ALPHAO) <= 1. -C -C A (input/output) DOUBLE PRECISION array, dimension (LDA,N) -C On entry, the leading N-by-N part of this array must -C contain the state dynamics matrix A. -C On exit, if INFO = 0, the leading NR-by-NR part of this -C array contains the state dynamics matrix Ar of the -C reduced order system. -C The resulting A has a block-diagonal form with two blocks. -C For a system with NU ALPHA-unstable eigenvalues and -C NS ALPHA-stable eigenvalues (NU+NS = N), the leading -C NU-by-NU block contains the unreduced part of A -C corresponding to ALPHA-unstable eigenvalues. -C The trailing (NR+NS-N)-by-(NR+NS-N) block contains -C the reduced part of A corresponding to ALPHA-stable -C eigenvalues. -C -C LDA INTEGER -C The leading dimension of array A. LDA >= MAX(1,N). -C -C B (input/output) DOUBLE PRECISION array, dimension (LDB,M) -C On entry, the leading N-by-M part of this array must -C contain the original input/state matrix B. -C On exit, if INFO = 0, the leading NR-by-M part of this -C array contains the input/state matrix Br of the reduced -C order system. -C -C LDB INTEGER -C The leading dimension of array B. LDB >= MAX(1,N). -C -C C (input/output) DOUBLE PRECISION array, dimension (LDC,N) -C On entry, the leading P-by-N part of this array must -C contain the original state/output matrix C. -C On exit, if INFO = 0, the leading P-by-NR part of this -C array contains the state/output matrix Cr of the reduced -C order system. -C -C LDC INTEGER -C The leading dimension of array C. LDC >= MAX(1,P). -C -C D (input/output) DOUBLE PRECISION array, dimension (LDD,M) -C On entry, the leading P-by-M part of this array must -C contain the original input/output matrix D. -C On exit, if INFO = 0, the leading P-by-M part of this -C array contains the input/output matrix Dr of the reduced -C order system. -C -C LDD INTEGER -C The leading dimension of array D. LDD >= MAX(1,P). -C -C AV (input/output) DOUBLE PRECISION array, dimension (LDAV,NV) -C On entry, if WEIGHT = 'L' or 'B', the leading NV-by-NV -C part of this array must contain the state matrix AV of -C the system with the transfer-function matrix V. -C On exit, if WEIGHT = 'L' or 'B', MIN(N,M,P) > 0 and -C INFO = 0, the leading NVR-by-NVR part of this array -C contains the state matrix of a minimal realization of V -C in a real Schur form. NVR is returned in IWORK(2). -C AV is not referenced if WEIGHT = 'R' or 'N', -C or MIN(N,M,P) = 0. -C -C LDAV INTEGER -C The leading dimension of array AV. -C LDAV >= MAX(1,NV), if WEIGHT = 'L' or 'B'; -C LDAV >= 1, if WEIGHT = 'R' or 'N'. -C -C BV (input/output) DOUBLE PRECISION array, dimension (LDBV,P) -C On entry, if WEIGHT = 'L' or 'B', the leading NV-by-P part -C of this array must contain the input matrix BV of the -C system with the transfer-function matrix V. -C On exit, if WEIGHT = 'L' or 'B', MIN(N,M,P) > 0 and -C INFO = 0, the leading NVR-by-P part of this array contains -C the input matrix of a minimal realization of V. -C BV is not referenced if WEIGHT = 'R' or 'N', -C or MIN(N,M,P) = 0. -C -C LDBV INTEGER -C The leading dimension of array BV. -C LDBV >= MAX(1,NV), if WEIGHT = 'L' or 'B'; -C LDBV >= 1, if WEIGHT = 'R' or 'N'. -C -C CV (input/output) DOUBLE PRECISION array, dimension (LDCV,NV) -C On entry, if WEIGHT = 'L' or 'B', the leading PV-by-NV -C part of this array must contain the output matrix CV of -C the system with the transfer-function matrix V. -C On exit, if WEIGHT = 'L' or 'B', MIN(N,M,P) > 0 and -C INFO = 0, the leading PV-by-NVR part of this array -C contains the output matrix of a minimal realization of V. -C CV is not referenced if WEIGHT = 'R' or 'N', -C or MIN(N,M,P) = 0. -C -C LDCV INTEGER -C The leading dimension of array CV. -C LDCV >= MAX(1,PV), if WEIGHT = 'L' or 'B'; -C LDCV >= 1, if WEIGHT = 'R' or 'N'. -C -C DV (input) DOUBLE PRECISION array, dimension (LDDV,P) -C If WEIGHT = 'L' or 'B', the leading PV-by-P part of this -C array must contain the feedthrough matrix DV of the system -C with the transfer-function matrix V. -C DV is not referenced if WEIGHT = 'R' or 'N', -C or MIN(N,M,P) = 0. -C -C LDDV INTEGER -C The leading dimension of array DV. -C LDDV >= MAX(1,PV), if WEIGHT = 'L' or 'B'; -C LDDV >= 1, if WEIGHT = 'R' or 'N'. -C -C AW (input/output) DOUBLE PRECISION array, dimension (LDAW,NW) -C On entry, if WEIGHT = 'R' or 'B', the leading NW-by-NW -C part of this array must contain the state matrix AW of -C the system with the transfer-function matrix W. -C On exit, if WEIGHT = 'R' or 'B', MIN(N,M,P) > 0 and -C INFO = 0, the leading NWR-by-NWR part of this array -C contains the state matrix of a minimal realization of W -C in a real Schur form. NWR is returned in IWORK(3). -C AW is not referenced if WEIGHT = 'L' or 'N', -C or MIN(N,M,P) = 0. -C -C LDAW INTEGER -C The leading dimension of array AW. -C LDAW >= MAX(1,NW), if WEIGHT = 'R' or 'B'; -C LDAW >= 1, if WEIGHT = 'L' or 'N'. -C -C BW (input/output) DOUBLE PRECISION array, dimension (LDBW,MW) -C On entry, if WEIGHT = 'R' or 'B', the leading NW-by-MW -C part of this array must contain the input matrix BW of the -C system with the transfer-function matrix W. -C On exit, if WEIGHT = 'R' or 'B', MIN(N,M,P) > 0 and -C INFO = 0, the leading NWR-by-MW part of this array -C contains the input matrix of a minimal realization of W. -C BW is not referenced if WEIGHT = 'L' or 'N', -C or MIN(N,M,P) = 0. -C -C LDBW INTEGER -C The leading dimension of array BW. -C LDBW >= MAX(1,NW), if WEIGHT = 'R' or 'B'; -C LDBW >= 1, if WEIGHT = 'L' or 'N'. -C -C CW (input/output) DOUBLE PRECISION array, dimension (LDCW,NW) -C On entry, if WEIGHT = 'R' or 'B', the leading M-by-NW part -C of this array must contain the output matrix CW of the -C system with the transfer-function matrix W. -C On exit, if WEIGHT = 'R' or 'B', MIN(N,M,P) > 0 and -C INFO = 0, the leading M-by-NWR part of this array contains -C the output matrix of a minimal realization of W. -C CW is not referenced if WEIGHT = 'L' or 'N', -C or MIN(N,M,P) = 0. -C -C LDCW INTEGER -C The leading dimension of array CW. -C LDCW >= MAX(1,M), if WEIGHT = 'R' or 'B'; -C LDCW >= 1, if WEIGHT = 'L' or 'N'. -C -C DW (input) DOUBLE PRECISION array, dimension (LDDW,MW) -C If WEIGHT = 'R' or 'B', the leading M-by-MW part of this -C array must contain the feedthrough matrix DW of the system -C with the transfer-function matrix W. -C DW is not referenced if WEIGHT = 'L' or 'N', -C or MIN(N,M,P) = 0. -C -C LDDW INTEGER -C The leading dimension of array DW. -C LDDW >= MAX(1,M), if WEIGHT = 'R' or 'B'; -C LDDW >= 1, if WEIGHT = 'L' or 'N'. -C -C NS (output) INTEGER -C The dimension of the ALPHA-stable subsystem. -C -C HSV (output) DOUBLE PRECISION array, dimension (N) -C If INFO = 0, the leading NS elements of this array contain -C the frequency-weighted Hankel singular values, ordered -C decreasingly, of the ALPHA-stable part of the original -C system. -C -C Tolerances -C -C TOL1 DOUBLE PRECISION -C If ORDSEL = 'A', TOL1 contains the tolerance for -C determining the order of reduced system. -C For model reduction, the recommended value is -C TOL1 = c*S1, where c is a constant in the -C interval [0.00001,0.001], and S1 is the largest -C frequency-weighted Hankel singular value of the -C ALPHA-stable part of the original system (computed -C in HSV(1)). -C If TOL1 <= 0 on entry, the used default value is -C TOL1 = NS*EPS*S1, where NS is the number of -C ALPHA-stable eigenvalues of A and EPS is the machine -C precision (see LAPACK Library Routine DLAMCH). -C If ORDSEL = 'F', the value of TOL1 is ignored. -C -C TOL2 DOUBLE PRECISION -C The tolerance for determining the order of a minimal -C realization of the ALPHA-stable part of the given system. -C The recommended value is TOL2 = NS*EPS*S1. -C This value is used by default if TOL2 <= 0 on entry. -C If TOL2 > 0 and ORDSEL = 'A', then TOL2 <= TOL1. -C -C Workspace -C -C IWORK INTEGER array, dimension -C ( MAX( 3, LIWRK1, LIWRK2, LIWRK3 ) ), where -C LIWRK1 = 0, if JOB = 'B'; -C LIWRK1 = N, if JOB = 'F'; -C LIWRK1 = 2*N, if JOB = 'S' or 'P'; -C LIWRK2 = 0, if WEIGHT = 'R' or 'N' or NV = 0; -C LIWRK2 = NV+MAX(P,PV), if WEIGHT = 'L' or 'B' and NV > 0; -C LIWRK3 = 0, if WEIGHT = 'L' or 'N' or NW = 0; -C LIWRK3 = NW+MAX(M,MW), if WEIGHT = 'R' or 'B' and NW > 0. -C On exit, if INFO = 0, IWORK(1) contains the order of a -C minimal realization of the stable part of the system, -C IWORK(2) and IWORK(3) contain the actual orders -C of the state space realizations of V and W, respectively. -C -C DWORK DOUBLE PRECISION array, dimension (LDWORK) -C On exit, if INFO = 0, DWORK(1) returns the optimal value -C of LDWORK. -C -C LDWORK INTEGER -C The length of the array DWORK. -C LDWORK >= MAX( LMINL, LMINR, LRCF, -C 2*N*N + MAX( 1, LLEFT, LRIGHT, 2*N*N+5*N, -C N*MAX(M,P) ) ), -C where -C LMINL = 0, if WEIGHT = 'R' or 'N' or NV = 0; otherwise, -C LMINL = MAX(LLCF,NV+MAX(NV,3*P)) if P = PV; -C LMINL = MAX(P,PV)*(2*NV+MAX(P,PV))+ -C MAX(LLCF,NV+MAX(NV,3*P,3*PV)) if P <> PV; -C LRCF = 0, and -C LMINR = 0, if WEIGHT = 'L' or 'N' or NW = 0; otherwise, -C LMINR = NW+MAX(NW,3*M) if M = MW; -C LMINR = 2*NW*MAX(M,MW)+NW+MAX(NW,3*M,3*MW) if M <> MW; -C LLCF = PV*(NV+PV)+PV*NV+MAX(NV*(NV+5), PV*(PV+2), -C 4*PV, 4*P); -C LRCF = MW*(NW+MW)+MAX(NW*(NW+5),MW*(MW+2),4*MW,4*M) -C LLEFT = (N+NV)*(N+NV+MAX(N+NV,PV)+5) -C if WEIGHT = 'L' or 'B' and PV > 0; -C LLEFT = N*(P+5) if WEIGHT = 'R' or 'N' or PV = 0; -C LRIGHT = (N+NW)*(N+NW+MAX(N+NW,MW)+5) -C if WEIGHT = 'R' or 'B' and MW > 0; -C LRIGHT = N*(M+5) if WEIGHT = 'L' or 'N' or MW = 0. -C For optimum performance LDWORK should be larger. -C -C Warning Indicator -C -C IWARN INTEGER -C = 0: no warning; -C = 1: with ORDSEL = 'F', the selected order NR is greater -C than NSMIN, the sum of the order of the -C ALPHA-unstable part and the order of a minimal -C realization of the ALPHA-stable part of the given -C system; in this case, the resulting NR is set equal -C to NSMIN; -C = 2: with ORDSEL = 'F', the selected order NR corresponds -C to repeated singular values for the ALPHA-stable -C part, which are neither all included nor all -C excluded from the reduced model; in this case, the -C resulting NR is automatically decreased to exclude -C all repeated singular values; -C = 3: with ORDSEL = 'F', the selected order NR is less -C than the order of the ALPHA-unstable part of the -C given system; in this case NR is set equal to the -C order of the ALPHA-unstable part. -C = 10+K: K violations of the numerical stability condition -C occured during the assignment of eigenvalues in the -C SLICOT Library routines SB08CD and/or SB08DD. -C -C Error Indicator -C -C INFO INTEGER -C = 0: successful exit; -C < 0: if INFO = -i, the i-th argument had an illegal -C value; -C = 1: the computation of the ordered real Schur form of A -C failed; -C = 2: the separation of the ALPHA-stable/unstable -C diagonal blocks failed because of very close -C eigenvalues; -C = 3: the reduction to a real Schur form of the state -C matrix of a minimal realization of V failed; -C = 4: a failure was detected during the ordering of the -C real Schur form of the state matrix of a minimal -C realization of V or in the iterative process to -C compute a left coprime factorization with inner -C denominator; -C = 5: if DICO = 'C' and the matrix AV has an observable -C eigenvalue on the imaginary axis, or DICO = 'D' and -C AV has an observable eigenvalue on the unit circle; -C = 6: the reduction to a real Schur form of the state -C matrix of a minimal realization of W failed; -C = 7: a failure was detected during the ordering of the -C real Schur form of the state matrix of a minimal -C realization of W or in the iterative process to -C compute a right coprime factorization with inner -C denominator; -C = 8: if DICO = 'C' and the matrix AW has a controllable -C eigenvalue on the imaginary axis, or DICO = 'D' and -C AW has a controllable eigenvalue on the unit circle; -C = 9: the computation of eigenvalues failed; -C = 10: the computation of Hankel singular values failed. -C -C METHOD -C -C Let G be the transfer-function matrix of the original -C linear system -C -C d[x(t)] = Ax(t) + Bu(t) -C y(t) = Cx(t) + Du(t), (1) -C -C where d[x(t)] is dx(t)/dt for a continuous-time system and x(t+1) -C for a discrete-time system. The subroutine AB09ID determines -C the matrices of a reduced order system -C -C d[z(t)] = Ar*z(t) + Br*u(t) -C yr(t) = Cr*z(t) + Dr*u(t), (2) -C -C such that the corresponding transfer-function matrix Gr minimizes -C the norm of the frequency-weighted error -C -C V*(G-Gr)*W, (3) -C -C where V and W are transfer-function matrices without poles on the -C imaginary axis in continuous-time case or on the unit circle in -C discrete-time case. -C -C The following procedure is used to reduce G: -C -C 1) Decompose additively G, of order N, as -C -C G = G1 + G2, -C -C such that G1 = (A1,B1,C1,D) has only ALPHA-stable poles and -C G2 = (A2,B2,C2,0), of order NU, has only ALPHA-unstable poles. -C -C 2) Compute for G1 a B&T or SPA frequency-weighted approximation -C G1r of order NR-NU using the combination method or the -C modified combination method of [4]. -C -C 3) Assemble the reduced model Gr as -C -C Gr = G1r + G2. -C -C For the frequency-weighted reduction of the ALPHA-stable part, -C several methods described in [4] can be employed in conjunction -C with the combination method and modified combination method -C proposed in [4]. -C -C If JOB = 'B', the square-root B&T method is used. -C If JOB = 'F', the balancing-free square-root version of the -C B&T method is used. -C If JOB = 'S', the square-root version of the SPA method is used. -C If JOB = 'P', the balancing-free square-root version of the -C SPA method is used. -C -C For each of these methods, left and right truncation matrices -C are determined using the Cholesky factors of an input -C frequency-weighted controllability Grammian P and an output -C frequency-weighted observability Grammian Q. -C P and Q are computed from the controllability Grammian Pi of G*W -C and the observability Grammian Qo of V*G. Using special -C realizations of G*W and V*G, Pi and Qo are computed in the -C partitioned forms -C -C Pi = ( P11 P12 ) and Qo = ( Q11 Q12 ) , -C ( P12' P22 ) ( Q12' Q22 ) -C -C where P11 and Q11 are the leading N-by-N parts of Pi and Qo, -C respectively. Let P0 and Q0 be non-negative definite matrices -C defined below -C -1 -C P0 = P11 - ALPHAC**2*P12*P22 *P21 , -C -1 -C Q0 = Q11 - ALPHAO**2*Q12*Q22 *Q21. -C -C The frequency-weighted controllability and observability -C Grammians, P and Q, respectively, are defined as follows: -C P = P0 if JOBC = 'S' (standard combination method [4]); -C P = P1 >= P0 if JOBC = 'E', where P1 is the controllability -C Grammian defined to enforce stability for a modified combination -C method of [4]; -C Q = Q0 if JOBO = 'S' (standard combination method [4]); -C Q = Q1 >= Q0 if JOBO = 'E', where Q1 is the observability -C Grammian defined to enforce stability for a modified combination -C method of [4]. -C -C If JOBC = JOBO = 'S' and ALPHAC = ALPHAO = 0, the choice of -C Grammians corresponds to the method of Enns [1], while if -C ALPHAC = ALPHAO = 1, the choice of Grammians corresponds -C to the method of Lin and Chiu [2,3]. -C -C If JOBC = 'S' and ALPHAC = 1, no pole-zero cancellations must -C occur in G*W. If JOBO = 'S' and ALPHAO = 1, no pole-zero -C cancellations must occur in V*G. The presence of pole-zero -C cancellations leads to meaningless results and must be avoided. -C -C The frequency-weighted Hankel singular values HSV(1), ...., -C HSV(N) are computed as the square roots of the eigenvalues -C of the product P*Q. -C -C REFERENCES -C -C [1] Enns, D. -C Model reduction with balanced realizations: An error bound -C and a frequency weighted generalization. -C Proc. 23-th CDC, Las Vegas, pp. 127-132, 1984. -C -C [2] Lin, C.-A. and Chiu, T.-Y. -C Model reduction via frequency-weighted balanced realization. -C Control Theory and Advanced Technology, vol. 8, -C pp. 341-351, 1992. -C -C [3] Sreeram, V., Anderson, B.D.O and Madievski, A.G. -C New results on frequency weighted balanced reduction -C technique. -C Proc. ACC, Seattle, Washington, pp. 4004-4009, 1995. -C -C [4] Varga, A. and Anderson, B.D.O. -C Square-root balancing-free methods for the frequency-weighted -C balancing related model reduction. -C (report in preparation) -C -C NUMERICAL ASPECTS -C -C The implemented methods rely on accuracy enhancing square-root -C techniques. -C -C CONTRIBUTORS -C -C A. Varga, German Aerospace Center, Oberpfaffenhofen, August 2000. -C D. Sima, University of Bucharest, August 2000. -C V. Sima, Research Institute for Informatics, Bucharest, Aug. 2000. -C -C REVISIONS -C -C A. Varga, Australian National University, Canberra, November 2000. -C V. Sima, Research Institute for Informatics, Bucharest, Dec. 2000, -C Sep. 2001. -C -C KEYWORDS -C -C Frequency weighting, model reduction, multivariable system, -C state-space model, state-space representation. -C -C ****************************************************************** -C -C .. Parameters .. - DOUBLE PRECISION C100, ONE, ZERO - PARAMETER ( C100 = 100.0D0, ONE = 1.0D0, ZERO = 0.0D0 ) -C .. Scalar Arguments .. - CHARACTER DICO, EQUIL, JOB, JOBC, JOBO, ORDSEL, WEIGHT - INTEGER INFO, IWARN, LDA, LDAV, LDAW, LDB, LDBV, LDBW, - $ LDC, LDCV, LDCW, LDD, LDDV, LDDW, LDWORK, M, MW, - $ N, NR, NS, NV, NW, P, PV - DOUBLE PRECISION ALPHA, ALPHAC, ALPHAO, TOL1, TOL2 -C .. Array Arguments .. - INTEGER IWORK(*) - DOUBLE PRECISION A(LDA,*), AV(LDAV,*), AW(LDAW,*), - $ B(LDB,*), BV(LDBV,*), BW(LDBW,*), - $ C(LDC,*), CV(LDCV,*), CW(LDCW,*), - $ D(LDD,*), DV(LDDV,*), DW(LDDW,*), DWORK(*), - $ HSV(*) -C .. Local Scalars .. - LOGICAL BAL, BTA, DISCR, FIXORD, FRWGHT, LEFTW, RIGHTW, - $ SCALE, SPA - INTEGER IERR, IWARNL, KBR, KBV, KBW, KCR, KCV, KCW, KDR, - $ KDV, KI, KL, KT, KTI, KU, KW, LCF, LDW, LW, NMR, - $ NN, NNQ, NNR, NNV, NNW, NRA, NU, NU1, NVR, NWR, - $ PPV, WRKOPT - DOUBLE PRECISION ALPWRK, MAXRED, SCALEC, SCALEO -C .. External Functions .. - LOGICAL LSAME - DOUBLE PRECISION DLAMCH - EXTERNAL DLAMCH, LSAME -C .. External Subroutines .. - EXTERNAL AB09IX, AB09IY, DLACPY, SB08CD, SB08DD, TB01ID, - $ TB01KD, TB01PD, XERBLA -C .. Intrinsic Functions .. - INTRINSIC ABS, INT, MAX, MIN, SQRT -C .. Executable Statements .. -C - INFO = 0 - IWARN = 0 - DISCR = LSAME( DICO, 'D' ) - BTA = LSAME( JOB, 'B' ) .OR. LSAME( JOB, 'F' ) - SPA = LSAME( JOB, 'S' ) .OR. LSAME( JOB, 'P' ) - BAL = LSAME( JOB, 'B' ) .OR. LSAME( JOB, 'S' ) - SCALE = LSAME( EQUIL, 'S' ) - FIXORD = LSAME( ORDSEL, 'F' ) - LEFTW = LSAME( WEIGHT, 'L' ) .OR. LSAME( WEIGHT, 'B' ) - RIGHTW = LSAME( WEIGHT, 'R' ) .OR. LSAME( WEIGHT, 'B' ) - FRWGHT = LEFTW .OR. RIGHTW -C - LW = 1 - NN = N*N - NNV = N + NV - NNW = N + NW - PPV = MAX( P, PV ) -C - IF( LEFTW .AND. PV.GT.0 ) THEN - LW = MAX( LW, NNV*( NNV + MAX( NNV, PV ) + 5 ) ) - ELSE - LW = MAX( LW, N*( P + 5 ) ) - END IF -C - IF( RIGHTW .AND. MW.GT.0 ) THEN - LW = MAX( LW, NNW*( NNW + MAX( NNW, MW ) + 5 ) ) - ELSE - LW = MAX( LW, N*( M + 5 ) ) - END IF - LW = 2*NN + MAX( LW, 2*NN + 5*N, N*MAX( M, P ) ) -C - IF( LEFTW .AND. NV.GT.0 ) THEN - LCF = PV*( NV + PV ) + PV*NV + - $ MAX( NV*( NV + 5 ), PV*( PV + 2 ), 4*PPV ) - IF( PV.EQ.P ) THEN - LW = MAX( LW, LCF, NV + MAX( NV, 3*P ) ) - ELSE - LW = MAX( LW, PPV*( 2*NV + PPV ) + - $ MAX( LCF, NV + MAX( NV, 3*PPV ) ) ) - END IF - END IF -C - IF( RIGHTW .AND. NW.GT.0 ) THEN - IF( MW.EQ.M ) THEN - LW = MAX( LW, NW + MAX( NW, 3*M ) ) - ELSE - LW = MAX( LW, 2*NW*MAX( M, MW ) + - $ NW + MAX( NW, 3*M, 3*MW ) ) - END IF - LW = MAX( LW, MW*( NW + MW ) + - $ MAX( NW*( NW + 5 ), MW*( MW + 2 ), 4*MW, 4*M ) ) - END IF -C -C Check the input scalar arguments. -C - IF( .NOT. ( LSAME( DICO, 'C' ) .OR. DISCR ) ) THEN - INFO = -1 - ELSE IF( .NOT.( LSAME( JOBC, 'S' ) .OR. LSAME( JOBC, 'E' ) ) ) - $ THEN - INFO = -2 - ELSE IF( .NOT.( LSAME( JOBO, 'S' ) .OR. LSAME( JOBO, 'E' ) ) ) - $ THEN - INFO = -3 - ELSE IF( .NOT. ( BTA .OR. SPA ) ) THEN - INFO = -4 - ELSE IF( .NOT. ( FRWGHT .OR. LSAME( WEIGHT, 'N' ) ) ) THEN - INFO = -5 - ELSE IF( .NOT. ( SCALE .OR. LSAME( EQUIL, 'N' ) ) ) THEN - INFO = -6 - ELSE IF( .NOT. ( FIXORD .OR. LSAME( ORDSEL, 'A' ) ) ) THEN - INFO = -7 - ELSE IF( N.LT.0 ) THEN - INFO = -8 - ELSE IF( M.LT.0 ) THEN - INFO = -9 - ELSE IF( P.LT.0 ) THEN - INFO = -10 - ELSE IF( NV.LT.0 ) THEN - INFO = -11 - ELSE IF( PV.LT.0 ) THEN - INFO = -12 - ELSE IF( NW.LT.0 ) THEN - INFO = -13 - ELSE IF( MW.LT.0 ) THEN - INFO = -14 - ELSE IF( FIXORD .AND. ( NR.LT.0 .OR. NR.GT.N ) ) THEN - INFO = -15 - ELSE IF( ( DISCR .AND. ( ALPHA.LT.ZERO .OR. ALPHA.GT.ONE ) ) .OR. - $ ( .NOT.DISCR .AND. ALPHA.GT.ZERO ) ) THEN - INFO = -16 - ELSE IF( ABS( ALPHAC ).GT.ONE ) THEN - INFO = -17 - ELSE IF( ABS( ALPHAO ).GT.ONE ) THEN - INFO = -18 - ELSE IF( LDA.LT.MAX( 1, N ) ) THEN - INFO = -20 - ELSE IF( LDB.LT.MAX( 1, N ) ) THEN - INFO = -22 - ELSE IF( LDC.LT.MAX( 1, P ) ) THEN - INFO = -24 - ELSE IF( LDD.LT.MAX( 1, P ) ) THEN - INFO = -26 - ELSE IF( LDAV.LT.1 .OR. ( LEFTW .AND. LDAV.LT.NV ) ) THEN - INFO = -28 - ELSE IF( LDBV.LT.1 .OR. ( LEFTW .AND. LDBV.LT.NV ) ) THEN - INFO = -30 - ELSE IF( LDCV.LT.1 .OR. ( LEFTW .AND. LDCV.LT.PV ) ) THEN - INFO = -32 - ELSE IF( LDDV.LT.1 .OR. ( LEFTW .AND. LDDV.LT.PV ) ) THEN - INFO = -34 - ELSE IF( LDAW.LT.1 .OR. ( RIGHTW .AND. LDAW.LT.NW ) ) THEN - INFO = -36 - ELSE IF( LDBW.LT.1 .OR. ( RIGHTW .AND. LDBW.LT.NW ) ) THEN - INFO = -38 - ELSE IF( LDCW.LT.1 .OR. ( RIGHTW .AND. LDCW.LT.M ) ) THEN - INFO = -40 - ELSE IF( LDDW.LT.1 .OR. ( RIGHTW .AND. LDDW.LT.M ) ) THEN - INFO = -42 - ELSE IF( TOL2.GT.ZERO .AND. .NOT.FIXORD .AND. TOL2.GT.TOL1 ) THEN - INFO = -46 - ELSE IF( LDWORK.LT.LW ) THEN - INFO = -49 - END IF -C - IF( INFO.NE.0 ) THEN -C -C Error return. -C - CALL XERBLA( 'AB09ID', -INFO ) - RETURN - END IF -C -C Quick return if possible. -C - IF( MIN( N, M, P ).EQ.0 ) THEN - NR = 0 - NS = 0 - IWORK(1) = 0 - IWORK(2) = NV - IWORK(3) = NW - DWORK(1) = ONE - RETURN - END IF -C - IF( SCALE ) THEN -C -C Scale simultaneously the matrices A, B and C: -C A <- inv(D)*A*D, B <- inv(D)*B and C <- C*D, where D is a -C diagonal matrix. -C Workspace: N. -C - MAXRED = C100 - CALL TB01ID( 'All', N, M, P, MAXRED, A, LDA, B, LDB, C, LDC, - $ DWORK, INFO ) - END IF -C -C Correct the value of ALPHA to ensure stability. -C - ALPWRK = ALPHA - IF( DISCR ) THEN - IF( ALPHA.EQ.ONE ) ALPWRK = ONE - SQRT( DLAMCH( 'E' ) ) - ELSE - IF( ALPHA.EQ.ZERO ) ALPWRK = -SQRT( DLAMCH( 'E' ) ) - END IF -C -C Allocate working storage. -C - KU = 1 - KL = KU + NN - KI = KL + N - KW = KI + N -C -C Reduce A to a block-diagonal real Schur form, with the -C ALPHA-unstable part in the leading diagonal position, using a -C non-orthogonal similarity transformation, A <- inv(T)*A*T, and -C apply the transformation to B and C: B <- inv(T)*B and C <- C*T. -C -C Workspace needed: N*(N+2); -C Additional workspace: need 3*N; -C prefer larger. -C - CALL TB01KD( DICO, 'Unstable', 'General', N, M, P, ALPWRK, A, LDA, - $ B, LDB, C, LDC, NU, DWORK(KU), N, DWORK(KL), - $ DWORK(KI), DWORK(KW), LDWORK-KW+1, IERR ) -C - IF( IERR.NE.0 ) THEN - IF( IERR.NE.3 ) THEN - INFO = 1 - ELSE - INFO = 2 - END IF - RETURN - END IF -C - WRKOPT = INT( DWORK(KW) ) + KW - 1 -C -C Determine NRA, the desired order for the reduction of stable part. -C - IWARNL = 0 - NS = N - NU - IF( FIXORD ) THEN - NRA = MAX( 0, NR-NU ) - IF( NR.LT.NU ) - $ IWARNL = 3 - ELSE - NRA = 0 - END IF -C -C Finish if only unstable part is present. -C - IF( NS.EQ.0 ) THEN - NR = NU - DWORK(1) = WRKOPT - IWORK(1) = 0 - IWORK(2) = NV - IWORK(3) = NW - RETURN - END IF -C - NVR = NV - IF( LEFTW .AND. NV.GT.0 ) THEN -C -C Compute a left-coprime factorization with inner denominator -C of a minimal realization of V. The resulting AV is in -C real Schur form. -C Workspace needed: real LV+MAX( 1, LCF, -C NV + MAX( NV, 3*P, 3*PV ) ), -C where -C LV = 0 if P = PV and -C LV = MAX(P,PV)*(2*NV+MAX(P,PV)) -C otherwise; -C LCF = PV*(NV+PV) + -C MAX( 1, PV*NV + MAX( NV*(NV+5), -C PV*(PV+2),4*PV,4*P ) ); -C prefer larger; -C integer NV + MAX(P,PV). -C - IF( P.EQ.PV ) THEN - KW = 1 - CALL TB01PD( 'Minimal', 'Scale', NV, P, PV, AV, LDAV, - $ BV, LDBV, CV, LDCV, NVR, ZERO, - $ IWORK, DWORK, LDWORK, INFO ) - WRKOPT = MAX( WRKOPT, INT( DWORK(KW) ) + KW - 1 ) - KBR = 1 - KDR = KBR + PV*NVR - KW = KDR + PV*PV - CALL SB08CD( DICO, NVR, P, PV, AV, LDAV, BV, LDBV, CV, LDCV, - $ DV, LDDV, NNQ, NNR, DWORK(KBR), MAX( 1, NVR ), - $ DWORK(KDR), PV, ZERO, DWORK(KW), LDWORK-KW+1, - $ IWARN, IERR ) - ELSE - LDW = MAX( P, PV ) - KBV = 1 - KCV = KBV + NV*LDW - KW = KCV + NV*LDW - CALL DLACPY( 'Full', NV, P, BV, LDBV, DWORK(KBV), NV ) - CALL DLACPY( 'Full', PV, NV, CV, LDCV, DWORK(KCV), LDW ) - CALL TB01PD( 'Minimal', 'Scale', NV, P, PV, AV, LDAV, - $ DWORK(KBV), NV, DWORK(KCV), LDW, NVR, ZERO, - $ IWORK, DWORK(KW), LDWORK-KW+1, INFO ) - KDV = KW - KBR = KDV + LDW*LDW - KDR = KBR + PV*NVR - KW = KDR + PV*PV - CALL DLACPY( 'Full', PV, P, DV, LDDV, DWORK(KDV), LDW ) - CALL SB08CD( DICO, NVR, P, PV, AV, LDAV, DWORK(KBV), NV, - $ DWORK(KCV), LDW, DWORK(KDV), LDW, NNQ, NNR, - $ DWORK(KBR), MAX( 1, NVR ), DWORK(KDR), PV, - $ ZERO, DWORK(KW), LDWORK-KW+1, IWARN, IERR ) - CALL DLACPY( 'Full', NVR, P, DWORK(KBV), NV, BV, LDBV ) - CALL DLACPY( 'Full', PV, NVR, DWORK(KCV), LDW, CV, LDCV ) - CALL DLACPY( 'Full', PV, P, DWORK(KDV), LDW, DV, LDDV ) - END IF - IF( IERR.NE.0 ) THEN - INFO = IERR + 2 - RETURN - END IF - NVR = NNQ - WRKOPT = MAX( WRKOPT, INT( DWORK(KW) ) + KW - 1 ) - IF( IWARN.GT.0 ) - $ IWARN = 10 + IWARN - END IF -C - NWR = NW - IF( RIGHTW .AND. NW.GT.0 ) THEN -C -C Compute a minimal realization of W. -C Workspace needed: real LW+MAX(1, NW + MAX(NW, 3*M, 3*MW)); -C where -C LW = 0, if M = MW and -C LW = 2*NW*MAX(M,MW), otherwise; -C prefer larger; -C integer NW + MAX(M,MW). -C - IF( M.EQ.MW ) THEN - KW = 1 - CALL TB01PD( 'Minimal', 'Scale', NW, MW, M, AW, LDAW, - $ BW, LDBW, CW, LDCW, NWR, ZERO, IWORK, DWORK, - $ LDWORK, INFO ) - ELSE - LDW = MAX( M, MW ) - KBW = 1 - KCW = KBW + NW*LDW - KW = KCW + NW*LDW - CALL DLACPY( 'Full', NW, MW, BW, LDBW, DWORK(KBW), NW ) - CALL DLACPY( 'Full', M, NW, CW, LDCW, DWORK(KCW), LDW ) - CALL TB01PD( 'Minimal', 'Scale', NW, MW, M, AW, LDAW, - $ DWORK(KBW), NW, DWORK(KCW), LDW, NWR, ZERO, - $ IWORK, DWORK(KW), LDWORK-KW+1, INFO ) - CALL DLACPY( 'Full', NWR, MW, DWORK(KBW), NW, BW, LDBW ) - CALL DLACPY( 'Full', M, NWR, DWORK(KCW), LDW, CW, LDCW ) - END IF - WRKOPT = MAX( WRKOPT, INT( DWORK(KW) ) + KW - 1 ) - END IF -C - IF( RIGHTW .AND. NWR.GT.0 ) THEN -C -C Compute a right-coprime factorization with inner denominator -C of the minimal realization of W. The resulting AW is in -C real Schur form. -C -C Workspace needed: MW*(NW+MW) + -C MAX( 1, NW*(NW+5), MW*(MW+2), 4*MW, 4*M ); -C prefer larger. -C - LDW = MAX( 1, MW ) - KCR = 1 - KDR = KCR + NWR*LDW - KW = KDR + MW*LDW - CALL SB08DD( DICO, NWR, MW, M, AW, LDAW, BW, LDBW, CW, LDCW, - $ DW, LDDW, NNQ, NNR, DWORK(KCR), LDW, DWORK(KDR), - $ LDW, ZERO, DWORK(KW), LDWORK-KW+1, IWARN, IERR ) - IF( IERR.NE.0 ) THEN - INFO = IERR + 5 - RETURN - END IF - NWR = NNQ - WRKOPT = MAX( WRKOPT, INT( DWORK(KW) ) + KW - 1 ) - IF( IWARN.GT.0 ) - $ IWARN = 10 + IWARN - END IF -C - NU1 = NU + 1 -C -C Allocate working storage. -C - KT = 1 - KTI = KT + NN - KW = KTI + NN -C -C Compute in DWORK(KTI) and DWORK(KT) the Cholesky factors S and R -C of the controllability and observability Grammians, respectively. -C Real workspace: need 2*N*N + MAX( 1, LLEFT, LRIGHT ), -C where -C LLEFT = (N+NV)*(N+NV+MAX(N+NV,PV)+5) -C if WEIGHT = 'L' or 'B' and PV > 0; -C LLEFT = N*(P+5) if WEIGHT = 'R' or 'N' or PV = 0; -C LRIGHT = (N+NW)*(N+NW+MAX(N+NW,MW)+5) -C if WEIGHT = 'R' or 'B' and MW > 0; -C LRIGHT = N*(M+5) if WEIGHT = 'L' or 'N' or MW = 0. -C prefer larger. -C - CALL AB09IY( DICO, JOBC, JOBO, WEIGHT, NS, M, P, NVR, PV, NWR, - $ MW, ALPHAC, ALPHAO, A(NU1,NU1), LDA, B(NU1,1), LDB, - $ C(1,NU1), LDC, AV, LDAV, BV, LDBV, CV, LDCV, - $ DV, LDDV, AW, LDAW, BW, LDBW, CW, LDCW, DW, LDDW, - $ SCALEC, SCALEO, DWORK(KTI), N, DWORK(KT), N, - $ DWORK(KW), LDWORK-KW+1, IERR ) - IF( IERR.NE.0 ) THEN - INFO = 9 - RETURN - END IF - WRKOPT = MAX( WRKOPT, INT( DWORK(KW) ) + KW - 1 ) -C -C Compute a BTA or SPA of the stable part. -C Real workspace: need 2*N*N + MAX( 1, 2*N*N+5*N, N*MAX(M,P) ). -C - CALL AB09IX( DICO, JOB, 'Schur', ORDSEL, NS, M, P, NRA, - $ SCALEC, SCALEO, A(NU1,NU1), LDA, B(NU1,1), LDB, - $ C(1,NU1), LDC, D, LDD, DWORK(KTI), N, DWORK(KT), N, - $ NMR, HSV, TOL1, TOL2, IWORK, DWORK(KW), LDWORK-KW+1, - $ IWARN, IERR ) - IWARN = MAX( IWARN, IWARNL ) - IF( IERR.NE.0 ) THEN - INFO = 10 - RETURN - END IF - NR = NRA + NU -C - DWORK(1) = MAX( WRKOPT, INT( DWORK(KW) ) + KW - 1 ) - IWORK(1) = NMR - IWORK(2) = NVR - IWORK(3) = NWR -C - RETURN -C *** Last line of AB09ID *** - END diff --git a/mex/sources/libslicot/AB09IX.f b/mex/sources/libslicot/AB09IX.f deleted file mode 100644 index f3ad3b395..000000000 --- a/mex/sources/libslicot/AB09IX.f +++ /dev/null @@ -1,695 +0,0 @@ - SUBROUTINE AB09IX( DICO, JOB, FACT, ORDSEL, N, M, P, NR, - $ SCALEC, SCALEO, A, LDA, B, LDB, C, LDC, D, LDD, - $ TI, LDTI, T, LDT, NMINR, HSV, TOL1, TOL2, - $ IWORK, DWORK, LDWORK, IWARN, INFO ) -C -C SLICOT RELEASE 5.0. -C -C Copyright (c) 2002-2009 NICONET e.V. -C -C This program is free software: you can redistribute it and/or -C modify it under the terms of the GNU General Public License as -C published by the Free Software Foundation, either version 2 of -C the License, or (at your option) any later version. -C -C This program is distributed in the hope that it will be useful, -C but WITHOUT ANY WARRANTY; without even the implied warranty of -C MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the -C GNU General Public License for more details. -C -C You should have received a copy of the GNU General Public License -C along with this program. If not, see -C . -C -C PURPOSE -C -C To compute a reduced order model (Ar,Br,Cr,Dr) for an original -C state-space representation (A,B,C,D) by using the square-root or -C balancing-free square-root Balance & Truncate (B&T) or -C Singular Perturbation Approximation (SPA) model reduction methods. -C The computation of truncation matrices TI and T is based on -C the Cholesky factor S of a controllability Grammian P = S*S' -C and the Cholesky factor R of an observability Grammian Q = R'*R, -C where S and R are given upper triangular matrices. -C -C For the B&T approach, the matrices of the reduced order system -C are computed using the truncation formulas: -C -C Ar = TI * A * T , Br = TI * B , Cr = C * T . (1) -C -C For the SPA approach, the matrices of a minimal realization -C (Am,Bm,Cm) are computed using the truncation formulas: -C -C Am = TI * A * T , Bm = TI * B , Cm = C * T . (2) -C -C Am, Bm, Cm and D serve further for computing the SPA of the given -C system. -C -C ARGUMENTS -C -C Mode Parameters -C -C DICO CHARACTER*1 -C Specifies the type of the original system as follows: -C = 'C': continuous-time system; -C = 'D': discrete-time system. -C -C JOB CHARACTER*1 -C Specifies the model reduction approach to be used -C as follows: -C = 'B': use the square-root B&T method; -C = 'F': use the balancing-free square-root B&T method; -C = 'S': use the square-root SPA method; -C = 'P': use the balancing-free square-root SPA method. -C -C FACT CHARACTER*1 -C Specifies whether or not, on entry, the matrix A is in a -C real Schur form, as follows: -C = 'S': A is in a real Schur form; -C = 'N': A is a general dense square matrix. -C -C ORDSEL CHARACTER*1 -C Specifies the order selection method as follows: -C = 'F': the resulting order NR is fixed; -C = 'A': the resulting order NR is automatically determined -C on basis of the given tolerance TOL1. -C -C Input/Output Parameters -C -C N (input) INTEGER -C The order of the original state-space representation, -C i.e., the order of the matrix A. N >= 0. -C -C M (input) INTEGER -C The number of system inputs. M >= 0. -C -C P (input) INTEGER -C The number of system outputs. P >= 0. -C -C NR (input/output) INTEGER -C On entry with ORDSEL = 'F', NR is the desired order of -C the resulting reduced order system. 0 <= NR <= N. -C On exit, if INFO = 0, NR is the order of the resulting -C reduced order model. NR is set as follows: -C if ORDSEL = 'F', NR is equal to MIN(NR,NMINR), where NR -C is the desired order on entry and NMINR is the number of -C the Hankel singular values greater than N*EPS*S1, where -C EPS is the machine precision (see LAPACK Library Routine -C DLAMCH) and S1 is the largest Hankel singular value -C (computed in HSV(1)); -C NR can be further reduced to ensure HSV(NR) > HSV(NR+1); -C if ORDSEL = 'A', NR is equal to the number of Hankel -C singular values greater than MAX(TOL1,N*EPS*S1). -C -C SCALEC (input) DOUBLE PRECISION -C Scaling factor for the Cholesky factor S of the -C controllability Grammian, i.e., S/SCALEC is used to -C compute the Hankel singular values. SCALEC > 0. -C -C SCALEO (input) DOUBLE PRECISION -C Scaling factor for the Cholesky factor R of the -C observability Grammian, i.e., R/SCALEO is used to -C compute the Hankel singular values. SCALEO > 0. -C -C A (input/output) DOUBLE PRECISION array, dimension (LDA,N) -C On entry, the leading N-by-N part of this array must -C contain the state dynamics matrix A. If FACT = 'S', -C A is in a real Schur form. -C On exit, if INFO = 0, the leading NR-by-NR part of this -C array contains the state dynamics matrix Ar of the -C reduced order system. -C -C LDA INTEGER -C The leading dimension of array A. LDA >= MAX(1,N). -C -C B (input/output) DOUBLE PRECISION array, dimension (LDB,M) -C On entry, the leading N-by-M part of this array must -C contain the original input/state matrix B. -C On exit, if INFO = 0, the leading NR-by-M part of this -C array contains the input/state matrix Br of the reduced -C order system. -C -C LDB INTEGER -C The leading dimension of array B. LDB >= MAX(1,N). -C -C C (input/output) DOUBLE PRECISION array, dimension (LDC,N) -C On entry, the leading P-by-N part of this array must -C contain the original state/output matrix C. -C On exit, if INFO = 0, the leading P-by-NR part of this -C array contains the state/output matrix Cr of the reduced -C order system. -C -C LDC INTEGER -C The leading dimension of array C. LDC >= MAX(1,P). -C -C D (input/output) DOUBLE PRECISION array, dimension (LDD,M) -C On entry, if JOB = 'S' or JOB = 'P', the leading P-by-M -C part of this array must contain the original input/output -C matrix D. -C On exit, if INFO = 0 and JOB = 'S' or JOB = 'P', the -C leading P-by-M part of this array contains the -C input/output matrix Dr of the reduced order system. -C If JOB = 'B' or JOB = 'F', this array is not referenced. -C -C LDD INTEGER -C The leading dimension of array D. -C LDD >= 1, if JOB = 'B' or JOB = 'F'; -C LDD >= MAX(1,P), if JOB = 'S' or JOB = 'P'. -C -C TI (input/output) DOUBLE PRECISION array, dimension (LDTI,N) -C On entry, the leading N-by-N upper triangular part of -C this array must contain the Cholesky factor S of a -C controllability Grammian P = S*S'. -C On exit, if INFO = 0, and NR > 0, the leading NMINR-by-N -C part of this array contains the left truncation matrix -C TI in (1), for the B&T approach, or in (2), for the -C SPA approach. -C -C LDTI INTEGER -C The leading dimension of array TI. LDTI >= MAX(1,N). -C -C T (input/output) DOUBLE PRECISION array, dimension (LDT,N) -C On entry, the leading N-by-N upper triangular part of -C this array must contain the Cholesky factor R of an -C observability Grammian Q = R'*R. -C On exit, if INFO = 0, and NR > 0, the leading N-by-NMINR -C part of this array contains the right truncation matrix -C T in (1), for the B&T approach, or in (2), for the -C SPA approach. -C -C LDT INTEGER -C The leading dimension of array T. LDT >= MAX(1,N). -C -C NMINR (output) INTEGER -C The number of Hankel singular values greater than -C MAX(TOL2,N*EPS*S1). -C Note: If S and R are the Cholesky factors of the -C controllability and observability Grammians of the -C original system (A,B,C,D), respectively, then NMINR is -C the order of a minimal realization of the original system. -C -C HSV (output) DOUBLE PRECISION array, dimension (N) -C If INFO = 0, it contains the Hankel singular values, -C ordered decreasingly. The Hankel singular values are -C singular values of the product R*S. -C -C Tolerances -C -C TOL1 DOUBLE PRECISION -C If ORDSEL = 'A', TOL1 contains the tolerance for -C determining the order of the reduced system. -C For model reduction, the recommended value lies in the -C interval [0.00001,0.001]. -C If TOL1 <= 0 on entry, the used default value is -C TOL1 = N*EPS*S1, where EPS is the machine precision -C (see LAPACK Library Routine DLAMCH) and S1 is the largest -C Hankel singular value (computed in HSV(1)). -C If ORDSEL = 'F', the value of TOL1 is ignored. -C -C TOL2 DOUBLE PRECISION -C The tolerance for determining the order of a minimal -C realization of the system. -C The recommended value is TOL2 = N*EPS*S1. -C This value is used by default if TOL2 <= 0 on entry. -C If TOL2 > 0, and ORDSEL = 'A', then TOL2 <= TOL1. -C -C Workspace -C -C IWORK INTEGER array, dimension LIWORK, where -C LIWORK = 0, if JOB = 'B'; -C LIWORK = N, if JOB = 'F'; -C LIWORK = 2*N, if JOB = 'S' or 'P'. -C -C DWORK DOUBLE PRECISION array, dimension (LDWORK) -C On exit, if INFO = 0, DWORK(1) returns the optimal value -C of LDWORK. -C -C LDWORK INTEGER -C The length of the array DWORK. -C LDWORK >= MAX( 1, 2*N*N + 5*N, N*MAX(M,P) ). -C For optimum performance LDWORK should be larger. -C -C Warning Indicator -C -C IWARN INTEGER -C = 0: no warning; -C = 1: with ORDSEL = 'F', the selected order NR is greater -C than NMINR, the order of a minimal realization of -C the given system; in this case, the resulting NR is -C set automatically to NMINR; -C = 2: with ORDSEL = 'F', the selected order NR corresponds -C to repeated singular values, which are neither all -C included nor all excluded from the reduced model; -C in this case, the resulting NR is set automatically -C to the largest value such that HSV(NR) > HSV(NR+1). -C -C Error Indicator -C -C INFO INTEGER -C = 0: successful exit; -C < 0: if INFO = -i, the i-th argument had an illegal -C value; -C = 1: the computation of Hankel singular values failed. -C -C METHOD -C -C Let be the stable linear system -C -C d[x(t)] = Ax(t) + Bu(t) -C y(t) = Cx(t) + Du(t), (3) -C -C where d[x(t)] is dx(t)/dt for a continuous-time system and x(t+1) -C for a discrete-time system. The subroutine AB09IX determines for -C the given system (3), the matrices of a reduced NR order system -C -C d[z(t)] = Ar*z(t) + Br*u(t) -C yr(t) = Cr*z(t) + Dr*u(t), (4) -C -C by using the square-root or balancing-free square-root -C Balance & Truncate (B&T) or Singular Perturbation Approximation -C (SPA) model reduction methods. -C -C The projection matrices TI and T are determined using the -C Cholesky factors S and R of a controllability Grammian P and an -C observability Grammian Q. -C The Hankel singular values HSV(1), ...., HSV(N) are computed as -C singular values of the product R*S. -C -C If JOB = 'B', the square-root Balance & Truncate technique -C of [1] is used. -C -C If JOB = 'F', the balancing-free square-root version of the -C Balance & Truncate technique [2] is used. -C -C If JOB = 'S', the square-root version of the Singular Perturbation -C Approximation method [3,4] is used. -C -C If JOB = 'P', the balancing-free square-root version of the -C Singular Perturbation Approximation method [3,4] is used. -C -C REFERENCES -C -C [1] Tombs M.S. and Postlethwaite I. -C Truncated balanced realization of stable, non-minimal -C state-space systems. -C Int. J. Control, Vol. 46, pp. 1319-1330, 1987. -C -C [2] Varga A. -C Efficient minimal realization procedure based on balancing. -C Proc. of IMACS/IFAC Symp. MCTS, Lille, France, May 1991, -C A. El Moudni, P. Borne, S. G. Tzafestas (Eds.), -C Vol. 2, pp. 42-46. -C -C [3] Liu Y. and Anderson B.D.O. -C Singular Perturbation Approximation of balanced systems. -C Int. J. Control, Vol. 50, pp. 1379-1405, 1989. -C -C [4] Varga A. -C Balancing-free square-root algorithm for computing singular -C perturbation approximations. -C Proc. 30-th CDC, Brighton, Dec. 11-13, 1991, -C Vol. 2, pp. 1062-1065. -C -C NUMERICAL ASPECTS -C -C The implemented method relies on accuracy enhancing square-root -C or balancing-free square-root methods. -C -C CONTRIBUTORS -C -C A. Varga, German Aerospace Center, Oberpfaffenhofen, August 2000. -C D. Sima, University of Bucharest, August 2000. -C V. Sima, Research Institute for Informatics, Bucharest, Aug. 2000. -C -C REVISIONS -C -C V. Sima, Research Institute for Informatics, Bucharest, Dec. 2000, -C Sep. 2001. -C -C KEYWORDS -C -C Balance and truncate, minimal state-space representation, -C model reduction, multivariable system, -C singular perturbation approximation, state-space model. -C -C ****************************************************************** -C -C .. Parameters .. - DOUBLE PRECISION ONE, ZERO - PARAMETER ( ONE = 1.0D0, ZERO = 0.0D0 ) -C .. Scalar Arguments .. - CHARACTER DICO, FACT, JOB, ORDSEL - INTEGER INFO, IWARN, LDA, LDB, LDC, LDD, LDT, LDTI, - $ LDWORK, M, N, NMINR, NR, P - DOUBLE PRECISION SCALEC, SCALEO, TOL1, TOL2 -C .. Array Arguments .. - INTEGER IWORK(*) - DOUBLE PRECISION A(LDA,*), B(LDB,*), C(LDC,*), D(LDD,*), - $ DWORK(*), HSV(*), T(LDT,*), TI(LDTI,*) -C .. Local Scalars .. - LOGICAL BAL, BTA, DISCR, FIXORD, RSF, SPA - INTEGER IERR, IJ, J, K, KTAU, KU, KV, KW, LDW, LW, - $ NRED, NR1, NS, WRKOPT - DOUBLE PRECISION ATOL, RCOND, SKP, TEMP, TOLDEF -C .. External Functions .. - LOGICAL LSAME - DOUBLE PRECISION DLAMCH - EXTERNAL DLAMCH, LSAME -C .. External Subroutines .. - EXTERNAL AB09DD, DGEMM, DGEMV, DGEQRF, DGETRF, DGETRS, - $ DLACPY, DORGQR, DSCAL, DTRMM, DTRMV, MA02AD, - $ MB03UD, XERBLA -C .. Intrinsic Functions .. - INTRINSIC DBLE, INT, MAX, MIN, SQRT -C .. Executable Statements .. -C - INFO = 0 - IWARN = 0 - DISCR = LSAME( DICO, 'D' ) - BTA = LSAME( JOB, 'B' ) .OR. LSAME( JOB, 'F' ) - SPA = LSAME( JOB, 'S' ) .OR. LSAME( JOB, 'P' ) - BAL = LSAME( JOB, 'B' ) .OR. LSAME( JOB, 'S' ) - RSF = LSAME( FACT, 'S' ) - FIXORD = LSAME( ORDSEL, 'F' ) -C - LW = MAX( 1, 2*N*N + 5*N, N*MAX( M, P ) ) -C -C Test the input scalar arguments. -C - IF( .NOT. ( LSAME( DICO, 'C' ) .OR. DISCR ) ) THEN - INFO = -1 - ELSE IF( .NOT. ( BTA .OR. SPA ) ) THEN - INFO = -2 - ELSE IF( .NOT. ( RSF .OR. LSAME( FACT, 'N' ) ) ) THEN - INFO = -3 - ELSE IF( .NOT. ( FIXORD .OR. LSAME( ORDSEL, 'A' ) ) ) THEN - INFO = -4 - ELSE IF( N.LT.0 ) THEN - INFO = -5 - ELSE IF( M.LT.0 ) THEN - INFO = -6 - ELSE IF( P.LT.0 ) THEN - INFO = -7 - ELSE IF( FIXORD .AND. ( NR.LT.0 .OR. NR.GT.N ) ) THEN - INFO = -8 - ELSE IF( SCALEC.LE.ZERO ) THEN - INFO = -9 - ELSE IF( SCALEO.LE.ZERO ) THEN - INFO = -10 - ELSE IF( LDA.LT.MAX( 1, N ) ) THEN - INFO = -12 - ELSE IF( LDB.LT.MAX( 1, N ) ) THEN - INFO = -14 - ELSE IF( LDC.LT.MAX( 1, P ) ) THEN - INFO = -16 - ELSE IF( LDD.LT.1 .OR. ( SPA .AND. LDD.LT.P ) ) THEN - INFO = -18 - ELSE IF( LDTI.LT.MAX( 1, N ) ) THEN - INFO = -20 - ELSE IF( LDT.LT.MAX( 1, N ) ) THEN - INFO = -22 - ELSE IF( TOL2.GT.ZERO .AND. .NOT.FIXORD .AND. TOL2.GT.TOL1 ) THEN - INFO = -26 - ELSE IF( LDWORK.LT.LW ) THEN - INFO = -29 - END IF -C - IF( INFO.NE.0 ) THEN -C -C Error return. -C - CALL XERBLA( 'AB09IX', -INFO ) - RETURN - END IF -C -C Quick return if possible. -C - IF( MIN( N, M, P ).EQ.0 ) THEN - NR = 0 - NMINR = 0 - DWORK(1) = ONE - RETURN - END IF -C -C Save S in DWORK(KV). -C - KV = 1 - KU = KV + N*N - KW = KU + N*N - CALL DLACPY( 'Upper', N, N, TI, LDTI, DWORK(KV), N ) -C | x x | -C Compute R*S in the form | 0 x | in TI. -C - DO 10 J = 1, N - CALL DTRMV( 'Upper', 'NoTranspose', 'NonUnit', J, T, LDT, - $ TI(1,J), 1 ) - 10 CONTINUE -C -C Compute the singular value decomposition R*S = V*Sigma*UT of the -C upper triangular matrix R*S, with UT in TI and V in DWORK(KU). -C -C Workspace: need 2*N*N + 5*N; -C prefer larger. -C - CALL MB03UD( 'Vectors', 'Vectors', N, TI, LDTI, DWORK(KU), N, HSV, - $ DWORK(KW), LDWORK-KW+1, IERR ) - IF( IERR.NE.0 ) THEN - INFO = 1 - RETURN - ENDIF - WRKOPT = INT( DWORK(KW) ) + KW - 1 -C -C Scale the singular values. -C - CALL DSCAL( N, ONE / SCALEC / SCALEO, HSV, 1 ) -C -C Partition Sigma, U and V conformally as: -C -C Sigma = diag(Sigma1,Sigma2,Sigma3), U = [U1,U2,U3] (U' in TI) and -C V = [V1,V2,V3] (in DWORK(KU)). -C -C Compute NMINR, the order of a minimal realization, as the order -C of [Sigma1 Sigma2]. -C - TOLDEF = DBLE( N )*DLAMCH( 'Epsilon' ) - ATOL = MAX( TOL2, TOLDEF*HSV(1) ) - NMINR = N - 20 IF( NMINR.GT.0 ) THEN - IF( HSV(NMINR).LE.ATOL ) THEN - NMINR = NMINR - 1 - GO TO 20 - END IF - END IF -C -C Compute the order NR of reduced system, as the order of Sigma1. -C - IF( FIXORD ) THEN -C -C Check if the desired order is less than the order of a minimal -C realization. -C - IF( NR.GT.NMINR ) THEN -C -C Reduce the order to NMINR. -C - NR = NMINR - IWARN = 1 - END IF -C -C Check for singular value multiplicity at cut-off point. -C - IF( NR.GT.0 .AND. NR.LT.NMINR ) THEN - SKP = HSV(NR) - IF( SKP-HSV(NR+1).LE.TOLDEF*SKP ) THEN - IWARN = 2 -C -C Reduce the order such that HSV(NR) > HSV(NR+1). -C - 30 NR = NR - 1 - IF( NR.GT.0 ) THEN - IF( HSV(NR)-SKP.LE.TOLDEF*SKP ) GO TO 30 - END IF - END IF - END IF - ELSE -C -C The order is given as the number of singular values -C exceeding MAX( TOL1, N*EPS*HSV(1) ). -C - ATOL = MAX( TOL1, ATOL ) - NR = 0 - DO 40 J = 1, NMINR - IF( HSV(J).LE.ATOL ) GO TO 50 - NR = NR + 1 - 40 CONTINUE - 50 CONTINUE - ENDIF -C -C Finish if the order is zero. -C - IF( NR.EQ.0 ) THEN - IF( SPA ) - $ CALL AB09DD( DICO, N, M, P, NR, A, LDA, B, LDB, C, LDC, - $ D, LDD, RCOND, IWORK, DWORK, IERR ) - DWORK(1) = WRKOPT - RETURN - END IF -C -C Compute NS, the order of Sigma2. For BTA, NS = 0. -C - IF( SPA ) THEN - NRED = NMINR - ELSE - NRED = NR - END IF - NS = NRED - NR -C -C Compute the truncation matrices. -C -C Compute TI' = | TI1' TI2' | = R'*| V1 V2 | in DWORK(KU). -C - CALL DTRMM( 'Left', 'Upper', 'Transpose', 'NonUnit', N, NRED, - $ ONE, T, LDT, DWORK(KU), N ) -C -C Compute T = | T1 T2 | = S*| U1 U2 | . -C - CALL MA02AD( 'Full', NRED, N, TI, LDTI, T, LDT ) - CALL DTRMM( 'Left', 'Upper', 'NoTranspose', 'NonUnit', N, - $ NRED, ONE, DWORK(KV), N, T, LDT ) -C - KTAU = KW - IF( BAL ) THEN - IJ = KU -C -C Square-Root B&T/SPA method. -C -C Compute the truncation matrices for balancing -C -1/2 -1/2 -C T1*Sigma1 and TI1'*Sigma1 . -C - DO 60 J = 1, NR - TEMP = ONE/SQRT( HSV(J) ) - CALL DSCAL( N, TEMP, T(1,J), 1 ) - CALL DSCAL( N, TEMP, DWORK(IJ), 1 ) - IJ = IJ + N - 60 CONTINUE -C - ELSE -C -C Balancing-Free B&T/SPA method. -C -C Compute orthogonal bases for the images of matrices T1 and -C TI1'. -C -C Workspace: need 2*N*N + 2*N; -C prefer larger. -C - KW = KTAU + NR - LDW = LDWORK - KW + 1 - CALL DGEQRF( N, NR, T, LDT, DWORK(KTAU), DWORK(KW), LDW, IERR ) - CALL DORGQR( N, NR, NR, T, LDT, DWORK(KTAU), DWORK(KW), LDW, - $ IERR ) - CALL DGEQRF( N, NR, DWORK(KU), N, DWORK(KTAU), DWORK(KW), LDW, - $ IERR ) - WRKOPT = MAX( WRKOPT, INT( DWORK(KW) ) + KW - 1 ) - CALL DORGQR( N, NR, NR, DWORK(KU), N, DWORK(KTAU), DWORK(KW), - $ LDW, IERR ) - WRKOPT = MAX( WRKOPT, INT( DWORK(KW) ) + KW - 1 ) - ENDIF -C - IF( NS.GT.0 ) THEN -C -C Compute orthogonal bases for the images of matrices T2 and -C TI2'. -C -C Workspace: need 2*N*N + 2*N; -C prefer larger. -C - NR1 = NR + 1 - KW = KTAU + NS - LDW = LDWORK - KW + 1 - CALL DGEQRF( N, NS, T(1,NR1), LDT, DWORK(KTAU), DWORK(KW), LDW, - $ IERR ) - CALL DORGQR( N, NS, NS, T(1,NR1), LDT, DWORK(KTAU), DWORK(KW), - $ LDW, IERR ) - CALL DGEQRF( N, NS, DWORK(KU+N*NR), N, DWORK(KTAU), DWORK(KW), - $ LDW, IERR ) - WRKOPT = MAX( WRKOPT, INT( DWORK(KW) ) + KW - 1 ) - CALL DORGQR( N, NS, NS, DWORK(KU+N*NR), N, DWORK(KTAU), - $ DWORK(KW), LDW, IERR ) - WRKOPT = MAX( WRKOPT, INT( DWORK(KW) ) + KW - 1 ) - ENDIF -C -C Transpose TI' in TI. -C - CALL MA02AD( 'Full', N, NRED, DWORK(KU), N, TI, LDTI ) -C - IF( .NOT.BAL ) THEN -C -1 -C Compute (TI1*T1) *TI1 in TI. -C - CALL DGEMM( 'NoTranspose', 'NoTranspose', NR, NR, N, ONE, TI, - $ LDTI, T, LDT, ZERO, DWORK(KU), N ) - CALL DGETRF( NR, NR, DWORK(KU), N, IWORK, IERR ) - CALL DGETRS( 'NoTranspose', NR, N, DWORK(KU), N, IWORK, TI, - $ LDTI, IERR ) -C - IF( NS.GT.0 ) THEN -C -1 -C Compute (TI2*T2) *TI2 in TI2. -C - CALL DGEMM( 'NoTranspose', 'NoTranspose', NS, NS, N, ONE, - $ TI(NR1,1), LDTI, T(1,NR1), LDT, ZERO, DWORK(KU), - $ N ) - CALL DGETRF( NS, NS, DWORK(KU), N, IWORK, IERR ) - CALL DGETRS( 'NoTranspose', NS, N, DWORK(KU), N, IWORK, - $ TI(NR1,1), LDTI, IERR ) - END IF - END IF -C -C Compute TI*A*T. Exploit RSF of A if possible. -C Workspace: need N*N. -C - IF( RSF ) THEN - IJ = 1 - DO 80 J = 1, N - K = MIN( J+1, N ) - CALL DGEMV( 'NoTranspose', NRED, K, ONE, TI, LDTI, - $ A(1,J), 1, ZERO, DWORK(IJ), 1 ) - IJ = IJ + N - 80 CONTINUE - ELSE - CALL DGEMM( 'NoTranspose', 'NoTranspose', NRED, N, N, ONE, - $ TI, LDTI, A, LDA, ZERO, DWORK, N ) - END IF - CALL DGEMM( 'NoTranspose', 'NoTranspose', NRED, NRED, N, ONE, - $ DWORK, N, T, LDT, ZERO, A, LDA ) -C -C Compute TI*B and C*T. -C Workspace: need N*MAX(M,P). -C - CALL DLACPY( 'Full', N, M, B, LDB, DWORK, N ) - CALL DGEMM( 'NoTranspose', 'NoTranspose', NRED, M, N, ONE, TI, - $ LDTI, DWORK, N, ZERO, B, LDB ) -C - CALL DLACPY( 'Full', P, N, C, LDC, DWORK, P ) - CALL DGEMM( 'NoTranspose', 'NoTranspose', P, NRED, N, ONE, - $ DWORK, P, T, LDT, ZERO, C, LDC ) -C -C Compute the singular perturbation approximation if possible. -C Note that IERR = 1 on exit from AB09DD cannot appear here. -C -C Workspace: need real 4*(NMINR-NR); -C need integer 2*(NMINR-NR). -C - IF( SPA) THEN - CALL AB09DD( DICO, NRED, M, P, NR, A, LDA, B, LDB, - $ C, LDC, D, LDD, RCOND, IWORK, DWORK, IERR ) - ELSE - NMINR = NR - END IF - DWORK(1) = WRKOPT -C - RETURN -C *** Last line of AB09IX *** - END diff --git a/mex/sources/libslicot/AB09IY.f b/mex/sources/libslicot/AB09IY.f deleted file mode 100644 index 475505219..000000000 --- a/mex/sources/libslicot/AB09IY.f +++ /dev/null @@ -1,859 +0,0 @@ - SUBROUTINE AB09IY( DICO, JOBC, JOBO, WEIGHT, N, M, P, NV, PV, - $ NW, MW, ALPHAC, ALPHAO, A, LDA, B, LDB, C, LDC, - $ AV, LDAV, BV, LDBV, CV, LDCV, DV, LDDV, - $ AW, LDAW, BW, LDBW, CW, LDCW, DW, LDDW, - $ SCALEC, SCALEO, S, LDS, R, LDR, - $ DWORK, LDWORK, INFO ) -C -C SLICOT RELEASE 5.0. -C -C Copyright (c) 2002-2009 NICONET e.V. -C -C This program is free software: you can redistribute it and/or -C modify it under the terms of the GNU General Public License as -C published by the Free Software Foundation, either version 2 of -C the License, or (at your option) any later version. -C -C This program is distributed in the hope that it will be useful, -C but WITHOUT ANY WARRANTY; without even the implied warranty of -C MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the -C GNU General Public License for more details. -C -C You should have received a copy of the GNU General Public License -C along with this program. If not, see -C . -C -C PURPOSE -C -C To compute for given state-space representations -C (A,B,C,0), (AV,BV,CV,DV), and (AW,BW,CW,DW) of the -C transfer-function matrices G, V and W, respectively, -C the Cholesky factors of the frequency-weighted -C controllability and observability Grammians corresponding -C to a frequency-weighted model reduction problem. -C G, V and W must be stable transfer-function matrices with -C the state matrices A, AV, and AW in real Schur form. -C It is assumed that the state space realizations (AV,BV,CV,DV) -C and (AW,BW,CW,DW) are minimal. In case of possible pole-zero -C cancellations in forming V*G and/or G*W, the parameters for the -C choice of frequency-weighted Grammians ALPHAO and/or ALPHAC, -C respectively, must be different from 1. -C -C ARGUMENTS -C -C Mode Parameters -C -C DICO CHARACTER*1 -C Specifies the type of the systems as follows: -C = 'C': G, V and W are continuous-time systems; -C = 'D': G, V and W are discrete-time systems. -C -C JOBC CHARACTER*1 -C Specifies the choice of frequency-weighted controllability -C Grammian as follows: -C = 'S': choice corresponding to a combination method [4] -C of the approaches of Enns [1] and Lin-Chiu [2,3]; -C = 'E': choice corresponding to the stability enhanced -C modified combination method of [4]. -C -C JOBO CHARACTER*1 -C Specifies the choice of frequency-weighted observability -C Grammian as follows: -C = 'S': choice corresponding to a combination method [4] -C of the approaches of Enns [1] and Lin-Chiu [2,3]; -C = 'E': choice corresponding to the stability enhanced -C modified combination method of [4]. -C -C WEIGHT CHARACTER*1 -C Specifies the type of frequency weighting, as follows: -C = 'N': no weightings are used (V = I, W = I); -C = 'L': only left weighting V is used (W = I); -C = 'R': only right weighting W is used (V = I); -C = 'B': both left and right weightings V and W are used. -C -C Input/Output Parameters -C -C N (input) INTEGER -C The order of the state-space representation of G, i.e., -C the order of the matrix A. N >= 0. -C -C M (input) INTEGER -C The number of columns of the matrix B and -C the number of rows of the matrices CW and DW. M >= 0. -C M represents the dimension of the input vector of the -C system with the transfer-function matrix G and -C also the dimension of the output vector of the system -C with the transfer-function matrix W. -C -C P (input) INTEGER -C The number of rows of the matrix C and the -C number of columns of the matrices BV and DV. P >= 0. -C P represents the dimension of the output vector of the -C system with the transfer-function matrix G and -C also the dimension of the input vector of the system -C with the transfer-function matrix V. -C -C NV (input) INTEGER -C The order of the matrix AV. Also the number of rows of -C the matrix BV and the number of columns of the matrix CV. -C NV represents the dimension of the state vector of the -C system with the transfer-function matrix V. NV >= 0. -C -C PV (input) INTEGER -C The number of rows of the matrices CV and DV. PV >= 0. -C PV represents the dimension of the output vector of the -C system with the transfer-function matrix V. -C -C NW (input) INTEGER -C The order of the matrix AW. Also the number of rows of -C the matrix BW and the number of columns of the matrix CW. -C NW represents the dimension of the state vector of the -C system with the transfer-function matrix W. NW >= 0. -C -C MW (input) INTEGER -C The number of columns of the matrices BW and DW. MW >= 0. -C MW represents the dimension of the input vector of the -C system with the transfer-function matrix W. -C -C ALPHAC (input) DOUBLE PRECISION -C Combination method parameter for defining the -C frequency-weighted controllability Grammian (see METHOD); -C ABS(ALPHAC) <= 1. -C -C ALPHAO (input) DOUBLE PRECISION -C Combination method parameter for defining the -C frequency-weighted observability Grammian (see METHOD); -C ABS(ALPHAO) <= 1. -C -C A (input) DOUBLE PRECISION array, dimension (LDA,N) -C The leading N-by-N part of this array must -C contain the state matrix A (of the system with the -C transfer-function matrix G) in a real Schur form. -C -C LDA INTEGER -C The leading dimension of array A. LDA >= MAX(1,N). -C -C B (input) DOUBLE PRECISION array, dimension (LDB,M) -C The leading N-by-M part of this array must contain the -C input/state matrix B. -C -C LDB INTEGER -C The leading dimension of array B. LDB >= MAX(1,N). -C -C C (input) DOUBLE PRECISION array, dimension (LDC,N) -C The leading P-by-N part of this array must contain the -C state/output matrix C. -C -C LDC INTEGER -C The leading dimension of array C. LDC >= MAX(1,P). -C -C AV (input) DOUBLE PRECISION array, dimension (LDAV,NV) -C If WEIGHT = 'L' or 'B', the leading NV-by-NV part of this -C array must contain the state matrix AV (of the system with -C the transfer-function matrix V) in a real Schur form. -C AV is not referenced if WEIGHT = 'R' or 'N'. -C -C LDAV INTEGER -C The leading dimension of array AV. -C LDAV >= MAX(1,NV), if WEIGHT = 'L' or 'B'; -C LDAV >= 1, if WEIGHT = 'R' or 'N'. -C -C BV (input) DOUBLE PRECISION array, dimension (LDBV,P) -C If WEIGHT = 'L' or 'B', the leading NV-by-P part of this -C array must contain the input matrix BV of the system with -C the transfer-function matrix V. -C BV is not referenced if WEIGHT = 'R' or 'N'. -C -C LDBV INTEGER -C The leading dimension of array BV. -C LDBV >= MAX(1,NV), if WEIGHT = 'L' or 'B'; -C LDBV >= 1, if WEIGHT = 'R' or 'N'. -C -C CV (input) DOUBLE PRECISION array, dimension (LDCV,NV) -C If WEIGHT = 'L' or 'B', the leading PV-by-NV part of this -C array must contain the output matrix CV of the system with -C the transfer-function matrix V. -C CV is not referenced if WEIGHT = 'R' or 'N'. -C -C LDCV INTEGER -C The leading dimension of array CV. -C LDCV >= MAX(1,PV), if WEIGHT = 'L' or 'B'; -C LDCV >= 1, if WEIGHT = 'R' or 'N'. -C -C DV (input) DOUBLE PRECISION array, dimension (LDDV,P) -C If WEIGHT = 'L' or 'B', the leading PV-by-P part of this -C array must contain the feedthrough matrix DV of the system -C with the transfer-function matrix V. -C DV is not referenced if WEIGHT = 'R' or 'N'. -C -C LDDV INTEGER -C The leading dimension of array DV. -C LDDV >= MAX(1,PV), if WEIGHT = 'L' or 'B'; -C LDDV >= 1, if WEIGHT = 'R' or 'N'. -C -C AW (input) DOUBLE PRECISION array, dimension (LDAW,NW) -C If WEIGHT = 'R' or 'B', the leading NW-by-NW part of this -C array must contain the state matrix AW (of the system with -C the transfer-function matrix W) in a real Schur form. -C AW is not referenced if WEIGHT = 'L' or 'N'. -C -C LDAW INTEGER -C The leading dimension of array AW. -C LDAW >= MAX(1,NW), if WEIGHT = 'R' or 'B'; -C LDAW >= 1, if WEIGHT = 'L' or 'N'. -C -C BW (input) DOUBLE PRECISION array, dimension (LDBW,MW) -C If WEIGHT = 'R' or 'B', the leading NW-by-MW part of this -C array must contain the input matrix BW of the system with -C the transfer-function matrix W. -C BW is not referenced if WEIGHT = 'L' or 'N'. -C -C LDBW INTEGER -C The leading dimension of array BW. -C LDBW >= MAX(1,NW), if WEIGHT = 'R' or 'B'; -C LDBW >= 1, if WEIGHT = 'L' or 'N'. -C -C CW (input) DOUBLE PRECISION array, dimension (LDCW,NW) -C If WEIGHT = 'R' or 'B', the leading M-by-NW part of this -C array must contain the output matrix CW of the system with -C the transfer-function matrix W. -C CW is not referenced if WEIGHT = 'L' or 'N'. -C -C LDCW INTEGER -C The leading dimension of array CW. -C LDCW >= MAX(1,M), if WEIGHT = 'R' or 'B'; -C LDCW >= 1, if WEIGHT = 'L' or 'N'. -C -C DW (input) DOUBLE PRECISION array, dimension (LDDW,MW) -C If WEIGHT = 'R' or 'B', the leading M-by-MW part of this -C array must contain the feedthrough matrix DW of the system -C with the transfer-function matrix W. -C DW is not referenced if WEIGHT = 'L' or 'N'. -C -C LDDW INTEGER -C The leading dimension of array DW. -C LDDW >= MAX(1,M), if WEIGHT = 'R' or 'B'; -C LDDW >= 1, if WEIGHT = 'L' or 'N'. -C -C SCALEC (output) DOUBLE PRECISION -C Scaling factor for the controllability Grammian in (1) -C or (3). See METHOD. -C -C SCALEO (output) DOUBLE PRECISION -C Scaling factor for the observability Grammian in (2) -C or (4). See METHOD. -C -C S (output) DOUBLE PRECISION array, dimension (LDS,N) -C The leading N-by-N upper triangular part of this array -C contains the Cholesky factor S of the frequency-weighted -C cotrollability Grammian P = S*S'. See METHOD. -C -C LDS INTEGER -C The leading dimension of array S. LDS >= MAX(1,N). -C -C R (output) DOUBLE PRECISION array, dimension (LDR,N) -C The leading N-by-N upper triangular part of this array -C contains the Cholesky factor R of the frequency-weighted -C observability Grammian Q = R'*R. See METHOD. -C -C LDR INTEGER -C The leading dimension of array R. LDR >= MAX(1,N). -C -C Workspace -C -C DWORK DOUBLE PRECISION array, dimension (LDWORK) -C On exit, if INFO = 0, DWORK(1) returns the optimal value -C of LDWORK. -C -C LDWORK INTEGER -C The length of the array DWORK. -C LDWORK >= MAX( 1, LLEFT, LRIGHT ), -C where -C LLEFT = (N+NV)*(N+NV+MAX(N+NV,PV)+5) -C if WEIGHT = 'L' or 'B' and PV > 0; -C LLEFT = N*(P+5) if WEIGHT = 'R' or 'N' or PV = 0; -C LRIGHT = (N+NW)*(N+NW+MAX(N+NW,MW)+5) -C if WEIGHT = 'R' or 'B' and MW > 0; -C LRIGHT = N*(M+5) if WEIGHT = 'L' or 'N' or MW = 0. -C For optimum performance LDWORK should be larger. -C -C Error Indicator -C -C INFO INTEGER -C = 0: successful exit; -C < 0: if INFO = -i, the i-th argument had an illegal -C value; -C = 1: if the state matrices A and/or AV are not stable or -C not in a real Schur form; -C = 2: if the state matrices A and/or AW are not stable or -C not in a real Schur form; -C = 3: eigenvalues computation failure. -C -C METHOD -C -C Let Pi = Si*Si' and Qo = Ro'*Ro be the Cholesky factored -C controllability and observability Grammians satisfying -C in the continuous-time case -C -C Ai*Pi + Pi*Ai' + scalec^2*Bi*Bi' = 0, (1) -C -C Ao'*Qo + Qo*Ao + scaleo^2*Co'*Co = 0, (2) -C -C and in the discrete-time case -C -C Ai*Pi*Ai' - Pi + scalec^2*Bi*Bi' = 0, (3) -C -C Ao'*Qo*Ao - Qo + scaleo^2*Co'*Co = 0, (4) -C -C where -C -C Ai = ( A B*Cw ) , Bi = ( B*Dw ) , -C ( 0 Aw ) ( Bw ) -C -C Ao = ( A 0 ) , Co = ( Dv*C Cv ) . -C ( Bv*C Av ) -C -C Consider the partitioned Grammians -C -C Pi = ( P11 P12 ) and Qo = ( Q11 Q12 ) , -C ( P12' P22 ) ( Q12' Q22 ) -C -C where P11 and Q11 are the leading N-by-N parts of Pi and Qo, -C respectively, and let P0 and Q0 be non-negative definite matrices -C defined in the combination method [4] -C -1 -C P0 = P11 - ALPHAC**2*P12*P22 *P21 , -C -1 -C Q0 = Q11 - ALPHAO**2*Q12*Q22 *Q21. -C -C The frequency-weighted controllability and observability -C Grammians, P and Q, respectively, are defined as follows: -C P = P0 if JOBC = 'S' (standard combination method [4]); -C P = P1 >= P0 if JOBC = 'E', where P1 is the controllability -C Grammian defined to enforce stability for a modified combination -C method of [4]; -C Q = Q0 if JOBO = 'S' (standard combination method [4]); -C Q = Q1 >= Q0 if JOBO = 'E', where Q1 is the observability -C Grammian defined to enforce stability for a modified combination -C method of [4]. -C -C If JOBC = JOBO = 'S' and ALPHAC = ALPHAO = 0, the choice of -C Grammians corresponds to the method of Enns [1], while if -C ALPHAC = ALPHAO = 1, the choice of Grammians corresponds to the -C method of Lin and Chiu [2,3]. -C -C The routine computes directly the Cholesky factors S and R -C such that P = S*S' and Q = R'*R according to formulas -C developed in [4]. No matrix inversions are involved. -C -C REFERENCES -C -C [1] Enns, D. -C Model reduction with balanced realizations: An error bound -C and a frequency weighted generalization. -C Proc. CDC, Las Vegas, pp. 127-132, 1984. -C -C [2] Lin, C.-A. and Chiu, T.-Y. -C Model reduction via frequency-weighted balanced realization. -C Control Theory and Advanced Technology, vol. 8, -C pp. 341-351, 1992. -C -C [3] Sreeram, V., Anderson, B.D.O and Madievski, A.G. -C New results on frequency weighted balanced reduction -C technique. -C Proc. ACC, Seattle, Washington, pp. 4004-4009, 1995. -C -C [4] Varga, A. and Anderson, B.D.O. -C Square-root balancing-free methods for the frequency-weighted -C balancing related model reduction. -C (report in preparation) -C -C CONTRIBUTORS -C -C A. Varga, German Aerospace Center, Oberpfaffenhofen, August 2000. -C D. Sima, University of Bucharest, August 2000. -C V. Sima, Research Institute for Informatics, Bucharest, Aug. 2000. -C -C REVISIONS -C -C A. Varga, Australian National University, Canberra, November 2000. -C V. Sima, Research Institute for Informatics, Bucharest, Dec. 2000. -C A. Varga, German Aerospace Center, Oberpfaffenhofen, August 2001. -C -C KEYWORDS -C -C Frequency weighting, model reduction, multivariable system, -C state-space model, state-space representation. -C -C ****************************************************************** -C -C .. Parameters .. - DOUBLE PRECISION ZERO, ONE - PARAMETER ( ZERO = 0.0D0, ONE = 1.0D0 ) -C .. Scalar Arguments .. - CHARACTER DICO, JOBC, JOBO, WEIGHT - INTEGER INFO, LDA, LDAV, LDAW, LDB, LDBV, LDBW, - $ LDC, LDCV, LDCW, LDDV, LDDW, LDR, LDS, LDWORK, - $ M, MW, N, NV, NW, P, PV - DOUBLE PRECISION ALPHAC, ALPHAO, SCALEC, SCALEO -C .. Array Arguments .. - DOUBLE PRECISION A(LDA,*), AV(LDAV,*), AW(LDAW,*), - $ B(LDB,*), BV(LDBV,*), BW(LDBW,*), - $ C(LDC,*), CV(LDCV,*), CW(LDCW,*), - $ DV(LDDV,*), DW(LDDW,*), - $ DWORK(*), R(LDR,*), S(LDS,*) -C .. Local Scalars .. - LOGICAL DISCR, FRWGHT, LEFTW, RIGHTW - INTEGER I, IERR, J, KAW, KTAU, KU, KW, LDU, LW, MBBAR, - $ NNV, NNW, PCBAR - DOUBLE PRECISION T, TOL, WORK -C .. Local Arrays .. - DOUBLE PRECISION DUM(1) -C .. External Functions .. - LOGICAL LSAME - DOUBLE PRECISION DLAMCH - EXTERNAL DLAMCH, LSAME -C .. External Subroutines .. - EXTERNAL DCOPY, DGEMM, DLACPY, DLASET, DSCAL, DSYEV, - $ MB01WD, MB04ND, MB04OD, SB03OU, XERBLA -C .. Intrinsic Functions .. - INTRINSIC ABS, DBLE, MAX, MIN, SQRT -C .. Executable Statements .. -C - DISCR = LSAME( DICO, 'D' ) - LEFTW = LSAME( WEIGHT, 'L' ) .OR. LSAME( WEIGHT, 'B' ) - RIGHTW = LSAME( WEIGHT, 'R' ) .OR. LSAME( WEIGHT, 'B' ) - FRWGHT = LEFTW .OR. RIGHTW -C - INFO = 0 - LW = 1 - NNV = N + NV - NNW = N + NW - IF( LEFTW .AND. PV.GT.0 ) THEN - LW = MAX( LW, NNV*( NNV + MAX( NNV, PV ) + 5 ) ) - ELSE - LW = MAX( LW, N*( P + 5 ) ) - END IF - IF( RIGHTW .AND. MW.GT.0 ) THEN - LW = MAX( LW, NNW*( NNW + MAX( NNW, MW ) + 5 ) ) - ELSE - LW = MAX( LW, N*( M + 5 ) ) - END IF -C - IF( .NOT. ( LSAME( DICO, 'C' ) .OR. DISCR ) ) THEN - INFO = -1 - ELSE IF( .NOT.( LSAME( JOBC, 'S' ) .OR. LSAME( JOBC, 'E' ) ) ) - $ THEN - INFO = -2 - ELSE IF( .NOT.( LSAME( JOBO, 'S' ) .OR. LSAME( JOBO, 'E' ) ) ) - $ THEN - INFO = -3 - ELSE IF( .NOT.( FRWGHT .OR. LSAME( WEIGHT, 'N' ) ) ) THEN - INFO = -4 - ELSE IF( N.LT.0 ) THEN - INFO = -5 - ELSE IF( M.LT.0 ) THEN - INFO = -6 - ELSE IF( P.LT.0 ) THEN - INFO = -7 - ELSE IF( NV.LT.0 ) THEN - INFO = -8 - ELSE IF( PV.LT.0 ) THEN - INFO = -9 - ELSE IF( NW.LT.0 ) THEN - INFO = -10 - ELSE IF( MW.LT.0 ) THEN - INFO = -11 - ELSE IF( ABS( ALPHAC ).GT.ONE ) THEN - INFO = -12 - ELSE IF( ABS( ALPHAO ).GT.ONE ) THEN - INFO = -13 - ELSE IF( LDA.LT.MAX( 1, N ) ) THEN - INFO = -15 - ELSE IF( LDB.LT.MAX( 1, N ) ) THEN - INFO = -17 - ELSE IF( LDC.LT.MAX( 1, P ) ) THEN - INFO = -19 - ELSE IF( LDAV.LT.1 .OR. ( LEFTW .AND. LDAV.LT.NV ) ) THEN - INFO = -21 - ELSE IF( LDBV.LT.1 .OR. ( LEFTW .AND. LDBV.LT.NV ) ) THEN - INFO = -23 - ELSE IF( LDCV.LT.1 .OR. ( LEFTW .AND. LDCV.LT.PV ) ) THEN - INFO = -25 - ELSE IF( LDDV.LT.1 .OR. ( LEFTW .AND. LDDV.LT.PV ) ) THEN - INFO = -27 - ELSE IF( LDAW.LT.1 .OR. ( RIGHTW .AND. LDAW.LT.NW ) ) THEN - INFO = -29 - ELSE IF( LDBW.LT.1 .OR. ( RIGHTW .AND. LDBW.LT.NW ) ) THEN - INFO = -31 - ELSE IF( LDCW.LT.1 .OR. ( RIGHTW .AND. LDCW.LT.M ) ) THEN - INFO = -33 - ELSE IF( LDDW.LT.1 .OR. ( RIGHTW .AND. LDDW.LT.M ) ) THEN - INFO = -35 - ELSE IF( LDS.LT.MAX( 1, N ) ) THEN - INFO = -39 - ELSE IF( LDR.LT.MAX( 1, N ) ) THEN - INFO = -41 - ELSE IF( LDWORK.LT.LW ) THEN - INFO = -43 - END IF -C - IF( INFO.NE.0 ) THEN -C -C Error return. -C - CALL XERBLA( 'AB09IY', -INFO ) - RETURN - END IF -C -C Quick return if possible. -C - SCALEC = ONE - SCALEO = ONE - IF( MIN( N, M, P ).EQ.0 ) THEN - DWORK(1) = ONE - RETURN - END IF -C - WORK = 1 - IF( LEFTW .AND. PV.GT.0 ) THEN -C -C Build the extended permuted matrices -C -C Ao = ( Av Bv*C ) , Co = ( Cv Dv*C ) . -C ( 0 A ) -C - KAW = 1 - KU = KAW + NNV*NNV - LDU = MAX( NNV, PV ) - CALL DLACPY( 'Full', NV, NV, AV, LDAV, DWORK(KAW), NNV ) - CALL DLASET( 'Full', N, NV, ZERO, ZERO, DWORK(KAW+NV), NNV ) - CALL DGEMM( 'No-transpose', 'No-transpose', NV, N, P, ONE, - $ BV, LDBV, C, LDC, ZERO, DWORK(KAW+NNV*NV), NNV ) - CALL DLACPY( 'Full', N, N, A, LDA, DWORK(KAW+NNV*NV+NV), NNV ) -C - CALL DLACPY( 'Full', PV, NV, CV, LDCV, DWORK(KU), LDU ) - CALL DGEMM( 'No-transpose', 'No-transpose', PV, N, P, ONE, - $ DV, LDDV, C, LDC, ZERO, DWORK(KU+LDU*NV), LDU ) -C -C Solve for the Cholesky factor Ro of Qo, Qo = Ro'*Ro, -C the continuous-time Lyapunov equation (if DICO = 'C') -C -C Ao'*Qo + Qo*Ao + scaleo^2*Co'*Co = 0, -C -C or the discrete-time Lyapunov equation (if DICO = 'D') -C -C Ao'*Qo*Ao - Qo + scaleo^2*Co'*Co = 0. -C -C Workspace: need (N+NV)*(N+NV+MAX(N+NV,PV)+5); -C prefer larger. -C - KTAU = KU + LDU*NNV - KW = KTAU + NNV -C - CALL SB03OU( DISCR, .FALSE., NNV, PV, DWORK(KAW), NNV, - $ DWORK(KU), LDU, DWORK(KTAU), DWORK(KU), LDU, - $ SCALEO, DWORK(KW), LDWORK-KW+1, IERR ) -C - IF( IERR.NE.0 ) THEN - INFO = 1 - RETURN - END IF - WORK = MAX( WORK, DWORK(KW) + DBLE( KW - 1 ) ) -C -C Partition Ro as Ro = ( R11 R12 ) and compute R such that -C ( 0 R22 ) -C -C R'*R = R22'*R22 + (1-ALPHAO**2)*R12'*R12. -C - KW = KU + LDU*NV + NV - CALL DLACPY( 'Upper', N, N, DWORK(KW), LDU, R, LDR ) - IF( ALPHAO.NE.ZERO ) THEN - T = SQRT( ONE - ALPHAO*ALPHAO ) - DO 10 J = KU + LDU*NV, KU + LDU*(NNV-1), LDU - CALL DSCAL( NV, T, DWORK(J), 1 ) - 10 CONTINUE - END IF - IF( ALPHAO.LT.ONE .AND. NV.GT.0 ) THEN - KTAU = 1 - CALL MB04OD( 'Full', N, 0, NV, R, LDR, DWORK(KU+LDU*NV), - $ LDU, DUM, 1, DUM, 1, DWORK(KTAU), DWORK(KW) ) -C - DO 30 J = 1, N - DWORK(J) = R(J,J) - DO 20 I = 1, J - IF ( DWORK(I).LT.ZERO ) R(I,J) = -R(I,J) - 20 CONTINUE - 30 CONTINUE -C - END IF -C - IF( LSAME( JOBO, 'E' ) .AND. ALPHAO.LT.ONE ) THEN -C -C Form Y = -A'*(R'*R)-(R'*R)*A if DICO = 'C', or -C Y = -A'*(R'*R)*A+(R'*R) if DICO = 'D'. -C - CALL DLACPY( 'Upper', N, N, R, LDR, DWORK(KU), N ) - CALL MB01WD( DICO, 'Upper', 'No-transpose', 'Hessenberg', N, - $ -ONE, ZERO, R, LDR, DWORK(KAW+NNV*NV+NV), NNV, - $ DWORK(KU), N, IERR ) -C -C Compute the eigendecomposition of Y as Y = Z*Sigma*Z'. -C - KU = N + 1 - CALL DSYEV( 'Vectors', 'Upper', N, R, LDR, DWORK, DWORK(KU), - $ LDWORK-N, IERR ) - IF( IERR.GT.0 ) THEN - INFO = 3 - RETURN - END IF - WORK = MAX( WORK, DWORK(KU) + DBLE( N ) ) -C -C Partition Sigma = (Sigma1,Sigma2), such that -C Sigma1 <= 0, Sigma2 > 0. -C Partition correspondingly Z = [Z1 Z2]. -C - TOL = MAX( ABS( DWORK(1) ), ABS( DWORK(N) ) ) - $ * DLAMCH( 'Epsilon') -C _ -C Form C = [ sqrt(Sigma2)*Z2' ] -C - PCBAR = 0 - DO 40 J = 1, N - IF( DWORK(J).GT.TOL ) THEN - CALL DSCAL( N, SQRT( DWORK(J) ), R(1,J), 1 ) - CALL DCOPY( N, R(1,J), 1, DWORK(KU+PCBAR), N ) - PCBAR = PCBAR + 1 - END IF - 40 CONTINUE -C -C Solve for the Cholesky factor R of Q, Q = R'*R, -C the continuous-time Lyapunov equation (if DICO = 'C') -C _ _ -C A'*Q + Q*A + t^2*C'*C = 0, -C -C or the discrete-time Lyapunov equation (if DICO = 'D') -C _ _ -C A'*Q*A - Q + t^2*C'*C = 0. -C -C Workspace: need N*(N + 6); -C prefer larger. -C - KTAU = KU + N*N - KW = KTAU + N -C - CALL SB03OU( DISCR, .FALSE., N, PCBAR, A, LDA, DWORK(KU), N, - $ DWORK(KTAU), R, LDR, T, DWORK(KW), LDWORK-KW+1, - $ IERR ) - IF( IERR.NE.0 ) THEN - INFO = 1 - RETURN - END IF - SCALEO = SCALEO*T - WORK = MAX( WORK, DWORK(KW) + DBLE( KW - 1 ) ) - END IF -C - ELSE -C -C Solve for the Cholesky factor R of Q, Q = R'*R, -C the continuous-time Lyapunov equation (if DICO = 'C') -C -C A'*Q + Q*A + scaleo^2*C'*C = 0, -C -C or the discrete-time Lyapunov equation (if DICO = 'D') -C -C A'*Q*A - Q + scaleo^2*C'*C = 0. -C -C Workspace: need N*(P + 5); -C prefer larger. -C - KU = 1 - KTAU = KU + P*N - KW = KTAU + N -C - CALL DLACPY( 'Full', P, N, C, LDC, DWORK(KU), P ) - CALL SB03OU( DISCR, .FALSE., N, P, A, LDA, DWORK(KU), P, - $ DWORK(KTAU), R, LDR, SCALEO, DWORK(KW), - $ LDWORK-KW+1, IERR ) - IF( IERR.NE.0 ) THEN - INFO = 1 - RETURN - END IF - WORK = MAX( WORK, DWORK(KW) + DBLE( KW - 1 ) ) - END IF -C - IF( RIGHTW .AND. MW.GT.0 ) THEN -C -C Build the extended matrices -C -C Ai = ( A B*Cw ) , Bi = ( B*Dw ) . -C ( 0 Aw ) ( Bw ) -C - KAW = 1 - KU = KAW + NNW*NNW - CALL DLACPY( 'Full', N, N, A, LDA, DWORK(KAW), NNW ) - CALL DLASET( 'Full', NW, N, ZERO, ZERO, DWORK(KAW+N), NNW ) - CALL DGEMM( 'No-transpose', 'No-transpose', N, NW, M, ONE, - $ B, LDB, CW, LDCW, ZERO, DWORK(KAW+NNW*N), NNW ) - CALL DLACPY( 'Full', NW, NW, AW, LDAW, - $ DWORK(KAW+NNW*N+N), NNW ) -C - CALL DGEMM( 'No-transpose', 'No-transpose', N, MW, M, ONE, - $ B, LDB, DW, LDDW, ZERO, DWORK(KU), NNW ) - CALL DLACPY( 'Full', NW, MW, BW, LDBW, DWORK(KU+N), NNW ) -C -C Solve for the Cholesky factor Si of Pi, Pi = Si*Si', -C the continuous-time Lyapunov equation (if DICO = 'C') -C -C Ai*Pi + Pi*Ai' + scalec^2*Bi*Bi' = 0, -C -C or the discrete-time Lyapunov equation (if DICO = 'D') -C -C Ai*Pi*Ai' - Pi + scalec^2*Bi*Bi' = 0. -C -C Workspace: need (N+NW)*(N+NW+MAX(N+NW,MW)+5); -C prefer larger. -C - KTAU = KU + NNW*MAX( NNW, MW ) - KW = KTAU + NNW -C - CALL SB03OU( DISCR, .TRUE., NNW, MW, DWORK(KAW), NNW, - $ DWORK(KU), NNW, DWORK(KTAU), DWORK(KU), NNW, - $ SCALEC, DWORK(KW), LDWORK-KW+1, IERR ) -C - IF( IERR.NE.0 ) THEN - INFO = 2 - RETURN - END IF - WORK = MAX( WORK, DWORK(KW) + DBLE( KW - 1 ) ) -C -C Partition Si as Si = ( S11 S12 ) and compute S such that -C ( 0 S22 ) -C -C S*S' = S11*S11' + (1-ALPHAC**2)*S12*S12'. -C - CALL DLACPY( 'Upper', N, N, DWORK(KU), NNW, S, LDS ) - IF( ALPHAC.NE.ZERO ) THEN - T = SQRT( ONE - ALPHAC*ALPHAC ) - DO 50 J = KU + NNW*N, KU + NNW*(NNW-1), NNW - CALL DSCAL( N, T, DWORK(J), 1 ) - 50 CONTINUE - END IF - IF( ALPHAC.LT.ONE .AND. NW.GT.0 ) THEN - KTAU = N*NNW + 1 - KW = KTAU + N - CALL MB04ND( 'Full', N, 0, NW, S, LDS, DWORK(KU+NNW*N), NNW, - $ DUM, 1, DUM, 1, DWORK(KTAU), DWORK(KW) ) -C - DO 70 J = 1, N - IF ( S(J,J).LT.ZERO ) THEN - DO 60 I = 1, J - S(I,J) = -S(I,J) - 60 CONTINUE - END IF - 70 CONTINUE - END IF -C - IF( LSAME( JOBC, 'E' ) .AND. ALPHAC.LT.ONE ) THEN -C -C Form X = -A*(S*S')-(S*S')*A' if DICO = 'C', or -C X = -A*(S*S')*A'+(S*S') if DICO = 'D'. -C - CALL DLACPY( 'Upper', N, N, S, LDS, DWORK(KU), N ) - CALL MB01WD( DICO, 'Upper', 'Transpose', 'Hessenberg', N, - $ -ONE, ZERO, S, LDS, DWORK(KAW), NNW, DWORK(KU), - $ N, IERR ) -C -C Compute the eigendecomposition of X as X = Z*Sigma*Z'. -C - KU = N + 1 - CALL DSYEV( 'Vectors', 'Upper', N, S, LDS, DWORK, DWORK(KU), - $ LDWORK-N, IERR ) - IF( IERR.GT.0 ) THEN - INFO = 3 - RETURN - END IF - WORK = MAX( WORK, DWORK(KU) + DBLE( N ) ) -C -C Partition Sigma = (Sigma1,Sigma2), such that -C Sigma1 =< 0, Sigma2 > 0. -C Partition correspondingly Z = [Z1 Z2]. -C - TOL = MAX( ABS( DWORK(1) ), ABS( DWORK(N) ) ) - $ * DLAMCH( 'Epsilon') -C _ -C Form B = [ Z2*sqrt(Sigma2) ] -C - MBBAR = 0 - I = KU - DO 80 J = 1, N - IF( DWORK(J).GT.TOL ) THEN - MBBAR = MBBAR + 1 - CALL DSCAL( N, SQRT( DWORK(J) ), S(1,J), 1 ) - CALL DCOPY( N, S(1,J), 1, DWORK(I), 1 ) - I = I + N - END IF - 80 CONTINUE -C -C Solve for the Cholesky factor S of P, P = S*S', -C the continuous-time Lyapunov equation (if DICO = 'C') -C _ _ -C A*P + P*A' + t^2*B*B' = 0, -C -C or the discrete-time Lyapunov equation (if DICO = 'D') -C _ _ -C A*P*A' - P + t^2*B*B' = 0. -C -C Workspace: need maximum N*(N + 6); -C prefer larger. -C - KTAU = KU + MBBAR*N - KW = KTAU + N -C - CALL SB03OU( DISCR, .TRUE., N, MBBAR, A, LDA, DWORK(KU), N, - $ DWORK(KTAU), S, LDS, T, DWORK(KW), LDWORK-KW+1, - $ IERR ) - IF( IERR.NE.0 ) THEN - INFO = 2 - RETURN - END IF - SCALEC = SCALEC*T - WORK = MAX( WORK, DWORK(KW) + DBLE( KW - 1 ) ) - END IF -C - ELSE -C -C Solve for the Cholesky factor S of P, P = S*S', -C the continuous-time Lyapunov equation (if DICO = 'C') -C -C A*P + P*A' + scalec^2*B*B' = 0, -C -C or the discrete-time Lyapunov equation (if DICO = 'D') -C -C A*P*A' - P + scalec^2*B*B' = 0. -C -C Workspace: need N*(M+5); -C prefer larger. -C - KU = 1 - KTAU = KU + N*M - KW = KTAU + N -C - CALL DLACPY( 'Full', N, M, B, LDB, DWORK(KU), N ) - CALL SB03OU( DISCR, .TRUE., N, M, A, LDA, DWORK(KU), N, - $ DWORK(KTAU), S, LDS, SCALEC, DWORK(KW), - $ LDWORK-KW+1, IERR ) - IF( IERR.NE.0 ) THEN - INFO = 2 - RETURN - END IF - WORK = MAX( WORK, DWORK(KW) + DBLE( KW - 1 ) ) - END IF -C -C Save optimal workspace. -C - DWORK(1) = WORK -C - RETURN -C *** Last line of AB09IY *** - END diff --git a/mex/sources/libslicot/AB09JD.f b/mex/sources/libslicot/AB09JD.f deleted file mode 100644 index 8729aa4e8..000000000 --- a/mex/sources/libslicot/AB09JD.f +++ /dev/null @@ -1,1482 +0,0 @@ - SUBROUTINE AB09JD( JOBV, JOBW, JOBINV, DICO, EQUIL, ORDSEL, - $ N, NV, NW, M, P, NR, ALPHA, A, LDA, B, LDB, - $ C, LDC, D, LDD, AV, LDAV, BV, LDBV, - $ CV, LDCV, DV, LDDV, AW, LDAW, BW, LDBW, - $ CW, LDCW, DW, LDDW, NS, HSV, TOL1, TOL2, - $ IWORK, DWORK, LDWORK, IWARN, INFO ) -C -C SLICOT RELEASE 5.0. -C -C Copyright (c) 2002-2009 NICONET e.V. -C -C This program is free software: you can redistribute it and/or -C modify it under the terms of the GNU General Public License as -C published by the Free Software Foundation, either version 2 of -C the License, or (at your option) any later version. -C -C This program is distributed in the hope that it will be useful, -C but WITHOUT ANY WARRANTY; without even the implied warranty of -C MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the -C GNU General Public License for more details. -C -C You should have received a copy of the GNU General Public License -C along with this program. If not, see -C . -C -C PURPOSE -C -C To compute a reduced order model (Ar,Br,Cr,Dr) for an original -C state-space representation (A,B,C,D) by using the frequency -C weighted optimal Hankel-norm approximation method. -C The Hankel norm of the weighted error -C -C op(V)*(G-Gr)*op(W) -C -C is minimized, where G and Gr are the transfer-function matrices -C of the original and reduced systems, respectively, V and W are -C invertible transfer-function matrices representing the left and -C right frequency weights, and op(X) denotes X, inv(X), conj(X) or -C conj(inv(X)). V and W are specified by their state space -C realizations (AV,BV,CV,DV) and (AW,BW,CW,DW), respectively. -C When minimizing ||V*(G-Gr)*W||, V and W must be antistable. -C When minimizing inv(V)*(G-Gr)*inv(W), V and W must have only -C antistable zeros. -C When minimizing conj(V)*(G-Gr)*conj(W), V and W must be stable. -C When minimizing conj(inv(V))*(G-Gr)*conj(inv(W)), V and W must -C be minimum-phase. -C If the original system is unstable, then the frequency weighted -C Hankel-norm approximation is computed only for the -C ALPHA-stable part of the system. -C -C For a transfer-function matrix G, conj(G) denotes the conjugate -C of G given by G'(-s) for a continuous-time system or G'(1/z) -C for a discrete-time system. -C -C ARGUMENTS -C -C Mode Parameters -C -C JOBV CHARACTER*1 -C Specifies the left frequency-weighting as follows: -C = 'N': V = I; -C = 'V': op(V) = V; -C = 'I': op(V) = inv(V); -C = 'C': op(V) = conj(V); -C = 'R': op(V) = conj(inv(V)). -C -C JOBW CHARACTER*1 -C Specifies the right frequency-weighting as follows: -C = 'N': W = I; -C = 'W': op(W) = W; -C = 'I': op(W) = inv(W); -C = 'C': op(W) = conj(W); -C = 'R': op(W) = conj(inv(W)). -C -C JOBINV CHARACTER*1 -C Specifies the computational approach to be used as -C follows: -C = 'N': use the inverse free descriptor system approach; -C = 'I': use the inversion based standard approach; -C = 'A': switch automatically to the inverse free -C descriptor approach in case of badly conditioned -C feedthrough matrices in V or W (see METHOD). -C -C DICO CHARACTER*1 -C Specifies the type of the original system as follows: -C = 'C': continuous-time system; -C = 'D': discrete-time system. -C -C EQUIL CHARACTER*1 -C Specifies whether the user wishes to preliminarily -C equilibrate the triplet (A,B,C) as follows: -C = 'S': perform equilibration (scaling); -C = 'N': do not perform equilibration. -C -C ORDSEL CHARACTER*1 -C Specifies the order selection method as follows: -C = 'F': the resulting order NR is fixed; -C = 'A': the resulting order NR is automatically determined -C on basis of the given tolerance TOL1. -C -C Input/Output Parameters -C -C N (input) INTEGER -C The order of the original state-space representation, -C i.e., the order of the matrix A. N >= 0. -C -C NV (input) INTEGER -C The order of the realization of the left frequency -C weighting V, i.e., the order of the matrix AV. NV >= 0. -C -C NW (input) INTEGER -C The order of the realization of the right frequency -C weighting W, i.e., the order of the matrix AW. NW >= 0. -C -C M (input) INTEGER -C The number of system inputs. M >= 0. -C -C P (input) INTEGER -C The number of system outputs. P >= 0. -C -C NR (input/output) INTEGER -C On entry with ORDSEL = 'F', NR is the desired order of -C the resulting reduced order system. 0 <= NR <= N. -C On exit, if INFO = 0, NR is the order of the resulting -C reduced order model. For a system with NU ALPHA-unstable -C eigenvalues and NS ALPHA-stable eigenvalues (NU+NS = N), -C NR is set as follows: if ORDSEL = 'F', NR is equal to -C NU+MIN(MAX(0,NR-NU-KR+1),NMIN), where KR is the -C multiplicity of the Hankel singular value HSV(NR-NU+1), -C NR is the desired order on entry, and NMIN is the order -C of a minimal realization of the ALPHA-stable part of the -C given system; NMIN is determined as the number of Hankel -C singular values greater than NS*EPS*HNORM(As,Bs,Cs), where -C EPS is the machine precision (see LAPACK Library Routine -C DLAMCH) and HNORM(As,Bs,Cs) is the Hankel norm of the -C ALPHA-stable part of the weighted system (computed in -C HSV(1)); -C if ORDSEL = 'A', NR is the sum of NU and the number of -C Hankel singular values greater than -C MAX(TOL1,NS*EPS*HNORM(As,Bs,Cs)). -C -C ALPHA (input) DOUBLE PRECISION -C Specifies the ALPHA-stability boundary for the eigenvalues -C of the state dynamics matrix A. For a continuous-time -C system (DICO = 'C'), ALPHA <= 0 is the boundary value for -C the real parts of eigenvalues, while for a discrete-time -C system (DICO = 'D'), 0 <= ALPHA <= 1 represents the -C boundary value for the moduli of eigenvalues. -C The ALPHA-stability domain does not include the boundary. -C -C A (input/output) DOUBLE PRECISION array, dimension (LDA,N) -C On entry, the leading N-by-N part of this array must -C contain the state dynamics matrix A. -C On exit, if INFO = 0, the leading NR-by-NR part of this -C array contains the state dynamics matrix Ar of the -C reduced order system in a real Schur form. -C The resulting A has a block-diagonal form with two blocks. -C For a system with NU ALPHA-unstable eigenvalues and -C NS ALPHA-stable eigenvalues (NU+NS = N), the leading -C NU-by-NU block contains the unreduced part of A -C corresponding to ALPHA-unstable eigenvalues. -C The trailing (NR+NS-N)-by-(NR+NS-N) block contains -C the reduced part of A corresponding to ALPHA-stable -C eigenvalues. -C -C LDA INTEGER -C The leading dimension of array A. LDA >= MAX(1,N). -C -C B (input/output) DOUBLE PRECISION array, dimension (LDB,M) -C On entry, the leading N-by-M part of this array must -C contain the original input/state matrix B. -C On exit, if INFO = 0, the leading NR-by-M part of this -C array contains the input/state matrix Br of the reduced -C order system. -C -C LDB INTEGER -C The leading dimension of array B. LDB >= MAX(1,N). -C -C C (input/output) DOUBLE PRECISION array, dimension (LDC,N) -C On entry, the leading P-by-N part of this array must -C contain the original state/output matrix C. -C On exit, if INFO = 0, the leading P-by-NR part of this -C array contains the state/output matrix Cr of the reduced -C order system. -C -C LDC INTEGER -C The leading dimension of array C. LDC >= MAX(1,P). -C -C D (input/output) DOUBLE PRECISION array, dimension (LDD,M) -C On entry, the leading P-by-M part of this array must -C contain the original input/output matrix D. -C On exit, if INFO = 0, the leading P-by-M part of this -C array contains the input/output matrix Dr of the reduced -C order system. -C -C LDD INTEGER -C The leading dimension of array D. LDD >= MAX(1,P). -C -C AV (input/output) DOUBLE PRECISION array, dimension (LDAV,NV) -C On entry, if JOBV <> 'N', the leading NV-by-NV part of -C this array must contain the state matrix AV of a state -C space realization of the left frequency weighting V. -C On exit, if JOBV <> 'N', and INFO = 0, the leading -C NV-by-NV part of this array contains the real Schur form -C of AV. -C AV is not referenced if JOBV = 'N'. -C -C LDAV INTEGER -C The leading dimension of the array AV. -C LDAV >= MAX(1,NV), if JOBV <> 'N'; -C LDAV >= 1, if JOBV = 'N'. -C -C BV (input/output) DOUBLE PRECISION array, dimension (LDBV,P) -C On entry, if JOBV <> 'N', the leading NV-by-P part of -C this array must contain the input matrix BV of a state -C space realization of the left frequency weighting V. -C On exit, if JOBV <> 'N', and INFO = 0, the leading -C NV-by-P part of this array contains the transformed -C input matrix BV corresponding to the transformed AV. -C BV is not referenced if JOBV = 'N'. -C -C LDBV INTEGER -C The leading dimension of the array BV. -C LDBV >= MAX(1,NV), if JOBV <> 'N'; -C LDBV >= 1, if JOBV = 'N'. -C -C CV (input/output) DOUBLE PRECISION array, dimension (LDCV,NV) -C On entry, if JOBV <> 'N', the leading P-by-NV part of -C this array must contain the output matrix CV of a state -C space realization of the left frequency weighting V. -C On exit, if JOBV <> 'N', and INFO = 0, the leading -C P-by-NV part of this array contains the transformed output -C matrix CV corresponding to the transformed AV. -C CV is not referenced if JOBV = 'N'. -C -C LDCV INTEGER -C The leading dimension of the array CV. -C LDCV >= MAX(1,P), if JOBV <> 'N'; -C LDCV >= 1, if JOBV = 'N'. -C -C DV (input) DOUBLE PRECISION array, dimension (LDDV,P) -C If JOBV <> 'N', the leading P-by-P part of this array -C must contain the feedthrough matrix DV of a state space -C realization of the left frequency weighting V. -C DV is not referenced if JOBV = 'N'. -C -C LDDV INTEGER -C The leading dimension of the array DV. -C LDDV >= MAX(1,P), if JOBV <> 'N'; -C LDDV >= 1, if JOBV = 'N'. -C -C AW (input/output) DOUBLE PRECISION array, dimension (LDAW,NW) -C On entry, if JOBW <> 'N', the leading NW-by-NW part of -C this array must contain the state matrix AW of a state -C space realization of the right frequency weighting W. -C On exit, if JOBW <> 'N', and INFO = 0, the leading -C NW-by-NW part of this array contains the real Schur form -C of AW. -C AW is not referenced if JOBW = 'N'. -C -C LDAW INTEGER -C The leading dimension of the array AW. -C LDAW >= MAX(1,NW), if JOBW <> 'N'; -C LDAW >= 1, if JOBW = 'N'. -C -C BW (input/output) DOUBLE PRECISION array, dimension (LDBW,M) -C On entry, if JOBW <> 'N', the leading NW-by-M part of -C this array must contain the input matrix BW of a state -C space realization of the right frequency weighting W. -C On exit, if JOBW <> 'N', and INFO = 0, the leading -C NW-by-M part of this array contains the transformed -C input matrix BW corresponding to the transformed AW. -C BW is not referenced if JOBW = 'N'. -C -C LDBW INTEGER -C The leading dimension of the array BW. -C LDBW >= MAX(1,NW), if JOBW <> 'N'; -C LDBW >= 1, if JOBW = 'N'. -C -C CW (input/output) DOUBLE PRECISION array, dimension (LDCW,NW) -C On entry, if JOBW <> 'N', the leading M-by-NW part of -C this array must contain the output matrix CW of a state -C space realization of the right frequency weighting W. -C On exit, if JOBW <> 'N', and INFO = 0, the leading -C M-by-NW part of this array contains the transformed output -C matrix CW corresponding to the transformed AW. -C CW is not referenced if JOBW = 'N'. -C -C LDCW INTEGER -C The leading dimension of the array CW. -C LDCW >= MAX(1,M), if JOBW <> 'N'; -C LDCW >= 1, if JOBW = 'N'. -C -C DW (input) DOUBLE PRECISION array, dimension (LDDW,M) -C If JOBW <> 'N', the leading M-by-M part of this array -C must contain the feedthrough matrix DW of a state space -C realization of the right frequency weighting W. -C DW is not referenced if JOBW = 'N'. -C -C LDDW INTEGER -C The leading dimension of the array DW. -C LDDW >= MAX(1,M), if JOBW <> 'N'; -C LDDW >= 1, if JOBW = 'N'. -C -C NS (output) INTEGER -C The dimension of the ALPHA-stable subsystem. -C -C HSV (output) DOUBLE PRECISION array, dimension (N) -C If INFO = 0, the leading NS elements of this array contain -C the Hankel singular values, ordered decreasingly, of the -C projection G1s of op(V)*G1*op(W) (see METHOD), where G1 -C is the ALPHA-stable part of the original system. -C -C Tolerances -C -C TOL1 DOUBLE PRECISION -C If ORDSEL = 'A', TOL1 contains the tolerance for -C determining the order of reduced system. -C For model reduction, the recommended value is -C TOL1 = c*HNORM(G1s), where c is a constant in the -C interval [0.00001,0.001], and HNORM(G1s) is the -C Hankel-norm of the projection G1s of op(V)*G1*op(W) -C (see METHOD), computed in HSV(1). -C If TOL1 <= 0 on entry, the used default value is -C TOL1 = NS*EPS*HNORM(G1s), where NS is the number of -C ALPHA-stable eigenvalues of A and EPS is the machine -C precision (see LAPACK Library Routine DLAMCH). -C If ORDSEL = 'F', the value of TOL1 is ignored. -C TOL1 < 1. -C -C TOL2 DOUBLE PRECISION -C The tolerance for determining the order of a minimal -C realization of the ALPHA-stable part of the given system. -C The recommended value is TOL2 = NS*EPS*HNORM(G1s). -C This value is used by default if TOL2 <= 0 on entry. -C If TOL2 > 0 and ORDSEL = 'A', then TOL2 <= TOL1. -C TOL2 < 1. -C -C Workspace -C -C IWORK INTEGER array, dimension (LIWORK) -C LIWORK = MAX(1,M,c,d), if DICO = 'C', -C LIWORK = MAX(1,N,M,c,d), if DICO = 'D', where -C c = 0, if JOBV = 'N', -C c = MAX(2*P,NV+P+N+6,2*NV+P+2), if JOBV <> 'N', -C d = 0, if JOBW = 'N', -C d = MAX(2*M,NW+M+N+6,2*NW+M+2), if JOBW <> 'N'. -C -C DWORK DOUBLE PRECISION array, dimension (LDWORK) -C On exit, if INFO = 0, DWORK(1) returns the optimal value -C of LDWORK. -C -C LDWORK INTEGER -C The length of the array DWORK. -C LDWORK >= MAX( LDW1, LDW2, LDW3, LDW4 ), where -C for NVP = NV+P and NWM = NW+M we have -C LDW1 = 0 if JOBV = 'N' and -C LDW1 = 2*NVP*(NVP+P) + P*P + -C MAX( 2*NVP*NVP + MAX( 11*NVP+16, P*NVP ), -C NVP*N + MAX( NVP*N+N*N, P*N, P*M ) ) -C if JOBV <> 'N', -C LDW2 = 0 if JOBW = 'N' and -C LDW2 = 2*NWM*(NWM+M) + M*M + -C MAX( 2*NWM*NWM + MAX( 11*NWM+16, M*NWM ), -C NWM*N + MAX( NWM*N+N*N, M*N, P*M ) ) -C if JOBW <> 'N', -C LDW3 = N*(2*N + MAX(N,M,P) + 5) + N*(N+1)/2, -C LDW4 = N*(M+P+2) + 2*M*P + MIN(N,M) + -C MAX( 3*M+1, MIN(N,M)+P ). -C For optimum performance LDWORK should be larger. -C -C Warning Indicator -C -C IWARN INTEGER -C = 0: no warning; -C = 1: with ORDSEL = 'F', the selected order NR is greater -C than NSMIN, the sum of the order of the -C ALPHA-unstable part and the order of a minimal -C realization of the ALPHA-stable part of the given -C system. In this case, the resulting NR is set equal -C to NSMIN. -C = 2: with ORDSEL = 'F', the selected order NR is less -C than the order of the ALPHA-unstable part of the -C given system. In this case NR is set equal to the -C order of the ALPHA-unstable part. -C -C Error Indicator -C -C INFO INTEGER -C = 0: successful exit; -C < 0: if INFO = -i, the i-th argument had an illegal -C value; -C = 1: the computation of the ordered real Schur form of A -C failed; -C = 2: the separation of the ALPHA-stable/unstable -C diagonal blocks failed because of very close -C eigenvalues; -C = 3: the reduction of AV to a real Schur form failed; -C = 4: the reduction of AW to a real Schur form failed; -C = 5: the reduction to generalized Schur form of the -C descriptor pair corresponding to the inverse of V -C failed; -C = 6: the reduction to generalized Schur form of the -C descriptor pair corresponding to the inverse of W -C failed; -C = 7: the computation of Hankel singular values failed; -C = 8: the computation of stable projection in the -C Hankel-norm approximation algorithm failed; -C = 9: the order of computed stable projection in the -C Hankel-norm approximation algorithm differs -C from the order of Hankel-norm approximation; -C = 10: the reduction of AV-BV*inv(DV)*CV to a -C real Schur form failed; -C = 11: the reduction of AW-BW*inv(DW)*CW to a -C real Schur form failed; -C = 12: the solution of the Sylvester equation failed -C because the poles of V (if JOBV = 'V') or of -C conj(V) (if JOBV = 'C') are not distinct from -C the poles of G1 (see METHOD); -C = 13: the solution of the Sylvester equation failed -C because the poles of W (if JOBW = 'W') or of -C conj(W) (if JOBW = 'C') are not distinct from -C the poles of G1 (see METHOD); -C = 14: the solution of the Sylvester equation failed -C because the zeros of V (if JOBV = 'I') or of -C conj(V) (if JOBV = 'R') are not distinct from -C the poles of G1sr (see METHOD); -C = 15: the solution of the Sylvester equation failed -C because the zeros of W (if JOBW = 'I') or of -C conj(W) (if JOBW = 'R') are not distinct from -C the poles of G1sr (see METHOD); -C = 16: the solution of the generalized Sylvester system -C failed because the zeros of V (if JOBV = 'I') or -C of conj(V) (if JOBV = 'R') are not distinct from -C the poles of G1sr (see METHOD); -C = 17: the solution of the generalized Sylvester system -C failed because the zeros of W (if JOBW = 'I') or -C of conj(W) (if JOBW = 'R') are not distinct from -C the poles of G1sr (see METHOD); -C = 18: op(V) is not antistable; -C = 19: op(W) is not antistable; -C = 20: V is not invertible; -C = 21: W is not invertible. -C -C METHOD -C -C Let G be the transfer-function matrix of the original -C linear system -C -C d[x(t)] = Ax(t) + Bu(t) -C y(t) = Cx(t) + Du(t), (1) -C -C where d[x(t)] is dx(t)/dt for a continuous-time system and x(t+1) -C for a discrete-time system. The subroutine AB09JD determines -C the matrices of a reduced order system -C -C d[z(t)] = Ar*z(t) + Br*u(t) -C yr(t) = Cr*z(t) + Dr*u(t), (2) -C -C such that the corresponding transfer-function matrix Gr minimizes -C the Hankel-norm of the frequency-weighted error -C -C op(V)*(G-Gr)*op(W). (3) -C -C For minimizing (3) with op(V) = V and op(W) = W, V and W are -C assumed to have poles distinct from those of G, while with -C op(V) = conj(V) and op(W) = conj(W), conj(V) and conj(W) are -C assumed to have poles distinct from those of G. For minimizing (3) -C with op(V) = inv(V) and op(W) = inv(W), V and W are assumed to -C have zeros distinct from the poles of G, while with -C op(V) = conj(inv(V)) and op(W) = conj(inv(W)), conj(V) and conj(W) -C are assumed to have zeros distinct from the poles of G. -C -C Note: conj(G) = G'(-s) for a continuous-time system and -C conj(G) = G'(1/z) for a discrete-time system. -C -C The following procedure is used to reduce G (see [1]): -C -C 1) Decompose additively G as -C -C G = G1 + G2, -C -C such that G1 = (A1,B1,C1,D) has only ALPHA-stable poles and -C G2 = (A2,B2,C2,0) has only ALPHA-unstable poles. -C -C 2) Compute G1s, the projection of op(V)*G1*op(W) containing the -C poles of G1, using explicit formulas [4] or the inverse-free -C descriptor system formulas of [5]. -C -C 3) Determine G1sr, the optimal Hankel-norm approximation of G1s, -C of order r. -C -C 4) Compute G1r, the projection of inv(op(V))*G1sr*inv(op(W)) -C containing the poles of G1sr, using explicit formulas [4] -C or the inverse-free descriptor system formulas of [5]. -C -C 5) Assemble the reduced model Gr as -C -C Gr = G1r + G2. -C -C To reduce the weighted ALPHA-stable part G1s at step 3, the -C optimal Hankel-norm approximation method of [2], based on the -C square-root balancing projection formulas of [3], is employed. -C -C The optimal weighted approximation error satisfies -C -C HNORM[op(V)*(G-Gr)*op(W)] >= S(r+1), -C -C where S(r+1) is the (r+1)-th Hankel singular value of G1s, the -C transfer-function matrix computed at step 2 of the above -C procedure, and HNORM(.) denotes the Hankel-norm. -C -C REFERENCES -C -C [1] Latham, G.A. and Anderson, B.D.O. -C Frequency-weighted optimal Hankel-norm approximation of stable -C transfer functions. -C Systems & Control Letters, Vol. 5, pp. 229-236, 1985. -C -C [2] Glover, K. -C All optimal Hankel norm approximation of linear -C multivariable systems and their L-infinity error bounds. -C Int. J. Control, Vol. 36, pp. 1145-1193, 1984. -C -C [3] Tombs, M.S. and Postlethwaite, I. -C Truncated balanced realization of stable, non-minimal -C state-space systems. -C Int. J. Control, Vol. 46, pp. 1319-1330, 1987. -C -C [4] Varga, A. -C Explicit formulas for an efficient implementation -C of the frequency-weighting model reduction approach. -C Proc. 1993 European Control Conference, Groningen, NL, -C pp. 693-696, 1993. -C -C [5] Varga, A. -C Efficient and numerically reliable implementation of the -C frequency-weighted Hankel-norm approximation model reduction -C approach. -C Proc. 2001 ECC, Porto, Portugal, 2001. -C -C NUMERICAL ASPECTS -C -C The implemented methods rely on an accuracy enhancing square-root -C technique. -C -C CONTRIBUTORS -C -C A. Varga, German Aerospace Center, Oberpfaffenhofen, March 2001. -C D. Sima, University of Bucharest, April 2001. -C V. Sima, Research Institute for Informatics, Bucharest, Apr. 2001. -C -C REVISIONS -C -C A. Varga, German Aerospace Center, Oberpfaffenhofen, May 2001. -C V. Sima, Research Institute for Informatics, Bucharest, June 2001, -C March 2005. -C -C KEYWORDS -C -C Frequency weighting, model reduction, multivariable system, -C state-space model, state-space representation. -C -C ****************************************************************** -C -C .. Parameters .. - DOUBLE PRECISION C100, ONE, P0001, ZERO - PARAMETER ( C100 = 100.0D0, ONE = 1.0D0, P0001 = 0.0001D0, - $ ZERO = 0.0D0 ) -C .. Scalar Arguments .. - CHARACTER DICO, EQUIL, JOBINV, JOBV, JOBW, ORDSEL - INTEGER INFO, IWARN, LDA, LDAV, LDAW, LDB, LDBV, LDBW, - $ LDC, LDCV, LDCW, LDD, LDDV, LDDW, LDWORK, M, N, - $ NR, NS, NV, NW, P - DOUBLE PRECISION ALPHA, TOL1, TOL2 -C .. Array Arguments .. - INTEGER IWORK(*) - DOUBLE PRECISION A(LDA,*), AV(LDAV,*), AW(LDAW,*), - $ B(LDB,*), BV(LDBV,*), BW(LDBW,*), - $ C(LDC,*), CV(LDCV,*), CW(LDCW,*), - $ D(LDD,*), DV(LDDV,*), DW(LDDW,*), DWORK(*), - $ HSV(*) -C .. Local Scalars .. - CHARACTER JOBVL, JOBWL - LOGICAL AUTOM, CONJV, CONJW, DISCR, FIXORD, FRWGHT, - $ INVFR, LEFTI, LEFTW, RIGHTI, RIGHTW - INTEGER IERR, IWARNL, KAV, KAW, KBV, KBW, KCV, KCW, KDV, - $ KDW, KEV, KEW, KI, KL, KU, KW, LDABV, LDABW, - $ LDCDV, LDCDW, LW, NRA, NU, NU1, NVP, NWM, RANK - DOUBLE PRECISION ALPWRK, MAXRED, RCOND, SQREPS, TOL, WRKOPT -C .. Local Arrays .. - DOUBLE PRECISION TEMP(1) -C .. External Functions .. - LOGICAL LSAME - DOUBLE PRECISION DLAMCH - EXTERNAL DLAMCH, LSAME -C .. External Subroutines .. - EXTERNAL AB07ND, AB08MD, AB09CX, AB09JV, AB09JW, AG07BD, - $ DLACPY, TB01ID, TB01KD, XERBLA -C .. Intrinsic Functions .. - INTRINSIC DBLE, MAX, MIN, SQRT -C .. Executable Statements .. -C - INFO = 0 - IWARN = 0 - DISCR = LSAME( DICO, 'D' ) - FIXORD = LSAME( ORDSEL, 'F' ) - LEFTI = LSAME( JOBV, 'I' ) .OR. LSAME( JOBV, 'R' ) - LEFTW = LSAME( JOBV, 'V' ) .OR. LSAME( JOBV, 'C' ) .OR. LEFTI - CONJV = LSAME( JOBV, 'C' ) .OR. LSAME( JOBV, 'R' ) - RIGHTI = LSAME( JOBW, 'I' ) .OR. LSAME( JOBW, 'R' ) - RIGHTW = LSAME( JOBW, 'W' ) .OR. LSAME( JOBW, 'C' ) .OR. RIGHTI - CONJW = LSAME( JOBW, 'C' ) .OR. LSAME( JOBW, 'R' ) - FRWGHT = LEFTW .OR. RIGHTW - INVFR = LSAME( JOBINV, 'N' ) - AUTOM = LSAME( JOBINV, 'A' ) -C - LW = 1 - IF( LEFTW ) THEN - NVP = NV + P - LW = MAX( LW, 2*NVP*( NVP + P ) + P*P + - $ MAX( 2*NVP*NVP + MAX( 11*NVP + 16, P*NVP ), - $ NVP*N + MAX( NVP*N+N*N, P*N, P*M ) ) ) - END IF - IF( RIGHTW ) THEN - NWM = NW + M - LW = MAX( LW, 2*NWM*( NWM + M ) + M*M + - $ MAX( 2*NWM*NWM + MAX( 11*NWM + 16, M*NWM ), - $ NWM*N + MAX( NWM*N+N*N, M*N, P*M ) ) ) - END IF - LW = MAX( LW, N*( 2*N + MAX( N, M, P ) + 5 ) + ( N*( N + 1 ) )/2 ) - LW = MAX( LW, N*( M + P + 2 ) + 2*M*P + MIN( N, M ) + - $ MAX ( 3*M + 1, MIN( N, M ) + P ) ) -C -C Check the input scalar arguments. -C - IF( .NOT. ( LSAME( JOBV, 'N' ) .OR. LEFTW ) ) THEN - INFO = -1 - ELSE IF( .NOT. ( LSAME( JOBW, 'N' ) .OR. RIGHTW ) ) THEN - INFO = -2 - ELSE IF( .NOT. ( INVFR .OR. AUTOM .OR. LSAME( JOBINV, 'I' ) ) ) - $ THEN - INFO = -3 - ELSE IF( .NOT. ( LSAME( DICO, 'C' ) .OR. DISCR ) ) THEN - INFO = -4 - ELSE IF( .NOT. ( LSAME( EQUIL, 'S' ) .OR. - $ LSAME( EQUIL, 'N' ) ) ) THEN - INFO = -5 - ELSE IF( .NOT. ( FIXORD .OR. LSAME( ORDSEL, 'A' ) ) ) THEN - INFO = -6 - ELSE IF( N.LT.0 ) THEN - INFO = -7 - ELSE IF( NV.LT.0 ) THEN - INFO = -8 - ELSE IF( NW.LT.0 ) THEN - INFO = -9 - ELSE IF( M.LT.0 ) THEN - INFO = -10 - ELSE IF( P.LT.0 ) THEN - INFO = -11 - ELSE IF( FIXORD .AND. ( NR.LT.0 .OR. NR.GT.N ) ) THEN - INFO = -12 - ELSE IF( ( DISCR .AND. ( ALPHA.LT.ZERO .OR. ALPHA.GT.ONE ) ) .OR. - $ ( .NOT.DISCR .AND. ALPHA.GT.ZERO ) ) THEN - INFO = -13 - ELSE IF( LDA.LT.MAX( 1, N ) ) THEN - INFO = -15 - ELSE IF( LDB.LT.MAX( 1, N ) ) THEN - INFO = -17 - ELSE IF( LDC.LT.MAX( 1, P ) ) THEN - INFO = -19 - ELSE IF( LDD.LT.MAX( 1, P ) ) THEN - INFO = -21 - ELSE IF( LDAV.LT.1 .OR. ( LEFTW .AND. LDAV.LT.NV ) ) THEN - INFO = -23 - ELSE IF( LDBV.LT.1 .OR. ( LEFTW .AND. LDBV.LT.NV ) ) THEN - INFO = -25 - ELSE IF( LDCV.LT.1 .OR. ( LEFTW .AND. LDCV.LT.P ) ) THEN - INFO = -27 - ELSE IF( LDDV.LT.1 .OR. ( LEFTW .AND. LDDV.LT.P ) ) THEN - INFO = -29 - ELSE IF( LDAW.LT.1 .OR. ( RIGHTW .AND. LDAW.LT.NW ) ) THEN - INFO = -31 - ELSE IF( LDBW.LT.1 .OR. ( RIGHTW .AND. LDBW.LT.NW ) ) THEN - INFO = -33 - ELSE IF( LDCW.LT.1 .OR. ( RIGHTW .AND. LDCW.LT.M ) ) THEN - INFO = -35 - ELSE IF( LDDW.LT.1 .OR. ( RIGHTW .AND. LDDW.LT.M ) ) THEN - INFO = -37 - ELSE IF( TOL1.GE.ONE ) THEN - INFO = -40 - ELSE IF( ( TOL2.GT.ZERO .AND. .NOT.FIXORD .AND. TOL2.GT.TOL1 ) - $ .OR. TOL2.GE.ONE ) THEN - INFO = -41 - ELSE IF( LDWORK.LT.LW ) THEN - INFO = -44 - END IF -C - IF( INFO.NE.0 ) THEN -C -C Error return. -C - CALL XERBLA( 'AB09JD', -INFO ) - RETURN - END IF -C -C Quick return if possible. -C - IF( MIN( N, M, P ).EQ.0 ) THEN - NR = 0 - NS = 0 - DWORK(1) = ONE - RETURN - END IF -C - IF( LSAME( EQUIL, 'S' ) ) THEN -C -C Scale simultaneously the matrices A, B and C: -C A <- inv(D)*A*D, B <- inv(D)*B and C <- C*D, where D is a -C diagonal matrix. -C Workspace: N. -C - MAXRED = C100 - CALL TB01ID( 'All', N, M, P, MAXRED, A, LDA, B, LDB, C, LDC, - $ DWORK, INFO ) - END IF -C -C Correct the value of ALPHA to ensure stability. -C - ALPWRK = ALPHA - SQREPS = SQRT( DLAMCH( 'E' ) ) - IF( DISCR ) THEN - IF( ALPHA.EQ.ONE ) ALPWRK = ONE - SQREPS - ELSE - IF( ALPHA.EQ.ZERO ) ALPWRK = -SQREPS - END IF -C -C Allocate working storage. -C - KU = 1 - KL = KU + N*N - KI = KL + N - KW = KI + N -C -C Compute an additive decomposition G = G1 + G2, where G1 -C is the ALPHA-stable projection of G. -C -C Reduce A to a block-diagonal real Schur form, with the NU-th order -C ALPHA-unstable part in the leading diagonal position, using a -C non-orthogonal similarity transformation A <- inv(T)*A*T and -C apply the transformation to B and C: B <- inv(T)*B and C <- C*T. -C -C Workspace needed: N*(N+2); -C Additional workspace: need 3*N; -C prefer larger. -C - CALL TB01KD( DICO, 'Unstable', 'General', N, M, P, ALPWRK, A, LDA, - $ B, LDB, C, LDC, NU, DWORK(KU), N, DWORK(KL), - $ DWORK(KI), DWORK(KW), LDWORK-KW+1, IERR ) -C - IF( IERR.NE.0 ) THEN - IF( IERR.NE.3 ) THEN - INFO = 1 - ELSE - INFO = 2 - END IF - RETURN - END IF -C - WRKOPT = DWORK(KW) + DBLE( KW-1 ) - IWARNL = 0 -C - NS = N - NU - IF( FIXORD ) THEN - NRA = MAX( 0, NR-NU ) - IF( NR.LT.NU ) - $ IWARNL = 2 - ELSE - NRA = 0 - END IF -C -C Finish if only unstable part is present. -C - IF( NS.EQ.0 ) THEN - NR = NU - DWORK(1) = WRKOPT - RETURN - END IF -C - NU1 = NU + 1 - IF( CONJV ) THEN - JOBVL = 'C' - ELSE - JOBVL = 'V' - END IF - IF( CONJW ) THEN - JOBWL = 'C' - ELSE - JOBWL = 'W' - END IF - IF( LEFTW ) THEN -C -C Check if V is invertible. -C Real workspace: need (NV+P)**2 + MAX( P + MAX(3*P,NV), -C MIN(P+1,NV) + MAX(3*(P+1),NV+P) ); -C prefer larger. -C Integer workspace: need 2*NV+P+2. -C - TOL = ZERO - CALL AB08MD( 'S', NV, P, P, AV, LDAV, BV, LDBV, CV, LDCV, - $ DV, LDDV, RANK, TOL, IWORK, DWORK, LDWORK, - $ IERR ) - IF( RANK.NE.P ) THEN - INFO = 20 - RETURN - END IF - WRKOPT = MAX( WRKOPT, DWORK(1) ) -C - IF( LEFTI ) THEN - IF( INVFR ) THEN - IERR = 1 - ELSE -C -C Allocate storage for a standard inverse of V. -C Workspace: need NV*(NV+2*P) + P*P. -C - KAV = 1 - KBV = KAV + NV*NV - KCV = KBV + NV*P - KDV = KCV + P*NV - KW = KDV + P*P -C - LDABV = MAX( NV, 1 ) - LDCDV = P - CALL DLACPY( 'Full', NV, NV, AV, LDAV, - $ DWORK(KAV), LDABV ) - CALL DLACPY( 'Full', NV, P, BV, LDBV, - $ DWORK(KBV), LDABV ) - CALL DLACPY( 'Full', P, NV, CV, LDCV, - $ DWORK(KCV), LDCDV ) - CALL DLACPY( 'Full', P, P, DV, LDDV, - $ DWORK(KDV), LDCDV ) -C -C Compute the standard inverse of V. -C Additional real workspace: need MAX(1,4*P); -C prefer larger. -C Integer workspace: need 2*P. -C - CALL AB07ND( NV, P, DWORK(KAV), LDABV, DWORK(KBV), LDABV, - $ DWORK(KCV), LDCDV, DWORK(KDV), LDCDV, - $ RCOND, IWORK, DWORK(KW), LDWORK-KW+1, IERR ) - WRKOPT = MAX( WRKOPT, DWORK(KW) + DBLE( KW-1 ) ) -C -C Check if inversion is accurate. -C - IF( AUTOM ) THEN - IF( IERR.EQ.0 .AND. RCOND.LE.P0001 ) IERR = 1 - ELSE - IF( IERR.EQ.0 .AND. RCOND.LE.SQREPS ) IERR = 1 - END IF - IF( IERR.NE.0 .AND. NV.EQ.0 ) THEN - INFO = 20 - RETURN - END IF - END IF -C - IF( IERR.NE.0 ) THEN -C -C Allocate storage for a descriptor inverse of V. -C - KAV = 1 - KEV = KAV + NVP*NVP - KBV = KEV + NVP*NVP - KCV = KBV + NVP*P - KDV = KCV + P*NVP - KW = KDV + P*P -C - LDABV = MAX( NVP, 1 ) - LDCDV = P -C -C DV is singular or ill-conditioned. -C Form a descriptor inverse of V. -C Workspace: need 2*(NV+P)*(NV+2*P) + P*P. -C - CALL AG07BD( 'I', NV, P, AV, LDAV, TEMP, 1, BV, LDBV, - $ CV, LDCV, DV, LDDV, DWORK(KAV), LDABV, - $ DWORK(KEV), LDABV, DWORK(KBV), LDABV, - $ DWORK(KCV), LDCDV, DWORK(KDV), LDCDV, IERR ) -C -C Compute the projection containing the poles of weighted -C reduced ALPHA-stable part using descriptor inverse of V -C of order NVP = NV + P. -C Additional real workspace: need -C MAX( 2*NVP*NVP + MAX( 11*NVP+16, P*NVP ), -C NVP*N + MAX( NVP*N+N*N, P*N, P*M ) ); -C prefer larger. -C Integer workspace: need NVP+N+6. -C - CALL AB09JV( JOBVL, DICO, 'G', 'C', NS, M, P, NVP, P, - $ A(NU1,NU1), LDA, B(NU1,1), LDB, - $ C(1,NU1), LDC, D, LDD, - $ DWORK(KAV), LDABV, DWORK(KEV), LDABV, - $ DWORK(KBV), LDABV, DWORK(KCV), LDCDV, - $ DWORK(KDV), LDCDV, IWORK, DWORK(KW), - $ LDWORK-KW+1, IERR ) - IF( IERR.NE.0 ) THEN - IF( IERR.EQ.1 ) THEN - INFO = 5 - ELSE IF( IERR.EQ.2 ) THEN - INFO = 16 - ELSE IF( IERR.EQ.4 ) THEN - INFO = 18 - END IF - RETURN - END IF - ELSE -C -C Compute the projection containing the poles of weighted -C reduced ALPHA-stable part using explicit inverse of V. -C Additional real workspace: need -C MAX( NV*(NV+5), NV*N + MAX( a, P*N, P*M ) ) -C a = 0, if DICO = 'C' or JOBVL = 'V', -C a = 2*NV, if DICO = 'D' and JOBVL = 'C'; -C prefer larger. -C - CALL AB09JV( JOBVL, DICO, 'I', 'C', NS, M, P, NV, P, - $ A(NU1,NU1), LDA, B(NU1,1), LDB, - $ C(1,NU1), LDC, D, LDD, DWORK(KAV), LDABV, - $ TEMP, 1, DWORK(KBV), LDABV, - $ DWORK(KCV), LDCDV, DWORK(KDV), LDCDV, IWORK, - $ DWORK(KW), LDWORK-KW+1, IERR ) - IF( IERR.NE.0 ) THEN - IF( IERR.EQ.1 ) THEN - INFO = 10 - ELSE IF( IERR.EQ.3 ) THEN - INFO = 14 - ELSE IF( IERR.EQ.4 ) THEN - INFO = 18 - END IF - RETURN - END IF - END IF -C - WRKOPT = MAX( WRKOPT, DWORK(KW) + DBLE( KW - 1 ) ) - ELSE -C -C Compute the projection of V*G1 or conj(V)*G1 containing the -C poles of G. -C -C Workspace need: -C real MAX( 1, NV*(NV+5), NV*N + MAX( a, P*N, P*M ) ) -C a = 0, if DICO = 'C' or JOBVL = 'V', -C a = 2*NV, if DICO = 'D' and JOBVL = 'C'; -C prefer larger. -C - CALL AB09JV( JOBVL, DICO, 'I', 'C', NS, M, P, NV, P, - $ A(NU1,NU1), LDA, B(NU1,1), LDB, - $ C(1,NU1), LDC, D, LDD, AV, LDAV, - $ TEMP, 1, BV, LDBV, CV, LDCV, DV, LDDV, IWORK, - $ DWORK, LDWORK, IERR ) - IF( IERR.NE.0 ) THEN - IF( IERR.EQ.1 ) THEN - INFO = 3 - ELSE IF( IERR.EQ.3 ) THEN - INFO = 12 - ELSE IF( IERR.EQ.4 ) THEN - INFO = 18 - END IF - RETURN - END IF -C - WRKOPT = MAX( WRKOPT, DWORK(1) ) - END IF - END IF -C - IF( RIGHTW ) THEN -C -C Check if W is invertible. -C Real workspace: need (NW+M)**2 + MAX( M + MAX(3*M,NW), -C MIN(M+1,NW) + MAX(3*(M+1),NW+M) ); -C prefer larger. -C Integer workspace: need 2*NW+M+2. -C - TOL = ZERO - CALL AB08MD( 'S', NW, M, M, AW, LDAW, BW, LDBW, CW, LDCW, - $ DW, LDDW, RANK, TOL, IWORK, DWORK, LDWORK, - $ IERR ) - IF( RANK.NE.M ) THEN - INFO = 21 - RETURN - END IF - WRKOPT = MAX( WRKOPT, DWORK(1) ) -C - IF( RIGHTI ) THEN - IF( INVFR ) THEN - IERR = 1 - ELSE -C -C Allocate storage for a standard inverse of W. -C Workspace: need NW*(NW+2*M) + M*M. -C - KAW = 1 - KBW = KAW + NW*NW - KCW = KBW + NW*M - KDW = KCW + M*NW - KW = KDW + M*M -C - LDABW = MAX( NW, 1 ) - LDCDW = M - CALL DLACPY( 'Full', NW, NW, AW, LDAW, - $ DWORK(KAW), LDABW ) - CALL DLACPY( 'Full', NW, M, BW, LDBW, - $ DWORK(KBW), LDABW ) - CALL DLACPY( 'Full', M, NW, CW, LDCW, - $ DWORK(KCW), LDCDW ) - CALL DLACPY( 'Full', M, M, DW, LDDW, - $ DWORK(KDW), LDCDW ) -C -C Compute the standard inverse of W. -C Additional real workspace: need MAX(1,4*M); -C prefer larger. -C Integer workspace: need 2*M. -C - CALL AB07ND( NW, M, DWORK(KAW), LDABW, DWORK(KBW), LDABW, - $ DWORK(KCW), LDCDW, DWORK(KDW), LDCDW, - $ RCOND, IWORK, DWORK(KW), LDWORK-KW+1, IERR ) - WRKOPT = MAX( WRKOPT, DWORK(KW) + DBLE( KW-1 ) ) -C -C Check if inversion is accurate. -C - IF( AUTOM ) THEN - IF( IERR.EQ.0 .AND. RCOND.LE.P0001 ) IERR = 1 - ELSE - IF( IERR.EQ.0 .AND. RCOND.LE.SQREPS ) IERR = 1 - END IF - IF( IERR.NE.0 .AND. NW.EQ.0 ) THEN - INFO = 21 - RETURN - END IF - END IF -C - IF( IERR.NE.0 ) THEN -C -C Allocate storage for a descriptor inverse of W. -C - KAW = 1 - KEW = KAW + NWM*NWM - KBW = KEW + NWM*NWM - KCW = KBW + NWM*M - KDW = KCW + M*NWM - KW = KDW + M*M -C - LDABW = MAX( NWM, 1 ) - LDCDW = M -C -C DW is singular or ill-conditioned. -C Form the descriptor inverse of W. -C Workspace: need 2*(NW+M)*(NW+2*M) + M*M. -C - CALL AG07BD( 'I', NW, M, AW, LDAW, TEMP, 1, BW, LDBW, - $ CW, LDCW, DW, LDDW, DWORK(KAW), LDABW, - $ DWORK(KEW), LDABW, DWORK(KBW), LDABW, - $ DWORK(KCW), LDCDW, DWORK(KDW), LDCDW, IERR ) -C -C Compute the projection containing the poles of weighted -C reduced ALPHA-stable part using descriptor inverse of W -C of order NWM = NW + M. -C Additional real workspace: need -C MAX( 2*NWM*NWM + MAX( 11*NWM+16, M*NWM ), -C NWM*N + MAX( NWM*N+N*N, M*N, P*M ) ); -C prefer larger. -C Integer workspace: need NWM+N+6. -C - CALL AB09JW( JOBWL, DICO, 'G', 'C', NS, M, P, NWM, M, - $ A(NU1,NU1), LDA, B(NU1,1), LDB, - $ C(1,NU1), LDC, D, LDD, DWORK(KAW), LDABW, - $ DWORK(KEW), LDABW, DWORK(KBW), LDABW, - $ DWORK(KCW), LDCDW, DWORK(KDW), LDCDW, - $ IWORK, DWORK(KW), LDWORK-KW+1, IERR ) - IF( IERR.NE.0 ) THEN - IF( IERR.EQ.1 ) THEN - INFO = 6 - ELSE IF( IERR.EQ.2 ) THEN - INFO = 17 - ELSE IF( IERR.EQ.4 ) THEN - INFO = 19 - END IF - RETURN - END IF - ELSE -C -C Compute the projection containing the poles of weighted -C reduced ALPHA-stable part using explicit inverse of W. -C Additional real workspace: need -C MAX( NW*(NW+5), NW*N + MAX( a, M*N, P*M ) ) -C a = 0, if DICO = 'C' or JOBWL = 'W', -C a = 2*NW, if DICO = 'D' and JOBWL = 'C'; -C prefer larger. -C - CALL AB09JW( JOBWL, DICO, 'I', 'C', NS, M, P, NW, M, - $ A(NU1,NU1), LDA, B(NU1,1), LDB, - $ C(1,NU1), LDC, D, LDD, DWORK(KAW), LDABW, - $ TEMP, 1, DWORK(KBW), LDABW, - $ DWORK(KCW), LDCDW, DWORK(KDW), LDCDW, - $ IWORK, DWORK(KW), LDWORK-KW+1, IERR ) - IF( IERR.NE.0 ) THEN - IF( IERR.EQ.1 ) THEN - INFO = 11 - ELSE IF( IERR.EQ.3 ) THEN - INFO = 15 - ELSE IF( IERR.EQ.4 ) THEN - INFO = 19 - END IF - RETURN - END IF - END IF -C - WRKOPT = MAX( WRKOPT, DWORK(KW) + DBLE( KW - 1 ) ) - ELSE -C -C Compute the projection G1s of V*G1*W or conj(V)*G1*conj(W) -C containing the poles of G. -C -C Workspace need: -C real MAX( 1, NW*(NW+5), NW*N + MAX( b, M*N, P*M ) ) -C b = 0, if DICO = 'C' or JOBWL = 'W', -C b = 2*NW, if DICO = 'D' and JOBWL = 'C'; -C prefer larger. -C - CALL AB09JW( JOBWL, DICO, 'I', 'C', NS, M, P, NW, M, - $ A(NU1,NU1), LDA, B(NU1,1), LDB, C(1,NU1), LDC, - $ D, LDD, AW, LDAW, TEMP, 1, BW, LDBW, CW, LDCW, - $ DW, LDDW, IWORK, DWORK, LDWORK, IERR ) - IF( IERR.NE.0 ) THEN - IF( IERR.EQ.1 ) THEN - INFO = 4 - ELSE IF( IERR.EQ.3 ) THEN - INFO = 13 - ELSE IF( IERR.EQ.4 ) THEN - INFO = 19 - END IF - RETURN - END IF -C - WRKOPT = MAX( WRKOPT, DWORK(1) ) - END IF - END IF -C -C Determine a reduced order approximation G1sr of G1s using the -C Hankel-norm approximation method. The resulting A(NU1:N,NU1:N) -C is further in a real Schur form. -C -C Workspace: need MAX( LDW3, LDW4 ), -C LDW3 = N*(2*N + MAX(N,M,P) + 5) + N*(N+1)/2, -C LDW4 = N*(M+P+2) + 2*M*P + MIN(N,M) + -C MAX( 3*M+1, MIN(N,M)+P ); -C prefer larger. -C - CALL AB09CX( DICO, ORDSEL, NS, M, P, NRA, A(NU1,NU1), LDA, - $ B(NU1,1), LDB, C(1,NU1), LDC, D, LDD, HSV, TOL1, - $ TOL2, IWORK, DWORK, LDWORK, IWARN, IERR ) -C - IF( IERR.NE.0 ) THEN -C -C Set INFO = 7, 8 or 9. -C - INFO = IERR + 5 - RETURN - END IF -C - IWARN = MAX( IWARNL, IWARN ) - WRKOPT = MAX( WRKOPT, DWORK(1) ) -C - IF( LEFTW ) THEN - IF( .NOT.LEFTI ) THEN - IF( INVFR ) THEN - IERR = 1 - ELSE -C -C Allocate storage for a standard inverse of V. -C Workspace: need NV*(NV+2*P) + P*P. -C - KAV = 1 - KBV = KAV + NV*NV - KCV = KBV + NV*P - KDV = KCV + P*NV - KW = KDV + P*P -C - LDABV = MAX( NV, 1 ) - LDCDV = P - CALL DLACPY( 'Full', NV, NV, AV, LDAV, - $ DWORK(KAV), LDABV ) - CALL DLACPY( 'Full', NV, P, BV, LDBV, - $ DWORK(KBV), LDABV ) - CALL DLACPY( 'Full', P, NV, CV, LDCV, - $ DWORK(KCV), LDCDV ) - CALL DLACPY( 'Full', P, P, DV, LDDV, - $ DWORK(KDV), LDCDV ) -C -C Compute the standard inverse of V. -C Additional real workspace: need MAX(1,4*P); -C prefer larger. -C Integer workspace: need 2*P. -C - CALL AB07ND( NV, P, DWORK(KAV), LDABV, DWORK(KBV), LDABV, - $ DWORK(KCV), LDCDV, DWORK(KDV), LDCDV, - $ RCOND, IWORK, DWORK(KW), LDWORK-KW+1, IERR ) - WRKOPT = MAX( WRKOPT, DWORK(KW) + DBLE( KW-1 ) ) -C -C Check if inversion is accurate. -C - IF( AUTOM ) THEN - IF( IERR.EQ.0 .AND. RCOND.LE.P0001 ) IERR = 1 - ELSE - IF( IERR.EQ.0 .AND. RCOND.LE.SQREPS ) IERR = 1 - END IF - IF( IERR.NE.0 .AND. NV.EQ.0 ) THEN - INFO = 20 - RETURN - END IF - END IF -C - IF( IERR.NE.0 ) THEN -C -C Allocate storage for a descriptor inverse of V. -C - KAV = 1 - KEV = KAV + NVP*NVP - KBV = KEV + NVP*NVP - KCV = KBV + NVP*P - KDV = KCV + P*NVP - KW = KDV + P*P -C - LDABV = MAX( NVP, 1 ) - LDCDV = P -C -C DV is singular or ill-conditioned. -C Form a descriptor inverse of V. -C Workspace: need 2*(NV+P)*(NV+2*P) + P*P. -C - CALL AG07BD( 'I', NV, P, AV, LDAV, TEMP, 1, BV, LDBV, - $ CV, LDCV, DV, LDDV, DWORK(KAV), LDABV, - $ DWORK(KEV), LDABV, DWORK(KBV), LDABV, - $ DWORK(KCV), LDCDV, DWORK(KDV), LDCDV, IERR ) -C -C Compute the projection containing the poles of weighted -C reduced ALPHA-stable part using descriptor inverse of V -C of order NVP = NV + P. -C Additional real workspace: need -C MAX( 2*NVP*NVP + MAX( 11*NVP+16, P*NVP ), -C NVP*N + MAX( NVP*N+N*N, P*N, P*M ) ); -C prefer larger. -C Integer workspace: need NVP+N+6. -C - CALL AB09JV( JOBVL, DICO, 'G', 'N', NRA, M, P, NVP, P, - $ A(NU1,NU1), LDA, B(NU1,1), LDB, - $ C(1,NU1), LDC, D, LDD, - $ DWORK(KAV), LDABV, DWORK(KEV), LDABV, - $ DWORK(KBV), LDABV, DWORK(KCV), LDCDV, - $ DWORK(KDV), LDCDV, IWORK, DWORK(KW), - $ LDWORK-KW+1, IERR ) - IF( IERR.NE.0 ) THEN - IF( IERR.EQ.1 ) THEN - INFO = 5 - ELSE IF( IERR.EQ.2 ) THEN - INFO = 16 - END IF - RETURN - END IF - ELSE -C -C Compute the projection containing the poles of weighted -C reduced ALPHA-stable part using explicit inverse of V. -C Additional real workspace: need -C MAX( NV*(NV+5), NV*N + MAX( a, P*N, P*M ) ) -C a = 0, if DICO = 'C' or JOBVL = 'V', -C a = 2*NV, if DICO = 'D' and JOBVL = 'C'; -C prefer larger. -C - CALL AB09JV( JOBVL, DICO, 'I', 'N', NRA, M, P, NV, P, - $ A(NU1,NU1), LDA, B(NU1,1), LDB, - $ C(1,NU1), LDC, D, LDD, DWORK(KAV), LDABV, - $ TEMP, 1, DWORK(KBV), LDABV, - $ DWORK(KCV), LDCDV, DWORK(KDV), LDCDV, IWORK, - $ DWORK(KW), LDWORK-KW+1, IERR ) - IF( IERR.NE.0 ) THEN - IF( IERR.EQ.1 ) THEN - INFO = 10 - ELSE IF( IERR.EQ.3 ) THEN - INFO = 14 - END IF - RETURN - END IF - END IF -C - WRKOPT = MAX( WRKOPT, DWORK(KW) + DBLE( KW - 1 ) ) - ELSE -C -C Compute the projection of V*G1sr or conj(V)*G1sr containing -C the poles of G. -C -C Workspace need: -C real MAX( 1, NV*(NV+5), NV*N + MAX( a, P*N, P*M ) ) -C a = 0, if DICO = 'C' or JOBVL = 'V', -C a = 2*NV, if DICO = 'D' and JOBVL = 'C'; -C prefer larger. -C - CALL AB09JV( JOBVL, DICO, 'I', 'N', NRA, M, P, NV, P, - $ A(NU1,NU1), LDA, B(NU1,1), LDB, - $ C(1,NU1), LDC, D, LDD, AV, LDAV, - $ TEMP, 1, BV, LDBV, CV, LDCV, DV, LDDV, IWORK, - $ DWORK, LDWORK, IERR ) - IF( IERR.NE.0 ) THEN - IF( IERR.EQ.1 ) THEN - INFO = 3 - ELSE IF( IERR.EQ.3 ) THEN - INFO = 12 - END IF - RETURN - END IF -C - WRKOPT = MAX( WRKOPT, DWORK(1) ) - END IF - END IF -C - IF( RIGHTW ) THEN - IF( .NOT.RIGHTI ) THEN - IF( INVFR ) THEN - IERR = 1 - ELSE -C -C Allocate storage for a standard inverse of W. -C Workspace: need NW*(NW+2*M) + M*M. -C - KAW = 1 - KBW = KAW + NW*NW - KCW = KBW + NW*M - KDW = KCW + M*NW - KW = KDW + M*M -C - LDABW = MAX( NW, 1 ) - LDCDW = M - CALL DLACPY( 'Full', NW, NW, AW, LDAW, - $ DWORK(KAW), LDABW ) - CALL DLACPY( 'Full', NW, M, BW, LDBW, - $ DWORK(KBW), LDABW ) - CALL DLACPY( 'Full', M, NW, CW, LDCW, - $ DWORK(KCW), LDCDW ) - CALL DLACPY( 'Full', M, M, DW, LDDW, - $ DWORK(KDW), LDCDW ) -C -C Compute the standard inverse of W. -C Additional real workspace: need MAX(1,4*M); -C prefer larger. -C Integer workspace: need 2*M. -C - CALL AB07ND( NW, M, DWORK(KAW), LDABW, DWORK(KBW), LDABW, - $ DWORK(KCW), LDCDW, DWORK(KDW), LDCDW, - $ RCOND, IWORK, DWORK(KW), LDWORK-KW+1, IERR ) - WRKOPT = MAX( WRKOPT, DWORK(KW) + DBLE( KW-1 ) ) -C -C Check if inversion is accurate. -C - IF( AUTOM ) THEN - IF( IERR.EQ.0 .AND. RCOND.LE.P0001 ) IERR = 1 - ELSE - IF( IERR.EQ.0 .AND. RCOND.LE.SQREPS ) IERR = 1 - END IF - IF( IERR.NE.0 .AND. NW.EQ.0 ) THEN - INFO = 21 - RETURN - END IF - END IF -C - IF( IERR.NE.0 ) THEN -C -C Allocate storage for a descriptor inverse of W. -C - KAW = 1 - KEW = KAW + NWM*NWM - KBW = KEW + NWM*NWM - KCW = KBW + NWM*M - KDW = KCW + M*NWM - KW = KDW + M*M -C - LDABW = MAX( NWM, 1 ) - LDCDW = M -C -C DW is singular or ill-conditioned. -C Form the descriptor inverse of W. -C Workspace: need 2*(NW+M)*(NW+2*M) + M*M. -C - CALL AG07BD( 'I', NW, M, AW, LDAW, TEMP, 1, BW, LDBW, - $ CW, LDCW, DW, LDDW, DWORK(KAW), LDABW, - $ DWORK(KEW), LDABW, DWORK(KBW), LDABW, - $ DWORK(KCW), LDCDW, DWORK(KDW), LDCDW, IERR ) -C -C Compute the projection containing the poles of weighted -C reduced ALPHA-stable part using descriptor inverse of W -C of order NWM = NW + M. -C Additional real workspace: need -C MAX( 2*NWM*NWM + MAX( 11*NWM+16, M*NWM ), -C NWM*N + MAX( NWM*N+N*N, M*N, P*M ) ); -C prefer larger. -C Integer workspace: need NWM+N+6. -C - CALL AB09JW( JOBWL, DICO, 'G', 'N', NRA, M, P, NWM, M, - $ A(NU1,NU1), LDA, B(NU1,1), LDB, - $ C(1,NU1), LDC, D, LDD, DWORK(KAW), LDABW, - $ DWORK(KEW), LDABW, DWORK(KBW), LDABW, - $ DWORK(KCW), LDCDW, DWORK(KDW), LDCDW, - $ IWORK, DWORK(KW), LDWORK-KW+1, IERR ) - IF( IERR.NE.0 ) THEN - IF( IERR.EQ.1 ) THEN - INFO = 6 - ELSE IF( IERR.EQ.2 ) THEN - INFO = 17 - END IF - RETURN - END IF - ELSE -C -C Compute the projection containing the poles of weighted -C reduced ALPHA-stable part using explicit inverse of W. -C Additional real workspace: need -C MAX( NW*(NW+5), NW*N + MAX( a, M*N, P*M ) ) -C a = 0, if DICO = 'C' or JOBWL = 'W', -C a = 2*NW, if DICO = 'D' and JOBWL = 'C'; -C prefer larger. -C - CALL AB09JW( JOBWL, DICO, 'I', 'N', NRA, M, P, NW, M, - $ A(NU1,NU1), LDA, B(NU1,1), LDB, - $ C(1,NU1), LDC, D, LDD, DWORK(KAW), LDABW, - $ TEMP, 1, DWORK(KBW), LDABW, - $ DWORK(KCW), LDCDW, DWORK(KDW), LDCDW, - $ IWORK, DWORK(KW), LDWORK-KW+1, IERR ) - IF( IERR.NE.0 ) THEN - IF( IERR.EQ.1 ) THEN - INFO = 11 - ELSE IF( IERR.EQ.3 ) THEN - INFO = 15 - END IF - RETURN - END IF - END IF -C - WRKOPT = MAX( WRKOPT, DWORK(KW) + DBLE( KW - 1 ) ) - ELSE -C -C Compute the projection G1r of V*G1sr*W or -C conj(V)*G1sr*conj(W) containing the poles of G. -C -C Workspace need: -C real MAX( 1, NW*(NW+5), NW*N + MAX( b, M*N, P*M ) ) -C b = 0, if DICO = 'C' or JOBWL = 'W', -C b = 2*NW, if DICO = 'D' and JOBWL = 'C'; -C prefer larger. -C - CALL AB09JW( JOBWL, DICO, 'I', 'N', NRA, M, P, NW, M, - $ A(NU1,NU1), LDA, B(NU1,1), LDB, C(1,NU1), LDC, - $ D, LDD, AW, LDAW, TEMP, 1, BW, LDBW, CW, LDCW, - $ DW, LDDW, IWORK, DWORK, LDWORK, IERR ) -C - IF( IERR.NE.0 ) THEN - IF( IERR.EQ.1 ) THEN - INFO = 4 - ELSE IF( IERR.EQ.3 ) THEN - INFO = 13 - END IF - RETURN - END IF -C - WRKOPT = MAX( WRKOPT, DWORK(1) ) - END IF - END IF -C - NR = NRA + NU - DWORK(1) = WRKOPT -C - RETURN -C *** Last line of AB09JD *** - END diff --git a/mex/sources/libslicot/AB09JV.f b/mex/sources/libslicot/AB09JV.f deleted file mode 100644 index 5a7d08ab2..000000000 --- a/mex/sources/libslicot/AB09JV.f +++ /dev/null @@ -1,958 +0,0 @@ - SUBROUTINE AB09JV( JOB, DICO, JOBEV, STBCHK, N, M, P, NV, PV, - $ A, LDA, B, LDB, C, LDC, D, LDD, AV, LDAV, - $ EV, LDEV, BV, LDBV, CV, LDCV, DV, LDDV, IWORK, - $ DWORK, LDWORK, INFO ) -C -C SLICOT RELEASE 5.0. -C -C Copyright (c) 2002-2009 NICONET e.V. -C -C This program is free software: you can redistribute it and/or -C modify it under the terms of the GNU General Public License as -C published by the Free Software Foundation, either version 2 of -C the License, or (at your option) any later version. -C -C This program is distributed in the hope that it will be useful, -C but WITHOUT ANY WARRANTY; without even the implied warranty of -C MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the -C GNU General Public License for more details. -C -C You should have received a copy of the GNU General Public License -C along with this program. If not, see -C . -C -C PURPOSE -C -C To construct a state-space representation (A,BS,CS,DS) of the -C projection of V*G or conj(V)*G containing the poles of G, from the -C state-space representations (A,B,C,D) and (AV-lambda*EV,BV,CV,DV), -C of the transfer-function matrices G and V, respectively. -C G is assumed to be a stable transfer-function matrix and -C the state matrix A must be in a real Schur form. -C When computing the stable projection of V*G, it is assumed -C that G and V have completely distinct poles. -C When computing the stable projection of conj(V)*G, it is assumed -C that G and conj(V) have completely distinct poles. -C -C Note: For a transfer-function matrix G, conj(G) denotes the -C conjugate of G given by G'(-s) for a continuous-time system or -C G'(1/z) for a discrete-time system. -C -C ARGUMENTS -C -C Mode Parameters -C -C JOB CHARACTER*1 -C Specifies the projection to be computed as follows: -C = 'V': compute the projection of V*G containing -C the poles of G; -C = 'C': compute the projection of conj(V)*G containing -C the poles of G. -C -C DICO CHARACTER*1 -C Specifies the type of the systems as follows: -C = 'C': G and V are continuous-time systems; -C = 'D': G and V are discrete-time systems. -C -C JOBEV CHARACTER*1 -C Specifies whether EV is a general square or an identity -C matrix as follows: -C = 'G': EV is a general square matrix; -C = 'I': EV is the identity matrix. -C -C STBCHK CHARACTER*1 -C Specifies whether stability/antistability of V is to be -C checked as follows: -C = 'C': check stability if JOB = 'C' or antistability if -C JOB = 'V'; -C = 'N': do not check stability or antistability. -C -C Input/Output Parameters -C -C N (input) INTEGER -C The dimension of the state vector of the system with -C the transfer-function matrix G. N >= 0. -C -C M (input) INTEGER -C The dimension of the input vector of the system with -C the transfer-function matrix G. M >= 0. -C -C P (input) INTEGER -C The dimension of the output vector of the system with the -C transfer-function matrix G, and also the dimension of -C the input vector if JOB = 'V', or of the output vector -C if JOB = 'C', of the system with the transfer-function -C matrix V. P >= 0. -C -C NV (input) INTEGER -C The dimension of the state vector of the system with -C the transfer-function matrix V. NV >= 0. -C -C PV (input) INTEGER -C The dimension of the output vector, if JOB = 'V', or -C of the input vector, if JOB = 'C', of the system with -C the transfer-function matrix V. PV >= 0. -C -C A (input) DOUBLE PRECISION array, dimension (LDA,N) -C The leading N-by-N part of this array must contain the -C state matrix A of the system with the transfer-function -C matrix G in a real Schur form. -C -C LDA INTEGER -C The leading dimension of the array A. LDA >= MAX(1,N). -C -C B (input) DOUBLE PRECISION array, dimension (LDB,M) -C The leading N-by-M part of this array must contain -C the input/state matrix B of the system with the -C transfer-function matrix G. The matrix BS is equal to B. -C -C LDB INTEGER -C The leading dimension of the array B. LDB >= MAX(1,N). -C -C C (input/output) DOUBLE PRECISION array, dimension (LDC,N) -C On entry, the leading P-by-N part of this array must -C contain the output matrix C of the system with the -C transfer-function matrix G. -C On exit, if INFO = 0, the leading PV-by-N part of this -C array contains the output matrix CS of the projection of -C V*G, if JOB = 'V', or of conj(V)*G, if JOB = 'C'. -C -C LDC INTEGER -C The leading dimension of the array C. LDC >= MAX(1,P,PV). -C -C D (input/output) DOUBLE PRECISION array, dimension (LDD,M) -C On entry, the leading P-by-M part of this array must -C contain the feedthrough matrix D of the system with the -C transfer-function matrix G. -C On exit, if INFO = 0, the leading PV-by-M part of -C this array contains the feedthrough matrix DS of the -C projection of V*G, if JOB = 'V', or of conj(V)*G, -C if JOB = 'C'. -C -C LDD INTEGER -C The leading dimension of the array D. LDD >= MAX(1,P,PV). -C -C AV (input/output) DOUBLE PRECISION array, dimension (LDAV,NV) -C On entry, the leading NV-by-NV part of this array must -C contain the state matrix AV of the system with the -C transfer-function matrix V. -C On exit, if INFO = 0, the leading NV-by-NV part of this -C array contains a condensed matrix as follows: -C if JOBEV = 'I', it contains the real Schur form of AV; -C if JOBEV = 'G' and JOB = 'V', it contains a quasi-upper -C triangular matrix representing the real Schur matrix -C in the real generalized Schur form of the pair (AV,EV); -C if JOBEV = 'G', JOB = 'C' and DICO = 'C', it contains a -C quasi-upper triangular matrix corresponding to the -C generalized real Schur form of the pair (AV',EV'); -C if JOBEV = 'G', JOB = 'C' and DICO = 'D', it contains an -C upper triangular matrix corresponding to the generalized -C real Schur form of the pair (EV',AV'). -C -C LDAV INTEGER -C The leading dimension of the array AV. LDAV >= MAX(1,NV). -C -C EV (input/output) DOUBLE PRECISION array, dimension (LDEV,NV) -C On entry, if JOBEV = 'G', the leading NV-by-NV part of -C this array must contain the descriptor matrix EV of the -C system with the transfer-function matrix V. -C If JOBEV = 'I', EV is assumed to be an identity matrix -C and is not referenced. -C On exit, if INFO = 0 and JOBEV = 'G', the leading NV-by-NV -C part of this array contains a condensed matrix as follows: -C if JOB = 'V', it contains an upper triangular matrix -C corresponding to the real generalized Schur form of the -C pair (AV,EV); -C if JOB = 'C' and DICO = 'C', it contains an upper -C triangular matrix corresponding to the generalized real -C Schur form of the pair (AV',EV'); -C if JOB = 'C' and DICO = 'D', it contains a quasi-upper -C triangular matrix corresponding to the generalized -C real Schur form of the pair (EV',AV'). -C -C LDEV INTEGER -C The leading dimension of the array EV. -C LDEV >= MAX(1,NV), if JOBEV = 'G'; -C LDEV >= 1, if JOBEV = 'I'. -C -C BV (input/output) DOUBLE PRECISION array, -C dimension (LDBV,MBV), where MBV = P, if JOB = 'V', and -C MBV = PV, if JOB = 'C'. -C On entry, the leading NV-by-MBV part of this array must -C contain the input matrix BV of the system with the -C transfer-function matrix V. -C On exit, if INFO = 0, the leading NV-by-MBV part of this -C array contains Q'*BV, where Q is the orthogonal matrix -C that reduces AV to the real Schur form or the left -C orthogonal matrix used to reduce the pair (AV,EV), -C (AV',EV') or (EV',AV') to the generalized real Schur form. -C -C LDBV INTEGER -C The leading dimension of the array BV. LDBV >= MAX(1,NV). -C -C CV (input/output) DOUBLE PRECISION array, dimension (LDCV,NV) -C On entry, the leading PCV-by-NV part of this array must -C contain the output matrix CV of the system with the -C transfer-function matrix V, where PCV = PV, if JOB = 'V', -C or PCV = P, if JOB = 'C'. -C On exit, if INFO = 0, the leading PCV-by-NV part of this -C array contains CV*Q, where Q is the orthogonal matrix that -C reduces AV to the real Schur form, or CV*Z, where Z is the -C right orthogonal matrix used to reduce the pair (AV,EV), -C (AV',EV') or (EV',AV') to the generalized real Schur form. -C -C LDCV INTEGER -C The leading dimension of the array CV. -C LDCV >= MAX(1,PV) if JOB = 'V'; -C LDCV >= MAX(1,P) if JOB = 'C'. -C -C DV (input) DOUBLE PRECISION array, -C dimension (LDDV,MBV), where MBV = P, if JOB = 'V', and -C MBV = PV, if JOB = 'C'. -C The leading PCV-by-MBV part of this array must contain -C the feedthrough matrix DV of the system with the -C transfer-function matrix V, where PCV = PV, if JOB = 'V', -C or PCV = P, if JOB = 'C'. -C -C LDDV INTEGER -C The leading dimension of the array DV. -C LDDV >= MAX(1,PV) if JOB = 'V'; -C LDDV >= MAX(1,P) if JOB = 'C'. -C -C Workspace -C -C IWORK INTEGER array, dimension (LIWORK) -C LIWORK = 0, if JOBEV = 'I'; -C LIWORK = NV+N+6, if JOBEV = 'G'. -C -C DWORK DOUBLE PRECISION array, dimension (LDWORK) -C On exit, if INFO = 0, DWORK(1) returns the optimal value -C of LDWORK. -C -C LDWORK INTEGER -C The length of the array DWORK. -C LDWORK >= LW1, if JOBEV = 'I', -C LDWORK >= LW2, if JOBEV = 'G', where -C LW1 = MAX( 1, NV*(NV+5), NV*N + MAX( a, PV*N, PV*M ) ) -C a = 0, if DICO = 'C' or JOB = 'V', -C a = 2*NV, if DICO = 'D' and JOB = 'C'; -C LW2 = MAX( 2*NV*NV + MAX( 11*NV+16, P*NV, PV*NV ), -C NV*N + MAX( NV*N+N*N, PV*N, PV*M ) ). -C For good performance, LDWORK should be larger. -C -C Error Indicator -C -C INFO INTEGER -C = 0: successful exit; -C < 0: if INFO = -i, the i-th argument had an illegal -C value; -C = 1: the reduction of the pair (AV,EV) to the real -C generalized Schur form failed (JOBEV = 'G'), -C or the reduction of the matrix AV to the real -C Schur form failed (JOBEV = 'I); -C = 2: the solution of the Sylvester equation failed -C because the matrix A and the pencil AV-lambda*EV -C have common eigenvalues (if JOB = 'V'), or the -C pencil -AV-lambda*EV and A have common eigenvalues -C (if JOB = 'C' and DICO = 'C'), or the pencil -C AV-lambda*EV has an eigenvalue which is the -C reciprocal of one of eigenvalues of A -C (if JOB = 'C' and DICO = 'D'); -C = 3: the solution of the Sylvester equation failed -C because the matrices A and AV have common -C eigenvalues (if JOB = 'V'), or the matrices A -C and -AV have common eigenvalues (if JOB = 'C' and -C DICO = 'C'), or the matrix A has an eigenvalue -C which is the reciprocal of one of eigenvalues of AV -C (if JOB = 'C' and DICO = 'D'); -C = 4: JOB = 'V' and the pair (AV,EV) has not completely -C unstable generalized eigenvalues, or JOB = 'C' and -C the pair (AV,EV) has not completely stable -C generalized eigenvalues. -C -C METHOD -C -C If JOB = 'V', the matrices of the stable projection of V*G are -C computed as -C -C BS = B, CS = CV*X + DV*C, DS = DV*D, -C -C where X satisfies the generalized Sylvester equation -C -C AV*X - EV*X*A + BV*C = 0. -C -C If JOB = 'C', the matrices of the stable projection of conj(V)*G -C are computed using the following formulas: -C -C - for a continuous-time system, the matrices BS, CS and DS of -C the stable projection are computed as -C -C BS = B, CS = BV'*X + DV'*C, DS = DV'*D, -C -C where X satisfies the generalized Sylvester equation -C -C AV'*X + EV'*X*A + CV'*C = 0. -C -C - for a discrete-time system, the matrices BS, CS and DS of -C the stable projection are computed as -C -C BS = B, CS = BV'*X*A + DV'*C, DS = DV'*D + BV'*X*B, -C -C where X satisfies the generalized Sylvester equation -C -C EV'*X - AV'*X*A = CV'*C. -C -C REFERENCES -C -C [1] Varga, A. -C Efficient and numerically reliable implementation of the -C frequency-weighted Hankel-norm approximation model reduction -C approach. -C Proc. 2001 ECC, Porto, Portugal, 2001. -C -C [2] Zhou, K. -C Frequency-weighted H-infinity norm and optimal Hankel norm -C model reduction. -C IEEE Trans. Autom. Control, vol. 40, pp. 1687-1699, 1995. -C -C NUMERICAL ASPECTS -C -C The implemented methods rely on numerically stable algorithms. -C -C CONTRIBUTORS -C -C A. Varga, German Aerospace Center, Oberpfaffenhofen, July 2000. -C D. Sima, University of Bucharest, March 2001. -C V. Sima, Research Institute for Informatics, Bucharest, Mar. 2001. -C -C REVISIONS -C -C A. Varga, German Aerospace Center, Oberpfaffenhofen, May 2001. -C V. Sima, Research Institute for Informatics, Bucharest, June 2001. -C A. Varga, German Aerospace Center, Oberpfaffenhofen, Nov. 2003. -C -C KEYWORDS -C -C Frequency weighting, model reduction, multivariable system, -C state-space model, state-space representation. -C -C ****************************************************************** -C -C .. Parameters .. - DOUBLE PRECISION ZERO, ONE - PARAMETER ( ZERO = 0.0D0, ONE = 1.0D0 ) -C .. Scalar Arguments .. - CHARACTER DICO, JOB, JOBEV, STBCHK - INTEGER INFO, LDA, LDAV, LDB, LDBV, LDC, LDCV, - $ LDD, LDDV, LDEV, LDWORK, M, N, NV, P, PV -C .. Array Arguments .. - INTEGER IWORK(*) - DOUBLE PRECISION A(LDA,*), AV(LDAV,*), B(LDB,*), BV(LDBV,*), - $ C(LDC,*), CV(LDCV,*), D(LDD,*), DV(LDDV,*), - $ DWORK(*), EV(LDEV,*) -C .. Local Scalars .. - CHARACTER*1 EVTYPE, STDOM - LOGICAL CONJS, DISCR, STABCK, UNITEV - DOUBLE PRECISION ALPHA, DIF, SCALE, TOLINF, WORK - INTEGER I, IA, IERR, KAI, KAR, KB, KC, KE, KF, KQ, KW, - $ KZ, LDW, LDWN, LW, SDIM -C .. Local Arrays .. - LOGICAL BWORK(1) -C .. External Functions .. - LOGICAL DELCTG, LSAME - DOUBLE PRECISION DLAMCH, DLANGE - EXTERNAL DELCTG, DLAMCH, DLANGE, LSAME -C .. External Subroutines .. - EXTERNAL AB09JX, DGEMM, DGGES, DLACPY, DLASET, DSWAP, - $ DTGSYL, DTRSYL, SB04PY, TB01WD, XERBLA -C .. Intrinsic Functions .. - INTRINSIC DBLE, MAX, SQRT -C -C .. Executable Statements .. -C - CONJS = LSAME( JOB, 'C' ) - DISCR = LSAME( DICO, 'D' ) - UNITEV = LSAME( JOBEV, 'I' ) - STABCK = LSAME( STBCHK, 'C' ) -C - INFO = 0 - IF( UNITEV ) THEN - IF ( DISCR .AND. CONJS ) THEN - IA = 2*NV - ELSE - IA = 0 - END IF - LW = MAX( 1, NV*( NV + 5 ), NV*N + MAX( IA, PV*N, PV*M ) ) - ELSE - LW = MAX( 2*NV*NV + MAX( 11*NV+16, P*NV, PV*NV ), - $ NV*N + MAX( NV*N + N*N, PV*N, PV*M ) ) - END IF -C -C Test the input scalar arguments. -C - LDWN = MAX( 1, N ) - LDW = MAX( 1, NV ) - IF( .NOT. ( LSAME( JOB, 'V' ) .OR. CONJS ) ) THEN - INFO = -1 - ELSE IF( .NOT. ( LSAME( DICO, 'C' ) .OR. DISCR ) ) THEN - INFO = -2 - ELSE IF( .NOT. ( LSAME( JOBEV, 'G' ) .OR. UNITEV ) ) THEN - INFO = -3 - ELSE IF( .NOT. ( LSAME( STBCHK, 'N' ) .OR. STABCK ) ) THEN - INFO = -4 - ELSE IF( N.LT.0 ) THEN - INFO = -5 - ELSE IF( M.LT.0 ) THEN - INFO = -6 - ELSE IF( P.LT.0 ) THEN - INFO = -7 - ELSE IF( NV.LT.0 ) THEN - INFO = -8 - ELSE IF( PV.LT.0 ) THEN - INFO = -9 - ELSE IF( LDA.LT.LDWN ) THEN - INFO = -11 - ELSE IF( LDB.LT.LDWN ) THEN - INFO = -13 - ELSE IF( LDC.LT.MAX( 1, P, PV ) ) THEN - INFO = -15 - ELSE IF( LDD.LT.MAX( 1, P, PV ) ) THEN - INFO = -17 - ELSE IF( LDAV.LT.LDW ) THEN - INFO = -19 - ELSE IF( LDEV.LT.1 .OR. ( .NOT.UNITEV .AND. LDEV.LT.NV ) ) THEN - INFO = -21 - ELSE IF( LDBV.LT.LDW ) THEN - INFO = -23 - ELSE IF( ( .NOT.CONJS .AND. LDCV.LT.MAX( 1, PV ) ) .OR. - $ ( CONJS .AND. LDCV.LT.MAX( 1, P ) ) ) THEN - INFO = -25 - ELSE IF( ( .NOT.CONJS .AND. LDDV.LT.MAX( 1, PV ) ) .OR. - $ ( CONJS .AND. LDDV.LT.MAX( 1, P ) ) ) THEN - INFO = -27 - ELSE IF( LDWORK.LT.LW ) THEN - INFO = -30 - END IF -C - IF( INFO.NE.0 ) THEN -C -C Error return. -C - CALL XERBLA( 'AB09JV', -INFO ) - RETURN - END IF -C -C Quick return if possible. -C - IF( P.EQ.0 .OR. PV.EQ.0 ) THEN - DWORK(1) = ONE - RETURN - END IF -C -C Set options for stability/antistability checking. -C - IF( DISCR ) THEN - ALPHA = ONE - ELSE - ALPHA = ZERO - END IF -C - WORK = ONE - TOLINF = DLAMCH( 'Epsilon' ) -C - IF( UNITEV ) THEN -C -C EV is the identity matrix. -C - IF( NV.GT.0 ) THEN -C -C Reduce AV to the real Schur form using an orthogonal -C similarity transformation AV <- Q'*AV*Q and apply the -C transformation to BV and CV: BV <- Q'*BV and CV <- CV*Q. -C -C Workspace needed: NV*(NV+5); -C prefer larger. -C - KW = NV*( NV + 2 ) + 1 - IF( CONJS ) THEN - STDOM = 'S' - ALPHA = ALPHA + SQRT( TOLINF ) - CALL TB01WD( NV, PV, P, AV, LDAV, BV, LDBV, CV, LDCV, - $ DWORK(2*NV+1), NV, DWORK, DWORK(NV+1), - $ DWORK(KW), LDWORK-KW+1, IERR ) - ELSE - STDOM = 'U' - ALPHA = ALPHA - SQRT( TOLINF ) - CALL TB01WD( NV, P, PV, AV, LDAV, BV, LDBV, CV, LDCV, - $ DWORK(2*NV+1), NV, DWORK, DWORK(NV+1), - $ DWORK(KW), LDWORK-KW+1, IERR ) - END IF - IF( IERR.NE.0 ) THEN - INFO = 1 - RETURN - END IF - IF( STABCK ) THEN -C -C Check stability/antistability of eigenvalues of AV. -C - CALL AB09JX( DICO, STDOM, 'S', NV, ALPHA, DWORK, - $ DWORK(NV+1), DWORK, TOLINF, IERR ) - IF( IERR.NE.0 ) THEN - INFO = 4 - RETURN - END IF - END IF -C - WORK = MAX( WORK, DWORK(KW) + DBLE( KW - 1 ) ) -C - END IF -C - KW = NV*N + 1 - IF( CONJS ) THEN -C -C Compute the projection of conj(V)*G. -C -C Total workspace needed: NV*N + MAX( a, PV*N, PV*M ), where -C a = 0, if DICO = 'C', -C a = 2*NV, if DICO = 'D'. -C -C Compute -CV'*C. -C Workspace needed: NV*N. -C - CALL DGEMM( 'T', 'N', NV, N, P, -ONE, CV, LDCV, C, LDC, - $ ZERO, DWORK, LDW ) -C - IF( DISCR ) THEN -C -C Compute X and SCALE satisfying -C -C AV'*X*A - X = -SCALE*CV'*C. -C -C Additional workspace needed: 2*NV. -C - CALL SB04PY( 'T', 'N', -1, NV, N, AV, LDAV, A, LDA, - $ DWORK, LDW, SCALE, DWORK(KW), IERR ) - IF( IERR.NE.0 ) THEN - INFO = 3 - RETURN - END IF -C -C Construct CS = DV'*C + BV'*X*A/SCALE, -C DS = DV'*D + BV'*X*B/SCALE. -C -C Additional workspace needed: MAX( PV*N, PV*M ). -C -C C <- DV'*C. -C - CALL DGEMM( 'T', 'N', PV, N, P, ONE, DV, LDDV, C, LDC, - $ ZERO, DWORK(KW), PV ) - CALL DLACPY( 'Full', PV, N, DWORK(KW), PV, C, LDC ) -C -C D <- DV'*D. -C - CALL DGEMM( 'T', 'N', PV, M, P, ONE, DV, LDDV, D, LDD, - $ ZERO, DWORK(KW), PV ) - CALL DLACPY( 'Full', PV, M, DWORK(KW), PV, D, LDD ) -C -C C <- C + BV'*X*A/SCALE. -C - CALL DGEMM( 'T', 'N', PV, N, NV, ONE / SCALE, BV, LDBV, - $ DWORK, LDW, ZERO, DWORK(KW), PV ) - CALL DGEMM( 'N', 'N', PV, N, N, ONE, DWORK(KW), PV, - $ A, LDA, ONE, C, LDC ) -C -C D <- D + BV'*X*B/SCALE. -C - CALL DGEMM( 'N', 'N', PV, M, N, ONE, DWORK(KW), PV, - $ B, LDB, ONE, D, LDD ) - ELSE -C -C Compute X and SCALE satisfying -C -C AV'*X + X*A + SCALE*CV'*C = 0. -C - IF( N.GT.0 ) THEN - CALL DTRSYL( 'T', 'N', 1, NV, N, AV, LDAV, A, LDA, - $ DWORK, LDW, SCALE, IERR ) - IF( IERR.NE.0 ) THEN - INFO = 3 - RETURN - END IF - END IF -C -C Construct CS = DV'*C + BV'*X/SCALE, -C DS = DV'*D. -C Additional workspace needed: MAX( PV*N, PV*M ). -C -C Construct C <- DV'*C + BV'*X/SCALE. -C - CALL DGEMM( 'T', 'N', PV, N, P, ONE, DV, LDDV, C, LDC, - $ ZERO, DWORK(KW), PV ) - CALL DLACPY( 'Full', PV, N, DWORK(KW), PV, C, LDC ) - CALL DGEMM( 'T', 'N', PV, N, NV, ONE / SCALE, BV, LDBV, - $ DWORK, LDW, ONE, C, LDC ) -C -C Construct D <- DV'*D. -C - CALL DGEMM( 'T', 'N', PV, M, P, ONE, DV, LDDV, D, LDD, - $ ZERO, DWORK(KW), PV ) - CALL DLACPY( 'Full', PV, M, DWORK(KW), PV, D, LDD ) - END IF - ELSE -C -C Compute the projection of V*G. -C -C Total workspace needed: NV*N + MAX( PV*N, PV*M ). -C -C Compute -BV*C. -C Workspace needed: NV*N. -C - CALL DGEMM( 'N', 'N', NV, N, P, -ONE, BV, LDBV, C, LDC, - $ ZERO, DWORK, LDW ) -C -C Compute X and SCALE satisfying -C -C AV*X - X*A + SCALE*BV*C = 0. -C - IF( N.GT.0 ) THEN - CALL DTRSYL( 'N', 'N', -1, NV, N, AV, LDAV, A, LDA, - $ DWORK, LDW, SCALE, IERR ) - IF( IERR.NE.0 ) THEN - INFO = 3 - RETURN - END IF - END IF -C -C Construct CS = DV*C + CV*X/SCALE, -C DS = DV*D. -C Additional workspace needed: MAX( PV*N, PV*M ). -C -C Construct C <- DV*C + CV*X/SCALE. -C - CALL DGEMM( 'N', 'N', PV, N, P, ONE, DV, LDDV, C, LDC, - $ ZERO, DWORK(KW), PV ) - CALL DLACPY( 'Full', PV, N, DWORK(KW), PV, C, LDC ) - CALL DGEMM( 'N', 'N', PV, N, NV, ONE / SCALE, CV, LDCV, - $ DWORK, LDW, ONE, C, LDC ) -C -C Construct D <- DV*D. -C - CALL DGEMM( 'N', 'N', PV, M, P, ONE, DV, LDDV, D, LDD, - $ ZERO, DWORK(KW), PV ) - CALL DLACPY( 'Full', PV, M, DWORK(KW), PV, D, LDD ) - END IF - ELSE -C -C EV is a general matrix. -C - IF( NV.GT.0 ) THEN - TOLINF = TOLINF * DLANGE( '1', NV, NV, EV, LDEV, DWORK ) -C -C Reduce (AV,EV), or (AV',EV') or (EV',AV') to a generalized -C real Schur form using an orthogonal equivalence -C transformation and apply the orthogonal transformation -C appropriately to BV and CV, or CV' and BV'. -C -C Workspace needed: 2*NV*NV + MAX( 11*NV+16, NV*P, NV*PV ); -C prefer larger. -C - KQ = 1 - KZ = KQ + NV*NV - KAR = KZ + NV*NV - KAI = KAR + NV - KB = KAI + NV - KW = KB + NV -C - IF( CONJS ) THEN - STDOM = 'S' - ALPHA = ALPHA + SQRT( TOLINF ) -C -C Transpose AV and EV, if non-scalar. -C - DO 10 I = 1, NV - 1 - CALL DSWAP( NV-I, AV(I+1,I), 1, AV(I,I+1), LDAV ) - CALL DSWAP( NV-I, EV(I+1,I), 1, EV(I,I+1), LDEV ) - 10 CONTINUE -C - IF( DISCR ) THEN -C -C Reduce (EV',AV') to a generalized real Schur form -C using orthogonal transformation matrices Q and Z -C such that Q'*EV'*Z results in a quasi-triangular form -C and Q'*AV'*Z results upper triangular. -C Total workspace needed: 2*NV*NV + 11*NV + 16. -C - EVTYPE = 'R' - CALL DGGES( 'Vectors', 'Vectors', 'Not ordered', - $ DELCTG, NV, EV, LDEV, AV, LDAV, SDIM, - $ DWORK(KAR), DWORK(KAI), DWORK(KB), - $ DWORK(KQ), LDW, DWORK(KZ), LDW, - $ DWORK(KW), LDWORK-KW+1, BWORK, IERR ) - ELSE -C -C Reduce (AV',EV') to a generalized real Schur form -C using orthogonal transformation matrices Q and Z -C such that Q'*AV'*Z results in a quasi-triangular form -C and Q'*EV'*Z results upper triangular. -C Total workspace needed: 2*NV*NV + 11*NV + 16. -C - EVTYPE = 'G' - CALL DGGES( 'Vectors', 'Vectors', 'Not ordered', - $ DELCTG, NV, AV, LDAV, EV, LDEV, SDIM, - $ DWORK(KAR), DWORK(KAI), DWORK(KB), - $ DWORK(KQ), LDW, DWORK(KZ), LDW, - $ DWORK(KW), LDWORK-KW+1, BWORK, IERR ) - END IF - IF( IERR.NE.0 ) THEN - INFO = 1 - RETURN - END IF - IF( STABCK ) THEN -C -C Check stability/antistability of generalized -C eigenvalues of the pair (AV,EV). -C - CALL AB09JX( DICO, STDOM, EVTYPE, NV, ALPHA, - $ DWORK(KAR), DWORK(KAI), DWORK(KB), - $ TOLINF, IERR ) - IF( IERR.NE.0 ) THEN - INFO = 4 - RETURN - END IF - END IF - WORK = MAX( WORK, DWORK(KW) + DBLE( KW - 1 ) ) -C -C Compute Z'*BV and CV*Q. -C Total workspace needed: 2*NV*NV + NV*MAX(P,PV). -C - KW = KAR - CALL DLACPY( 'Full', NV, PV, BV, LDBV, DWORK(KW), LDW ) - CALL DGEMM( 'T', 'N', NV, PV, NV, ONE, DWORK(KZ), LDW, - $ DWORK(KW), LDW, ZERO, BV, LDBV ) - CALL DLACPY( 'Full', P, NV, CV, LDCV, DWORK(KW), P ) - CALL DGEMM( 'N', 'N', P, NV, NV, ONE, DWORK(KW), P, - $ DWORK(KQ), LDW, ZERO, CV, LDCV ) - ELSE -C -C Reduce (AV,EV) to a generalized real Schur form -C using orthogonal transformation matrices Q and Z -C such that Q'*AV*Z results in a quasi-triangular form -C and Q'*EV*Z results upper triangular. -C Total workspace needed: 2*NV*NV + 11*NV + 16. -C - STDOM = 'U' - EVTYPE = 'G' - ALPHA = ALPHA - SQRT( TOLINF ) - CALL DGGES( 'Vectors', 'Vectors', 'Not ordered', - $ DELCTG, NV, AV, LDAV, EV, LDEV, SDIM, - $ DWORK(KAR), DWORK(KAI), DWORK(KB), - $ DWORK(KQ), LDW, DWORK(KZ), LDW, - $ DWORK(KW), LDWORK-KW+1, BWORK, IERR ) - IF( IERR.NE.0 ) THEN - INFO = 1 - RETURN - END IF - IF( STABCK ) THEN -C -C Check stability/antistability of generalized -C eigenvalues of the pair (AV,EV). -C - CALL AB09JX( DICO, STDOM, EVTYPE, NV, ALPHA, - $ DWORK(KAR), DWORK(KAI), DWORK(KB), - $ TOLINF, IERR ) - IF( IERR.NE.0 ) THEN - INFO = 4 - RETURN - END IF - END IF - WORK = MAX( WORK, DWORK(KW) + DBLE( KW - 1 ) ) -C -C Compute Q'*BV and CV*Z. -C Total workspace needed: 2*NV*NV + NV*MAX(P,PV). -C - KW = KAR - CALL DLACPY( 'Full', NV, P, BV, LDBV, DWORK(KW), LDW ) - CALL DGEMM( 'T', 'N', NV, P, NV, ONE, DWORK(KQ), LDW, - $ DWORK(KW), LDW, ZERO, BV, LDBV ) - CALL DLACPY( 'Full', PV, NV, CV, LDCV, DWORK(KW), PV ) - CALL DGEMM( 'N', 'N', PV, NV, NV, ONE, DWORK(KW), PV, - $ DWORK(KZ), LDW, ZERO, CV, LDCV ) - END IF - WORK = MAX( WORK, DBLE( 2*NV*NV + NV*MAX( P, PV ) ) ) -C - END IF -C - KC = 1 - KF = KC + NV*N - KE = KF + NV*N - KW = KE + N*N - CALL DLASET( 'Full', NV, N, ZERO, ZERO, DWORK(KF), LDW ) -C - IF( CONJS ) THEN -C -C Compute the projection of conj(V)*G. -C -C Total workspace needed: NV*N + MAX( NV*N+N*N, PV*N, PV*M ) -C -C Compute CV'*C. -C Workspace needed: NV*N. -C - CALL DGEMM( 'T', 'N', NV, N, P, ONE, CV, LDCV, C, LDC, - $ ZERO, DWORK(KC), LDW ) -C - IF( DISCR ) THEN -C -C Compute X and SCALE satisfying -C -C EV'*X - AV'*X*A = SCALE*CV'*C by solving equivalently -C -C EV'*X - Y*A = SCALE*CV'*C, -C AV'*X - Y = 0. -C -C Additional workspace needed: -C real NV*N + N*N; -C integer NV+N+6. -C - IF( N.GT.0 ) THEN - CALL DLASET( 'Full', N, N, ZERO, ONE, DWORK(KE), LDWN - $ ) - CALL DTGSYL( 'N', 0, NV, N, EV, LDEV, A, LDA, - $ DWORK(KC), LDW, AV, LDAV, DWORK(KE), - $ LDWN, DWORK(KF), LDW, SCALE, DIF, - $ DWORK(KW), LDWORK-KW+1, IWORK, IERR ) - IF( IERR.NE.0 ) THEN - INFO = 2 - RETURN - END IF - END IF -C -C Construct C <- DV'*C + BV'*X*A/SCALE, -C D <- DV'*D + BV'*X*B/SCALE. -C -C Additional workspace needed: MAX( PV*N, PV*M ). -C -C C <- DV'*C. -C - KW = KF - CALL DGEMM( 'T', 'N', PV, N, P, ONE, DV, LDDV, C, LDC, - $ ZERO, DWORK(KW), PV ) - CALL DLACPY( 'Full', PV, N, DWORK(KW), PV, C, LDC ) -C -C D <- DV'*D. -C - CALL DGEMM( 'T', 'N', PV, M, P, ONE, DV, LDDV, D, LDD, - $ ZERO, DWORK(KW), PV ) - CALL DLACPY( 'Full', PV, M, DWORK(KW), PV, D, LDD ) -C -C C <- C + BV'*X*A/SCALE. -C - CALL DGEMM( 'T', 'N', PV, N, NV, ONE / SCALE, BV, LDBV, - $ DWORK(KC), LDW, ZERO, DWORK(KW), PV ) - CALL DGEMM( 'N', 'N', PV, N, N, ONE, DWORK(KW), PV, - $ A, LDA, ONE, C, LDC ) -C -C D <- D + BV'*X*B/SCALE. -C - CALL DGEMM( 'N', 'N', PV, M, N, ONE, DWORK(KW), PV, - $ B, LDB, ONE, D, LDD ) - ELSE -C -C Compute X and SCALE satisfying -C -C AV'*X + EV'*X*A + SCALE*CV'*C = 0 by solving equivalently -C -C AV'*X - Y*A = -SCALE*CV'*C, -C EV'*X - Y*(-I) = 0. -C -C Additional workspace needed: -C real NV*N+N*N; -C integer NV+N+6. -C - IF( N.GT.0 ) THEN - CALL DLASET( 'Full', N, N, ZERO, -ONE, DWORK(KE), LDWN - $ ) - CALL DTGSYL( 'N', 0, NV, N, AV, LDAV, A, LDA, - $ DWORK(KC), LDW, EV, LDEV, DWORK(KE), - $ LDWN, DWORK(KF), LDW, SCALE, DIF, - $ DWORK(KW), LDWORK-KW+1, IWORK, IERR ) -C -C Note that the computed solution in DWORK(KC) is -X. -C - IF( IERR.NE.0 ) THEN - INFO = 2 - RETURN - END IF - END IF -C -C Construct C <- DV'*C + BV'*X/SCALE. -C - KW = KF - CALL DGEMM( 'T', 'N', PV, N, P, ONE, DV, LDDV, C, LDC, - $ ZERO, DWORK(KW), PV ) - CALL DLACPY( 'Full', PV, N, DWORK(KW), PV, C, LDC ) - CALL DGEMM( 'T', 'N', PV, N, NV, -ONE / SCALE, BV, LDBV, - $ DWORK(KC), LDW, ONE, C, LDC ) -C -C Construct D <- DV'*D. -C - CALL DGEMM( 'T', 'N', PV, M, P, ONE, DV, LDDV, D, LDD, - $ ZERO, DWORK(KW), PV ) - CALL DLACPY( 'Full', PV, M, DWORK(KW), PV, D, LDD ) - END IF - ELSE -C -C Compute the projection of V*G. -C -C Total workspace needed: NV*N + MAX( NV*N+N*N, PV*N, PV*M ) -C -C Compute -BV*C. -C Workspace needed: NV*N. -C - CALL DGEMM( 'N', 'N', NV, N, P, -ONE, BV, LDBV, C, LDC, - $ ZERO, DWORK, LDW ) -C -C Compute X and SCALE satisfying -C -C AV*X - EV*X*A + SCALE*BV*C = 0 by solving equivalently -C -C AV*X - Y*A = -SCALE*BV*C, -C EV*X - Y = 0. -C -C Additional workspace needed: -C real NV*N + N*N; -C integer NV+N+6. -C - IF( N.GT.0 ) THEN - CALL DLASET( 'Full', N, N, ZERO, ONE, DWORK(KE), LDWN ) - CALL DTGSYL( 'N', 0, NV, N, AV, LDAV, A, LDA, - $ DWORK(KC), LDW, EV, LDEV, DWORK(KE), LDWN, - $ DWORK(KF), LDW, SCALE, DIF, DWORK(KW), - $ LDWORK-KW+1, IWORK, IERR ) - IF( IERR.NE.0 ) THEN - INFO = 2 - RETURN - END IF - END IF -C -C Construct C <- DV*C + CV*X/SCALE. -C - KW = KF - CALL DGEMM( 'N', 'N', PV, N, P, ONE, DV, LDDV, C, LDC, - $ ZERO, DWORK(KW), PV ) - CALL DLACPY( 'Full', PV, N, DWORK(KW), PV, C, LDC ) - CALL DGEMM( 'N', 'N', PV, N, NV, ONE / SCALE, CV, LDCV, - $ DWORK, LDW, ONE, C, LDC ) -C -C Construct D <- DV*D. -C - CALL DGEMM( 'N', 'N', PV, M, P, ONE, DV, LDDV, D, LDD, - $ ZERO, DWORK(KW), PV ) - CALL DLACPY( 'Full', PV, M, DWORK(KW), PV, D, LDD ) - END IF - END IF -C - DWORK(1) = MAX( WORK, DBLE( LW ) ) -C - RETURN -C *** Last line of AB09JV *** - END diff --git a/mex/sources/libslicot/AB09JW.f b/mex/sources/libslicot/AB09JW.f deleted file mode 100644 index 9c8068428..000000000 --- a/mex/sources/libslicot/AB09JW.f +++ /dev/null @@ -1,972 +0,0 @@ - SUBROUTINE AB09JW( JOB, DICO, JOBEW, STBCHK, N, M, P, NW, MW, - $ A, LDA, B, LDB, C, LDC, D, LDD, AW, LDAW, - $ EW, LDEW, BW, LDBW, CW, LDCW, DW, LDDW, IWORK, - $ DWORK, LDWORK, INFO ) -C -C SLICOT RELEASE 5.0. -C -C Copyright (c) 2002-2009 NICONET e.V. -C -C This program is free software: you can redistribute it and/or -C modify it under the terms of the GNU General Public License as -C published by the Free Software Foundation, either version 2 of -C the License, or (at your option) any later version. -C -C This program is distributed in the hope that it will be useful, -C but WITHOUT ANY WARRANTY; without even the implied warranty of -C MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the -C GNU General Public License for more details. -C -C You should have received a copy of the GNU General Public License -C along with this program. If not, see -C . -C -C PURPOSE -C -C To construct a state-space representation (A,BS,CS,DS) of the -C projection of G*W or G*conj(W) containing the poles of G, from the -C state-space representations (A,B,C,D) and (AW-lambda*EW,BW,CW,DW), -C of the transfer-function matrices G and W, respectively. -C G is assumed to be a stable transfer-function matrix and -C the state matrix A must be in a real Schur form. -C When computing the stable projection of G*W, it is assumed -C that G and W have completely distinct poles. -C When computing the stable projection of G*conj(W), it is assumed -C that G and conj(W) have completely distinct poles. -C -C Note: For a transfer-function matrix G, conj(G) denotes the -C conjugate of G given by G'(-s) for a continuous-time system or -C G'(1/z) for a discrete-time system. -C -C ARGUMENTS -C -C Mode Parameters -C -C JOB CHARACTER*1 -C Specifies the projection to be computed as follows: -C = 'W': compute the projection of G*W containing -C the poles of G; -C = 'C': compute the projection of G*conj(W) containing -C the poles of G. -C -C DICO CHARACTER*1 -C Specifies the type of the systems as follows: -C = 'C': G and W are continuous-time systems; -C = 'D': G and W are discrete-time systems. -C -C JOBEW CHARACTER*1 -C Specifies whether EW is a general square or an identity -C matrix as follows: -C = 'G': EW is a general square matrix; -C = 'I': EW is the identity matrix. -C -C STBCHK CHARACTER*1 -C Specifies whether stability/antistability of W is to be -C checked as follows: -C = 'C': check stability if JOB = 'C' or antistability if -C JOB = 'W'; -C = 'N': do not check stability or antistability. -C -C Input/Output Parameters -C -C N (input) INTEGER -C The dimension of the state vector of the system with -C the transfer-function matrix G. N >= 0. -C -C M (input) INTEGER -C The dimension of the input vector of the system with -C the transfer-function matrix G, and also the dimension -C of the output vector if JOB = 'W', or of the input vector -C if JOB = 'C', of the system with the transfer-function -C matrix W. M >= 0. -C -C P (input) INTEGER -C The dimension of the output vector of the system with the -C transfer-function matrix G. P >= 0. -C -C NW (input) INTEGER -C The dimension of the state vector of the system with the -C transfer-function matrix W. NW >= 0. -C -C MW (input) INTEGER -C The dimension of the input vector, if JOB = 'W', or of -C the output vector, if JOB = 'C', of the system with the -C transfer-function matrix W. MW >= 0. -C -C A (input) DOUBLE PRECISION array, dimension (LDA,N) -C The leading N-by-N part of this array must contain the -C state matrix A of the system with the transfer-function -C matrix G in a real Schur form. -C -C LDA INTEGER -C The leading dimension of the array A. LDA >= MAX(1,N). -C -C B (input/output) DOUBLE PRECISION array, -C dimension (LDB,MAX(M,MW)) -C On entry, the leading N-by-M part of this array must -C contain the input matrix B of the system with the -C transfer-function matrix G. -C On exit, if INFO = 0, the leading N-by-MW part of this -C array contains the input matrix BS of the projection of -C G*W, if JOB = 'W', or of G*conj(W), if JOB = 'C'. -C -C LDB INTEGER -C The leading dimension of the array B. LDB >= MAX(1,N). -C -C C (input) DOUBLE PRECISION array, dimension (LDC,N) -C The leading P-by-N part of this array must contain -C the output/state matrix C of the system with the -C transfer-function matrix G. The matrix CS is equal to C. -C -C LDC INTEGER -C The leading dimension of the array C. LDC >= MAX(1,P). -C -C D (input/output) DOUBLE PRECISION array, -C dimension (LDB,MAX(M,MW)) -C On entry, the leading P-by-M part of this array must -C contain the feedthrough matrix D of the system with -C the transfer-function matrix G. -C On exit, if INFO = 0, the leading P-by-MW part of -C this array contains the feedthrough matrix DS of the -C projection of G*W, if JOB = 'W', or of G*conj(W), -C if JOB = 'C'. -C -C LDD INTEGER -C The leading dimension of the array D. LDD >= MAX(1,P). -C -C AW (input/output) DOUBLE PRECISION array, dimension (LDAW,NW) -C On entry, the leading NW-by-NW part of this array must -C contain the state matrix AW of the system with the -C transfer-function matrix W. -C On exit, if INFO = 0, the leading NW-by-NW part of this -C array contains a condensed matrix as follows: -C if JOBEW = 'I', it contains the real Schur form of AW; -C if JOBEW = 'G' and JOB = 'W', it contains a quasi-upper -C triangular matrix representing the real Schur matrix -C in the real generalized Schur form of the pair (AW,EW); -C if JOBEW = 'G', JOB = 'C' and DICO = 'C', it contains a -C quasi-upper triangular matrix corresponding to the -C generalized real Schur form of the pair (AW',EW'); -C if JOBEW = 'G', JOB = 'C' and DICO = 'D', it contains an -C upper triangular matrix corresponding to the generalized -C real Schur form of the pair (EW',AW'). -C -C LDAW INTEGER -C The leading dimension of the array AW. LDAW >= MAX(1,NW). -C -C EW (input/output) DOUBLE PRECISION array, dimension (LDEW,NW) -C On entry, if JOBEW = 'G', the leading NW-by-NW part of -C this array must contain the descriptor matrix EW of the -C system with the transfer-function matrix W. -C If JOBEW = 'I', EW is assumed to be an identity matrix -C and is not referenced. -C On exit, if INFO = 0 and JOBEW = 'G', the leading NW-by-NW -C part of this array contains a condensed matrix as follows: -C if JOB = 'W', it contains an upper triangular matrix -C corresponding to the real generalized Schur form of the -C pair (AW,EW); -C if JOB = 'C' and DICO = 'C', it contains an upper -C triangular matrix corresponding to the generalized real -C Schur form of the pair (AW',EW'); -C if JOB = 'C' and DICO = 'D', it contains a quasi-upper -C triangular matrix corresponding to the generalized -C real Schur form of the pair (EW',AW'). -C -C LDEW INTEGER -C The leading dimension of the array EW. -C LDEW >= MAX(1,NW), if JOBEW = 'G'; -C LDEW >= 1, if JOBEW = 'I'. -C -C BW (input/output) DOUBLE PRECISION array, -C dimension (LDBW,MBW), where MBW = MW, if JOB = 'W', and -C MBW = M, if JOB = 'C'. -C On entry, the leading NW-by-MBW part of this array must -C contain the input matrix BW of the system with the -C transfer-function matrix W. -C On exit, if INFO = 0, the leading NW-by-MBW part of this -C array contains Q'*BW, where Q is the orthogonal matrix -C that reduces AW to the real Schur form or the left -C orthogonal matrix used to reduce the pair (AW,EW), -C (AW',EW') or (EW',AW') to the generalized real Schur form. -C -C LDBW INTEGER -C The leading dimension of the array BW. LDBW >= MAX(1,NW). -C -C CW (input/output) DOUBLE PRECISION array, dimension (LDCW,NW) -C On entry, the leading PCW-by-NW part of this array must -C contain the output matrix CW of the system with the -C transfer-function matrix W, where PCW = M if JOB = 'W' or -C PCW = MW if JOB = 'C'. -C On exit, if INFO = 0, the leading PCW-by-NW part of this -C array contains CW*Q, where Q is the orthogonal matrix that -C reduces AW to the real Schur form, or CW*Z, where Z is the -C right orthogonal matrix used to reduce the pair (AW,EW), -C (AW',EW') or (EW',AW') to the generalized real Schur form. -C -C LDCW INTEGER -C The leading dimension of the array CW. -C LDCW >= MAX(1,PCW), where PCW = M if JOB = 'W', or -C PCW = MW if JOB = 'C'. -C -C DW (input) DOUBLE PRECISION array, -C dimension (LDDW,MBW), where MBW = MW if JOB = 'W', and -C MBW = M if JOB = 'C'. -C The leading PCW-by-MBW part of this array must contain -C the feedthrough matrix DW of the system with the -C transfer-function matrix W, where PCW = M if JOB = 'W', -C or PCW = MW if JOB = 'C'. -C -C LDDW INTEGER -C LDDW >= MAX(1,PCW), where PCW = M if JOB = 'W', or -C PCW = MW if JOB = 'C'. -C -C Workspace -C -C IWORK INTEGER array, dimension (LIWORK) -C LIWORK = 0, if JOBEW = 'I'; -C LIWORK = NW+N+6, if JOBEW = 'G'. -C -C DWORK DOUBLE PRECISION array, dimension (LDWORK) -C On exit, if INFO = 0, DWORK(1) returns the optimal value -C of LDWORK. -C -C LDWORK INTEGER -C The length of the array DWORK. -C LDWORK >= LW1, if JOBEW = 'I', -C LDWORK >= LW2, if JOBEW = 'G', where -C LW1 = MAX( 1, NW*(NW+5), NW*N + MAX( a, N*MW, P*MW ) ) -C a = 0, if DICO = 'C' or JOB = 'W', -C a = 2*NW, if DICO = 'D' and JOB = 'C'; -C LW2 = MAX( 2*NW*NW + MAX( 11*NW+16, NW*M, MW*NW ), -C NW*N + MAX( NW*N+N*N, MW*N, P*MW ) ). -C For good performance, LDWORK should be larger. -C -C Error Indicator -C -C INFO INTEGER -C = 0: successful exit; -C < 0: if INFO = -i, the i-th argument had an illegal -C value; -C = 1: the reduction of the pair (AW,EW) to the real -C generalized Schur form failed (JOBEW = 'G'), -C or the reduction of the matrix AW to the real -C Schur form failed (JOBEW = 'I); -C = 2: the solution of the Sylvester equation failed -C because the matrix A and the pencil AW-lambda*EW -C have common eigenvalues (if JOB = 'W'), or the -C pencil -AW-lambda*EW and A have common eigenvalues -C (if JOB = 'C' and DICO = 'C'), or the pencil -C AW-lambda*EW has an eigenvalue which is the -C reciprocal of one of eigenvalues of A -C (if JOB = 'C' and DICO = 'D'); -C = 3: the solution of the Sylvester equation failed -C because the matrices A and AW have common -C eigenvalues (if JOB = 'W'), or the matrices A -C and -AW have common eigenvalues (if JOB = 'C' and -C DICO = 'C'), or the matrix A has an eigenvalue -C which is the reciprocal of one of eigenvalues of AW -C (if JOB = 'C' and DICO = 'D'); -C = 4: JOB = 'W' and the pair (AW,EW) has not completely -C unstable generalized eigenvalues, or JOB = 'C' and -C the pair (AW,EW) has not completely stable -C generalized eigenvalues. -C -C METHOD -C -C If JOB = 'W', the matrices of the stable projection of G*W are -C computed as -C -C BS = B*DW + Y*BW, CS = C, DS = D*DW, -C -C where Y satisfies the generalized Sylvester equation -C -C -A*Y*EW + Y*AW + B*CW = 0. -C -C If JOB = 'C', the matrices of the stable projection of G*conj(W) -C are computed using the following formulas: -C -C - for a continuous-time system, the matrices BS, CS and DS of -C the stable projection are computed as -C -C BS = B*DW' + Y*CW', CS = C, DS = D*DW', -C -C where Y satisfies the generalized Sylvester equation -C -C A*Y*EW' + Y*AW' + B*BW' = 0. -C -C - for a discrete-time system, the matrices BS, CS and DS of -C the stable projection are computed as -C -C BS = B*DW' + A*Y*CW', CS = C, DS = D*DW' + C*Y*CW', -C -C where Y satisfies the generalized Sylvester equation -C -C Y*EW' - A*Y*AW' = B*BW'. -C -C REFERENCES -C -C [1] Varga, A. -C Efficient and numerically reliable implementation of the -C frequency-weighted Hankel-norm approximation model reduction -C approach. -C Proc. 2001 ECC, Porto, Portugal, 2001. -C -C [2] Zhou, K. -C Frequency-weighted H-infinity norm and optimal Hankel norm -C model reduction. -C IEEE Trans. Autom. Control, vol. 40, pp. 1687-1699, 1995. -C -C NUMERICAL ASPECTS -C -C The implemented methods rely on numerically stable algorithms. -C -C CONTRIBUTORS -C -C A. Varga, German Aerospace Center, Oberpfaffenhofen, July 2000. -C D. Sima, University of Bucharest, March 2001. -C V. Sima, Research Institute for Informatics, Bucharest, Mar. 2001. -C -C REVISIONS -C -C A. Varga, German Aerospace Center, Oberpfaffenhofen, May 2001. -C V. Sima, Research Institute for Informatics, Bucharest, June 2001. -C A. Varga, German Aerospace Center, Oberpfaffenhofen, Nov. 2003. -C -C KEYWORDS -C -C Frequency weighting, model reduction, multivariable system, -C state-space model, state-space representation. -C -C ****************************************************************** -C -C .. Parameters .. - DOUBLE PRECISION ZERO, ONE - PARAMETER ( ZERO = 0.0D0, ONE = 1.0D0 ) -C .. Scalar Arguments .. - CHARACTER DICO, JOB, JOBEW, STBCHK - INTEGER INFO, LDA, LDAW, LDB, LDBW, LDC, LDCW, - $ LDD, LDDW, LDEW, LDWORK, M, MW, N, NW, P -C .. Array Arguments .. - INTEGER IWORK(*) - DOUBLE PRECISION A(LDA,*), AW(LDAW,*), B(LDB,*), BW(LDBW,*), - $ C(LDC,*), CW(LDCW,*), D(LDD,*), DW(LDDW,*), - $ DWORK(*), EW(LDEW,*) -C .. Local Scalars .. - CHARACTER*1 EVTYPE, STDOM - LOGICAL CONJS, DISCR, STABCK, UNITEW - DOUBLE PRECISION ALPHA, DIF, SCALE, TOLINF, WORK - INTEGER I, IA, IERR, KAI, KAR, KB, KC, KE, KF, KQ, KW, - $ KZ, LDW, LDWM, LDWN, LDWP, LW, SDIM -C .. Local Arrays .. - LOGICAL BWORK(1) -C .. External Functions .. - LOGICAL DELCTG, LSAME - DOUBLE PRECISION DLAMCH, DLANGE - EXTERNAL DELCTG, DLAMCH, DLANGE, LSAME -C .. External Subroutines .. - EXTERNAL AB09JX, DGEMM, DGGES, DLACPY, DLASET, DSWAP, - $ DTGSYL, DTRSYL, SB04PY, TB01WD, XERBLA -C .. Intrinsic Functions .. - INTRINSIC DBLE, MAX, SQRT -C -C .. Executable Statements .. -C - CONJS = LSAME( JOB, 'C' ) - DISCR = LSAME( DICO, 'D' ) - UNITEW = LSAME( JOBEW, 'I' ) - STABCK = LSAME( STBCHK, 'C' ) -C - INFO = 0 - IF( UNITEW ) THEN - IF ( DISCR .AND. CONJS ) THEN - IA = 2*NW - ELSE - IA = 0 - END IF - LW = MAX( 1, NW*( NW + 5 ), NW*N + MAX( IA, N*MW, P*MW ) ) - ELSE - LW = MAX( 2*NW*NW + MAX( 11*NW+16, NW*M, MW*NW ), - $ NW*N + MAX( NW*N + N*N, MW*N, P*MW ) ) - END IF -C -C Test the input scalar arguments. -C - LDW = MAX( 1, NW ) - LDWM = MAX( 1, MW ) - LDWN = MAX( 1, N ) - LDWP = MAX( 1, P ) - IF( .NOT. ( LSAME( JOB, 'W' ) .OR. CONJS ) ) THEN - INFO = -1 - ELSE IF( .NOT. ( LSAME( DICO, 'C' ) .OR. DISCR ) ) THEN - INFO = -2 - ELSE IF( .NOT. ( LSAME( JOBEW, 'G' ) .OR. UNITEW ) ) THEN - INFO = -3 - ELSE IF( .NOT. ( LSAME( STBCHK, 'N' ) .OR. STABCK ) ) THEN - INFO = -4 - ELSE IF( N.LT.0 ) THEN - INFO = -5 - ELSE IF( M.LT.0 ) THEN - INFO = -6 - ELSE IF( P.LT.0 ) THEN - INFO = -7 - ELSE IF( NW.LT.0 ) THEN - INFO = -8 - ELSE IF( MW.LT.0 ) THEN - INFO = -9 - ELSE IF( LDA.LT.LDWN ) THEN - INFO = -11 - ELSE IF( LDB.LT.LDWN ) THEN - INFO = -13 - ELSE IF( LDC.LT.LDWP ) THEN - INFO = -15 - ELSE IF( LDD.LT.LDWP ) THEN - INFO = -17 - ELSE IF( LDAW.LT.LDW ) THEN - INFO = -19 - ELSE IF( LDEW.LT.1 .OR. ( .NOT.UNITEW .AND. LDEW.LT.NW ) ) THEN - INFO = -21 - ELSE IF( LDBW.LT.LDW ) THEN - INFO = -23 - ELSE IF( ( .NOT.CONJS .AND. LDCW.LT.MAX( 1, M ) ) .OR. - $ ( CONJS .AND. LDCW.LT.LDWM ) ) THEN - INFO = -25 - ELSE IF( ( .NOT.CONJS .AND. LDDW.LT.MAX( 1, M ) ) .OR. - $ ( CONJS .AND. LDDW.LT.LDWM ) ) THEN - INFO = -27 - ELSE IF( LDWORK.LT.LW ) THEN - INFO = -30 - END IF -C - IF( INFO.NE.0 ) THEN -C -C Error return. -C - CALL XERBLA( 'AB09JW', -INFO ) - RETURN - END IF -C -C Quick return if possible. -C - IF( M.EQ.0 ) THEN - CALL DLASET( 'Full', N, MW, ZERO, ZERO, B, LDB ) - CALL DLASET( 'Full', P, MW, ZERO, ZERO, D, LDD ) - DWORK(1) = ONE - RETURN - END IF -C -C Set options for stability/antistability checking. -C - IF( DISCR ) THEN - ALPHA = ONE - ELSE - ALPHA = ZERO - END IF -C - WORK = ONE - TOLINF = DLAMCH( 'Epsilon' ) -C - IF( UNITEW ) THEN -C -C EW is the identity matrix. -C - IF( NW.GT.0 ) THEN -C -C Reduce AW to the real Schur form using an orthogonal -C similarity transformation AW <- Q'*AW*Q and apply the -C transformation to BW and CW: BW <- Q'*BW and CW <- CW*Q. -C -C Workspace needed: NW*(NW+5); -C prefer larger. -C - KW = NW*( NW + 2 ) + 1 - IF( CONJS ) THEN - STDOM = 'S' - ALPHA = ALPHA + SQRT( TOLINF ) - CALL TB01WD( NW, M, MW, AW, LDAW, BW, LDBW, CW, LDCW, - $ DWORK(2*NW+1), NW, DWORK, DWORK(NW+1), - $ DWORK(KW), LDWORK-KW+1, IERR ) - ELSE - STDOM = 'U' - ALPHA = ALPHA - SQRT( TOLINF ) - CALL TB01WD( NW, MW, M, AW, LDAW, BW, LDBW, CW, LDCW, - $ DWORK(2*NW+1), NW, DWORK, DWORK(NW+1), - $ DWORK(KW), LDWORK-KW+1, IERR ) - END IF - IF( IERR.NE.0 ) THEN - INFO = 1 - RETURN - END IF - IF( STABCK ) THEN -C -C Check stability/antistability of eigenvalues of AV. -C - CALL AB09JX( DICO, STDOM, 'S', NW, ALPHA, DWORK, - $ DWORK(NW+1), DWORK, TOLINF, IERR ) - IF( IERR.NE.0 ) THEN - INFO = 4 - RETURN - END IF - END IF -C - WORK = MAX( WORK, DWORK(KW) + DBLE( KW - 1 ) ) -C - END IF -C - KW = NW*N + 1 - IF( CONJS ) THEN -C -C Compute the projection of G*conj(W). -C -C Total workspace needed: NW*N + MAX( a, N*MW, P*MW ), where -C a = 0, if DICO = 'C', -C a = 2*NW, if DICO = 'D'. -C -C Compute -BW*B'. -C Workspace needed: NW*N. -C - CALL DGEMM( 'N', 'T', NW, N, M, -ONE, BW, LDBW, B, LDB, - $ ZERO, DWORK, LDW ) -C - IF( DISCR ) THEN -C -C Compute Y' and SCALE satisfying -C -C AW*Y'*A' - Y' = -SCALE*BW*B'. -C -C Additional workspace needed: 2*NW. -C - CALL SB04PY( 'N', 'T', -1, NW, N, AW, LDAW, A, LDA, - $ DWORK, LDW, SCALE, DWORK(KW), IERR ) - IF( IERR.NE.0 ) THEN - INFO = 3 - RETURN - END IF -C -C Construct BS = B*DW' + A*Y*CW'/SCALE, -C DS = D*DW' + C*Y*CW'/SCALE. -C -C Additional workspace needed: MAX( N*MW, P*MW ). -C -C B <- B*DW'. -C - CALL DGEMM( 'N', 'T', N, MW, M, ONE, B, LDB, DW, LDDW, - $ ZERO, DWORK(KW), LDWN ) - CALL DLACPY( 'Full', N, MW, DWORK(KW), LDWN, B, LDB ) -C -C D <- D*DW'. -C - CALL DGEMM( 'N', 'T', P, MW, M, ONE, D, LDD, DW, LDDW, - $ ZERO, DWORK(KW), LDWP ) - CALL DLACPY( 'Full', P, MW, DWORK(KW), LDWP, D, LDD ) -C -C B <- B + A*Y*CW'/SCALE. -C - CALL DGEMM( 'T', 'T', N, MW, NW, ONE / SCALE, DWORK, LDW, - $ CW, LDCW, ZERO, DWORK(KW), LDWN ) - CALL DGEMM( 'N', 'N', N, MW, N, ONE, A, LDA, - $ DWORK(KW), LDWN, ONE, B, LDB ) -C -C D <- D + C*Y*CW'/SCALE. -C - CALL DGEMM( 'N', 'N', P, MW, N, ONE, C, LDC, - $ DWORK(KW), LDWN, ONE, D, LDD ) - ELSE -C -C Compute Y' and SCALE satisfying -C -C AW*Y' + Y'*A' + SCALE*BW*B' = 0. -C - IF( N.GT.0 ) THEN - CALL DTRSYL( 'N', 'T', 1, NW, N, AW, LDAW, A, LDA, - $ DWORK, LDW, SCALE, IERR ) - IF( IERR.NE.0 ) THEN - INFO = 3 - RETURN - END IF - END IF -C -C Construct BS = B*DW' + Y*CW'/SCALE, -C DS = D*DW'. -C -C Additional workspace needed: MAX( N*MW, P*MW ). -C -C Construct B <- B*DW' + Y*CW'/SCALE. -C - CALL DGEMM( 'N', 'T', N, MW, M, ONE, B, LDB, DW, LDDW, - $ ZERO, DWORK(KW), LDWN ) - CALL DLACPY( 'Full', N, MW, DWORK(KW), LDWN, B, LDB ) - CALL DGEMM( 'T', 'T', N, MW, NW, ONE / SCALE, DWORK, LDW, - $ CW, LDCW, ONE, B, LDB) -C -C D <- D*DW'. -C - CALL DGEMM( 'N', 'T', P, MW, M, ONE, D, LDD, DW, LDDW, - $ ZERO, DWORK(KW), LDWP ) - CALL DLACPY( 'Full', P, MW, DWORK(KW), LDWP, D, LDD ) - END IF - ELSE -C -C Compute the projection of G*W. -C -C Total workspace needed: NW*N + MAX( N*MW, P*MW ). -C -C Compute B*CW. -C Workspace needed: N*NW. -C - CALL DGEMM( 'N', 'N', N, NW, M, ONE, B, LDB, CW, LDCW, - $ ZERO, DWORK, LDWN ) -C -C Compute Y and SCALE satisfying -C -C A*Y - Y*AW - SCALE*B*CW = 0. -C - IF( N.GT.0 ) THEN - CALL DTRSYL( 'N', 'N', -1, N, NW, A, LDA, AW, LDAW, - $ DWORK, LDWN, SCALE, IERR ) - IF( IERR.NE.0 ) THEN - INFO = 3 - RETURN - END IF - END IF -C -C Construct BS = B*DW + Y*BW/SCALE, -C DS = D*DW. -C -C Additional workspace needed: MAX( N*MW, P*MW ). -C Construct B <- B*DW + Y*BW/SCALE. -C - CALL DGEMM( 'N', 'N', N, MW, M, ONE, B, LDB, DW, LDDW, - $ ZERO, DWORK(KW), LDWN ) - CALL DLACPY( 'Full', N, MW, DWORK(KW), LDWN, B, LDB ) - CALL DGEMM( 'N', 'N', N, MW, NW, ONE / SCALE, DWORK, LDWN, - $ BW, LDBW, ONE, B, LDB) -C -C D <- D*DW. -C - CALL DGEMM( 'N', 'N', P, MW, M, ONE, D, LDD, DW, LDDW, - $ ZERO, DWORK(KW), LDWP ) - CALL DLACPY( 'Full', P, MW, DWORK(KW), LDWP, D, LDD ) - END IF - ELSE -C -C EW is a general matrix. -C - IF( NW.GT.0 ) THEN - TOLINF = TOLINF * DLANGE( '1', NW, NW, EW, LDEW, DWORK ) -C -C Reduce (AW,EW), or (AW',EW') or (EW',AW') to a generalized -C real Schur form using an orthogonal equivalence -C transformation and apply the orthogonal transformation -C appropriately to BW and CW, or CW' and BW'. -C -C Workspace needed: 2*NW*NW + MAX( 11*NW+16, NW*M, MW*NW ); -C prefer larger. -C - KQ = 1 - KZ = KQ + NW*NW - KAR = KZ + NW*NW - KAI = KAR + NW - KB = KAI + NW - KW = KB + NW -C - IF( CONJS ) THEN - STDOM = 'S' - ALPHA = ALPHA + SQRT( TOLINF ) -C -C Transpose AW and EW, if non-scalar. -C - DO 10 I = 1, NW - 1 - CALL DSWAP( NW-I, AW(I+1,I), 1, AW(I,I+1), LDAW ) - CALL DSWAP( NW-I, EW(I+1,I), 1, EW(I,I+1), LDEW ) - 10 CONTINUE -C - IF( DISCR ) THEN -C -C Reduce (EW',AW') to a generalized real Schur form -C using orthogonal transformation matrices Q and Z -C such that Q'*EW'*Z results in a quasi-triangular form -C and Q'*AW'*Z results upper triangular. -C Total workspace needed: 2*NW*NW + 11*NW + 16. -C - EVTYPE = 'R' - CALL DGGES( 'Vectors', 'Vectors', 'Not ordered', - $ DELCTG, NW, EW, LDEW, AW, LDAW, SDIM, - $ DWORK(KAR), DWORK(KAI), DWORK(KB), - $ DWORK(KQ), LDW, DWORK(KZ), LDW, - $ DWORK(KW), LDWORK-KW+1, BWORK, IERR ) - ELSE -C -C Reduce (AW',EW') to a generalized real Schur form -C using orthogonal transformation matrices Q and Z -C such that Q'*AW'*Z results in a quasi-triangular form -C and Q'*EW'*Z results upper triangular. -C Total workspace needed: 2*NW*NW + 11*NW + 16. -C - EVTYPE = 'G' - CALL DGGES( 'Vectors', 'Vectors', 'Not ordered', - $ DELCTG, NW, AW, LDAW, EW, LDEW, SDIM, - $ DWORK(KAR), DWORK(KAI), DWORK(KB), - $ DWORK(KQ), LDW, DWORK(KZ), LDW, - $ DWORK(KW), LDWORK-KW+1, BWORK, IERR ) - END IF - IF( IERR.NE.0 ) THEN - INFO = 1 - RETURN - END IF - IF( STABCK ) THEN -C -C Check stability/antistability of generalized -C eigenvalues of the pair (AV,EV). -C - CALL AB09JX( DICO, STDOM, EVTYPE, NW, ALPHA, - $ DWORK(KAR), DWORK(KAI), DWORK(KB), - $ TOLINF, IERR ) - IF( IERR.NE.0 ) THEN - INFO = 4 - RETURN - END IF - END IF - WORK = MAX( WORK, DWORK(KW) + DBLE( KW - 1 ) ) -C -C Compute Z'*BW and CW*Q. -C Total workspace needed: 2*NW*NW + NW*MAX(M,MW). -C - KW = KAR - CALL DLACPY( 'Full', NW, M, BW, LDBW, DWORK(KW), LDW ) - CALL DGEMM( 'T', 'N', NW, M, NW, ONE, DWORK(KZ), LDW, - $ DWORK(KW), LDW, ZERO, BW, LDBW ) - CALL DLACPY( 'Full', MW, NW, CW, LDCW, DWORK(KW), LDWM ) - CALL DGEMM( 'N', 'N', MW, NW, NW, ONE, DWORK(KW), LDWM, - $ DWORK(KQ), LDW, ZERO, CW, LDCW ) - ELSE -C -C Reduce (AW,EW) to a generalized real Schur form -C using orthogonal transformation matrices Q and Z -C such that Q'*AW*Z results in a quasi-triangular form -C and Q'*EW*Z results upper triangular. -C Total workspace needed: 2*NW*NW + 11*NW + 16. -C - STDOM = 'U' - EVTYPE = 'G' - ALPHA = ALPHA - SQRT( TOLINF ) - CALL DGGES( 'Vectors', 'Vectors', 'Not ordered', - $ DELCTG, NW, AW, LDAW, EW, LDEW, SDIM, - $ DWORK(KAR), DWORK(KAI), DWORK(KB), - $ DWORK(KQ), LDW, DWORK(KZ), LDW, - $ DWORK(KW), LDWORK-KW+1, BWORK, IERR ) - IF( IERR.NE.0 ) THEN - INFO = 1 - RETURN - END IF - IF( STABCK ) THEN -C -C Check stability/antistability of generalized -C eigenvalues of the pair (AV,EV). -C - CALL AB09JX( DICO, STDOM, EVTYPE, NW, ALPHA, - $ DWORK(KAR), DWORK(KAI), DWORK(KB), - $ TOLINF, IERR ) - IF( IERR.NE.0 ) THEN - INFO = 4 - RETURN - END IF - END IF - WORK = MAX( WORK, DWORK(KW) + DBLE( KW - 1 ) ) -C -C Compute Q'*BW and CW*Z. -C Total workspace needed: 2*NW*NW + NW*MAX(M,MW). -C - KW = KAR - CALL DLACPY( 'Full', NW, MW, BW, LDBW, DWORK(KW), LDW ) - CALL DGEMM( 'T', 'N', NW, MW, NW, ONE, DWORK(KQ), LDW, - $ DWORK(KW), LDW, ZERO, BW, LDBW ) - CALL DLACPY( 'Full', M, NW, CW, LDCW, DWORK(KW), M ) - CALL DGEMM( 'N', 'N', M, NW, NW, ONE, DWORK(KW), M, - $ DWORK(KZ), LDW, ZERO, CW, LDCW ) - END IF - WORK = MAX( WORK, DBLE( 2*NW*NW + NW*MAX( M, MW ) ) ) -C - END IF -C - KC = 1 - KF = KC + NW*N - KE = KF + NW*N - KW = KE + N*N - CALL DLASET( 'Full', N, NW, ZERO, ZERO, DWORK(KF), LDWN ) -C - IF( CONJS ) THEN -C -C Compute the projection of G*conj(W). -C -C Total workspace needed: NW*N + MAX( NW*N+N*N, MW*N, P*MW ) -C -C Compute B*BW'. -C Workspace needed: N*NW. -C - CALL DGEMM( 'N', 'T', N, NW, M, ONE, B, LDB, BW, LDBW, - $ ZERO, DWORK(KC), LDWN ) -C - IF( DISCR ) THEN -C -C Compute Y and SCALE satisfying -C -C Y*EW' - A*Y*AW' = SCALE*B*BW' by solving equivalently -C -C A*X - Y*EW' = -SCALE*B*BW', -C X - Y*AW' = 0. -C -C Additional workspace needed: -C real N*NW + N*N; -C integer NW+N+6. -C -C - IF( N.GT.0 ) THEN - CALL DLASET( 'Full', N, N, ZERO, ONE, DWORK(KE), LDWN - $ ) - CALL DTGSYL( 'N', 0, N, NW, A, LDA, EW, LDEW, - $ DWORK(KC), LDWN, DWORK(KE), LDWN, AW, - $ LDAW, DWORK(KF), LDWN, SCALE, DIF, - $ DWORK(KW), LDWORK-KW+1, IWORK, IERR ) -C -C Note that the computed solution in DWORK(KC) is -Y. -C - IF( IERR.NE.0 ) THEN - INFO = 2 - RETURN - END IF - END IF -C -C Construct BS = B*DW' + A*Y*CW'/SCALE, -C DS = D*DW' + C*Y*CW'/SCALE. -C -C Additional workspace needed: MAX( N*MW, P*MW ). -C -C B <- B*DW'. -C - CALL DGEMM( 'N', 'T', N, MW, M, ONE, B, LDB, DW, LDDW, - $ ZERO, DWORK(KW), LDWN ) - CALL DLACPY( 'Full', N, MW, DWORK(KW), LDWN, B, LDB ) -C -C D <- D*DW'. -C - CALL DGEMM( 'N', 'T', P, MW, M, ONE, D, LDD, DW, LDDW, - $ ZERO, DWORK(KW), LDWP ) - CALL DLACPY( 'Full', P, MW, DWORK(KW), LDWP, D, LDD ) -C -C B <- B + A*Y*CW'/SCALE. -C - CALL DGEMM( 'N', 'T', N, MW, NW, -ONE / SCALE, - $ DWORK(KF), LDWN, CW, LDCW, ZERO, - $ DWORK(KW), LDWN ) - CALL DGEMM( 'N', 'N', N, MW, N, ONE, A, LDA, - $ DWORK(KW), LDWN, ONE, B, LDB ) -C -C D <- D + C*Y*CW'/SCALE. -C - CALL DGEMM( 'N', 'N', P, MW, N, ONE, C, LDC, - $ DWORK(KW), LDWN, ONE, D, LDD ) - ELSE -C -C Compute Y and SCALE satisfying -C -C A*Y*EW' + Y*AW' + SCALE*B*BW' = 0 by solving equivalently -C -C A*X - Y*AW' = SCALE*B*BW', -C (-I)*X - Y*EW' = 0. -C -C Additional workspace needed: -C real N*NW+N*N; -C integer NW+N+6. -C - IF( N.GT.0 ) THEN - CALL DLASET( 'Full', N, N, ZERO, -ONE, DWORK(KE), LDWN - $ ) - CALL DTGSYL( 'N', 0, N, NW, A, LDA, AW, LDAW, - $ DWORK(KC), LDWN, DWORK(KE), LDWN, EW, - $ LDEW, DWORK(KF), LDWN, SCALE, DIF, - $ DWORK(KW), LDWORK-KW+1, IWORK, IERR ) - IF( IERR.NE.0 ) THEN - INFO = 2 - RETURN - END IF - END IF -C -C Construct BS = B*DW' + Y*CW'/SCALE, -C DS = D*DW'. -C -C Additional workspace needed: MAX( N*MW, P*MW ). -C -C Construct B <- B*DW' + Y*CW'/SCALE. -C - CALL DGEMM( 'N', 'T', N, MW, M, ONE, B, LDB, DW, LDDW, - $ ZERO, DWORK(KW), LDWN ) - CALL DLACPY( 'Full', N, MW, DWORK(KW), LDWN, B, LDB ) - CALL DGEMM( 'N', 'T', N, MW, NW, ONE / SCALE, - $ DWORK(KF), LDWN, CW, LDCW, ONE, B, LDB ) -C -C D <- D*DW'. -C - CALL DGEMM( 'N', 'T', P, MW, M, ONE, D, LDD, DW, LDDW, - $ ZERO, DWORK(KW), LDWP ) - CALL DLACPY( 'Full', P, MW, DWORK(KW), LDWP, D, LDD ) - END IF - ELSE -C -C Compute the projection of G*W. -C -C Total workspace needed: NW*N + MAX( NW*N+N*N, MW*N, P*MW ) -C -C Compute B*CW. -C Workspace needed: N*NW. -C - CALL DGEMM( 'N', 'N', N, NW, M, ONE, B, LDB, CW, LDCW, - $ ZERO, DWORK(KC), LDWN ) -C -C Compute Y and SCALE satisfying -C -C -A*Y*EW + Y*AW + B*CW = 0 by solving equivalently -C -C A*X - Y*AW = SCALE*B*CW, -C X - Y*EW = 0. -C -C Additional workspace needed: -C real N*NW + N*N; -C integer NW+N+6. -C - IF( N.GT.0 ) THEN - CALL DLASET( 'Full', N, N, ZERO, ONE, DWORK(KE), LDWN ) - CALL DTGSYL( 'N', 0, N, NW, A, LDA, AW, LDAW, - $ DWORK(KC), LDWN, DWORK(KE), LDWN, EW, LDEW, - $ DWORK(KF), LDWN, SCALE, DIF, DWORK(KW), - $ LDWORK-KW+1, IWORK, IERR ) - IF( IERR.NE.0 ) THEN - INFO = 2 - RETURN - END IF - END IF -C -C Construct BS = B*DW + Y*BW/SCALE, -C DS = D*DW. -C -C Additional workspace needed: MAX( N*MW, P*MW ). -C Construct B <- B*DW + Y*BW/SCALE. -C - CALL DGEMM( 'N', 'N', N, MW, M, ONE, B, LDB, DW, LDDW, - $ ZERO, DWORK(KW), LDWN ) - CALL DLACPY( 'Full', N, MW, DWORK(KW), LDWN, B, LDB ) - CALL DGEMM( 'N', 'N', N, MW, NW, ONE / SCALE, - $ DWORK(KF), LDWN, BW, LDBW, ONE, B, LDB) -C -C D <- D*DW. -C - CALL DGEMM( 'N', 'N', P, MW, M, ONE, D, LDD, DW, LDDW, - $ ZERO, DWORK(KW), LDWP ) - CALL DLACPY( 'Full', P, MW, DWORK(KW), LDWP, D, LDD ) - END IF - END IF -C - DWORK(1) = MAX( WORK, DBLE( LW ) ) -C - RETURN -C *** Last line of AB09JW *** - END diff --git a/mex/sources/libslicot/AB09JX.f b/mex/sources/libslicot/AB09JX.f deleted file mode 100644 index 68e2c60dd..000000000 --- a/mex/sources/libslicot/AB09JX.f +++ /dev/null @@ -1,253 +0,0 @@ - SUBROUTINE AB09JX( DICO, STDOM, EVTYPE, N, ALPHA, ER, EI, ED, - $ TOLINF, INFO ) -C -C SLICOT RELEASE 5.0. -C -C Copyright (c) 2002-2009 NICONET e.V. -C -C This program is free software: you can redistribute it and/or -C modify it under the terms of the GNU General Public License as -C published by the Free Software Foundation, either version 2 of -C the License, or (at your option) any later version. -C -C This program is distributed in the hope that it will be useful, -C but WITHOUT ANY WARRANTY; without even the implied warranty of -C MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the -C GNU General Public License for more details. -C -C You should have received a copy of the GNU General Public License -C along with this program. If not, see -C . -C -C PURPOSE -C -C To check stability/antistability of finite eigenvalues with -C respect to a given stability domain. -C -C ARGUMENTS -C -C Mode Parameters -C -C DICO CHARACTER*1 -C Specifies the type of the stability domain as follows: -C = 'C': for a continuous-time system; -C = 'D': for a discrete-time system. -C -C STDOM CHARACTER*1 -C Specifies whether the domain of interest is of stability -C type (left part of complex plane or inside of a circle) -C or of instability type (right part of complex plane or -C outside of a circle) as follows: -C = 'S': stability type domain; -C = 'U': instability type domain. -C -C EVTYPE CHARACTER*1 -C Specifies whether the eigenvalues arise from a standard -C or a generalized eigenvalue problem as follows: -C = 'S': standard eigenvalue problem; -C = 'G': generalized eigenvalue problem; -C = 'R': reciprocal generalized eigenvalue problem. -C -C Input/Output Parameters -C -C N (input) INTEGER -C The dimension of vectors ER, EI and ED. N >= 0. -C -C ALPHA (input) DOUBLE PRECISION -C Specifies the boundary of the domain of interest for the -C eigenvalues. For a continuous-time system -C (DICO = 'C'), ALPHA is the boundary value for the real -C parts of eigenvalues, while for a discrete-time system -C (DICO = 'D'), ALPHA >= 0 represents the boundary value for -C the moduli of eigenvalues. -C -C ER, EI, (input) DOUBLE PRECISION arrays, dimension (N) -C ED If EVTYPE = 'S', ER(j) + EI(j)*i, j = 1,...,N, are -C the eigenvalues of a real matrix. -C ED is not referenced and is implicitly considered as -C a vector having all elements equal to one. -C If EVTYPE = 'G' or EVTYPE = 'R', (ER(j) + EI(j)*i)/ED(j), -C j = 1,...,N, are the generalized eigenvalues of a pair of -C real matrices. If ED(j) is zero, then the j-th generalized -C eigenvalue is infinite. -C Complex conjugate pairs of eigenvalues must appear -C consecutively. -C -C Tolerances -C -C TOLINF DOUBLE PRECISION -C If EVTYPE = 'G' or 'R', TOLINF contains the tolerance for -C detecting infinite generalized eigenvalues. -C 0 <= TOLINF < 1. -C -C Error Indicator -C -C INFO INTEGER -C = 0: successful exit, i.e., all eigenvalues lie within -C the domain of interest defined by DICO, STDOM -C and ALPHA; -C < 0: if INFO = -i, the i-th argument had an illegal -C value; -C = 1: some eigenvalues lie outside the domain of interest -C defined by DICO, STDOM and ALPHA. -C METHOD -C -C The domain of interest for an eigenvalue lambda is defined by the -C parameters ALPHA, DICO and STDOM as follows: -C - for a continuous-time system (DICO = 'C'): -C Real(lambda) < ALPHA if STDOM = 'S'; -C Real(lambda) > ALPHA if STDOM = 'U'; -C - for a discrete-time system (DICO = 'D'): -C Abs(lambda) < ALPHA if STDOM = 'S'; -C Abs(lambda) > ALPHA if STDOM = 'U'. -C If EVTYPE = 'R', the same conditions apply for 1/lambda. -C -C CONTRIBUTORS -C -C A. Varga, German Aerospace Center, Oberpfaffenhofen, May 2001. -C -C REVISIONS -C -C V. Sima, Research Institute for Informatics, Bucharest, June 2001. -C -C KEYWORDS -C -C Stability. -C -C ****************************************************************** -C -C .. Parameters .. - DOUBLE PRECISION ZERO, ONE - PARAMETER ( ZERO = 0.0D0, ONE = 1.0D0 ) -C .. Scalar Arguments .. - CHARACTER DICO, EVTYPE, STDOM - INTEGER INFO, N - DOUBLE PRECISION ALPHA, TOLINF -C .. Array Arguments .. - DOUBLE PRECISION ED(*), EI(*), ER(*) -C .. Local Scalars - LOGICAL DISCR, RECEVP, STAB, STDEVP - DOUBLE PRECISION ABSEV, RPEV, SCALE - INTEGER I -C .. External Functions .. - LOGICAL LSAME - DOUBLE PRECISION DLAPY2 - EXTERNAL DLAPY2, LSAME -C .. External Subroutines .. - EXTERNAL XERBLA -C .. Intrinsic Functions .. - INTRINSIC ABS -C .. Executable Statements .. -C - INFO = 0 - DISCR = LSAME( DICO, 'D' ) - STAB = LSAME( STDOM, 'S' ) - STDEVP = LSAME( EVTYPE, 'S' ) - RECEVP = LSAME( EVTYPE, 'R' ) -C -C Check the scalar input arguments. -C - IF( .NOT. ( LSAME( DICO, 'C' ) .OR. DISCR ) ) THEN - INFO = -1 - ELSE IF( .NOT. ( STAB .OR. LSAME( STDOM, 'U' ) ) ) THEN - INFO = -2 - ELSE IF( .NOT. ( STDEVP .OR. LSAME( EVTYPE, 'G' ) .OR. - $ RECEVP ) ) THEN - INFO = -3 - ELSE IF( N.LT.0 ) THEN - INFO = -4 - ELSE IF( DISCR .AND. ALPHA.LT.ZERO ) THEN - INFO = -5 - ELSE IF( TOLINF.LT.ZERO .OR. TOLINF.GE.ONE ) THEN - INFO = -9 - END IF -C - IF( INFO.NE.0 ) THEN -C -C Error return. -C - CALL XERBLA( 'AB09JX', -INFO ) - RETURN - END IF -C -C Quick return if possible. -C - IF( N.EQ.0 ) - $ RETURN -C - IF( STAB ) THEN -C -C Check the stability of finite eigenvalues. -C - SCALE = ONE - IF( DISCR ) THEN - DO 10 I = 1, N - ABSEV = DLAPY2( ER(I), EI(I) ) - IF( RECEVP ) THEN - SCALE = ABSEV - ABSEV = ABS( ED(I) ) - ELSE IF( .NOT.STDEVP ) THEN - SCALE = ED(I) - END IF - IF( ABS( SCALE ).GT.TOLINF .AND. - $ ABSEV.GE.ALPHA*SCALE ) THEN - INFO = 1 - RETURN - END IF - 10 CONTINUE - ELSE - DO 20 I = 1, N - RPEV = ER(I) - IF( RECEVP ) THEN - SCALE = RPEV - RPEV = ED(I) - ELSE IF( .NOT.STDEVP ) THEN - SCALE = ED(I) - END IF - IF( ABS( SCALE ).GT.TOLINF .AND. - $ RPEV.GE.ALPHA*SCALE ) THEN - INFO = 1 - RETURN - END IF - 20 CONTINUE - END IF - ELSE -C -C Check the anti-stability of finite eigenvalues. -C - IF( DISCR ) THEN - DO 30 I = 1, N - ABSEV = DLAPY2( ER(I), EI(I) ) - IF( RECEVP ) THEN - SCALE = ABSEV - ABSEV = ABS( ED(I) ) - ELSE IF( .NOT.STDEVP ) THEN - SCALE = ED(I) - END IF - IF( ABS( SCALE ).GT.TOLINF .AND. - $ ABSEV.LE.ALPHA*SCALE ) THEN - INFO = 1 - RETURN - END IF - 30 CONTINUE - ELSE - DO 40 I = 1, N - RPEV = ER(I) - IF( RECEVP ) THEN - SCALE = RPEV - RPEV = ED(I) - ELSE IF( .NOT.STDEVP ) THEN - SCALE = ED(I) - END IF - IF( ABS( SCALE ).GT.TOLINF .AND. - $ RPEV.LE.ALPHA*SCALE ) THEN - INFO = 1 - RETURN - END IF - 40 CONTINUE - END IF - END IF -C - RETURN -C *** Last line of AB09JX *** - END diff --git a/mex/sources/libslicot/AB09KD.f b/mex/sources/libslicot/AB09KD.f deleted file mode 100644 index d390cfd6b..000000000 --- a/mex/sources/libslicot/AB09KD.f +++ /dev/null @@ -1,864 +0,0 @@ - SUBROUTINE AB09KD( JOB, DICO, WEIGHT, EQUIL, ORDSEL, N, NV, NW, M, - $ P, NR, ALPHA, A, LDA, B, LDB, C, LDC, D, LDD, - $ AV, LDAV, BV, LDBV, CV, LDCV, DV, LDDV, - $ AW, LDAW, BW, LDBW, CW, LDCW, DW, LDDW, - $ NS, HSV, TOL1, TOL2, IWORK, DWORK, LDWORK, - $ IWARN, INFO ) -C -C SLICOT RELEASE 5.0. -C -C Copyright (c) 2002-2009 NICONET e.V. -C -C This program is free software: you can redistribute it and/or -C modify it under the terms of the GNU General Public License as -C published by the Free Software Foundation, either version 2 of -C the License, or (at your option) any later version. -C -C This program is distributed in the hope that it will be useful, -C but WITHOUT ANY WARRANTY; without even the implied warranty of -C MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the -C GNU General Public License for more details. -C -C You should have received a copy of the GNU General Public License -C along with this program. If not, see -C . -C -C PURPOSE -C -C To compute a reduced order model (Ar,Br,Cr,Dr) for an original -C state-space representation (A,B,C,D) by using the frequency -C weighted optimal Hankel-norm approximation method. -C The Hankel norm of the weighted error -C -C V*(G-Gr)*W or conj(V)*(G-Gr)*conj(W) -C -C is minimized, where G and Gr are the transfer-function matrices -C of the original and reduced systems, respectively, and V and W -C are the transfer-function matrices of the left and right frequency -C weights, specified by their state space realizations (AV,BV,CV,DV) -C and (AW,BW,CW,DW), respectively. When minimizing the weighted -C error V*(G-Gr)*W, V and W must be antistable transfer-function -C matrices. When minimizing conj(V)*(G-Gr)*conj(W), V and W must be -C stable transfer-function matrices. -C Additionally, V and W must be invertible transfer-function -C matrices, with the feedthrough matrices DV and DW invertible. -C If the original system is unstable, then the frequency weighted -C Hankel-norm approximation is computed only for the -C ALPHA-stable part of the system. -C -C For a transfer-function matrix G, conj(G) denotes the conjugate -C of G given by G'(-s) for a continuous-time system or G'(1/z) -C for a discrete-time system. -C -C ARGUMENTS -C -C Mode Parameters -C -C JOB CHARACTER*1 -C Specifies the frequency-weighting problem as follows: -C = 'N': solve min||V*(G-Gr)*W||_H; -C = 'C': solve min||conj(V)*(G-Gr)*conj(W)||_H. -C -C DICO CHARACTER*1 -C Specifies the type of the original system as follows: -C = 'C': continuous-time system; -C = 'D': discrete-time system. -C -C WEIGHT CHARACTER*1 -C Specifies the type of frequency weighting, as follows: -C = 'N': no weightings are used (V = I, W = I); -C = 'L': only left weighting V is used (W = I); -C = 'R': only right weighting W is used (V = I); -C = 'B': both left and right weightings V and W are used. -C -C EQUIL CHARACTER*1 -C Specifies whether the user wishes to preliminarily -C equilibrate the triplet (A,B,C) as follows: -C = 'S': perform equilibration (scaling); -C = 'N': do not perform equilibration. -C -C ORDSEL CHARACTER*1 -C Specifies the order selection method as follows: -C = 'F': the resulting order NR is fixed; -C = 'A': the resulting order NR is automatically determined -C on basis of the given tolerance TOL1. -C -C Input/Output Parameters -C -C N (input) INTEGER -C The order of the original state-space representation, -C i.e., the order of the matrix A. N >= 0. -C -C NV (input) INTEGER -C The order of the realization of the left frequency -C weighting V, i.e., the order of the matrix AV. NV >= 0. -C -C NW (input) INTEGER -C The order of the realization of the right frequency -C weighting W, i.e., the order of the matrix AW. NW >= 0. -C -C M (input) INTEGER -C The number of system inputs. M >= 0. -C -C P (input) INTEGER -C The number of system outputs. P >= 0. -C -C NR (input/output) INTEGER -C On entry with ORDSEL = 'F', NR is the desired order of -C the resulting reduced order system. 0 <= NR <= N. -C On exit, if INFO = 0, NR is the order of the resulting -C reduced order model. For a system with NU ALPHA-unstable -C eigenvalues and NS ALPHA-stable eigenvalues (NU+NS = N), -C NR is set as follows: if ORDSEL = 'F', NR is equal to -C NU+MIN(MAX(0,NR-NU-KR+1),NMIN), where KR is the -C multiplicity of the Hankel singular value HSV(NR-NU+1), -C NR is the desired order on entry, and NMIN is the order -C of a minimal realization of the ALPHA-stable part of the -C given system; NMIN is determined as the number of Hankel -C singular values greater than NS*EPS*HNORM(As,Bs,Cs), where -C EPS is the machine precision (see LAPACK Library Routine -C DLAMCH) and HNORM(As,Bs,Cs) is the Hankel norm of the -C ALPHA-stable part of the weighted system (computed in -C HSV(1)); -C if ORDSEL = 'A', NR is the sum of NU and the number of -C Hankel singular values greater than -C MAX(TOL1,NS*EPS*HNORM(As,Bs,Cs)). -C -C ALPHA (input) DOUBLE PRECISION -C Specifies the ALPHA-stability boundary for the eigenvalues -C of the state dynamics matrix A. For a continuous-time -C system (DICO = 'C'), ALPHA <= 0 is the boundary value for -C the real parts of eigenvalues, while for a discrete-time -C system (DICO = 'D'), 0 <= ALPHA <= 1 represents the -C boundary value for the moduli of eigenvalues. -C The ALPHA-stability domain does not include the boundary. -C -C A (input/output) DOUBLE PRECISION array, dimension (LDA,N) -C On entry, the leading N-by-N part of this array must -C contain the state dynamics matrix A. -C On exit, if INFO = 0, the leading NR-by-NR part of this -C array contains the state dynamics matrix Ar of the -C reduced order system in a real Schur form. -C The resulting A has a block-diagonal form with two blocks. -C For a system with NU ALPHA-unstable eigenvalues and -C NS ALPHA-stable eigenvalues (NU+NS = N), the leading -C NU-by-NU block contains the unreduced part of A -C corresponding to ALPHA-unstable eigenvalues. -C The trailing (NR+NS-N)-by-(NR+NS-N) block contains -C the reduced part of A corresponding to ALPHA-stable -C eigenvalues. -C -C LDA INTEGER -C The leading dimension of array A. LDA >= MAX(1,N). -C -C B (input/output) DOUBLE PRECISION array, dimension (LDB,M) -C On entry, the leading N-by-M part of this array must -C contain the original input/state matrix B. -C On exit, if INFO = 0, the leading NR-by-M part of this -C array contains the input/state matrix Br of the reduced -C order system. -C -C LDB INTEGER -C The leading dimension of array B. LDB >= MAX(1,N). -C -C C (input/output) DOUBLE PRECISION array, dimension (LDC,N) -C On entry, the leading P-by-N part of this array must -C contain the original state/output matrix C. -C On exit, if INFO = 0, the leading P-by-NR part of this -C array contains the state/output matrix Cr of the reduced -C order system. -C -C LDC INTEGER -C The leading dimension of array C. LDC >= MAX(1,P). -C -C D (input/output) DOUBLE PRECISION array, dimension (LDD,M) -C On entry, the leading P-by-M part of this array must -C contain the original input/output matrix D. -C On exit, if INFO = 0, the leading P-by-M part of this -C array contains the input/output matrix Dr of the reduced -C order system. -C -C LDD INTEGER -C The leading dimension of array D. LDD >= MAX(1,P). -C -C AV (input/output) DOUBLE PRECISION array, dimension (LDAV,NV) -C On entry, if WEIGHT = 'L' or 'B', the leading NV-by-NV -C part of this array must contain the state matrix AV of a -C state space realization of the left frequency weighting V. -C On exit, if WEIGHT = 'L' or 'B', and INFO = 0, the leading -C NV-by-NV part of this array contains a real Schur form -C of the state matrix of a state space realization of the -C inverse of V. -C AV is not referenced if WEIGHT = 'R' or 'N'. -C -C LDAV INTEGER -C The leading dimension of the array AV. -C LDAV >= MAX(1,NV), if WEIGHT = 'L' or 'B'; -C LDAV >= 1, if WEIGHT = 'R' or 'N'. -C -C BV (input/output) DOUBLE PRECISION array, dimension (LDBV,P) -C On entry, if WEIGHT = 'L' or 'B', the leading NV-by-P part -C of this array must contain the input matrix BV of a state -C space realization of the left frequency weighting V. -C On exit, if WEIGHT = 'L' or 'B', and INFO = 0, the leading -C NV-by-P part of this array contains the input matrix of a -C state space realization of the inverse of V. -C BV is not referenced if WEIGHT = 'R' or 'N'. -C -C LDBV INTEGER -C The leading dimension of the array BV. -C LDBV >= MAX(1,NV), if WEIGHT = 'L' or 'B'; -C LDBV >= 1, if WEIGHT = 'R' or 'N'. -C -C CV (input/output) DOUBLE PRECISION array, dimension (LDCV,NV) -C On entry, if WEIGHT = 'L' or 'B', the leading P-by-NV part -C of this array must contain the output matrix CV of a state -C space realization of the left frequency weighting V. -C On exit, if WEIGHT = 'L' or 'B', and INFO = 0, the leading -C P-by-NV part of this array contains the output matrix of a -C state space realization of the inverse of V. -C CV is not referenced if WEIGHT = 'R' or 'N'. -C -C LDCV INTEGER -C The leading dimension of the array CV. -C LDCV >= MAX(1,P), if WEIGHT = 'L' or 'B'; -C LDCV >= 1, if WEIGHT = 'R' or 'N'. -C -C DV (input/output) DOUBLE PRECISION array, dimension (LDDV,P) -C On entry, if WEIGHT = 'L' or 'B', the leading P-by-P part -C of this array must contain the feedthrough matrix DV of a -C state space realization of the left frequency weighting V. -C On exit, if WEIGHT = 'L' or 'B', and INFO = 0, the leading -C P-by-P part of this array contains the feedthrough matrix -C of a state space realization of the inverse of V. -C DV is not referenced if WEIGHT = 'R' or 'N'. -C -C LDDV INTEGER -C The leading dimension of the array DV. -C LDDV >= MAX(1,P), if WEIGHT = 'L' or 'B'; -C LDDV >= 1, if WEIGHT = 'R' or 'N'. -C -C AW (input/output) DOUBLE PRECISION array, dimension (LDAW,NW) -C On entry, if WEIGHT = 'R' or 'B', the leading NW-by-NW -C part of this array must contain the state matrix AW of -C a state space realization of the right frequency -C weighting W. -C On exit, if WEIGHT = 'R' or 'B', and INFO = 0, the leading -C NW-by-NW part of this array contains a real Schur form of -C the state matrix of a state space realization of the -C inverse of W. -C AW is not referenced if WEIGHT = 'L' or 'N'. -C -C LDAW INTEGER -C The leading dimension of the array AW. -C LDAW >= MAX(1,NW), if WEIGHT = 'R' or 'B'; -C LDAW >= 1, if WEIGHT = 'L' or 'N'. -C -C BW (input/output) DOUBLE PRECISION array, dimension (LDBW,M) -C On entry, if WEIGHT = 'R' or 'B', the leading NW-by-M part -C of this array must contain the input matrix BW of a state -C space realization of the right frequency weighting W. -C On exit, if WEIGHT = 'R' or 'B', and INFO = 0, the leading -C NW-by-M part of this array contains the input matrix of a -C state space realization of the inverse of W. -C BW is not referenced if WEIGHT = 'L' or 'N'. -C -C LDBW INTEGER -C The leading dimension of the array BW. -C LDBW >= MAX(1,NW), if WEIGHT = 'R' or 'B'; -C LDBW >= 1, if WEIGHT = 'L' or 'N'. -C -C CW (input/output) DOUBLE PRECISION array, dimension (LDCW,NW) -C On entry, if WEIGHT = 'R' or 'B', the leading M-by-NW part -C of this array must contain the output matrix CW of a state -C space realization of the right frequency weighting W. -C On exit, if WEIGHT = 'R' or 'B', and INFO = 0, the leading -C M-by-NW part of this array contains the output matrix of a -C state space realization of the inverse of W. -C CW is not referenced if WEIGHT = 'L' or 'N'. -C -C LDCW INTEGER -C The leading dimension of the array CW. -C LDCW >= MAX(1,M), if WEIGHT = 'R' or 'B'; -C LDCW >= 1, if WEIGHT = 'L' or 'N'. -C -C DW (input/output) DOUBLE PRECISION array, dimension (LDDW,M) -C On entry, if WEIGHT = 'R' or 'B', the leading M-by-M part -C of this array must contain the feedthrough matrix DW of -C a state space realization of the right frequency -C weighting W. -C On exit, if WEIGHT = 'R' or 'B', and INFO = 0, the leading -C M-by-M part of this array contains the feedthrough matrix -C of a state space realization of the inverse of W. -C DW is not referenced if WEIGHT = 'L' or 'N'. -C -C LDDW INTEGER -C The leading dimension of the array DW. -C LDDW >= MAX(1,M), if WEIGHT = 'R' or 'B'; -C LDDW >= 1, if WEIGHT = 'L' or 'N'. -C -C NS (output) INTEGER -C The dimension of the ALPHA-stable subsystem. -C -C HSV (output) DOUBLE PRECISION array, dimension (N) -C If INFO = 0, the leading NS elements of this array contain -C the Hankel singular values, ordered decreasingly, of the -C ALPHA-stable part of the weighted original system. -C HSV(1) is the Hankel norm of the ALPHA-stable weighted -C subsystem. -C -C Tolerances -C -C TOL1 DOUBLE PRECISION -C If ORDSEL = 'A', TOL1 contains the tolerance for -C determining the order of reduced system. -C For model reduction, the recommended value is -C TOL1 = c*HNORM(As,Bs,Cs), where c is a constant in the -C interval [0.00001,0.001], and HNORM(As,Bs,Cs) is the -C Hankel-norm of the ALPHA-stable part of the weighted -C original system (computed in HSV(1)). -C If TOL1 <= 0 on entry, the used default value is -C TOL1 = NS*EPS*HNORM(As,Bs,Cs), where NS is the number of -C ALPHA-stable eigenvalues of A and EPS is the machine -C precision (see LAPACK Library Routine DLAMCH). -C If ORDSEL = 'F', the value of TOL1 is ignored. -C -C TOL2 DOUBLE PRECISION -C The tolerance for determining the order of a minimal -C realization of the ALPHA-stable part of the given system. -C The recommended value is TOL2 = NS*EPS*HNORM(As,Bs,Cs). -C This value is used by default if TOL2 <= 0 on entry. -C If TOL2 > 0 and ORDSEL = 'A', then TOL2 <= TOL1. -C -C Workspace -C -C IWORK INTEGER array, dimension (LIWORK) -C LIWORK = MAX(1,M,c), if DICO = 'C', -C LIWORK = MAX(1,N,M,c), if DICO = 'D', -C where c = 0, if WEIGHT = 'N', -C c = 2*P, if WEIGHT = 'L', -C c = 2*M, if WEIGHT = 'R', -C c = MAX(2*M,2*P), if WEIGHT = 'B'. -C On exit, if INFO = 0, IWORK(1) contains NMIN, the order of -C the computed minimal realization. -C -C DWORK DOUBLE PRECISION array, dimension (LDWORK) -C On exit, if INFO = 0, DWORK(1) returns the optimal value -C of LDWORK. -C -C LDWORK INTEGER -C The length of the array DWORK. -C LDWORK >= MAX( LDW1, LDW2, LDW3, LDW4 ), where -C LDW1 = 0 if WEIGHT = 'R' or 'N' and -C LDW1 = MAX( NV*(NV+5), NV*N + MAX( a, P*N, P*M ) ) -C if WEIGHT = 'L' or WEIGHT = 'B', -C LDW2 = 0 if WEIGHT = 'L' or 'N' and -C LDW2 = MAX( NW*(NW+5), NW*N + MAX( b, M*N, P*M ) ) -C if WEIGHT = 'R' or WEIGHT = 'B', with -C a = 0, b = 0, if DICO = 'C' or JOB = 'N', -C a = 2*NV, b = 2*NW, if DICO = 'D' and JOB = 'C'; -C LDW3 = N*(2*N + MAX(N,M,P) + 5) + N*(N+1)/2, -C LDW4 = N*(M+P+2) + 2*M*P + MIN(N,M) + -C MAX( 3*M+1, MIN(N,M)+P ). -C For optimum performance LDWORK should be larger. -C -C Warning Indicator -C -C IWARN INTEGER -C = 0: no warning; -C = 1: with ORDSEL = 'F', the selected order NR is greater -C than NSMIN, the sum of the order of the -C ALPHA-unstable part and the order of a minimal -C realization of the ALPHA-stable part of the given -C system; in this case, the resulting NR is set equal -C to NSMIN; -C = 2: with ORDSEL = 'F', the selected order NR is less -C than the order of the ALPHA-unstable part of the -C given system; in this case NR is set equal to the -C order of the ALPHA-unstable part. -C -C Error Indicator -C -C INFO INTEGER -C = 0: successful exit; -C < 0: if INFO = -i, the i-th argument had an illegal -C value; -C = 1: the computation of the ordered real Schur form of A -C failed; -C = 2: the separation of the ALPHA-stable/unstable -C diagonal blocks failed because of very close -C eigenvalues; -C = 3: the reduction of AV or AV-BV*inv(DV)*CV to a -C real Schur form failed; -C = 4: the reduction of AW or AW-BW*inv(DW)*CW to a -C real Schur form failed; -C = 5: JOB = 'N' and AV is not antistable, or -C JOB = 'C' and AV is not stable; -C = 6: JOB = 'N' and AW is not antistable, or -C JOB = 'C' and AW is not stable; -C = 7: the computation of Hankel singular values failed; -C = 8: the computation of stable projection in the -C Hankel-norm approximation algorithm failed; -C = 9: the order of computed stable projection in the -C Hankel-norm approximation algorithm differs -C from the order of Hankel-norm approximation; -C = 10: DV is singular; -C = 11: DW is singular; -C = 12: the solution of the Sylvester equation failed -C because the zeros of V (if JOB = 'N') or of conj(V) -C (if JOB = 'C') are not distinct from the poles -C of G1sr (see METHOD); -C = 13: the solution of the Sylvester equation failed -C because the zeros of W (if JOB = 'N') or of conj(W) -C (if JOB = 'C') are not distinct from the poles -C of G1sr (see METHOD). -C -C METHOD -C -C Let G be the transfer-function matrix of the original -C linear system -C -C d[x(t)] = Ax(t) + Bu(t) -C y(t) = Cx(t) + Du(t), (1) -C -C where d[x(t)] is dx(t)/dt for a continuous-time system and x(t+1) -C for a discrete-time system. The subroutine AB09KD determines -C the matrices of a reduced order system -C -C d[z(t)] = Ar*z(t) + Br*u(t) -C yr(t) = Cr*z(t) + Dr*u(t), (2) -C -C such that the corresponding transfer-function matrix Gr minimizes -C the Hankel-norm of the frequency-weighted error -C -C V*(G-Gr)*W, (3) -C or -C conj(V)*(G-Gr)*conj(W). (4) -C -C For minimizing (3), V and W are assumed to be antistable, while -C for minimizing (4), V and W are assumed to be stable transfer- -C function matrices. -C -C Note: conj(G) = G'(-s) for a continuous-time system and -C conj(G) = G'(1/z) for a discrete-time system. -C -C The following procedure is used to reduce G (see [1]): -C -C 1) Decompose additively G as -C -C G = G1 + G2, -C -C such that G1 = (A1,B1,C1,D) has only ALPHA-stable poles and -C G2 = (A2,B2,C2,0) has only ALPHA-unstable poles. -C -C 2) Compute G1s, the stable projection of V*G1*W or -C conj(V)*G1*conj(W), using explicit formulas [4]. -C -C 3) Determine G1sr, the optimal Hankel-norm approximation of G1s -C of order r. -C -C 4) Compute G1r, the stable projection of either inv(V)*G1sr*inv(W) -C or conj(inv(V))*G1sr*conj(inv(W)), using explicit formulas [4]. -C -C 5) Assemble the reduced model Gr as -C -C Gr = G1r + G2. -C -C To reduce the weighted ALPHA-stable part G1s at step 3, the -C optimal Hankel-norm approximation method of [2], based on the -C square-root balancing projection formulas of [3], is employed. -C -C The optimal weighted approximation error satisfies -C -C HNORM[V*(G-Gr)*W] = S(r+1), -C or -C HNORM[conj(V)*(G-Gr)*conj(W)] = S(r+1), -C -C where S(r+1) is the (r+1)-th Hankel singular value of G1s, the -C transfer-function matrix computed at step 2 of the above -C procedure, and HNORM(.) denotes the Hankel-norm. -C -C REFERENCES -C -C [1] Latham, G.A. and Anderson, B.D.O. -C Frequency-weighted optimal Hankel-norm approximation of stable -C transfer functions. -C Systems & Control Letters, Vol. 5, pp. 229-236, 1985. -C -C [2] Glover, K. -C All optimal Hankel norm approximation of linear -C multivariable systems and their L-infinity error bounds. -C Int. J. Control, Vol. 36, pp. 1145-1193, 1984. -C -C [3] Tombs M.S. and Postlethwaite I. -C Truncated balanced realization of stable, non-minimal -C state-space systems. -C Int. J. Control, Vol. 46, pp. 1319-1330, 1987. -C -C [4] Varga A. -C Explicit formulas for an efficient implementation -C of the frequency-weighting model reduction approach. -C Proc. 1993 European Control Conference, Groningen, NL, -C pp. 693-696, 1993. -C -C NUMERICAL ASPECTS -C -C The implemented methods rely on an accuracy enhancing square-root -C technique. -C 3 -C The algorithms require less than 30N floating point operations. -C -C CONTRIBUTORS -C -C A. Varga, German Aerospace Center, Oberpfaffenhofen, April 2000. -C D. Sima, University of Bucharest, May 2000. -C V. Sima, Research Institute for Informatics, Bucharest, May 2000. -C Based on the RASP routines SFRLW, SFRLW1, SFRRW and SFRRW1, -C by A. Varga, 1992. -C -C REVISIONS -C -C A. Varga, Australian National University, Canberra, November 2000. -C V. Sima, Research Institute for Informatics, Bucharest, Dec. 2000. -C Oct. 2001, March 2005. -C -C KEYWORDS -C -C Frequency weighting, model reduction, multivariable system, -C state-space model, state-space representation. -C -C ****************************************************************** -C -C .. Parameters .. - DOUBLE PRECISION C100, ONE, ZERO - PARAMETER ( C100 = 100.0D0, ONE = 1.0D0, ZERO = 0.0D0 ) -C .. Scalar Arguments .. - CHARACTER DICO, EQUIL, JOB, ORDSEL, WEIGHT - INTEGER INFO, IWARN, LDA, LDAV, LDAW, LDB, LDBV, LDBW, - $ LDC, LDCV, LDCW, LDD, LDDV, LDDW, LDWORK, M, N, - $ NR, NS, NV, NW, P - DOUBLE PRECISION ALPHA, TOL1, TOL2 -C .. Array Arguments .. - INTEGER IWORK(*) - DOUBLE PRECISION A(LDA,*), AV(LDAV,*), AW(LDAW,*), - $ B(LDB,*), BV(LDBV,*), BW(LDBW,*), - $ C(LDC,*), CV(LDCV,*), CW(LDCW,*), - $ D(LDD,*), DV(LDDV,*), DW(LDDW,*), DWORK(*), - $ HSV(*) -C .. Local Scalars .. - LOGICAL CONJS, DISCR, FIXORD, FRWGHT, LEFTW, RIGHTW - INTEGER IA, IB, IERR, IWARNL, KI, KL, KU, KW, LW, NMIN, - $ NRA, NU, NU1 - DOUBLE PRECISION ALPWRK, MAXRED, RCOND, WRKOPT -C .. External Functions .. - LOGICAL LSAME - DOUBLE PRECISION DLAMCH - EXTERNAL DLAMCH, LSAME -C .. External Subroutines .. - EXTERNAL AB07ND, AB09CX, AB09KX, TB01ID, TB01KD, XERBLA -C .. Intrinsic Functions .. - INTRINSIC DBLE, MAX, MIN, SQRT -C .. Executable Statements .. -C - INFO = 0 - IWARN = 0 - CONJS = LSAME( JOB, 'C' ) - DISCR = LSAME( DICO, 'D' ) - FIXORD = LSAME( ORDSEL, 'F' ) - LEFTW = LSAME( WEIGHT, 'L' ) .OR. LSAME( WEIGHT, 'B' ) - RIGHTW = LSAME( WEIGHT, 'R' ) .OR. LSAME( WEIGHT, 'B' ) - FRWGHT = LEFTW .OR. RIGHTW -C - IF ( DISCR .AND. CONJS ) THEN - IA = 2*NV - IB = 2*NW - ELSE - IA = 0 - IB = 0 - END IF - LW = 1 - IF( LEFTW ) - $ LW = MAX( LW, NV*(NV+5), NV*N + MAX( IA, P*N, P*M ) ) - IF( RIGHTW ) - $ LW = MAX( LW, MAX( NW*(NW+5), NW*N + MAX( IB, M*N, P*M ) ) ) - LW = MAX( LW, N*( 2*N + MAX( N, M, P ) + 5 ) + ( N*( N + 1 ) )/2 ) - LW = MAX( LW, N*( M + P + 2 ) + 2*M*P + MIN( N, M ) + - $ MAX ( 3*M + 1, MIN( N, M ) + P ) ) -C -C Check the input scalar arguments. -C - IF( .NOT. ( LSAME( JOB, 'N' ) .OR. CONJS ) ) THEN - INFO = -1 - ELSE IF( .NOT. ( LSAME( DICO, 'C' ) .OR. DISCR ) ) THEN - INFO = -2 - ELSE IF( .NOT.( FRWGHT .OR. LSAME( WEIGHT, 'N' ) ) ) THEN - INFO = -3 - ELSE IF( .NOT. ( LSAME( EQUIL, 'S' ) .OR. - $ LSAME( EQUIL, 'N' ) ) ) THEN - INFO = -4 - ELSE IF( .NOT. ( FIXORD .OR. LSAME( ORDSEL, 'A' ) ) ) THEN - INFO = -5 - ELSE IF( N.LT.0 ) THEN - INFO = -6 - ELSE IF( NV.LT.0 ) THEN - INFO = -7 - ELSE IF( NW.LT.0 ) THEN - INFO = -8 - ELSE IF( M.LT.0 ) THEN - INFO = -9 - ELSE IF( P.LT.0 ) THEN - INFO = -10 - ELSE IF( FIXORD .AND. ( NR.LT.0 .OR. NR.GT.N ) ) THEN - INFO = -11 - ELSE IF( ( DISCR .AND. ( ALPHA.LT.ZERO .OR. ALPHA.GT.ONE ) ) .OR. - $ ( .NOT.DISCR .AND. ALPHA.GT.ZERO ) ) THEN - INFO = -12 - ELSE IF( LDA.LT.MAX( 1, N ) ) THEN - INFO = -14 - ELSE IF( LDB.LT.MAX( 1, N ) ) THEN - INFO = -16 - ELSE IF( LDC.LT.MAX( 1, P ) ) THEN - INFO = -18 - ELSE IF( LDD.LT.MAX( 1, P ) ) THEN - INFO = -20 - ELSE IF( LDAV.LT.1 .OR. ( LEFTW .AND. LDAV.LT.NV ) ) THEN - INFO = -22 - ELSE IF( LDBV.LT.1 .OR. ( LEFTW .AND. LDBV.LT.NV ) ) THEN - INFO = -24 - ELSE IF( LDCV.LT.1 .OR. ( LEFTW .AND. LDCV.LT.P ) ) THEN - INFO = -26 - ELSE IF( LDDV.LT.1 .OR. ( LEFTW .AND. LDDV.LT.P ) ) THEN - INFO = -28 - ELSE IF( LDAW.LT.1 .OR. ( RIGHTW .AND. LDAW.LT.NW ) ) THEN - INFO = -30 - ELSE IF( LDBW.LT.1 .OR. ( RIGHTW .AND. LDBW.LT.NW ) ) THEN - INFO = -32 - ELSE IF( LDCW.LT.1 .OR. ( RIGHTW .AND. LDCW.LT.M ) ) THEN - INFO = -34 - ELSE IF( LDDW.LT.1 .OR. ( RIGHTW .AND. LDDW.LT.M ) ) THEN - INFO = -36 - ELSE IF( TOL2.GT.ZERO .AND. .NOT.FIXORD .AND. TOL2.GT.TOL1 ) THEN - INFO = -40 - ELSE IF( LDWORK.LT.LW ) THEN - INFO = -43 - END IF -C - IF( INFO.NE.0 ) THEN -C -C Error return. -C - CALL XERBLA( 'AB09KD', -INFO ) - RETURN - END IF -C -C Quick return if possible. -C - IF( MIN( N, M, P ).EQ.0 ) THEN - NR = 0 - NS = 0 - IWORK(1) = 0 - DWORK(1) = ONE - RETURN - END IF -C - IF( LSAME( EQUIL, 'S' ) ) THEN -C -C Scale simultaneously the matrices A, B and C: -C A <- inv(D)*A*D, B <- inv(D)*B and C <- C*D, where D is a -C diagonal matrix. -C Workspace: N. -C - MAXRED = C100 - CALL TB01ID( 'All', N, M, P, MAXRED, A, LDA, B, LDB, C, LDC, - $ DWORK, INFO ) - END IF -C -C Correct the value of ALPHA to ensure stability. -C - ALPWRK = ALPHA - IF( DISCR ) THEN - IF( ALPHA.EQ.ONE ) ALPWRK = ONE - SQRT( DLAMCH( 'E' ) ) - ELSE - IF( ALPHA.EQ.ZERO ) ALPWRK = -SQRT( DLAMCH( 'E' ) ) - END IF -C -C Allocate working storage. -C - KU = 1 - KL = KU + N*N - KI = KL + N - KW = KI + N -C -C Reduce A to a block-diagonal real Schur form, with the -C ALPHA-unstable part in the leading diagonal position, using a -C non-orthogonal similarity transformation, A <- inv(T)*A*T, and -C apply the transformation to B and C: B <- inv(T)*B and C <- C*T. -C -C Workspace needed: N*(N+2); -C Additional workspace: need 3*N; -C prefer larger. -C - CALL TB01KD( DICO, 'Unstable', 'General', N, M, P, ALPWRK, A, LDA, - $ B, LDB, C, LDC, NU, DWORK(KU), N, DWORK(KL), - $ DWORK(KI), DWORK(KW), LDWORK-KW+1, IERR ) -C - IF( IERR.NE.0 ) THEN - IF( IERR.NE.3 ) THEN - INFO = 1 - ELSE - INFO = 2 - END IF - RETURN - END IF -C - WRKOPT = DWORK(KW) + DBLE( KW-1 ) -C -C Compute the stable projection of the weighted ALPHA-stable part. -C -C Workspace: need MAX( 1, LDW1, LDW2 ), -C LDW1 = 0 if WEIGHT = 'R' or 'N' and -C LDW1 = MAX( NV*(NV+5), NV*N + MAX( a, P*N, P*M ) ) -C if WEIGHT = 'L' or 'B', -C LDW2 = 0 if WEIGHT = 'L' or 'N' and -C LDW2 = MAX( NW*(NW+5), NW*N + MAX( b, M*N, P*M ) ) -C if WEIGHT = 'R' or 'B', -C where a = 0, b = 0, if DICO = 'C' or JOB = 'N', -C a = 2*NV, b = 2*NW, if DICO = 'D' and JOB = 'C'; -C prefer larger. -C - NS = N - NU -C -C Finish if only unstable part is present. -C - IF( NS.EQ.0 ) THEN - NR = NU - IWORK(1) = 0 - DWORK(1) = WRKOPT - RETURN - END IF -C - NU1 = NU + 1 - IF( FRWGHT ) THEN - CALL AB09KX( JOB, DICO, WEIGHT, NS, NV, NW, M, P, A(NU1,NU1), - $ LDA, B(NU1,1), LDB, C(1,NU1), LDC, D, LDD, - $ AV, LDAV, BV, LDBV, CV, LDCV, DV, LDDV, - $ AW, LDAW, BW, LDBW, CW, LDCW, DW, LDDW, - $ DWORK, LDWORK, IWARNL, IERR ) -C - IF( IERR.NE.0 ) THEN -C -C Note: Only IERR = 1 or IERR = 2 are possible. -C Set INFO to 3 or 4. -C - INFO = IERR + 2 - RETURN - END IF -C - IF( IWARNL.NE.0 ) THEN -C -C Stability/antistability of V and W are compulsory. -C - IF( IWARNL.EQ.1 .OR. IWARNL.EQ.3 ) THEN - INFO = 5 - ELSE - INFO = 6 - END IF - RETURN - END IF -C - DWORK(1) = MAX( WRKOPT, DWORK(1) ) - END IF -C -C Determine a reduced order approximation of the ALPHA-stable part. -C -C Workspace: need MAX( LDW3, LDW4 ), -C LDW3 = N*(2*N + MAX(N,M,P) + 5) + N*(N+1)/2, -C LDW4 = N*(M+P+2) + 2*M*P + MIN(N,M) + -C MAX( 3*M+1, MIN(N,M)+P ); -C prefer larger. -C - IWARNL = 0 - IF( FIXORD ) THEN - NRA = MAX( 0, NR - NU ) - IF( NRA.EQ.0 ) - $ IWARNL = 2 - ELSE - NRA = 0 - END IF - CALL AB09CX( DICO, ORDSEL, NS, M, P, NRA, A(NU1,NU1), LDA, - $ B(NU1,1), LDB, C(1,NU1), LDC, D, LDD, HSV, TOL1, - $ TOL2, IWORK, DWORK, LDWORK, IWARN, IERR ) -C - IWARN = MAX( IWARN, IWARNL ) - IF( IERR.NE.0 ) THEN -C -C Set INFO = 7, 8 or 9. -C - INFO = IERR + 5 - RETURN - END IF -C - WRKOPT = MAX( WRKOPT, DWORK(1) ) - NMIN = IWORK(1) -C -C Compute the state space realizations of the inverses of V and W. -C -C Integer workspace: need c, -C Real workspace: need MAX(1,2*c), -C where c = 0, if WEIGHT = 'N', -C c = 2*P, if WEIGHT = 'L', -C c = 2*M, if WEIGHT = 'R', -C c = MAX(2*M,2*P), if WEIGHT = 'B'. -C - IF( LEFTW ) THEN - CALL AB07ND( NV, P, AV, LDAV, BV, LDBV, CV, LDCV, DV, LDDV, - $ RCOND, IWORK, DWORK, LDWORK, IERR ) - IF( IERR.NE.0 ) THEN - INFO = 10 - RETURN - END IF - END IF - IF( RIGHTW ) THEN - CALL AB07ND( NW, M, AW, LDAW, BW, LDBW, CW, LDCW, DW, LDDW, - $ RCOND, IWORK, DWORK, LDWORK, IERR ) - IF( IERR.NE.0 ) THEN - INFO = 11 - RETURN - END IF - END IF -C - WRKOPT = MAX( WRKOPT, DWORK(1) ) -C -C Compute the stable projection of weighted reduced ALPHA-stable -C part. -C - IF( FRWGHT ) THEN - CALL AB09KX( JOB, DICO, WEIGHT, NRA, NV, NW, M, P, A(NU1,NU1), - $ LDA, B(NU1,1), LDB, C(1,NU1), LDC, D, LDD, - $ AV, LDAV, BV, LDBV, CV, LDCV, DV, LDDV, - $ AW, LDAW, BW, LDBW, CW, LDCW, DW, LDDW, - $ DWORK, LDWORK, IWARNL, IERR ) -C - IF( IERR.NE.0 ) THEN - IF( IERR.LE.2 ) THEN -C -C Set INFO to 3 or 4. -C - INFO = IERR + 2 - ELSE -C -C Set INFO to 12 or 13. -C - INFO = IERR + 9 - END IF - RETURN - END IF - END IF -C - NR = NRA + NU - IWORK(1) = NMIN - DWORK(1) = MAX( WRKOPT, DWORK(1) ) -C - RETURN -C *** Last line of AB09KD *** - END diff --git a/mex/sources/libslicot/AB09KX.f b/mex/sources/libslicot/AB09KX.f deleted file mode 100644 index 5ac044c76..000000000 --- a/mex/sources/libslicot/AB09KX.f +++ /dev/null @@ -1,869 +0,0 @@ - SUBROUTINE AB09KX( JOB, DICO, WEIGHT, N, NV, NW, M, P, - $ A, LDA, B, LDB, C, LDC, D, LDD, - $ AV, LDAV, BV, LDBV, CV, LDCV, DV, LDDV, - $ AW, LDAW, BW, LDBW, CW, LDCW, DW, LDDW, - $ DWORK, LDWORK, IWARN, INFO ) -C -C SLICOT RELEASE 5.0. -C -C Copyright (c) 2002-2009 NICONET e.V. -C -C This program is free software: you can redistribute it and/or -C modify it under the terms of the GNU General Public License as -C published by the Free Software Foundation, either version 2 of -C the License, or (at your option) any later version. -C -C This program is distributed in the hope that it will be useful, -C but WITHOUT ANY WARRANTY; without even the implied warranty of -C MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the -C GNU General Public License for more details. -C -C You should have received a copy of the GNU General Public License -C along with this program. If not, see -C . -C -C PURPOSE -C -C To construct a state-space representation (A,BS,CS,DS) of the -C stable projection of V*G*W or conj(V)*G*conj(W) from the -C state-space representations (A,B,C,D), (AV,BV,CV,DV), and -C (AW,BW,CW,DW) of the transfer-function matrices G, V and W, -C respectively. G is assumed to be a stable transfer-function -C matrix and the state matrix A must be in a real Schur form. -C When computing the stable projection of V*G*W, V and W are assumed -C to be completely unstable transfer-function matrices. -C When computing the stable projection of conj(V)*G*conj(W), -C V and W are assumed to be stable transfer-function matrices. -C -C For a transfer-function matrix G, conj(G) denotes the conjugate -C of G given by G'(-s) for a continuous-time system or G'(1/z) -C for a discrete-time system. -C -C ARGUMENTS -C -C Mode Parameters -C -C JOB CHARACTER*1 -C Specifies which projection to be computed as follows: -C = 'N': compute the stable projection of V*G*W; -C = 'C': compute the stable projection of -C conj(V)*G*conj(W). -C -C DICO CHARACTER*1 -C Specifies the type of the systems as follows: -C = 'C': G, V and W are continuous-time systems; -C = 'D': G, V and W are discrete-time systems. -C -C WEIGHT CHARACTER*1 -C Specifies the type of frequency weighting, as follows: -C = 'N': no weightings are used (V = I, W = I); -C = 'L': only left weighting V is used (W = I); -C = 'R': only right weighting W is used (V = I); -C = 'B': both left and right weightings V and W are used. -C -C Input/Output Parameters -C -C N (input) INTEGER -C The order of the matrix A. Also the number of rows of -C the matrix B and the number of columns of the matrix C. -C N represents the dimension of the state vector of the -C system with the transfer-function matrix G. N >= 0. -C -C NV (input) INTEGER -C The order of the matrix AV. Also the number of rows of -C the matrix BV and the number of columns of the matrix CV. -C NV represents the dimension of the state vector of the -C system with the transfer-function matrix V. NV >= 0. -C -C NW (input) INTEGER -C The order of the matrix AW. Also the number of rows of -C the matrix BW and the number of columns of the matrix CW. -C NW represents the dimension of the state vector of the -C system with the transfer-function matrix W. NW >= 0. -C -C M (input) INTEGER -C The number of columns of the matrices B, D, BW and DW -C and number of rows of the matrices CW and DW. M >= 0. -C M represents the dimension of input vectors of the -C systems with the transfer-function matrices G and W and -C also the dimension of the output vector of the system -C with the transfer-function matrix W. -C -C P (input) INTEGER -C The number of rows of the matrices C, D, CV and DV and the -C number of columns of the matrices BV and DV. P >= 0. -C P represents the dimension of output vectors of the -C systems with the transfer-function matrices G and V and -C also the dimension of the input vector of the system -C with the transfer-function matrix V. -C -C A (input) DOUBLE PRECISION array, dimension (LDA,N) -C The leading N-by-N part of this array must -C contain the state matrix A of the system with the -C transfer-function matrix G in a real Schur form. -C -C LDA INTEGER -C The leading dimension of the array A. LDA >= MAX(1,N). -C -C B (input/output) DOUBLE PRECISION array, dimension (LDB,M) -C On entry, the leading N-by-M part of this array must -C contain the input matrix B of the system with the -C transfer-function matrix G. -C On exit, if INFO = 0, the leading N-by-M part of this -C array contains the input matrix BS of the stable -C projection of V*G*W if JOB = 'N', and of conj(V)*G*conj(W) -C if JOB = 'C'. -C -C LDB INTEGER -C The leading dimension of the array B. LDB >= MAX(1,N). -C -C C (input/output) DOUBLE PRECISION array, dimension (LDC,N) -C On entry, the leading P-by-N part of this array must -C contain the output matrix C of the system with the -C transfer-function matrix G. -C On exit, if INFO = 0, the leading P-by-N part of this -C array contains the output matrix CS of the stable -C projection of V*G*W if JOB = 'N', and of conj(V)*G*conj(W) -C if JOB = 'C'. -C -C LDC INTEGER -C The leading dimension of the array C. LDC >= MAX(1,P). -C -C D (input/output) DOUBLE PRECISION array, dimension (LDD,M) -C On entry, the leading P-by-M part of this array must -C contain the feedthrough matrix D of the system with the -C transfer-function matrix G. -C On exit, if INFO = 0, the leading P-by-M part of this -C array contains the feedthrough matrix DS of the stable -C projection of V*G*W if JOB = 'N', and of conj(V)*G*conj(W) -C if JOB = 'C'. -C -C LDD INTEGER -C The leading dimension of the array D. LDD >= MAX(1,P). -C -C AV (input/output) DOUBLE PRECISION array, dimension (LDAV,NV) -C On entry, if WEIGHT = 'L' or 'B', the leading NV-by-NV -C part of this array must contain the state matrix AV of -C the system with the transfer-function matrix V. -C On exit, if WEIGHT = 'L' or 'B', and INFO = 0, the leading -C NV-by-NV part of this array contains a real Schur form -C of AV. -C AV is not referenced if WEIGHT = 'R' or 'N'. -C -C LDAV INTEGER -C The leading dimension of the array AV. -C LDAV >= MAX(1,NV), if WEIGHT = 'L' or 'B'; -C LDAV >= 1, if WEIGHT = 'R' or 'N'. -C -C BV (input/output) DOUBLE PRECISION array, dimension (LDBV,P) -C On entry, if WEIGHT = 'L' or 'B', the leading NV-by-P part -C of this array must contain the input matrix BV of the -C system with the transfer-function matrix V. -C On exit, if WEIGHT = 'L' or 'B', and INFO = 0, the leading -C NV-by-P part of this array contains the transformed input -C matrix BV. -C BV is not referenced if WEIGHT = 'R' or 'N'. -C -C LDBV INTEGER -C The leading dimension of the array BV. -C LDBV >= MAX(1,NV), if WEIGHT = 'L' or 'B'; -C LDBV >= 1, if WEIGHT = 'R' or 'N'. -C -C CV (input/output) DOUBLE PRECISION array, dimension (LDCV,NV) -C On entry, if WEIGHT = 'L' or 'B', the leading P-by-NV part -C of this array must contain the output matrix CV of the -C system with the transfer-function matrix V. -C On exit, if WEIGHT = 'L' or 'B', and INFO = 0, the leading -C P-by-NV part of this array contains the transformed output -C matrix CV. -C CV is not referenced if WEIGHT = 'R' or 'N'. -C -C LDCV INTEGER -C The leading dimension of the array CV. -C LDCV >= MAX(1,P), if WEIGHT = 'L' or 'B'; -C LDCV >= 1, if WEIGHT = 'R' or 'N'. -C -C DV (input) DOUBLE PRECISION array, dimension (LDDV,P) -C If WEIGHT = 'L' or 'B', the leading P-by-P part of this -C array must contain the feedthrough matrix DV of the system -C with the transfer-function matrix V. -C DV is not referenced if WEIGHT = 'R' or 'N'. -C -C LDDV INTEGER -C The leading dimension of the array DV. -C LDDV >= MAX(1,P), if WEIGHT = 'L' or 'B'; -C LDDV >= 1, if WEIGHT = 'R' or 'N'. -C -C AW (input/output) DOUBLE PRECISION array, dimension (LDAW,NW) -C On entry, if WEIGHT = 'R' or 'B', the leading NW-by-NW -C part of this array must contain the state matrix AW of -C the system with the transfer-function matrix W. -C On exit, if WEIGHT = 'R' or 'B', and INFO = 0, the leading -C NW-by-NW part of this array contains a real Schur form -C of AW. -C AW is not referenced if WEIGHT = 'L' or 'N'. -C -C LDAW INTEGER -C The leading dimension of the array AW. -C LDAW >= MAX(1,NW), if WEIGHT = 'R' or 'B'; -C LDAW >= 1, if WEIGHT = 'L' or 'N'. -C -C BW (input/output) DOUBLE PRECISION array, dimension (LDBW,M) -C On entry, if WEIGHT = 'R' or 'B', the leading NW-by-M part -C of this array must contain the input matrix BW of the -C system with the transfer-function matrix W. -C On exit, if WEIGHT = 'R' or 'B', and INFO = 0, the leading -C NW-by-M part of this array contains the transformed input -C matrix BW. -C BW is not referenced if WEIGHT = 'L' or 'N'. -C -C LDBW INTEGER -C The leading dimension of the array BW. -C LDBW >= MAX(1,NW), if WEIGHT = 'R' or 'B'; -C LDBW >= 1, if WEIGHT = 'L' or 'N'. -C -C CW (input/output) DOUBLE PRECISION array, dimension (LDCW,NW) -C On entry, if WEIGHT = 'R' or 'B', the leading M-by-NW part -C of this array must contain the output matrix CW of the -C system with the transfer-function matrix W. -C On exit, if WEIGHT = 'R' or 'B', and INFO = 0, the leading -C M-by-NW part of this array contains the transformed output -C matrix CW. -C CW is not referenced if WEIGHT = 'L' or 'N'. -C -C LDCW INTEGER -C The leading dimension of the array CW. -C LDCW >= MAX(1,M), if WEIGHT = 'R' or 'B'; -C LDCW >= 1, if WEIGHT = 'L' or 'N'. -C -C DW (input) DOUBLE PRECISION array, dimension (LDDW,M) -C If WEIGHT = 'R' or 'B', the leading M-by-M part of this -C array must contain the feedthrough matrix DW of the system -C with the transfer-function matrix W. -C DW is not referenced if WEIGHT = 'L' or 'N'. -C -C LDDW INTEGER -C The leading dimension of the array DW. -C LDDW >= MAX(1,M), if WEIGHT = 'R' or 'B'; -C LDDW >= 1, if WEIGHT = 'L' or 'N'. -C -C Workspace -C -C DWORK DOUBLE PRECISION array, dimension (LDWORK) -C On exit, if INFO = 0, DWORK(1) returns the optimal value -C of LDWORK. -C -C LDWORK INTEGER -C The length of the array DWORK. -C LDWORK >= MAX( 1, LDW1, LDW2 ), where -C LDW1 = 0 if WEIGHT = 'R' or 'N' and -C LDW1 = MAX( NV*(NV+5), NV*N + MAX( a, P*N, P*M ) ) -C if WEIGHT = 'L' or WEIGHT = 'B', -C LDW2 = 0 if WEIGHT = 'L' or 'N' and -C LDW2 = MAX( NW*(NW+5), NW*N + MAX( b, M*N, P*M ) ) -C if WEIGHT = 'R' or WEIGHT = 'B', -C a = 0, b = 0, if DICO = 'C' or JOB = 'N', -C a = 2*NV, b = 2*NW, if DICO = 'D' and JOB = 'C'. -C For good performance, LDWORK should be larger. -C -C Warning Indicator -C -C IWARN INTEGER -C = 0: no warning; -C = 1: JOB = 'N' and AV is not completely unstable, or -C JOB = 'C' and AV is not stable; -C = 2: JOB = 'N' and AW is not completely unstable, or -C JOB = 'C' and AW is not stable; -C = 3: both above conditions appear. -C -C Error Indicator -C -C INFO INTEGER -C = 0: successful exit; -C < 0: if INFO = -i, the i-th argument had an illegal -C value; -C = 1: the reduction of AV to a real Schur form failed; -C = 2: the reduction of AW to a real Schur form failed; -C = 3: the solution of the Sylvester equation failed -C because the matrices A and AV have common -C eigenvalues (if JOB = 'N'), or -AV and A have -C common eigenvalues (if JOB = 'C' and DICO = 'C'), -C or AV has an eigenvalue which is the reciprocal of -C one of the eigenvalues of A (if JOB = 'C' and -C DICO = 'D'); -C = 4: the solution of the Sylvester equation failed -C because the matrices A and AW have common -C eigenvalues (if JOB = 'N'), or -AW and A have -C common eigenvalues (if JOB = 'C' and DICO = 'C'), -C or AW has an eigenvalue which is the reciprocal of -C one of the eigenvalues of A (if JOB = 'C' and -C DICO = 'D'). -C -C METHOD -C -C The matrices of the stable projection of V*G*W are computed as -C -C BS = B*DW + Y*BW, CS = CV*X + DV*C, DS = DV*D*DW, -C -C where X and Y satisfy the continuous-time Sylvester equations -C -C AV*X - X*A + BV*C = 0, -C -A*Y + Y*AW + B*CW = 0. -C -C The matrices of the stable projection of conj(V)*G*conj(W) are -C computed using the explicit formulas established in [1]. -C -C For a continuous-time system, the matrices BS, CS and DS of -C the stable projection are computed as -C -C BS = B*DW' + Y*CW', CS = BV'*X + DV'*C, DS = DV'*D*DW', -C -C where X and Y satisfy the continuous-time Sylvester equations -C -C AV'*X + X*A + CV'*C = 0, -C A*Y + Y*AW' + B*BW' = 0. -C -C For a discrete-time system, the matrices BS, CS and DS of -C the stable projection are computed as -C -C BS = B*DW' + A*Y*CW', CS = BV'*X*A + DV'*C, -C DS = DV'*D*DW' + BV'*X*B*DW' + DV'*C*Y*CW' + BV'*X*A*Y*CW', -C -C where X and Y satisfy the discrete-time Sylvester equations -C -C AV'*X*A + CV'*C = X, -C A*Y*AW' + B*BW' = Y. -C -C REFERENCES -C -C [1] Varga A. -C Explicit formulas for an efficient implementation -C of the frequency-weighting model reduction approach. -C Proc. 1993 European Control Conference, Groningen, NL, -C pp. 693-696, 1993. -C -C NUMERICAL ASPECTS -C -C The implemented methods rely on numerically stable algorithms. -C -C FURTHER COMMENTS -C -C The matrix A must be stable, but its stability is not checked by -C this routine. -C -C CONTRIBUTORS -C -C A. Varga, German Aerospace Center, Oberpfaffenhofen, April 2000. -C D. Sima, University of Bucharest, May 2000. -C V. Sima, Research Institute for Informatics, Bucharest, May 2000. -C Based on the RASP routines SFRLW, SFRLW1, SFRRW and SFRRW1, -C by A. Varga, 1992. -C -C REVISIONS -C -C - -C -C KEYWORDS -C -C Frequency weighting, model reduction, multivariable system, -C state-space model, state-space representation. -C -C ****************************************************************** -C -C .. Parameters .. - DOUBLE PRECISION ZERO, ONE - PARAMETER ( ZERO = 0.0D0, ONE = 1.0D0 ) -C .. Scalar Arguments .. - CHARACTER DICO, JOB, WEIGHT - INTEGER INFO, IWARN, LDA, LDAV, LDAW, LDB, LDBV, LDBW, - $ LDC, LDCV, LDCW, LDD, LDDV, LDDW, LDWORK, M, N, - $ NV, NW, P -C .. Array Arguments .. - DOUBLE PRECISION A(LDA,*), B(LDB,*), C(LDC,*), D(LDD,*), - $ AV(LDAV,*), BV(LDBV,*), CV(LDCV,*), DV(LDDV,*), - $ AW(LDAW,*), BW(LDBW,*), CW(LDCW,*), DW(LDDW,*), - $ DWORK(*) -C .. Local Scalars - LOGICAL CONJS, DISCR, FRWGHT, LEFTW, RIGHTW - DOUBLE PRECISION SCALE, WORK - INTEGER I, IA, IB, IERR, KW, LDW, LDWN, LW -C .. External Functions .. - LOGICAL LSAME - DOUBLE PRECISION DLAPY2 - EXTERNAL DLAPY2, LSAME -C .. External Subroutines .. - EXTERNAL DGEMM, DLACPY, DTRSYL, SB04PY, TB01WD, XERBLA -C .. Executable Statements .. -C - CONJS = LSAME( JOB, 'C' ) - DISCR = LSAME( DICO, 'D' ) - LEFTW = LSAME( WEIGHT, 'L' ) .OR. LSAME( WEIGHT, 'B' ) - RIGHTW = LSAME( WEIGHT, 'R' ) .OR. LSAME( WEIGHT, 'B' ) - FRWGHT = LEFTW .OR. RIGHTW -C - IWARN = 0 - INFO = 0 - IF ( DISCR .AND. CONJS ) THEN - IA = 2*NV - IB = 2*NW - ELSE - IA = 0 - IB = 0 - END IF - LW = 1 - IF( LEFTW ) - $ LW = MAX( LW, NV*( NV + 5 ), NV*N + MAX( IA, P*N, P*M ) ) - IF( RIGHTW ) - $ LW = MAX( LW, NW*( NW + 5 ), NW*N + MAX( IB, M*N, P*M ) ) -C -C Test the input scalar arguments. -C - IF( .NOT. ( LSAME( JOB, 'N' ) .OR. CONJS ) ) THEN - INFO = -1 - ELSE IF( .NOT. ( LSAME( DICO, 'C' ) .OR. DISCR ) ) THEN - INFO = -2 - ELSE IF( .NOT.( FRWGHT .OR. LSAME( WEIGHT, 'N' ) ) ) THEN - INFO = -3 - ELSE IF( N.LT.0 ) THEN - INFO = -4 - ELSE IF( NV.LT.0 ) THEN - INFO = -5 - ELSE IF( NW.LT.0 ) THEN - INFO = -6 - ELSE IF( M.LT.0 ) THEN - INFO = -7 - ELSE IF( P.LT.0 ) THEN - INFO = -8 - ELSE IF( LDA.LT.MAX( 1, N ) ) THEN - INFO = -10 - ELSE IF( LDB.LT.MAX( 1, N ) ) THEN - INFO = -12 - ELSE IF( LDC.LT.MAX( 1, P ) ) THEN - INFO = -14 - ELSE IF( LDD.LT.MAX( 1, P ) ) THEN - INFO = -16 - ELSE IF( LDAV.LT.1 .OR. ( LEFTW .AND. LDAV.LT.NV ) ) THEN - INFO = -18 - ELSE IF( LDBV.LT.1 .OR. ( LEFTW .AND. LDBV.LT.NV ) ) THEN - INFO = -20 - ELSE IF( LDCV.LT.1 .OR. ( LEFTW .AND. LDCV.LT.P ) ) THEN - INFO = -22 - ELSE IF( LDDV.LT.1 .OR. ( LEFTW .AND. LDDV.LT.P ) ) THEN - INFO = -24 - ELSE IF( LDAW.LT.1 .OR. ( RIGHTW .AND. LDAW.LT.NW ) ) THEN - INFO = -26 - ELSE IF( LDBW.LT.1 .OR. ( RIGHTW .AND. LDBW.LT.NW ) ) THEN - INFO = -28 - ELSE IF( LDCW.LT.1 .OR. ( RIGHTW .AND. LDCW.LT.M ) ) THEN - INFO = -30 - ELSE IF( LDDW.LT.1 .OR. ( RIGHTW .AND. LDDW.LT.M ) ) THEN - INFO = -32 - ELSE IF( LDWORK.LT.LW ) THEN - INFO = -34 - END IF -C - IF( INFO.NE.0 ) THEN -C -C Error return. -C - CALL XERBLA( 'AB09KX', -INFO ) - RETURN - END IF -C -C Quick return if possible. -C - IF( .NOT.FRWGHT .OR. MIN( M, P ).EQ.0 ) THEN - DWORK(1) = ONE - RETURN - END IF -C - WORK = ONE - IF( LEFTW .AND. NV.GT.0 ) THEN -C -C Reduce AV to a real Schur form using an orthogonal similarity -C transformation AV <- Q'*AV*Q and apply the transformation to -C BV and CV: BV <- Q'*BV and CV <- CV*Q. -C -C Workspace needed: NV*(NV+5); -C prefer larger. -C - KW = NV*( NV + 2 ) + 1 - CALL TB01WD( NV, P, P, AV, LDAV, BV, LDBV, CV, LDCV, - $ DWORK(2*NV+1), NV, DWORK, DWORK(NV+1), DWORK(KW), - $ LDWORK-KW+1, IERR ) - IF( IERR.NE.0 ) THEN - INFO = 1 - RETURN - END IF - WORK = MAX( WORK, DWORK(KW) + DBLE( KW - 1 ) ) -C - IF( CONJS ) THEN -C -C Check the stability of the eigenvalues of AV. -C - IF ( DISCR ) THEN - DO 10 I = 1, NV - IF( DLAPY2( DWORK(I), DWORK(NV+I) ).GE.ONE) THEN - IWARN = 1 - GO TO 50 - END IF - 10 CONTINUE - ELSE - DO 20 I = 1, NV - IF( DWORK(I).GE.ZERO ) THEN - IWARN = 1 - GO TO 50 - END IF - 20 CONTINUE - END IF - ELSE -C -C Check the anti-stability of the eigenvalues of AV. -C - IF ( DISCR ) THEN - DO 30 I = 1, NV - IF( DLAPY2( DWORK(I), DWORK(NV+I) ).LE.ONE) THEN - IWARN = 1 - GO TO 50 - END IF - 30 CONTINUE - ELSE - DO 40 I = 1, NV - IF( DWORK(I).LE.ZERO ) THEN - IWARN = 1 - GO TO 50 - END IF - 40 CONTINUE - END IF - END IF - 50 CONTINUE -C - END IF -C - IF( RIGHTW .AND. NW.GT.0 ) THEN -C -C Reduce AW to a real Schur form using an orthogonal similarity -C transformation AW <- T'*AW*T and apply the transformation to -C BW and CW: BW <- T'*BW and CW <- CW*T. -C -C Workspace needed: NW*(NW+5); -C prefer larger. -C - KW = NW*( NW + 2 ) + 1 - CALL TB01WD( NW, M, M, AW, LDAW, BW, LDBW, CW, LDCW, - $ DWORK(2*NW+1), NW, DWORK, DWORK(NW+1), DWORK(KW), - $ LDWORK-KW+1, IERR ) - IF( IERR.NE.0 ) THEN - INFO = 2 - RETURN - END IF - WORK = MAX( WORK, DWORK(KW) + DBLE( KW - 1 ) ) -C - IF( CONJS ) THEN -C -C Check the stability of the eigenvalues of AW. -C - IF ( DISCR ) THEN - DO 60 I = 1, NW - IF( DLAPY2( DWORK(I), DWORK(NW+I) ).GE.ONE) THEN - IWARN = IWARN + 2 - GO TO 100 - END IF - 60 CONTINUE - ELSE - DO 70 I = 1, NW - IF( DWORK(I).GE.ZERO ) THEN - IWARN = IWARN + 2 - GO TO 100 - END IF - 70 CONTINUE - END IF - ELSE -C -C Check the anti-stability of the eigenvalues of AW. -C - IF ( DISCR ) THEN - DO 80 I = 1, NW - IF( DLAPY2( DWORK(I), DWORK(NW+I) ).LE.ONE) THEN - IWARN = IWARN + 2 - GO TO 100 - END IF - 80 CONTINUE - ELSE - DO 90 I = 1, NW - IF( DWORK(I).LE.ZERO ) THEN - IWARN = IWARN + 2 - GO TO 100 - END IF - 90 CONTINUE - END IF - END IF - 100 CONTINUE - END IF -C - IF( LEFTW ) THEN - LDW = MAX( NV, 1 ) - KW = NV*N + 1 - IF( CONJS ) THEN -C -C Compute the projection of conj(V)*G. -C -C Total workspace needed: NV*N + MAX( a, P*N, P*M ), where -C a = 0, if DICO = 'C', -C a = 2*NV, if DICO = 'D'. -C -C Compute -CV'*C. -C Workspace needed: NV*N. -C - CALL DGEMM( 'T', 'N', NV, N, P, -ONE, CV, LDCV, C, LDC, - $ ZERO, DWORK, LDW ) -C - IF( DISCR ) THEN -C -C Compute X and SCALE satisfying -C -C AV'*X*A - X = -SCALE*CV'*C. -C -C Additional workspace needed: 2*NV. -C - CALL SB04PY( 'T', 'N', -1, NV, N, AV, LDAV, A, LDA, - $ DWORK, LDW, SCALE, DWORK(KW), IERR ) - IF( IERR.NE.0 ) THEN - INFO = 3 - RETURN - END IF -C -C Construct C <- DV'*C + BV'*X*A/SCALE, -C D <- DV'*D + BV'*X*B/SCALE. -C -C Additional workspace needed: MAX( P*N, P*M ). -C -C C <- DV'*C. -C - CALL DGEMM( 'T', 'N', P, N, P, ONE, DV, LDDV, C, LDC, - $ ZERO, DWORK(KW), P ) - CALL DLACPY( 'F', P, N, DWORK(KW), P, C, LDC ) -C -C D <- DV'*D. -C - CALL DGEMM( 'T', 'N', P, M, P, ONE, DV, LDDV, D, LDD, - $ ZERO, DWORK(KW), P ) - CALL DLACPY( 'F', P, M, DWORK(KW), P, D, LDD ) -C -C C <- C + BV'*X*A/SCALE. -C - CALL DGEMM( 'T', 'N', P, N, NV, ONE / SCALE, BV, LDBV, - $ DWORK, LDW, ZERO, DWORK(KW), P ) - CALL DGEMM( 'N', 'N', P, N, N, ONE, DWORK(KW), P, A, LDA, - $ ONE, C, LDC ) -C -C D <- D + BV'*X*B/SCALE. -C - CALL DGEMM( 'N', 'N', P, M, N, ONE, DWORK(KW), P, B, LDB, - $ ONE, D, LDD ) - ELSE -C -C Compute X and SCALE satisfying -C -C AV'*X + X*A + SCALE*CV'*C = 0. -C - CALL DTRSYL( 'T', 'N', 1, NV, N, AV, LDAV, A, LDA, - $ DWORK, LDW, SCALE, IERR ) - IF( IERR.NE.0 ) THEN - INFO = 3 - RETURN - END IF -C -C Construct C and D. -C Additional workspace needed: MAX( P*N, P*M ). -C -C Construct C <- BV'*X/SCALE + DV'*C. -C - CALL DGEMM( 'T', 'N', P, N, P, ONE, DV, LDDV, C, LDC, - $ ZERO, DWORK(KW), P ) - CALL DLACPY( 'F', P, N, DWORK(KW), P, C, LDC ) - CALL DGEMM( 'T', 'N', P, N, NV, ONE / SCALE, BV, LDBV, - $ DWORK, LDW, ONE, C, LDC ) -C -C Construct D <- DV'*D. -C - CALL DGEMM( 'T', 'N', P, M, P, ONE, DV, LDDV, D, LDD, - $ ZERO, DWORK(KW), P ) - CALL DLACPY( 'F', P, M, DWORK(KW), P, D, LDD ) - END IF - ELSE -C -C Compute the projection of V*G. -C -C Total workspace needed: NV*N + MAX( P*N, P*M ). -C -C Compute -BV*C. -C Workspace needed: NV*N. -C - CALL DGEMM( 'N', 'N', NV, N, P, -ONE, BV, LDBV, C, LDC, - $ ZERO, DWORK, LDW ) -C -C Compute X and SCALE satisfying -C -C AV*X - X*A + SCALE*BV*C = 0. -C - CALL DTRSYL( 'N', 'N', -1, NV, N, AV, LDAV, A, LDA, - $ DWORK, LDW, SCALE, IERR ) - IF( IERR.NE.0 ) THEN - INFO = 3 - RETURN - END IF -C -C Construct C <- CV*X/SCALE + DV*C. -C - CALL DGEMM( 'N', 'N', P, N, P, ONE, DV, LDDV, C, LDC, - $ ZERO, DWORK(KW), P ) - CALL DLACPY( 'F', P, N, DWORK(KW), P, C, LDC ) - CALL DGEMM( 'N', 'N', P, N, NV, ONE / SCALE, CV, LDCV, - $ DWORK, LDW, ONE, C, LDC ) -C -C Construct D <- DV*D. -C - CALL DGEMM( 'N', 'N', P, M, P, ONE, DV, LDDV, D, LDD, - $ ZERO, DWORK(KW), P ) - CALL DLACPY( 'F', P, M, DWORK(KW), P, D, LDD ) - END IF - END IF -C - IF( RIGHTW ) THEN - LDWN = MAX( N, 1 ) - KW = N*NW + 1 - IF( CONJS ) THEN -C -C Compute the projection of G*conj(W) or of conj(V)*G*conj(W). -C -C Total workspace needed: NW*N + MAX( b, M*N, P*M ), where -C b = 0, if DICO = 'C', -C b = 2*NW, if DICO = 'D'. -C -C Compute -BW*B'. -C Workspace needed: N*NW. -C - LDW = MAX( NW, 1 ) - CALL DGEMM( 'N', 'T', NW, N, M, -ONE, BW, LDBW, B, LDB, - $ ZERO, DWORK, LDW ) -C - IF( DISCR ) THEN -C -C Compute Y' and SCALE satisfying -C -C AW*Y'*A' - Y' = -SCALE*BW*B'. -C -C Additional workspace needed: 2*NW. -C - CALL SB04PY( 'N', 'T', -1, NW, N, AW, LDAW, A, LDA, - $ DWORK, LDW, SCALE, DWORK(KW), IERR ) - IF( IERR.NE.0 ) THEN - INFO = 4 - RETURN - END IF -C -C Construct B <- B*DW' + A*Y*CW'/SCALE, -C D <- D*DW' + C*Y*CW'/SCALE. -C -C Additional workspace needed: MAX( N*M, P*M ). -C -C B <- B*DW'. -C - CALL DGEMM( 'N', 'T', N, M, M, ONE, B, LDB, DW, LDDW, - $ ZERO, DWORK(KW), LDWN ) - CALL DLACPY( 'F', N, M, DWORK(KW), LDWN, B, LDB ) -C -C D <- D*DW'. -C - CALL DGEMM( 'N', 'T', P, M, M, ONE, D, LDD, DW, LDDW, - $ ZERO, DWORK(KW), P ) - CALL DLACPY( 'F', P, M, DWORK(KW), P, D, LDD ) -C -C B <- B + A*Y*CW'/SCALE. -C - CALL DGEMM( 'T', 'T', N, M, NW, ONE / SCALE, DWORK, LDW, - $ CW, LDCW, ZERO, DWORK(KW), LDWN ) - CALL DGEMM( 'N', 'N', N, M, N, ONE, A, LDA, - $ DWORK(KW), LDWN, ONE, B, LDB ) -C -C D <- D + C*Y*CW'/SCALE. -C - CALL DGEMM( 'N', 'N', P, M, N, ONE, C, LDC, - $ DWORK(KW), LDWN, ONE, D, LDD ) - ELSE -C -C Compute Y' and SCALE satisfying -C -C AW*Y' + Y'*A' + SCALE*BW*B' = 0. -C - CALL DTRSYL( 'N', 'T', 1, NW, N, AW, LDAW, A, LDA, - $ DWORK, LDW, SCALE, IERR ) - IF( IERR.NE.0 ) THEN - INFO = 4 - RETURN - END IF -C -C Construct B and D. -C Additional workspace needed: MAX( N*M, P*M ). -C -C Construct B <- B*DW' + Y*CW'/SCALE. -C - CALL DGEMM( 'N', 'T', N, M, M, ONE, B, LDB, DW, LDDW, - $ ZERO, DWORK(KW), LDWN ) - CALL DLACPY( 'F', N, M, DWORK(KW), LDWN, B, LDB ) - CALL DGEMM( 'T', 'T', N, M, NW, ONE / SCALE, DWORK, LDW, - $ CW, LDCW, ONE, B, LDB) -C -C D <- D*DW'. -C - CALL DGEMM( 'N', 'T', P, M, M, ONE, D, LDD, DW, LDDW, - $ ZERO, DWORK(KW), P ) - CALL DLACPY( 'F', P, M, DWORK(KW), P, D, LDD ) - END IF - ELSE -C -C Compute the projection of G*W or of V*G*W. -C -C Total workspace needed: NW*N + MAX( M*N, P*M ). -C -C Compute B*CW. -C Workspace needed: N*NW. -C - CALL DGEMM( 'N', 'N', N, NW, M, ONE, B, LDB, CW, LDCW, - $ ZERO, DWORK, LDWN ) -C -C Compute Y and SCALE satisfying -C -C A*Y - Y*AW - SCALE*B*CW = 0. -C - CALL DTRSYL( 'N', 'N', -1, N, NW, A, LDA, AW, LDAW, - $ DWORK, LDWN, SCALE, IERR ) - IF( IERR.NE.0 ) THEN - INFO = 4 - RETURN - END IF -C -C Construct B and D. -C Additional workspace needed: MAX( N*M, P*M ). -C Construct B <- B*DW + Y*BW/SCALE. -C - CALL DGEMM( 'N', 'N', N, M, M, ONE, B, LDB, DW, LDDW, - $ ZERO, DWORK(KW), LDWN ) - CALL DLACPY( 'F', N, M, DWORK(KW), LDWN, B, LDB ) - CALL DGEMM( 'N', 'N', N, M, NW, ONE / SCALE, DWORK, LDWN, - $ BW, LDBW, ONE, B, LDB) -C -C D <- D*DW. -C - CALL DGEMM( 'N', 'N', P, M, M, ONE, D, LDD, DW, LDDW, - $ ZERO, DWORK(KW), P ) - CALL DLACPY( 'F', P, M, DWORK(KW), P, D, LDD ) - END IF - END IF -C - DWORK(1) = MAX( WORK, DBLE( LW ) ) -C - RETURN -C *** Last line of AB09KX *** - END diff --git a/mex/sources/libslicot/AB09MD.f b/mex/sources/libslicot/AB09MD.f deleted file mode 100644 index aaa808bfe..000000000 --- a/mex/sources/libslicot/AB09MD.f +++ /dev/null @@ -1,474 +0,0 @@ - SUBROUTINE AB09MD( DICO, JOB, EQUIL, ORDSEL, N, M, P, NR, ALPHA, - $ A, LDA, B, LDB, C, LDC, NS, HSV, TOL, IWORK, - $ DWORK, LDWORK, IWARN, INFO ) -C -C SLICOT RELEASE 5.0. -C -C Copyright (c) 2002-2009 NICONET e.V. -C -C This program is free software: you can redistribute it and/or -C modify it under the terms of the GNU General Public License as -C published by the Free Software Foundation, either version 2 of -C the License, or (at your option) any later version. -C -C This program is distributed in the hope that it will be useful, -C but WITHOUT ANY WARRANTY; without even the implied warranty of -C MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the -C GNU General Public License for more details. -C -C You should have received a copy of the GNU General Public License -C along with this program. If not, see -C . -C -C PURPOSE -C -C To compute a reduced order model (Ar,Br,Cr) for an original -C state-space representation (A,B,C) by using either the square-root -C or the balancing-free square-root Balance & Truncate (B & T) -C model reduction method for the ALPHA-stable part of the system. -C -C ARGUMENTS -C -C Mode Parameters -C -C DICO CHARACTER*1 -C Specifies the type of the original system as follows: -C = 'C': continuous-time system; -C = 'D': discrete-time system. -C -C JOB CHARACTER*1 -C Specifies the model reduction approach to be used -C as follows: -C = 'B': use the square-root Balance & Truncate method; -C = 'N': use the balancing-free square-root -C Balance & Truncate method. -C -C EQUIL CHARACTER*1 -C Specifies whether the user wishes to preliminarily -C equilibrate the triplet (A,B,C) as follows: -C = 'S': perform equilibration (scaling); -C = 'N': do not perform equilibration. -C -C ORDSEL CHARACTER*1 -C Specifies the order selection method as follows: -C = 'F': the resulting order NR is fixed; -C = 'A': the resulting order NR is automatically determined -C on basis of the given tolerance TOL. -C -C Input/Output Parameters -C -C N (input) INTEGER -C The order of the original state-space representation, i.e. -C the order of the matrix A. N >= 0. -C -C M (input) INTEGER -C The number of system inputs. M >= 0. -C -C P (input) INTEGER -C The number of system outputs. P >= 0. -C -C NR (input/output) INTEGER -C On entry with ORDSEL = 'F', NR is the desired order of the -C resulting reduced order system. 0 <= NR <= N. -C On exit, if INFO = 0, NR is the order of the resulting -C reduced order model. For a system with NU ALPHA-unstable -C eigenvalues and NS ALPHA-stable eigenvalues (NU+NS = N), -C NR is set as follows: if ORDSEL = 'F', NR is equal to -C NU+MIN(MAX(0,NR-NU),NMIN), where NR is the desired order -C on entry, and NMIN is the order of a minimal realization -C of the ALPHA-stable part of the given system; NMIN is -C determined as the number of Hankel singular values greater -C than NS*EPS*HNORM(As,Bs,Cs), where EPS is the machine -C precision (see LAPACK Library Routine DLAMCH) and -C HNORM(As,Bs,Cs) is the Hankel norm of the ALPHA-stable -C part of the given system (computed in HSV(1)); -C if ORDSEL = 'A', NR is the sum of NU and the number of -C Hankel singular values greater than -C MAX(TOL,NS*EPS*HNORM(As,Bs,Cs)). -C -C ALPHA (input) DOUBLE PRECISION -C Specifies the ALPHA-stability boundary for the eigenvalues -C of the state dynamics matrix A. For a continuous-time -C system (DICO = 'C'), ALPHA <= 0 is the boundary value for -C the real parts of eigenvalues, while for a discrete-time -C system (DICO = 'D'), 0 <= ALPHA <= 1 represents the -C boundary value for the moduli of eigenvalues. -C The ALPHA-stability domain does not include the boundary. -C -C A (input/output) DOUBLE PRECISION array, dimension (LDA,N) -C On entry, the leading N-by-N part of this array must -C contain the state dynamics matrix A. -C On exit, if INFO = 0, the leading NR-by-NR part of this -C array contains the state dynamics matrix Ar of the reduced -C order system. -C The resulting A has a block-diagonal form with two blocks. -C For a system with NU ALPHA-unstable eigenvalues and -C NS ALPHA-stable eigenvalues (NU+NS = N), the leading -C NU-by-NU block contains the unreduced part of A -C corresponding to ALPHA-unstable eigenvalues in an -C upper real Schur form. -C The trailing (NR+NS-N)-by-(NR+NS-N) block contains -C the reduced part of A corresponding to ALPHA-stable -C eigenvalues. -C -C LDA INTEGER -C The leading dimension of array A. LDA >= MAX(1,N). -C -C B (input/output) DOUBLE PRECISION array, dimension (LDB,M) -C On entry, the leading N-by-M part of this array must -C contain the original input/state matrix B. -C On exit, if INFO = 0, the leading NR-by-M part of this -C array contains the input/state matrix Br of the reduced -C order system. -C -C LDB INTEGER -C The leading dimension of array B. LDB >= MAX(1,N). -C -C C (input/output) DOUBLE PRECISION array, dimension (LDC,N) -C On entry, the leading P-by-N part of this array must -C contain the original state/output matrix C. -C On exit, if INFO = 0, the leading P-by-NR part of this -C array contains the state/output matrix Cr of the reduced -C order system. -C -C LDC INTEGER -C The leading dimension of array C. LDC >= MAX(1,P). -C -C NS (output) INTEGER -C The dimension of the ALPHA-stable subsystem. -C -C HSV (output) DOUBLE PRECISION array, dimension (N) -C If INFO = 0, the leading NS elements of HSV contain the -C Hankel singular values of the ALPHA-stable part of the -C original system ordered decreasingly. -C HSV(1) is the Hankel norm of the ALPHA-stable subsystem. -C -C Tolerances -C -C TOL DOUBLE PRECISION -C If ORDSEL = 'A', TOL contains the tolerance for -C determining the order of reduced system. -C For model reduction, the recommended value is -C TOL = c*HNORM(As,Bs,Cs), where c is a constant in the -C interval [0.00001,0.001], and HNORM(As,Bs,Cs) is the -C Hankel-norm of the ALPHA-stable part of the given system -C (computed in HSV(1)). -C If TOL <= 0 on entry, the used default value is -C TOL = NS*EPS*HNORM(As,Bs,Cs), where NS is the number of -C ALPHA-stable eigenvalues of A and EPS is the machine -C precision (see LAPACK Library Routine DLAMCH). -C This value is appropriate to compute a minimal realization -C of the ALPHA-stable part. -C If ORDSEL = 'F', the value of TOL is ignored. -C -C Workspace -C -C IWORK INTEGER array, dimension (LIWORK) -C LIWORK = 0, if JOB = 'B'; -C LIWORK = N, if JOB = 'N'. -C -C DWORK DOUBLE PRECISION array, dimension (LDWORK) -C On exit, if INFO = 0, DWORK(1) returns the optimal value -C of LDWORK. -C -C LDWORK INTEGER -C The length of the array DWORK. -C LDWORK >= MAX(1,N*(2*N+MAX(N,M,P)+5) + N*(N+1)/2). -C For optimum performance LDWORK should be larger. -C -C Warning Indicator -C -C IWARN INTEGER -C = 0: no warning; -C = 1: with ORDSEL = 'F', the selected order NR is greater -C than NSMIN, the sum of the order of the -C ALPHA-unstable part and the order of a minimal -C realization of the ALPHA-stable part of the given -C system. In this case, the resulting NR is set equal -C to NSMIN. -C = 2: with ORDSEL = 'F', the selected order NR is less -C than the order of the ALPHA-unstable part of the -C given system. In this case NR is set equal to the -C order of the ALPHA-unstable part. -C -C Error Indicator -C -C INFO INTEGER -C = 0: successful exit; -C < 0: if INFO = -i, the i-th argument had an illegal -C value; -C = 1: the computation of the ordered real Schur form of A -C failed; -C = 2: the separation of the ALPHA-stable/unstable diagonal -C blocks failed because of very close eigenvalues; -C = 3: the computation of Hankel singular values failed. -C -C METHOD -C -C Let be the following linear system -C -C d[x(t)] = Ax(t) + Bu(t) -C y(t) = Cx(t) (1) -C -C where d[x(t)] is dx(t)/dt for a continuous-time system and x(t+1) -C for a discrete-time system. The subroutine AB09MD determines for -C the given system (1), the matrices of a reduced order system -C -C d[z(t)] = Ar*z(t) + Br*u(t) -C yr(t) = Cr*z(t) (2) -C -C such that -C -C HSV(NR+NS-N) <= INFNORM(G-Gr) <= 2*[HSV(NR+NS-N+1)+...+HSV(NS)], -C -C where G and Gr are transfer-function matrices of the systems -C (A,B,C) and (Ar,Br,Cr), respectively, and INFNORM(G) is the -C infinity-norm of G. -C -C The following procedure is used to reduce a given G: -C -C 1) Decompose additively G as -C -C G = G1 + G2 -C -C such that G1 = (As,Bs,Cs) has only ALPHA-stable poles and -C G2 = (Au,Bu,Cu) has only ALPHA-unstable poles. -C -C 2) Determine G1r, a reduced order approximation of the -C ALPHA-stable part G1. -C -C 3) Assemble the reduced model Gr as -C -C Gr = G1r + G2. -C -C To reduce the ALPHA-stable part G1, if JOB = 'B', the square-root -C Balance & Truncate method of [1] is used, and for an ALPHA-stable -C continuous-time system (DICO = 'C'), the resulting reduced model -C is balanced. For ALPHA-stable systems, setting TOL < 0, the -C routine can be used to compute balanced minimal state-space -C realizations. -C -C If JOB = 'N', the balancing-free square-root version of the -C Balance & Truncate method [2] is used to reduce the ALPHA-stable -C part G1. -C -C REFERENCES -C -C [1] Tombs M.S. and Postlethwaite I. -C Truncated balanced realization of stable, non-minimal -C state-space systems. -C Int. J. Control, Vol. 46, pp. 1319-1330, 1987. -C -C [2] Varga A. -C Efficient minimal realization procedure based on balancing. -C Proc. of IMACS/IFAC Symp. MCTS, Lille, France, May 1991, -C A. El Moudui, P. Borne, S. G. Tzafestas (Eds.), -C Vol. 2, pp. 42-46. -C -C NUMERICAL ASPECTS -C -C The implemented methods rely on accuracy enhancing square-root or -C balancing-free square-root techniques. -C 3 -C The algorithms require less than 30N floating point operations. -C -C CONTRIBUTOR -C -C C. Oara, University "Politehnica" Bucharest. -C A. Varga, German Aerospace Center, DLR Oberpfaffenhofen. -C February 1999. Based on the RASP routines SADSDC, SRBT and SRBFT. -C -C REVISIONS -C -C Mar. 1999, V. Sima, Research Institute for Informatics, Bucharest. -C Nov. 2000, A. Varga, DLR Oberpfaffenhofen. -C -C KEYWORDS -C -C Balancing, minimal realization, model reduction, multivariable -C system, state-space model, state-space representation. -C -C ****************************************************************** -C -C .. Parameters .. - DOUBLE PRECISION ZERO, ONE, C100 - PARAMETER ( ZERO = 0.0D0, ONE = 1.0D0, C100 = 100.0D0 ) -C .. Scalar Arguments .. - CHARACTER DICO, EQUIL, JOB, ORDSEL - INTEGER INFO, IWARN, LDA, LDB, LDC, LDWORK, M, N, NR, - $ NS, P - DOUBLE PRECISION ALPHA, TOL -C .. Array Arguments .. - INTEGER IWORK(*) - DOUBLE PRECISION A(LDA,*), B(LDB,*), C(LDC,*), DWORK(*), HSV(*) -C .. Local Scalars .. - LOGICAL DISCR, FIXORD - INTEGER IERR, IWARNL, KT, KTI, KU, KW, KWI, KWR, LWR, - $ NN, NRA, NU, NU1, WRKOPT - DOUBLE PRECISION ALPWRK, MAXRED -C .. External Functions .. - LOGICAL LSAME - DOUBLE PRECISION DLAMCH - EXTERNAL DLAMCH, LSAME -C .. External Subroutines .. - EXTERNAL AB09AX, TB01ID, TB01KD, XERBLA -C .. Intrinsic Functions .. - INTRINSIC DBLE, INT, MAX, MIN, SQRT -C .. Executable Statements .. -C - INFO = 0 - IWARN = 0 - DISCR = LSAME( DICO, 'D' ) - FIXORD = LSAME( ORDSEL, 'F' ) -C -C Test the input scalar arguments. -C - IF( .NOT. ( LSAME( DICO, 'C' ) .OR. DISCR ) ) THEN - INFO = -1 - ELSE IF( .NOT. ( LSAME( JOB, 'B' ) .OR. LSAME( JOB, 'N' ) ) ) THEN - INFO = -2 - ELSE IF( .NOT. ( LSAME( EQUIL, 'S' ) .OR. - $ LSAME( EQUIL, 'N' ) ) ) THEN - INFO = -3 - ELSE IF( .NOT. ( FIXORD .OR. LSAME( ORDSEL, 'A' ) ) ) THEN - INFO = -4 - ELSE IF( N.LT.0 ) THEN - INFO = -5 - ELSE IF( M.LT.0 ) THEN - INFO = -6 - ELSE IF( P.LT.0 ) THEN - INFO = -7 - ELSE IF( FIXORD .AND. ( NR.LT.0 .OR. NR.GT.N ) ) THEN - INFO = -8 - ELSE IF( ( DISCR .AND. ( ALPHA.LT.ZERO .OR. ALPHA.GT.ONE ) ) .OR. - $ ( .NOT.DISCR .AND. ALPHA.GT.ZERO ) ) THEN - INFO = -9 - ELSE IF( LDA.LT.MAX( 1, N ) ) THEN - INFO = -11 - ELSE IF( LDB.LT.MAX( 1, N ) ) THEN - INFO = -13 - ELSE IF( LDC.LT.MAX( 1, P ) ) THEN - INFO = -15 - ELSE IF( LDWORK.LT.MAX( 1, N*( 2*N + MAX( N, M, P ) + 5 ) + - $ ( N*( N + 1 ) )/2 ) ) THEN - INFO = -21 - END IF -C - IF( INFO.NE.0 ) THEN -C -C Error return. -C - CALL XERBLA( 'AB09MD', -INFO ) - RETURN - END IF -C -C Quick return if possible. -C - IF( MIN( N, M, P ).EQ.0 ) THEN - NR = 0 - DWORK(1) = ONE - RETURN - END IF -C - IF( LSAME( EQUIL, 'S' ) ) THEN -C -C Scale simultaneously the matrices A, B and C: -C A <- inv(D)*A*D, B <- inv(D)*B and C <- C*D, where D is a -C diagonal matrix. -C Workspace: N. -C - MAXRED = C100 - CALL TB01ID( 'All', N, M, P, MAXRED, A, LDA, B, LDB, C, LDC, - $ DWORK, INFO ) - END IF -C -C Correct the value of ALPHA to ensure stability. -C - ALPWRK = ALPHA - IF( DISCR ) THEN - IF( ALPHA.EQ.ONE ) ALPWRK = ONE - SQRT( DLAMCH( 'E' ) ) - ELSE - IF( ALPHA.EQ.ZERO ) ALPWRK = -SQRT( DLAMCH( 'E' ) ) - END IF -C -C Allocate working storage. -C - NN = N*N - KU = 1 - KWR = KU + NN - KWI = KWR + N - KW = KWI + N - LWR = LDWORK - KW + 1 -C -C Reduce A to a block-diagonal real Schur form, with the -C ALPHA-unstable part in the leading diagonal position, using a -C non-orthogonal similarity transformation A <- inv(T)*A*T and -C apply the transformation to B and C: B <- inv(T)*B and C <- C*T. -C -C Workspace needed: N*(N+2); -C Additional workspace: need 3*N; -C prefer larger. -C - CALL TB01KD( DICO, 'Unstable', 'General', N, M, P, ALPWRK, A, LDA, - $ B, LDB, C, LDC, NU, DWORK(KU), N, DWORK(KWR), - $ DWORK(KWI), DWORK(KW), LWR, IERR ) -C - IF( IERR.NE.0 ) THEN - IF( IERR.NE.3 ) THEN - INFO = 1 - ELSE - INFO = 2 - END IF - RETURN - END IF -C - WRKOPT = DWORK(KW) + DBLE( KW-1 ) -C - IWARNL = 0 - NS = N - NU - IF( FIXORD ) THEN - NRA = MAX( 0, NR-NU ) - IF( NR.LT.NU ) - $ IWARNL = 2 - ELSE - NRA = 0 - END IF -C -C Finish if only unstable part is present. -C - IF( NS.EQ.0 ) THEN - NR = NU - DWORK(1) = WRKOPT - RETURN - END IF -C - NU1 = NU + 1 -C -C Allocate working storage. -C - KT = 1 - KTI = KT + NN - KW = KTI + NN -C -C Compute a B & T approximation of the stable part. -C Workspace: need N*(2*N+MAX(N,M,P)+5) + N*(N+1)/2; -C prefer larger. -C - CALL AB09AX( DICO, JOB, ORDSEL, NS, M, P, NRA, A(NU1,NU1), LDA, - $ B(NU1,1), LDB, C(1,NU1), LDC, HSV, DWORK(KT), N, - $ DWORK(KTI), N, TOL, IWORK, DWORK(KW), LDWORK-KW+1, - $ IWARN, IERR ) - IWARN = MAX( IWARN, IWARNL ) -C - IF( IERR.NE.0 ) THEN - INFO = IERR + 1 - RETURN - END IF -C - NR = NRA + NU -C - DWORK(1) = MAX( WRKOPT, INT( DWORK(KW) ) + KW - 1 ) -C - RETURN -C *** Last line of AB09MD *** - END diff --git a/mex/sources/libslicot/AB09ND.f b/mex/sources/libslicot/AB09ND.f deleted file mode 100644 index 49ea0c0cd..000000000 --- a/mex/sources/libslicot/AB09ND.f +++ /dev/null @@ -1,497 +0,0 @@ - SUBROUTINE AB09ND( DICO, JOB, EQUIL, ORDSEL, N, M, P, NR, ALPHA, - $ A, LDA, B, LDB, C, LDC, D, LDD, NS, HSV, TOL1, - $ TOL2, IWORK, DWORK, LDWORK, IWARN, INFO ) -C -C SLICOT RELEASE 5.0. -C -C Copyright (c) 2002-2009 NICONET e.V. -C -C This program is free software: you can redistribute it and/or -C modify it under the terms of the GNU General Public License as -C published by the Free Software Foundation, either version 2 of -C the License, or (at your option) any later version. -C -C This program is distributed in the hope that it will be useful, -C but WITHOUT ANY WARRANTY; without even the implied warranty of -C MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the -C GNU General Public License for more details. -C -C You should have received a copy of the GNU General Public License -C along with this program. If not, see -C . -C -C PURPOSE -C -C To compute a reduced order model (Ar,Br,Cr,Dr) for an original -C state-space representation (A,B,C,D) by using either the -C square-root or the balancing-free square-root Singular -C Perturbation Approximation (SPA) model reduction method for the -C ALPHA-stable part of the system. -C -C ARGUMENTS -C -C Mode Parameters -C -C DICO CHARACTER*1 -C Specifies the type of the original system as follows: -C = 'C': continuous-time system; -C = 'D': discrete-time system. -C -C JOB CHARACTER*1 -C Specifies the model reduction approach to be used -C as follows: -C = 'B': use the square-root SPA method; -C = 'N': use the balancing-free square-root SPA method. -C -C EQUIL CHARACTER*1 -C Specifies whether the user wishes to preliminarily -C equilibrate the triplet (A,B,C) as follows: -C = 'S': perform equilibration (scaling); -C = 'N': do not perform equilibration. -C -C ORDSEL CHARACTER*1 -C Specifies the order selection method as follows: -C = 'F': the resulting order NR is fixed; -C = 'A': the resulting order NR is automatically determined -C on basis of the given tolerance TOL1. -C -C Input/Output Parameters -C -C N (input) INTEGER -C The order of the original state-space representation, i.e. -C the order of the matrix A. N >= 0. -C -C M (input) INTEGER -C The number of system inputs. M >= 0. -C -C P (input) INTEGER -C The number of system outputs. P >= 0. -C -C NR (input/output) INTEGER -C On entry with ORDSEL = 'F', NR is the desired order of the -C resulting reduced order system. 0 <= NR <= N. -C On exit, if INFO = 0, NR is the order of the resulting -C reduced order model. For a system with NU ALPHA-unstable -C eigenvalues and NS ALPHA-stable eigenvalues (NU+NS = N), -C NR is set as follows: if ORDSEL = 'F', NR is equal to -C NU+MIN(MAX(0,NR-NU),NMIN), where NR is the desired order -C on entry, and NMIN is the order of a minimal realization -C of the ALPHA-stable part of the given system; NMIN is -C determined as the number of Hankel singular values greater -C than NS*EPS*HNORM(As,Bs,Cs), where EPS is the machine -C precision (see LAPACK Library Routine DLAMCH) and -C HNORM(As,Bs,Cs) is the Hankel norm of the ALPHA-stable -C part of the given system (computed in HSV(1)); -C if ORDSEL = 'A', NR is the sum of NU and the number of -C Hankel singular values greater than -C MAX(TOL1,NS*EPS*HNORM(As,Bs,Cs)). -C -C ALPHA (input) DOUBLE PRECISION -C Specifies the ALPHA-stability boundary for the eigenvalues -C of the state dynamics matrix A. For a continuous-time -C system (DICO = 'C'), ALPHA <= 0 is the boundary value for -C the real parts of eigenvalues, while for a discrete-time -C system (DICO = 'D'), 0 <= ALPHA <= 1 represents the -C boundary value for the moduli of eigenvalues. -C The ALPHA-stability domain does not include the boundary. -C -C A (input/output) DOUBLE PRECISION array, dimension (LDA,N) -C On entry, the leading N-by-N part of this array must -C contain the state dynamics matrix A. -C On exit, if INFO = 0, the leading NR-by-NR part of this -C array contains the state dynamics matrix Ar of the reduced -C order system. -C The resulting A has a block-diagonal form with two blocks. -C For a system with NU ALPHA-unstable eigenvalues and -C NS ALPHA-stable eigenvalues (NU+NS = N), the leading -C NU-by-NU block contains the unreduced part of A -C corresponding to ALPHA-unstable eigenvalues in an -C upper real Schur form. -C The trailing (NR+NS-N)-by-(NR+NS-N) block contains -C the reduced part of A corresponding to ALPHA-stable -C eigenvalues. -C -C LDA INTEGER -C The leading dimension of array A. LDA >= MAX(1,N). -C -C B (input/output) DOUBLE PRECISION array, dimension (LDB,M) -C On entry, the leading N-by-M part of this array must -C contain the original input/state matrix B. -C On exit, if INFO = 0, the leading NR-by-M part of this -C array contains the input/state matrix Br of the reduced -C order system. -C -C LDB INTEGER -C The leading dimension of array B. LDB >= MAX(1,N). -C -C C (input/output) DOUBLE PRECISION array, dimension (LDC,N) -C On entry, the leading P-by-N part of this array must -C contain the original state/output matrix C. -C On exit, if INFO = 0, the leading P-by-NR part of this -C array contains the state/output matrix Cr of the reduced -C order system. -C -C LDC INTEGER -C The leading dimension of array C. LDC >= MAX(1,P). -C -C D (input/output) DOUBLE PRECISION array, dimension (LDD,M) -C On entry, the leading P-by-M part of this array must -C contain the original input/output matrix D. -C On exit, if INFO = 0, the leading P-by-M part of this -C array contains the input/output matrix Dr of the reduced -C order system. -C -C LDD INTEGER -C The leading dimension of array D. LDD >= MAX(1,P). -C -C NS (output) INTEGER -C The dimension of the ALPHA-stable subsystem. -C -C HSV (output) DOUBLE PRECISION array, dimension (N) -C If INFO = 0, the leading NS elements of HSV contain the -C Hankel singular values of the ALPHA-stable part of the -C original system ordered decreasingly. -C HSV(1) is the Hankel norm of the ALPHA-stable subsystem. -C -C Tolerances -C -C TOL1 DOUBLE PRECISION -C If ORDSEL = 'A', TOL1 contains the tolerance for -C determining the order of reduced system. -C For model reduction, the recommended value is -C TOL1 = c*HNORM(As,Bs,Cs), where c is a constant in the -C interval [0.00001,0.001], and HNORM(As,Bs,Cs) is the -C Hankel-norm of the ALPHA-stable part of the given system -C (computed in HSV(1)). -C If TOL1 <= 0 on entry, the used default value is -C TOL1 = NS*EPS*HNORM(As,Bs,Cs), where NS is the number of -C ALPHA-stable eigenvalues of A and EPS is the machine -C precision (see LAPACK Library Routine DLAMCH). -C This value is appropriate to compute a minimal realization -C of the ALPHA-stable part. -C If ORDSEL = 'F', the value of TOL1 is ignored. -C -C TOL2 DOUBLE PRECISION -C The tolerance for determining the order of a minimal -C realization of the ALPHA-stable part of the given system. -C The recommended value is TOL2 = NS*EPS*HNORM(As,Bs,Cs). -C This value is used by default if TOL2 <= 0 on entry. -C If TOL2 > 0, then TOL2 <= TOL1. -C -C Workspace -C -C IWORK INTEGER array, dimension MAX(1,2*N) -C On exit, if INFO = 0, IWORK(1) contains the order of the -C minimal realization of the ALPHA-stable part of the -C system. -C -C DWORK DOUBLE PRECISION array, dimension (LDWORK) -C On exit, if INFO = 0, DWORK(1) returns the optimal value -C of LDWORK. -C -C LDWORK INTEGER -C The length of the array DWORK. -C LDWORK >= MAX(1,N*(2*N+MAX(N,M,P)+5) + N*(N+1)/2). -C For optimum performance LDWORK should be larger. -C -C Warning Indicator -C -C IWARN INTEGER -C = 0: no warning; -C = 1: with ORDSEL = 'F', the selected order NR is greater -C than NSMIN, the sum of the order of the -C ALPHA-unstable part and the order of a minimal -C realization of the ALPHA-stable part of the given -C system. In this case, the resulting NR is set equal -C to NSMIN. -C = 2: with ORDSEL = 'F', the selected order NR is less -C than the order of the ALPHA-unstable part of the -C given system. In this case NR is set equal to the -C order of the ALPHA-unstable part. -C -C Error Indicator -C -C INFO INTEGER -C = 0: successful exit; -C < 0: if INFO = -i, the i-th argument had an illegal -C value; -C = 1: the computation of the ordered real Schur form of A -C failed; -C = 2: the separation of the ALPHA-stable/unstable diagonal -C blocks failed because of very close eigenvalues; -C = 3: the computation of Hankel singular values failed. -C -C METHOD -C -C Let be the following linear system -C -C d[x(t)] = Ax(t) + Bu(t) -C y(t) = Cx(t) + Du(t) (1) -C -C where d[x(t)] is dx(t)/dt for a continuous-time system and x(t+1) -C for a discrete-time system. The subroutine AB09ND determines for -C the given system (1), the matrices of a reduced order system -C -C d[z(t)] = Ar*z(t) + Br*u(t) -C yr(t) = Cr*z(t) + Dr*u(t) (2) -C -C such that -C -C HSV(NR+NS-N) <= INFNORM(G-Gr) <= 2*[HSV(NR+NS-N+1)+...+HSV(NS)], -C -C where G and Gr are transfer-function matrices of the systems -C (A,B,C,D) and (Ar,Br,Cr,Dr), respectively, and INFNORM(G) is the -C infinity-norm of G. -C -C The following procedure is used to reduce a given G: -C -C 1) Decompose additively G as -C -C G = G1 + G2 -C -C such that G1 = (As,Bs,Cs,D) has only ALPHA-stable poles and -C G2 = (Au,Bu,Cu,0) has only ALPHA-unstable poles. -C -C 2) Determine G1r, a reduced order approximation of the -C ALPHA-stable part G1. -C -C 3) Assemble the reduced model Gr as -C -C Gr = G1r + G2. -C -C To reduce the ALPHA-stable part G1, if JOB = 'B', the square-root -C balancing-based SPA method of [1] is used, and for an ALPHA-stable -C system, the resulting reduced model is balanced. -C -C If JOB = 'N', the balancing-free square-root SPA method of [2] -C is used to reduce the ALPHA-stable part G1. -C By setting TOL1 = TOL2, the routine can be used to compute -C Balance & Truncate approximations as well. -C -C REFERENCES -C -C [1] Liu Y. and Anderson B.D.O. -C Singular Perturbation Approximation of Balanced Systems, -C Int. J. Control, Vol. 50, pp. 1379-1405, 1989. -C -C [2] Varga A. -C Balancing-free square-root algorithm for computing -C singular perturbation approximations. -C Proc. 30-th IEEE CDC, Brighton, Dec. 11-13, 1991, -C Vol. 2, pp. 1062-1065. -C -C NUMERICAL ASPECTS -C -C The implemented methods rely on accuracy enhancing square-root or -C balancing-free square-root techniques. -C 3 -C The algorithms require less than 30N floating point operations. -C -C CONTRIBUTOR -C -C C. Oara, University "Politehnica" Bucharest. -C A. Varga, German Aerospace Center, DLR Oberpfaffenhofen. -C February 1999. Based on the RASP routines SADSDC and SRBFSP. -C -C REVISIONS -C -C Mar. 1999, V. Sima, Research Institute for Informatics, Bucharest. -C Nov. 2000, A. Varga, DLR Oberpfaffenhofen. -C -C KEYWORDS -C -C Balancing, minimal realization, model reduction, multivariable -C system, singular perturbation approximation, state-space model, -C state-space representation. -C -C ****************************************************************** -C -C .. Parameters .. - DOUBLE PRECISION ZERO, ONE, C100 - PARAMETER ( ZERO = 0.0D0, ONE = 1.0D0, C100 = 100.0D0 ) -C .. Scalar Arguments .. - CHARACTER DICO, EQUIL, JOB, ORDSEL - INTEGER INFO, IWARN, LDA, LDB, LDC, LDD, LDWORK, - $ M, N, NR, NS, P - DOUBLE PRECISION ALPHA, TOL1, TOL2 -C .. Array Arguments .. - INTEGER IWORK(*) - DOUBLE PRECISION A(LDA,*), B(LDB,*), C(LDC,*), D(LDD,*), - $ DWORK(*), HSV(*) -C .. Local Scalars .. - LOGICAL DISCR, FIXORD - INTEGER IERR, IWARNL, KT, KTI, KU, KW, KWI, KWR, LWR, - $ NN, NRA, NU, NU1, WRKOPT - DOUBLE PRECISION ALPWRK, MAXRED -C .. External Functions .. - LOGICAL LSAME - DOUBLE PRECISION DLAMCH - EXTERNAL DLAMCH, LSAME -C .. External Subroutines .. - EXTERNAL AB09BX, TB01ID, TB01KD, XERBLA -C .. Intrinsic Functions .. - INTRINSIC DBLE, INT, MAX, MIN, SQRT -C .. Executable Statements .. -C - INFO = 0 - IWARN = 0 - DISCR = LSAME( DICO, 'D' ) - FIXORD = LSAME( ORDSEL, 'F' ) -C -C Test the input scalar arguments. -C - IF( .NOT. ( LSAME( DICO, 'C' ) .OR. DISCR ) ) THEN - INFO = -1 - ELSE IF( .NOT. ( LSAME( JOB, 'B' ) .OR. LSAME( JOB, 'N' ) ) ) THEN - INFO = -2 - ELSE IF( .NOT. ( LSAME( EQUIL, 'S' ) .OR. - $ LSAME( EQUIL, 'N' ) ) ) THEN - INFO = -3 - ELSE IF( .NOT. ( FIXORD .OR. LSAME( ORDSEL, 'A' ) ) ) THEN - INFO = -4 - ELSE IF( N.LT.0 ) THEN - INFO = -5 - ELSE IF( M.LT.0 ) THEN - INFO = -6 - ELSE IF( P.LT.0 ) THEN - INFO = -7 - ELSE IF( FIXORD .AND. ( NR.LT.0 .OR. NR.GT.N ) ) THEN - INFO = -8 - ELSE IF( ( DISCR .AND. ( ALPHA.LT.ZERO .OR. ALPHA.GT.ONE ) ) .OR. - $ ( .NOT.DISCR .AND. ALPHA.GT.ZERO ) ) THEN - INFO = -9 - ELSE IF( LDA.LT.MAX( 1, N ) ) THEN - INFO = -11 - ELSE IF( LDB.LT.MAX( 1, N ) ) THEN - INFO = -13 - ELSE IF( LDC.LT.MAX( 1, P ) ) THEN - INFO = -15 - ELSE IF( LDD.LT.MAX( 1, P ) ) THEN - INFO = -17 - ELSE IF( TOL2.GT.ZERO .AND. TOL2.GT.TOL1 ) THEN - INFO = -21 - ELSE IF( LDWORK.LT.MAX( 1, N*( 2*N + MAX( N, M, P ) + 5 ) + - $ ( N*( N + 1 ) )/2 ) ) THEN - INFO = -24 - END IF -C - IF( INFO.NE.0 ) THEN -C -C Error return. -C - CALL XERBLA( 'AB09ND', -INFO ) - RETURN - END IF -C -C Quick return if possible. -C - IF( MIN( N, M, P ).EQ.0 ) THEN - NR = 0 - IWORK(1) = 0 - DWORK(1) = ONE - RETURN - END IF -C - IF( LSAME( EQUIL, 'S' ) ) THEN -C -C Scale simultaneously the matrices A, B and C: -C A <- inv(D)*A*D, B <- inv(D)*B and C <- C*D, where D is a -C diagonal matrix. -C Workspace: N. -C - MAXRED = C100 - CALL TB01ID( 'All', N, M, P, MAXRED, A, LDA, B, LDB, C, LDC, - $ DWORK, INFO ) - END IF -C -C Correct the value of ALPHA to ensure stability. -C - ALPWRK = ALPHA - IF( DISCR ) THEN - IF( ALPHA.EQ.ONE ) ALPWRK = ONE - SQRT( DLAMCH( 'E' ) ) - ELSE - IF( ALPHA.EQ.ZERO ) ALPWRK = -SQRT( DLAMCH( 'E' ) ) - END IF -C -C Allocate working storage. -C - NN = N*N - KU = 1 - KWR = KU + NN - KWI = KWR + N - KW = KWI + N - LWR = LDWORK - KW + 1 -C -C Reduce A to a block-diagonal real Schur form, with the -C ALPHA-unstable part in the leading diagonal position, using a -C non-orthogonal similarity transformation A <- inv(T)*A*T and -C apply the transformation to B and C: B <- inv(T)*B and C <- C*T. -C -C Workspace needed: N*(N+2); -C Additional workspace: need 3*N; -C prefer larger. -C - CALL TB01KD( DICO, 'Unstable', 'General', N, M, P, ALPWRK, A, LDA, - $ B, LDB, C, LDC, NU, DWORK(KU), N, DWORK(KWR), - $ DWORK(KWI), DWORK(KW), LWR, IERR ) -C - IF( IERR.NE.0 ) THEN - IF( IERR.NE.3 ) THEN - INFO = 1 - ELSE - INFO = 2 - END IF - RETURN - END IF -C - WRKOPT = DWORK(KW) + DBLE( KW-1 ) -C - IWARNL = 0 - NS = N - NU - IF( FIXORD ) THEN - NRA = MAX( 0, NR-NU ) - IF( NR.LT.NU ) - $ IWARNL = 2 - ELSE - NRA = 0 - END IF -C -C Finish if only unstable part is present. -C - IF( NS.EQ.0 ) THEN - NR = NU - IWORK(1) = 0 - DWORK(1) = WRKOPT - RETURN - END IF -C - NU1 = NU + 1 -C -C Allocate working storage. -C - KT = 1 - KTI = KT + NN - KW = KTI + NN -C -C Compute a SPA of the stable part. -C Workspace: need N*(2*N+MAX(N,M,P)+5) + N*(N+1)/2; -C prefer larger. -C - CALL AB09BX( DICO, JOB, ORDSEL, NS, M, P, NRA, A(NU1,NU1), LDA, - $ B(NU1,1), LDB, C(1,NU1), LDC, D, LDD, HSV, - $ DWORK(KT), N, DWORK(KTI), N, TOL1, TOL2, IWORK, - $ DWORK(KW), LDWORK-KW+1, IWARN, IERR ) - IWARN = MAX( IWARN, IWARNL ) -C - IF( IERR.NE.0 ) THEN - INFO = IERR + 1 - RETURN - END IF -C - NR = NRA + NU -C - DWORK(1) = MAX( WRKOPT, INT( DWORK(KW) ) + KW - 1 ) -C - RETURN -C *** Last line of AB09ND *** - END diff --git a/mex/sources/libslicot/AB13AD.f b/mex/sources/libslicot/AB13AD.f deleted file mode 100644 index fb2b2018e..000000000 --- a/mex/sources/libslicot/AB13AD.f +++ /dev/null @@ -1,349 +0,0 @@ - DOUBLE PRECISION FUNCTION AB13AD( DICO, EQUIL, N, M, P, ALPHA, A, - $ LDA, B, LDB, C, LDC, NS, HSV, - $ DWORK, LDWORK, INFO ) -C -C SLICOT RELEASE 5.0. -C -C Copyright (c) 2002-2009 NICONET e.V. -C -C This program is free software: you can redistribute it and/or -C modify it under the terms of the GNU General Public License as -C published by the Free Software Foundation, either version 2 of -C the License, or (at your option) any later version. -C -C This program is distributed in the hope that it will be useful, -C but WITHOUT ANY WARRANTY; without even the implied warranty of -C MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the -C GNU General Public License for more details. -C -C You should have received a copy of the GNU General Public License -C along with this program. If not, see -C . -C -C PURPOSE -C -C To compute the Hankel-norm of the ALPHA-stable projection of the -C transfer-function matrix G of the state-space system (A,B,C). -C -C FUNCTION VALUE -C -C AB13AD DOUBLE PRECISION -C The Hankel-norm of the ALPHA-stable projection of G -C (if INFO = 0). -C -C ARGUMENTS -C -C Mode Parameters -C -C DICO CHARACTER*1 -C Specifies the type of the system as follows: -C = 'C': continuous-time system; -C = 'D': discrete-time system. -C -C EQUIL CHARACTER*1 -C Specifies whether the user wishes to preliminarily -C equilibrate the triplet (A,B,C) as follows: -C = 'S': perform equilibration (scaling); -C = 'N': do not perform equilibration. -C -C Input/Output Parameters -C -C N (input) INTEGER -C The order of the state-space representation, i.e. the -C order of the matrix A. N >= 0. -C -C M (input) INTEGER -C The number of system inputs. M >= 0. -C -C P (input) INTEGER -C The number of system outputs. P >= 0. -C -C ALPHA (input) DOUBLE PRECISION -C Specifies the ALPHA-stability boundary for the eigenvalues -C of the state dynamics matrix A. For a continuous-time -C system (DICO = 'C'), ALPHA <= 0 is the boundary value for -C the real parts of eigenvalues, while for a discrete-time -C system (DICO = 'D'), 0 <= ALPHA <= 1 represents the -C boundary value for the moduli of eigenvalues. -C The ALPHA-stability domain does not include the boundary -C (see the Note below). -C -C A (input/output) DOUBLE PRECISION array, dimension (LDA,N) -C On entry, the leading N-by-N part of this array must -C contain the state dynamics matrix A. -C On exit, if INFO = 0, the leading N-by-N part of this -C array contains the state dynamics matrix A in a block -C diagonal real Schur form with its eigenvalues reordered -C and separated. The resulting A has two diagonal blocks. -C The leading NS-by-NS part of A has eigenvalues in the -C ALPHA-stability domain and the trailing (N-NS) x (N-NS) -C part has eigenvalues outside the ALPHA-stability domain. -C Note: The ALPHA-stability domain is defined either -C as the open half complex plane left to ALPHA, -C for a continous-time system (DICO = 'C'), or the -C interior of the ALPHA-radius circle centered in the -C origin, for a discrete-time system (DICO = 'D'). -C -C LDA INTEGER -C The leading dimension of array A. LDA >= MAX(1,N). -C -C B (input/output) DOUBLE PRECISION array, dimension (LDB,M) -C On entry, the leading N-by-M part of this array must -C contain the original input/state matrix B. -C On exit, if INFO = 0, the leading N-by-M part of this -C array contains the input/state matrix B of the transformed -C system. -C -C LDB INTEGER -C The leading dimension of array B. LDB >= MAX(1,N). -C -C C (input/output) DOUBLE PRECISION array, dimension (LDC,N) -C On entry, the leading P-by-N part of this array must -C contain the original state/output matrix C. -C On exit, if INFO = 0, the leading P-by-N part of this -C array contains the state/output matrix C of the -C transformed system. -C -C LDC INTEGER -C The leading dimension of array C. LDC >= MAX(1,P). -C -C NS (output) INTEGER -C The dimension of the ALPHA-stable subsystem. -C -C HSV (output) DOUBLE PRECISION array, dimension (N) -C If INFO = 0, the leading NS elements of HSV contain the -C Hankel singular values of the ALPHA-stable part of the -C original system ordered decreasingly. -C HSV(1) is the Hankel norm of the ALPHA-stable subsystem. -C -C Workspace -C -C DWORK DOUBLE PRECISION array, dimension (LDWORK) -C On exit, if INFO = 0, DWORK(1) returns the optimal value -C of LDWORK. -C -C LDWORK INTEGER -C The length of the array DWORK. -C LDWORK >= MAX(1,N*(MAX(N,M,P)+5)+N*(N+1)/2). -C For optimum performance LDWORK should be larger. -C -C Error Indicator -C -C INFO INTEGER -C = 0: successful exit; -C < 0: if INFO = -i, the i-th argument had an illegal -C value; -C = 1: the computation of the ordered real Schur form of A -C failed; -C = 2: the separation of the ALPHA-stable/unstable diagonal -C blocks failed because of very close eigenvalues; -C = 3: the computed ALPHA-stable part is just stable, -C having stable eigenvalues very near to the imaginary -C axis (if DICO = 'C') or to the unit circle -C (if DICO = 'D'); -C = 4: the computation of Hankel singular values failed. -C -C METHOD -C -C Let be the following linear system -C -C d[x(t)] = Ax(t) + Bu(t) -C y(t) = Cx(t) (1) -C -C where d[x(t)] is dx(t)/dt for a continuous-time system and x(t+1) -C for a discrete-time system, and let G be the corresponding -C transfer-function matrix. The following procedure is used to -C compute the Hankel-norm of the ALPHA-stable projection of G: -C -C 1) Decompose additively G as -C -C G = G1 + G2 -C -C such that G1 = (As,Bs,Cs) has only ALPHA-stable poles and -C G2 = (Au,Bu,Cu) has only ALPHA-unstable poles. -C For the computation of the additive decomposition, the -C algorithm presented in [1] is used. -C -C 2) Compute the Hankel-norm of ALPHA-stable projection G1 as the -C the maximum Hankel singular value of the system (As,Bs,Cs). -C The computation of the Hankel singular values is performed -C by using the square-root method of [2]. -C -C REFERENCES -C -C [1] Safonov, M.G., Jonckheere, E.A., Verma, M. and Limebeer, D.J. -C Synthesis of positive real multivariable feedback systems, -C Int. J. Control, Vol. 45, pp. 817-842, 1987. -C -C [2] Tombs, M.S. and Postlethwaite, I. -C Truncated balanced realization of stable, non-minimal -C state-space systems. -C Int. J. Control, Vol. 46, pp. 1319-1330, 1987. -C -C NUMERICAL ASPECTS -C -C The implemented method relies on a square-root technique. -C 3 -C The algorithms require about 17N floating point operations. -C -C CONTRIBUTOR -C -C C. Oara and A. Varga, German Aerospace Center, -C DLR Oberpfaffenhofen, July 1998. -C Based on the RASP routine SHANRM. -C -C REVISIONS -C -C Nov. 1998, V. Sima, Research Institute for Informatics, Bucharest. -C Dec. 1998, V. Sima, Katholieke Univ. Leuven, Leuven. -C Oct. 2001, V. Sima, Research Institute for Informatics, Bucharest. -C -C KEYWORDS -C -C Additive spectral decomposition, model reduction, -C multivariable system, state-space model, system norms. -C -C ****************************************************************** -C -C .. Parameters .. - DOUBLE PRECISION C100, ONE, ZERO - PARAMETER ( C100 = 100.0D0, ONE = 1.0D0, ZERO = 0.0D0 ) -C .. Scalar Arguments .. - CHARACTER DICO, EQUIL - INTEGER INFO, LDA, LDB, LDC, LDWORK, M, N, NS, P - DOUBLE PRECISION ALPHA -C .. Array Arguments .. - DOUBLE PRECISION A(LDA,*), B(LDB,*), C(LDC,*), DWORK(*), HSV(*) -C .. Local Scalars .. - LOGICAL DISCR - INTEGER IERR, KT, KW, KW1, KW2 - DOUBLE PRECISION ALPWRK, MAXRED, WRKOPT -C .. External Functions .. - LOGICAL LSAME - DOUBLE PRECISION AB13AX, DLAMCH - EXTERNAL AB13AX, DLAMCH, LSAME -C .. External Subroutines .. - EXTERNAL TB01ID, TB01KD, XERBLA -C .. Intrinsic Functions .. - INTRINSIC DBLE, MAX, MIN, SQRT -C .. Executable Statements .. -C - INFO = 0 - DISCR = LSAME( DICO, 'D' ) -C -C Test the input scalar arguments. -C - IF( .NOT. ( LSAME( DICO, 'C' ) .OR. DISCR ) ) THEN - INFO = -1 - ELSE IF( .NOT. ( LSAME( EQUIL, 'S' ) .OR. - $ LSAME( EQUIL, 'N' ) ) ) THEN - INFO = -2 - ELSE IF( N.LT.0 ) THEN - INFO = -3 - ELSE IF( M.LT.0 ) THEN - INFO = -4 - ELSE IF( P.LT.0 ) THEN - INFO = -5 - ELSE IF( ( DISCR .AND. ( ALPHA.LT.ZERO .OR. ALPHA.GT.ONE ) ) .OR. - $ ( .NOT.DISCR .AND. ALPHA.GT.ZERO ) ) THEN - INFO = -6 - ELSE IF( LDA.LT.MAX( 1, N ) ) THEN - INFO = -8 - ELSE IF( LDB.LT.MAX( 1, N ) ) THEN - INFO = -10 - ELSE IF( LDC.LT.MAX( 1, P ) ) THEN - INFO = -12 - ELSE IF( LDWORK.LT.MAX( 1, N*( MAX( N, M, P ) + 5 ) + - $ ( N*( N + 1 ) )/2 ) ) THEN - INFO = -16 - END IF -C - IF( INFO.NE.0 ) THEN -C -C Error return. -C - CALL XERBLA( 'AB13AD', -INFO ) - RETURN - END IF -C -C Quick return if possible. -C - IF( MIN( N, M, P ).EQ.0 ) THEN - NS = 0 - AB13AD = ZERO - DWORK(1) = ONE - RETURN - END IF -C - IF( LSAME( EQUIL, 'S' ) ) THEN -C -C Scale simultaneously the matrices A, B and C: -C A <- inv(D)*A*D, B <- inv(D)*B and C <- C*D, where D is a -C diagonal matrix. -C Workspace: N. -C - MAXRED = C100 - CALL TB01ID( 'All', N, M, P, MAXRED, A, LDA, B, LDB, C, LDC, - $ DWORK, INFO ) - END IF -C -C Correct the value of ALPHA to ensure stability. -C - ALPWRK = ALPHA - IF( DISCR ) THEN - IF( ALPHA.EQ.ONE ) ALPWRK = ONE - SQRT( DLAMCH( 'E' ) ) - ELSE - IF( ALPHA.EQ.ZERO ) ALPWRK = -SQRT( DLAMCH( 'E' ) ) - END IF -C -C Allocate working storage. -C - KT = 1 - KW1 = N*N + 1 - KW2 = KW1 + N - KW = KW2 + N -C -C Reduce A to a block diagonal real Schur form, with the -C ALPHA-stable part in the leading diagonal position, using a -C non-orthogonal similarity transformation A <- inv(T)*A*T and -C apply the transformation to B and C: B <- inv(T)*B and C <- C*T. -C -C Workspace needed: N*(N+2); -C Additional workspace: need 3*N; -C prefer larger. -C - CALL TB01KD( DICO, 'Stable', 'General', N, M, P, ALPWRK, A, LDA, - $ B, LDB, C, LDC, NS, DWORK(KT), N, DWORK(KW1), - $ DWORK(KW2), DWORK(KW), LDWORK-KW+1, IERR ) - IF( IERR.NE.0 ) THEN - IF( IERR.NE.3 ) THEN - INFO = 1 - ELSE - INFO = 2 - END IF - RETURN - END IF -C - WRKOPT = DWORK(KW) + DBLE( KW-1 ) -C - IF( NS.EQ.0 ) THEN - AB13AD = ZERO - ELSE -C -C Workspace: need N*(MAX(N,M,P)+5)+N*(N+1)/2; -C prefer larger. -C - AB13AD = AB13AX( DICO, NS, M, P, A, LDA, B, LDB, C, LDC, HSV, - $ DWORK, LDWORK, IERR ) -C - IF( IERR.NE.0 ) THEN - INFO = IERR + 2 - RETURN - END IF -C - DWORK(1) = MAX( WRKOPT, DWORK(1) ) - END IF -C - RETURN -C *** Last line of AB13AD *** - END diff --git a/mex/sources/libslicot/AB13AX.f b/mex/sources/libslicot/AB13AX.f deleted file mode 100644 index 4053e2a7e..000000000 --- a/mex/sources/libslicot/AB13AX.f +++ /dev/null @@ -1,308 +0,0 @@ - DOUBLE PRECISION FUNCTION AB13AX( DICO, N, M, P, A, LDA, B, LDB, - $ C, LDC, HSV, DWORK, LDWORK, - $ INFO ) -C -C SLICOT RELEASE 5.0. -C -C Copyright (c) 2002-2009 NICONET e.V. -C -C This program is free software: you can redistribute it and/or -C modify it under the terms of the GNU General Public License as -C published by the Free Software Foundation, either version 2 of -C the License, or (at your option) any later version. -C -C This program is distributed in the hope that it will be useful, -C but WITHOUT ANY WARRANTY; without even the implied warranty of -C MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the -C GNU General Public License for more details. -C -C You should have received a copy of the GNU General Public License -C along with this program. If not, see -C . -C -C PURPOSE -C -C To compute the Hankel-norm of the transfer-function matrix G of -C a stable state-space system (A,B,C). The state dynamics matrix A -C of the given system is an upper quasi-triangular matrix in -C real Schur form. -C -C FUNCTION VALUE -C -C AB13AX DOUBLE PRECISION -C The Hankel-norm of G (if INFO = 0). -C -C ARGUMENTS -C -C Mode Parameters -C -C DICO CHARACTER*1 -C Specifies the type of the system as follows: -C = 'C': continuous-time system; -C = 'D': discrete-time system. -C -C Input/Output Parameters -C -C N (input) INTEGER -C The order of the state-space representation, i.e. the -C order of the matrix A. N >= 0. -C -C M (input) INTEGER -C The number of system inputs. M >= 0. -C -C P (input) INTEGER -C The number of system outputs. P >= 0. -C -C A (input) DOUBLE PRECISION array, dimension (LDA,N) -C The leading N-by-N part of this array must contain the -C state dynamics matrix A in a real Schur canonical form. -C -C LDA INTEGER -C The leading dimension of array A. LDA >= MAX(1,N). -C -C B (input) DOUBLE PRECISION array, dimension (LDB,M) -C The leading N-by-M part of this array must contain the -C input/state matrix B. -C -C LDB INTEGER -C The leading dimension of array B. LDB >= MAX(1,N). -C -C C (input) DOUBLE PRECISION array, dimension (LDC,N) -C The leading P-by-N part of this array must contain the -C state/output matrix C. -C -C LDC INTEGER -C The leading dimension of array C. LDC >= MAX(1,P). -C -C HSV (output) DOUBLE PRECISION array, dimension (N) -C If INFO = 0, this array contains the Hankel singular -C values of the given system ordered decreasingly. -C HSV(1) is the Hankel norm of the given system. -C -C Workspace -C -C DWORK DOUBLE PRECISION array, dimension (LDWORK) -C On exit, if INFO = 0, DWORK(1) returns the optimal value -C of LDWORK. -C -C LDWORK INTEGER -C The length of the array DWORK. -C LDWORK >= MAX(1,N*(MAX(N,M,P)+5)+N*(N+1)/2). -C For optimum performance LDWORK should be larger. -C -C Error Indicator -C -C INFO INTEGER -C = 0: successful exit; -C < 0: if INFO = -i, the i-th argument had an illegal -C value; -C = 1: the state matrix A is not stable (if DICO = 'C') -C or not convergent (if DICO = 'D'); -C = 2: the computation of Hankel singular values failed. -C -C METHOD -C -C Let be the stable linear system -C -C d[x(t)] = Ax(t) + Bu(t) -C y(t) = Cx(t) (1) -C -C where d[x(t)] is dx(t)/dt for a continuous-time system and x(t+1) -C for a discrete-time system, and let G be the corresponding -C transfer-function matrix. The Hankel-norm of G is computed as the -C the maximum Hankel singular value of the system (A,B,C). -C The computation of the Hankel singular values is performed -C by using the square-root method of [1]. -C -C REFERENCES -C -C [1] Tombs M.S. and Postlethwaite I. -C Truncated balanced realization of stable, non-minimal -C state-space systems. -C Int. J. Control, Vol. 46, pp. 1319-1330, 1987. -C -C NUMERICAL ASPECTS -C -C The implemented method relies on a square-root technique. -C 3 -C The algorithms require about 17N floating point operations. -C -C CONTRIBUTOR -C -C A. Varga, German Aerospace Center, -C DLR Oberpfaffenhofen, July 1998. -C Based on the RASP routine SHANRM. -C -C REVISIONS -C -C Nov. 1998, V. Sima, Research Institute for Informatics, Bucharest. -C Feb. 2000, V. Sima, Research Institute for Informatics, Bucharest. -C Oct. 2001, V. Sima, Research Institute for Informatics, Bucharest. -C -C KEYWORDS -C -C Multivariable system, state-space model, system norms. -C -C ****************************************************************** -C -C .. Parameters .. - DOUBLE PRECISION ONE, ZERO - PARAMETER ( ONE = 1.0D0, ZERO = 0.0D0 ) -C .. Scalar Arguments .. - CHARACTER DICO - INTEGER INFO, LDA, LDB, LDC, LDWORK, M, N, P -C .. Array Arguments .. - DOUBLE PRECISION A(LDA,*), B(LDB,*), C(LDC,*), DWORK(*), HSV(*) -C .. Local Scalars .. - LOGICAL DISCR - INTEGER I, IERR, J, KR, KS, KTAU, KU, KW, MNMP - DOUBLE PRECISION SCALEC, SCALEO, WRKOPT -C .. External Functions .. - LOGICAL LSAME - EXTERNAL LSAME -C .. External Subroutines .. - EXTERNAL DLACPY, DSCAL, DTPMV, MA02DD, MB03UD, SB03OU, - $ XERBLA -C .. Intrinsic Functions .. - INTRINSIC DBLE, MAX, MIN -C .. Executable Statements .. -C - INFO = 0 - DISCR = LSAME( DICO, 'D' ) -C -C Test the input scalar arguments. -C - IF( .NOT. ( LSAME( DICO, 'C' ) .OR. DISCR ) ) THEN - INFO = -1 - ELSE IF( N.LT.0 ) THEN - INFO = -2 - ELSE IF( M.LT.0 ) THEN - INFO = -3 - ELSE IF( P.LT.0 ) THEN - INFO = -4 - ELSE IF( LDA.LT.MAX( 1, N ) ) THEN - INFO = -6 - ELSE IF( LDB.LT.MAX( 1, N ) ) THEN - INFO = -8 - ELSE IF( LDC.LT.MAX( 1, P ) ) THEN - INFO = -10 - ELSE IF( LDWORK.LT.MAX( 1, N*( MAX( N, M, P ) + 5 ) + - $ ( N*( N + 1 ) )/2 ) ) THEN - INFO = -13 - END IF -C - IF( INFO.NE.0 ) THEN -C -C Error return. -C - CALL XERBLA( 'AB13AX', -INFO ) - RETURN - END IF -C -C Quick return if possible. -C - IF( MIN( N, M, P ).EQ.0 ) THEN - AB13AX = ZERO - DWORK(1) = ONE - RETURN - END IF -C -C Allocate N*MAX(N,M,P), N, and N*(N+1)/2 working storage for the -C matrices S, TAU, and R, respectively. S shares the storage with U. -C - KU = 1 - KS = 1 - MNMP = MAX( N, M, P ) - KTAU = KS + N*MNMP - KR = KTAU + N - KW = KR -C -C Copy C in U. -C - CALL DLACPY( 'Full', P, N, C, LDC, DWORK(KU), MNMP ) -C -C If DISCR = .FALSE., solve for R the Lyapunov equation -C 2 -C A'*(R'*R) + (R'*R)*A + scaleo * C'*C = 0 . -C -C If DISCR = .TRUE., solve for R the Lyapunov equation -C 2 -C A'*(R'*R)*A + scaleo * C'*C = R'*R . -C -C Workspace needed: N*(MAX(N,M,P)+1); -C Additional workspace: need 4*N; -C prefer larger. -C - CALL SB03OU( DISCR, .FALSE., N, P, A, LDA, DWORK(KU), MNMP, - $ DWORK(KTAU), DWORK(KU), N, SCALEO, DWORK(KW), - $ LDWORK-KW+1, IERR ) - IF( IERR.NE.0 ) THEN - INFO = 1 - RETURN - ENDIF -C - WRKOPT = DWORK(KW) + DBLE( KW-1 ) -C -C Pack the upper triangle of R in DWORK(KR). -C Workspace needed: N*(MAX(N,M,P) + 1) + N*(N+1)/2. -C - CALL MA02DD( 'Pack', 'Upper', N, DWORK(KU), N, DWORK(KR) ) -C - KW = KR + ( N*( N + 1 ) )/2 -C -C Copy B in S (over U). -C - CALL DLACPY( 'Full', N, M, B, LDB, DWORK(KS), N ) -C -C If DISCR = .FALSE., solve for S the Lyapunov equation -C 2 -C A*(S*S') + (S*S')*A' + scalec *B*B' = 0 . -C -C If DISCR = .TRUE., solve for S the Lyapunov equation -C 2 -C A*(S*S')*A' + scalec *B*B' = S*S' . -C -C Workspace needed: N*(MAX(N,M,P) + 1) + N*(N+1)/2; -C Additional workspace: need 4*N; -C prefer larger. -C - CALL SB03OU( DISCR, .TRUE., N, M, A, LDA, DWORK(KS), N, - $ DWORK(KTAU), DWORK(KS), N, SCALEC, DWORK(KW), - $ LDWORK-KW+1, IERR ) -C - WRKOPT = MAX( WRKOPT, DWORK(KW) + DBLE( KW-1 ) ) -C -C | x x | -C Compute R*S in the form | 0 x | in S. Note that R is packed. -C - J = KS - DO 10 I = 1, N - CALL DTPMV( 'Upper', 'NoTranspose', 'NonUnit', I, DWORK(KR), - $ DWORK(J), 1 ) - J = J + N - 10 CONTINUE -C -C Compute the singular values of the upper triangular matrix R*S. -C -C Workspace needed: N*MAX(N,M,P); -C Additional workspace: need MAX(1,5*N); -C prefer larger. -C - KW = KTAU - CALL MB03UD( 'NoVectors', 'NoVectors', N, DWORK(KS), N, DWORK, 1, - $ HSV, DWORK(KW), LDWORK-KW+1, IERR ) - IF( IERR.NE.0 ) THEN - INFO = 2 - RETURN - ENDIF -C -C Scale singular values. -C - CALL DSCAL( N, ONE / SCALEC / SCALEO, HSV, 1 ) - AB13AX = HSV(1) -C - DWORK(1) = MAX( WRKOPT, DWORK(KW) + DBLE( KW-1 ) ) -C - RETURN -C *** Last line of AB13AX *** - END diff --git a/mex/sources/libslicot/AB13BD.f b/mex/sources/libslicot/AB13BD.f deleted file mode 100644 index ac69fd7b6..000000000 --- a/mex/sources/libslicot/AB13BD.f +++ /dev/null @@ -1,390 +0,0 @@ - DOUBLE PRECISION FUNCTION AB13BD( DICO, JOBN, N, M, P, A, LDA, - $ B, LDB, C, LDC, D, LDD, NQ, TOL, - $ DWORK, LDWORK, IWARN, INFO) -C -C SLICOT RELEASE 5.0. -C -C Copyright (c) 2002-2009 NICONET e.V. -C -C This program is free software: you can redistribute it and/or -C modify it under the terms of the GNU General Public License as -C published by the Free Software Foundation, either version 2 of -C the License, or (at your option) any later version. -C -C This program is distributed in the hope that it will be useful, -C but WITHOUT ANY WARRANTY; without even the implied warranty of -C MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the -C GNU General Public License for more details. -C -C You should have received a copy of the GNU General Public License -C along with this program. If not, see -C . -C -C PURPOSE -C -C To compute the H2 or L2 norm of the transfer-function matrix G -C of the system (A,B,C,D). G must not have poles on the imaginary -C axis, for a continuous-time system, or on the unit circle, for -C a discrete-time system. If the H2-norm is computed, the system -C must be stable. -C -C FUNCTION VALUE -C -C AB13BD DOUBLE PRECISION -C The H2-norm of G, if JOBN = 'H', or the L2-norm of G, -C if JOBN = 'L' (if INFO = 0). -C -C ARGUMENTS -C -C Mode Parameters -C -C DICO CHARACTER*1 -C Specifies the type of the system as follows: -C = 'C': continuous-time system; -C = 'D': discrete-time system. -C -C JOBN CHARACTER*1 -C Specifies the norm to be computed as follows: -C = 'H': the H2-norm; -C = 'L': the L2-norm. -C -C Input/Output Parameters -C -C N (input) INTEGER -C The order of the matrix A, the number of rows of the -C matrix B, and the number of columns of the matrix C. -C N represents the dimension of the state vector. N >= 0. -C -C M (input) INTEGER -C The number of columns of the matrices B and D. -C M represents the dimension of input vector. M >= 0. -C -C P (input) INTEGER -C The number of rows of the matrices C and D. -C P represents the dimension of output vector. P >= 0. -C -C A (input/output) DOUBLE PRECISION array, dimension (LDA,N) -C On entry, the leading N-by-N part of this array must -C contain the state dynamics matrix of the system. -C On exit, the leading NQ-by-NQ part of this array contains -C the state dynamics matrix (in a real Schur form) of the -C numerator factor Q of the right coprime factorization with -C inner denominator of G (see METHOD). -C -C LDA INTEGER -C The leading dimension of array A. LDA >= MAX(1,N). -C -C B (input/output) DOUBLE PRECISION array, dimension (LDB,M) -C On entry, the leading N-by-M part of this array must -C contain the input/state matrix of the system. -C On exit, the leading NQ-by-M part of this array contains -C the input/state matrix of the numerator factor Q of the -C right coprime factorization with inner denominator of G -C (see METHOD). -C -C LDB INTEGER -C The leading dimension of array B. LDB >= MAX(1,N). -C -C C (input/output) DOUBLE PRECISION array, dimension (LDC,N) -C On entry, the leading P-by-N part of this array must -C contain the state/output matrix of the system. -C On exit, the leading P-by-NQ part of this array contains -C the state/output matrix of the numerator factor Q of the -C right coprime factorization with inner denominator of G -C (see METHOD). -C -C LDC INTEGER -C The leading dimension of array C. LDC >= MAX(1,P). -C -C D (input/output) DOUBLE PRECISION array, dimension (LDD,M) -C On entry, the leading P-by-M part of this array must -C contain the input/output matrix of the system. -C If DICO = 'C', D must be a null matrix. -C On exit, the leading P-by-M part of this array contains -C the input/output matrix of the numerator factor Q of -C the right coprime factorization with inner denominator -C of G (see METHOD). -C -C LDD INTEGER -C The leading dimension of array D. LDD >= MAX(1,P). -C -C NQ (output) INTEGER -C The order of the resulting numerator Q of the right -C coprime factorization with inner denominator of G (see -C METHOD). -C Generally, NQ = N - NS, where NS is the number of -C uncontrollable unstable eigenvalues. -C -C Tolerances -C -C TOL DOUBLE PRECISION -C The absolute tolerance level below which the elements of -C B are considered zero (used for controllability tests). -C If the user sets TOL <= 0, then an implicitly computed, -C default tolerance, defined by TOLDEF = N*EPS*NORM(B), -C is used instead, where EPS is the machine precision -C (see LAPACK Library routine DLAMCH) and NORM(B) denotes -C the 1-norm of B. -C -C Workspace -C -C DWORK DOUBLE PRECISION array, dimension (LDWORK) -C On exit, if INFO = 0, DWORK(1) returns the optimal value -C of LDWORK. -C -C LDWORK INTEGER -C The dimension of working array DWORK. -C LDWORK >= MAX( 1, M*(N+M) + MAX( N*(N+5), M*(M+2), 4*P ), -C N*( MAX( N, P ) + 4 ) + MIN( N, P ) ). -C For optimum performance LDWORK should be larger. -C -C Warning Indicator -C -C IWARN INTEGER -C = 0: no warning; -C = K: K violations of the numerical stability condition -C occured during the assignment of eigenvalues in -C computing the right coprime factorization with inner -C denominator of G (see the SLICOT subroutine SB08DD). -C -C Error Indicator -C -C INFO INTEGER -C = 0: successful exit; -C < 0: if INFO = -i, the i-th argument had an illegal -C value; -C = 1: the reduction of A to a real Schur form failed; -C = 2: a failure was detected during the reordering of the -C real Schur form of A, or in the iterative process -C for reordering the eigenvalues of Z'*(A + B*F)*Z -C along the diagonal (see SLICOT routine SB08DD); -C = 3: if DICO = 'C' and the matrix A has a controllable -C eigenvalue on the imaginary axis, or DICO = 'D' -C and A has a controllable eigenvalue on the unit -C circle; -C = 4: the solution of Lyapunov equation failed because -C the equation is singular; -C = 5: if DICO = 'C' and D is a nonzero matrix; -C = 6: if JOBN = 'H' and the system is unstable. -C -C METHOD -C -C The subroutine is based on the algorithms proposed in [1] and [2]. -C -C If the given transfer-function matrix G is unstable, then a right -C coprime factorization with inner denominator of G is first -C computed -C -1 -C G = Q*R , -C -C where Q and R are stable transfer-function matrices and R is -C inner. If G is stable, then Q = G and R = I. -C Let (AQ,BQ,CQ,DQ) be the state-space representation of Q. -C -C If DICO = 'C', then the L2-norm of G is computed as -C -C NORM2(G) = NORM2(Q) = SQRT(TRACE(BQ'*X*BQ)), -C -C where X satisfies the continuous-time Lyapunov equation -C -C AQ'*X + X*AQ + CQ'*CQ = 0. -C -C If DICO = 'D', then the l2-norm of G is computed as -C -C NORM2(G) = NORM2(Q) = SQRT(TRACE(BQ'*X*BQ+DQ'*DQ)), -C -C where X satisfies the discrete-time Lyapunov equation -C -C AQ'*X*AQ - X + CQ'*CQ = 0. -C -C REFERENCES -C -C [1] Varga A. -C On computing 2-norms of transfer-function matrices. -C Proc. 1992 ACC, Chicago, June 1992. -C -C [2] Varga A. -C A Schur method for computing coprime factorizations with -C inner denominators and applications in model reduction. -C Proc. ACC'93, San Francisco, CA, pp. 2130-2131, 1993. -C -C NUMERICAL ASPECTS -C 3 -C The algorithm requires no more than 14N floating point -C operations. -C -C CONTRIBUTOR -C -C C. Oara and A. Varga, German Aerospace Center, -C DLR Oberpfaffenhofen, July 1998. -C Based on the RASP routine SL2NRM. -C -C REVISIONS -C -C Nov. 1998, V. Sima, Research Institute for Informatics, Bucharest. -C Dec. 1998, V. Sima, Katholieke Univ. Leuven, Leuven. -C Oct. 2001, V. Sima, Research Institute for Informatics, Bucharest. -C Jan. 2003, V. Sima, Research Institute for Informatics, Bucharest. -C -C KEYWORDS -C -C Coprime factorization, Lyapunov equation, multivariable system, -C state-space model, system norms. -C -C ****************************************************************** -C -C .. Parameters .. - DOUBLE PRECISION ONE, ZERO - PARAMETER ( ONE = 1.0D0, ZERO = 0.0D0 ) -C .. Scalar Arguments .. - CHARACTER DICO, JOBN - INTEGER INFO, IWARN, LDA, LDB, LDC, LDD, LDWORK, M, - $ N, NQ, P - DOUBLE PRECISION TOL -C .. Array Arguments .. - DOUBLE PRECISION A(LDA,*), B(LDB,*), C(LDC,*), D(LDD,*), DWORK(*) -C .. Local Scalars .. - LOGICAL DISCR - INTEGER KCR, KDR, KRW, KTAU, KU, MXNP, NR - DOUBLE PRECISION S2NORM, SCALE, WRKOPT -C .. External functions .. - LOGICAL LSAME - DOUBLE PRECISION DLANGE, DLAPY2 - EXTERNAL DLANGE, DLAPY2, LSAME -C .. External subroutines .. - EXTERNAL DLACPY, DTRMM, SB03OU, SB08DD, XERBLA -C .. Intrinsic Functions .. - INTRINSIC DBLE, MAX, MIN -C .. Executable Statements .. -C - DISCR = LSAME( DICO, 'D' ) - INFO = 0 - IWARN = 0 -C -C Check the scalar input parameters. -C - IF( .NOT. ( LSAME( DICO, 'C' ) .OR. DISCR ) ) THEN - INFO = -1 - ELSE IF( .NOT. ( LSAME( JOBN, 'H' ) .OR. LSAME( JOBN, 'L' ) ) ) - $ THEN - INFO = -2 - ELSE IF( N.LT.0 ) THEN - INFO = -3 - ELSE IF( M.LT.0 ) THEN - INFO = -4 - ELSE IF( P.LT.0 ) THEN - INFO = -5 - ELSE IF( LDA.LT.MAX( 1, N ) ) THEN - INFO = -7 - ELSE IF( LDB.LT.MAX( 1, N ) ) THEN - INFO = -9 - ELSE IF( LDC.LT.MAX( 1, P ) ) THEN - INFO = -11 - ELSE IF( LDD.LT.MAX( 1, P ) ) THEN - INFO = -13 - ELSE IF( LDWORK.LT.MAX( 1, M*( N + M ) + - $ MAX( N*( N + 5 ), M*( M + 2 ), 4*P ), - $ N*( MAX( N, P ) + 4 ) + MIN( N, P ) ) ) - $ THEN - INFO = -17 - END IF - IF( INFO.NE.0 )THEN -C -C Error return. -C - CALL XERBLA( 'AB13BD', -INFO ) - RETURN - END IF -C -C Compute the Frobenius norm of D. -C - S2NORM = DLANGE( 'Frobenius', P, M, D, LDD, DWORK ) - IF( .NOT.DISCR .AND. S2NORM.NE.ZERO ) THEN - INFO = 5 - RETURN - END IF -C -C Quick return if possible. -C - IF( MIN( N, M, P ).EQ.0 ) THEN - NQ = 0 - AB13BD = ZERO - DWORK(1) = ONE - RETURN - END IF -C - KCR = 1 - KDR = KCR + M*N - KRW = KDR + M*M -C -C Compute the right coprime factorization with inner denominator -C of G. -C -C Workspace needed: M*(N+M); -C Additional workspace: need MAX( N*(N+5), M*(M+2), 4*M, 4*P ); -C prefer larger. -C - CALL SB08DD( DICO, N, M, P, A, LDA, B, LDB, C, LDC, D, LDD, NQ, - $ NR, DWORK(KCR), M, DWORK(KDR), M, TOL, DWORK(KRW), - $ LDWORK-KRW+1, IWARN, INFO ) - IF( INFO.NE.0 ) - $ RETURN -C - WRKOPT = DWORK(KRW) + DBLE( KRW-1 ) -C -C Check stability. -C - IF( LSAME( JOBN, 'H' ) .AND. NR.GT.0 ) THEN - INFO = 6 - RETURN - END IF -C - IF( NQ.GT.0 ) THEN - KU = 1 - MXNP = MAX( NQ, P ) - KTAU = NQ*MXNP + 1 - KRW = KTAU + MIN( NQ, P ) -C -C Find X, the solution of Lyapunov equation. -C -C Workspace needed: N*MAX(N,P) + MIN(N,P); -C Additional workspace: 4*N; -C prefer larger. -C - CALL DLACPY( 'Full', P, NQ, C, LDC, DWORK(KU), MXNP ) - CALL SB03OU( DISCR, .FALSE., NQ, P, A, LDA, DWORK(KU), MXNP, - $ DWORK(KTAU), DWORK(KU), NQ, SCALE, DWORK(KRW), - $ LDWORK-KRW+1, INFO ) - IF( INFO.NE.0 ) THEN - IF( INFO.EQ.1 ) THEN - INFO = 4 - ELSE IF( INFO.EQ.2 ) THEN - INFO = 3 - END IF - RETURN - END IF -C - WRKOPT = MAX( WRKOPT, DWORK(KRW) + DBLE( KRW-1 ) ) -C -C Add the contribution of BQ'*X*BQ. -C -C Workspace needed: N*(N+M). -C - KTAU = NQ*NQ + 1 - CALL DLACPY( 'Full', NQ, M, B, LDB, DWORK(KTAU), NQ ) - CALL DTRMM( 'Left', 'Upper', 'NoTranspose', 'NonUnit', NQ, M, - $ ONE, DWORK(KU), NQ, DWORK(KTAU), NQ ) - IF( NR.GT.0 ) - $ S2NORM = DLANGE( 'Frobenius', P, M, D, LDD, DWORK ) - S2NORM = DLAPY2( S2NORM, DLANGE( 'Frobenius', NQ, M, - $ DWORK(KTAU), NQ, DWORK ) - $ / SCALE ) - END IF -C - AB13BD = S2NORM -C - DWORK(1) = WRKOPT -C - RETURN -C *** Last line of AB13BD *** - END diff --git a/mex/sources/libslicot/AB13CD.f b/mex/sources/libslicot/AB13CD.f deleted file mode 100644 index ec9fa2559..000000000 --- a/mex/sources/libslicot/AB13CD.f +++ /dev/null @@ -1,601 +0,0 @@ - DOUBLE PRECISION FUNCTION AB13CD( N, M, NP, A, LDA, B, LDB, C, - $ LDC, D, LDD, TOL, IWORK, DWORK, - $ LDWORK, CWORK, LCWORK, BWORK, - $ INFO ) -C -C SLICOT RELEASE 5.0. -C -C Copyright (c) 2002-2009 NICONET e.V. -C -C This program is free software: you can redistribute it and/or -C modify it under the terms of the GNU General Public License as -C published by the Free Software Foundation, either version 2 of -C the License, or (at your option) any later version. -C -C This program is distributed in the hope that it will be useful, -C but WITHOUT ANY WARRANTY; without even the implied warranty of -C MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the -C GNU General Public License for more details. -C -C You should have received a copy of the GNU General Public License -C along with this program. If not, see -C . -C -C PURPOSE -C -C To compute the H-infinity norm of the continuous-time stable -C system -C -C | A | B | -C G(s) = |---|---| . -C | C | D | -C -C FUNCTION VALUE -C -C AB13CD DOUBLE PRECISION -C If INFO = 0, the H-infinity norm of the system, HNORM, -C i.e., the peak gain of the frequency response (as measured -C by the largest singular value in the MIMO case). -C -C ARGUMENTS -C -C Input/Output Parameters -C -C N (input) INTEGER -C The order of the system. N >= 0. -C -C M (input) INTEGER -C The column size of the matrix B. M >= 0. -C -C NP (input) INTEGER -C The row size of the matrix C. NP >= 0. -C -C A (input) DOUBLE PRECISION array, dimension (LDA,N) -C The leading N-by-N part of this array must contain the -C system state matrix A. -C -C LDA INTEGER -C The leading dimension of the array A. LDA >= max(1,N). -C -C B (input) DOUBLE PRECISION array, dimension (LDB,M) -C The leading N-by-M part of this array must contain the -C system input matrix B. -C -C LDB INTEGER -C The leading dimension of the array B. LDB >= max(1,N). -C -C C (input) DOUBLE PRECISION array, dimension (LDC,N) -C The leading NP-by-N part of this array must contain the -C system output matrix C. -C -C LDC INTEGER -C The leading dimension of the array C. LDC >= max(1,NP). -C -C D (input) DOUBLE PRECISION array, dimension (LDD,M) -C The leading NP-by-M part of this array must contain the -C system input/output matrix D. -C -C LDD INTEGER -C The leading dimension of the array D. LDD >= max(1,NP). -C -C Tolerances -C -C TOL DOUBLE PRECISION -C Tolerance used to set the accuracy in determining the -C norm. -C -C Workspace -C -C IWORK INTEGER array, dimension N -C -C DWORK DOUBLE PRECISION array, dimension (LDWORK) -C On exit, if INFO = 0, DWORK(1) contains the optimal value -C of LDWORK, and DWORK(2) contains the frequency where the -C gain of the frequency response achieves its peak value -C HNORM. -C -C LDWORK INTEGER -C The dimension of the array DWORK. -C LDWORK >= max(2,4*N*N+2*M*M+3*M*N+M*NP+2*(N+NP)*NP+10*N+ -C 6*max(M,NP)). -C For good performance, LDWORK must generally be larger. -C -C CWORK COMPLEX*16 array, dimension (LCWORK) -C On exit, if INFO = 0, CWORK(1) contains the optimal value -C of LCWORK. -C -C LCWORK INTEGER -C The dimension of the array CWORK. -C LCWORK >= max(1,(N+M)*(N+NP)+3*max(M,NP)). -C For good performance, LCWORK must generally be larger. -C -C BWORK LOGICAL array, dimension (2*N) -C -C Error Indicator -C -C INFO INTEGER -C = 0: successful exit; -C < 0: if INFO = -i, the i-th argument had an illegal -C value; -C = 1: the system is unstable; -C = 2: the tolerance is too small (the algorithm for -C computing the H-infinity norm did not converge); -C = 3: errors in computing the eigenvalues of A or of the -C Hamiltonian matrix (the QR algorithm did not -C converge); -C = 4: errors in computing singular values. -C -C METHOD -C -C The routine implements the method presented in [1]. -C -C REFERENCES -C -C [1] Bruinsma, N.A. and Steinbuch, M. -C A fast algorithm to compute the Hinfinity-norm of a transfer -C function matrix. -C Systems & Control Letters, vol. 14, pp. 287-293, 1990. -C -C NUMERICAL ASPECTS -C -C If the algorithm does not converge (INFO = 2), the tolerance must -C be increased. -C -C CONTRIBUTORS -C -C P.Hr. Petkov, D.W. Gu and M.M. Konstantinov, May 1999. -C -C REVISIONS -C -C V. Sima, Research Institute for Informatics, Bucharest, Aug. 1999, -C Oct. 2000. -C P.Hr. Petkov, October 2000. -C A. Varga, October 2000. -C Oct. 2001, V. Sima, Research Institute for Informatics, Bucharest. -C -C KEYWORDS -C -C H-infinity optimal control, robust control, system norm. -C -C ****************************************************************** -C -C .. Parameters .. - INTEGER MAXIT - PARAMETER ( MAXIT = 10 ) - COMPLEX*16 CONE, JIMAG - PARAMETER ( CONE = ( 1.0D0, 0.0D0 ), - $ JIMAG = ( 0.0D0, 1.0D0 ) ) - DOUBLE PRECISION ZERO, ONE, TWO - PARAMETER ( ZERO = 0.0D+0, ONE = 1.0D+0, TWO = 2.0D+0 ) - DOUBLE PRECISION HUGE - PARAMETER ( HUGE = 10.0D+0**30 ) -C .. -C .. Scalar Arguments .. - INTEGER INFO, LDA, LDB, LDC, LCWORK, LDD, LDWORK, M, N, - $ NP - DOUBLE PRECISION TOL -C .. -C .. Array Arguments .. - INTEGER IWORK( * ) - COMPLEX*16 CWORK( * ) - DOUBLE PRECISION A( LDA, * ), B( LDB, * ), C( LDC, * ), - $ D( LDD, * ), DWORK( * ) - LOGICAL BWORK( * ) -C .. -C .. Local Scalars .. - INTEGER I, ICW2, ICW3, ICW4, ICWRK, INFO2, ITER, IW10, - $ IW11, IW12, IW2, IW3, IW4, IW5, IW6, IW7, IW8, - $ IW9, IWRK, J, K, L, LCWAMX, LWAMAX, MINCWR, - $ MINWRK, SDIM - DOUBLE PRECISION DEN, FPEAK, GAMMA, GAMMAL, GAMMAU, OMEGA, RAT, - $ RATMAX, TEMP, WIMAX, WRMIN - LOGICAL COMPLX -C -C .. External Functions .. - DOUBLE PRECISION DLAPY2 - LOGICAL SB02MV, SB02CX - EXTERNAL DLAPY2, SB02MV, SB02CX -C .. -C .. External Subroutines .. - EXTERNAL DGEES, DGEMM, DGESV, DGESVD, DLACPY, DPOSV, - $ DPOTRF, DPOTRS, DSYRK, MA02ED, MB01RX, XERBLA, - $ ZGEMM, ZGESV, ZGESVD -C .. -C .. Intrinsic Functions .. - INTRINSIC ABS, DBLE, INT, MAX, MIN -C .. -C .. Executable Statements .. -C -C Test the input scalar parameters. -C - INFO = 0 - IF( N.LT.0 ) THEN - INFO = -1 - ELSE IF( M.LT.0 ) THEN - INFO = -2 - ELSE IF( NP.LT.0 ) THEN - INFO = -3 - ELSE IF( LDA.LT.MAX( 1, N ) ) THEN - INFO = -5 - ELSE IF( LDB.LT.MAX( 1, N ) ) THEN - INFO = -7 - ELSE IF( LDC.LT.MAX( 1, NP ) ) THEN - INFO = -9 - ELSE IF( LDD.LT.MAX( 1, NP ) ) THEN - INFO = -11 - END IF -C -C Compute workspace. -C - MINWRK = MAX( 2, 4*N*N + 2*M*M + 3*M*N + M*NP + 2*( N + NP )*NP + - $ 10*N + 6*MAX( M, NP ) ) - IF( LDWORK.LT.MINWRK ) THEN - INFO = -15 - END IF - MINCWR = MAX( 1, ( N + M )*( N + NP ) + 3*MAX( M, NP ) ) - IF( LCWORK.LT.MINCWR ) THEN - INFO = -17 - END IF - IF( INFO.NE.0 ) THEN - CALL XERBLA( 'AB13CD', -INFO ) - RETURN - END IF -C -C Quick return if possible. -C - IF( M.EQ.0 .OR. NP.EQ.0 ) RETURN -C -C Workspace usage. -C - IW2 = N - IW3 = IW2 + N - IW4 = IW3 + N*N - IW5 = IW4 + N*M - IW6 = IW5 + NP*M - IWRK = IW6 + MIN( NP, M ) -C -C Determine the maximum singular value of G(infinity) = D . -C - CALL DLACPY( 'Full', NP, M, D, LDD, DWORK( IW5+1 ), NP ) - CALL DGESVD( 'N', 'N', NP, M, DWORK( IW5+1 ), NP, DWORK( IW6+1 ), - $ DWORK, NP, DWORK, M, DWORK( IWRK+1 ), LDWORK-IWRK, - $ INFO2 ) - IF( INFO2.GT.0 ) THEN - INFO = 4 - RETURN - END IF - GAMMAL = DWORK( IW6+1 ) - FPEAK = HUGE - LWAMAX = INT( DWORK( IWRK+1 ) ) + IWRK -C -C Quick return if N = 0 . -C - IF( N.EQ.0 ) THEN - AB13CD = GAMMAL - DWORK(1) = TWO - DWORK(2) = ZERO - CWORK(1) = ONE - RETURN - END IF -C -C Stability check. -C - CALL DLACPY( 'Full', N, N, A, LDA, DWORK( IW3+1 ), N ) - CALL DGEES( 'N', 'S', SB02MV, N, DWORK( IW3+1 ), N, SDIM, DWORK, - $ DWORK( IW2+1 ), DWORK, N, DWORK( IWRK+1 ), - $ LDWORK-IWRK, BWORK, INFO2 ) - IF( INFO2.GT.0 ) THEN - INFO = 3 - RETURN - END IF - IF( SDIM.LT.N ) THEN - INFO = 1 - RETURN - END IF - LWAMAX = MAX( INT( DWORK( IWRK+1 ) ) + IWRK, LWAMAX ) -C -C Determine the maximum singular value of G(0) = -C*inv(A)*B + D . -C - CALL DLACPY( 'Full', N, N, A, LDA, DWORK( IW3+1 ), N ) - CALL DLACPY( 'Full', N, M, B, LDB, DWORK( IW4+1 ), N ) - CALL DLACPY( 'Full', NP, M, D, LDD, DWORK( IW5+1 ), NP ) - CALL DGESV( N, M, DWORK( IW3+1 ), N, IWORK, DWORK( IW4+1 ), N, - $ INFO2 ) - IF( INFO2.GT.0 ) THEN - INFO = 1 - RETURN - END IF - CALL DGEMM( 'N', 'N', NP, M, N, -ONE, C, LDC, DWORK( IW4+1 ), N, - $ ONE, DWORK( IW5+1 ), NP ) - CALL DGESVD( 'N', 'N', NP, M, DWORK( IW5+1 ), NP, DWORK( IW6+1 ), - $ DWORK, NP, DWORK, M, DWORK( IWRK+1 ), LDWORK-IWRK, - $ INFO2 ) - IF( INFO2.GT.0 ) THEN - INFO = 4 - RETURN - END IF - IF( GAMMAL.LT.DWORK( IW6+1 ) ) THEN - GAMMAL = DWORK( IW6+1 ) - FPEAK = ZERO - END IF - LWAMAX = MAX( INT( DWORK( IWRK+1 ) ) + IWRK, LWAMAX ) -C -C Find a frequency which is close to the peak frequency. -C - COMPLX = .FALSE. - DO 10 I = 1, N - IF( DWORK( IW2+I ).NE.ZERO ) COMPLX = .TRUE. - 10 CONTINUE - IF( .NOT.COMPLX ) THEN - WRMIN = ABS( DWORK( 1 ) ) - DO 20 I = 2, N - IF( WRMIN.GT.ABS( DWORK( I ) ) ) WRMIN = ABS( DWORK( I ) ) - 20 CONTINUE - OMEGA = WRMIN - ELSE - RATMAX = ZERO - DO 30 I = 1, N - DEN = DLAPY2( DWORK( I ), DWORK( IW2+I ) ) - RAT = ABS( ( DWORK( IW2+I )/DWORK( I ) )/DEN ) - IF( RATMAX.LT.RAT ) THEN - RATMAX = RAT - WIMAX = DEN - END IF - 30 CONTINUE - OMEGA = WIMAX - END IF -C -C Workspace usage. -C - ICW2 = N*N - ICW3 = ICW2 + N*M - ICW4 = ICW3 + NP*N - ICWRK = ICW4 + NP*M -C -C Determine the maximum singular value of -C G(omega) = C*inv(j*omega*In - A)*B + D . -C - DO 50 J = 1, N - DO 40 I = 1, N - CWORK( I+(J-1)*N ) = -A( I, J ) - 40 CONTINUE - CWORK( J+(J-1)*N ) = JIMAG*OMEGA - A( J, J ) - 50 CONTINUE - DO 70 J = 1, M - DO 60 I = 1, N - CWORK( ICW2+I+(J-1)*N ) = B( I, J ) - 60 CONTINUE - 70 CONTINUE - DO 90 J = 1, N - DO 80 I = 1, NP - CWORK( ICW3+I+(J-1)*NP ) = C( I, J ) - 80 CONTINUE - 90 CONTINUE - DO 110 J = 1, M - DO 100 I = 1, NP - CWORK( ICW4+I+(J-1)*NP ) = D( I, J ) - 100 CONTINUE - 110 CONTINUE - CALL ZGESV( N, M, CWORK, N, IWORK, CWORK( ICW2+1 ), N, INFO2 ) - IF( INFO2.GT.0 ) THEN - INFO = 1 - RETURN - END IF - CALL ZGEMM( 'N', 'N', NP, M, N, CONE, CWORK( ICW3+1 ), NP, - $ CWORK( ICW2+1 ), N, CONE, CWORK( ICW4+1 ), NP ) - CALL ZGESVD( 'N', 'N', NP, M, CWORK( ICW4+1 ), NP, DWORK( IW6+1 ), - $ CWORK, NP, CWORK, M, CWORK( ICWRK+1 ), LCWORK-ICWRK, - $ DWORK( IWRK+1 ), INFO2 ) - IF( INFO2.GT.0 ) THEN - INFO = 4 - RETURN - END IF - IF( GAMMAL.LT.DWORK( IW6+1 ) ) THEN - GAMMAL = DWORK( IW6+1 ) - FPEAK = OMEGA - END IF - LCWAMX = INT( CWORK( ICWRK+1 ) ) + ICWRK -C -C Workspace usage. -C - IW2 = M*N - IW3 = IW2 + M*M - IW4 = IW3 + NP*NP - IW5 = IW4 + M*M - IW6 = IW5 + M*N - IW7 = IW6 + M*N - IW8 = IW7 + NP*NP - IW9 = IW8 + NP*N - IW10 = IW9 + 4*N*N - IW11 = IW10 + 2*N - IW12 = IW11 + 2*N - IWRK = IW12 + MIN( NP, M ) -C -C Compute D'*C . -C - CALL DGEMM( 'T', 'N', M, N, NP, ONE, D, LDD, C, LDC, ZERO, - $ DWORK, M ) -C -C Compute D'*D . -C - CALL DSYRK( 'U', 'T', M, NP, ONE, D, LDD, ZERO, DWORK( IW2+1 ), - $ M ) -C -C Compute D*D' . -C - CALL DSYRK( 'U', 'N', NP, M, ONE, D, LDD, ZERO, DWORK( IW3+1 ), - $ NP ) -C -C Main iteration loop for gamma. -C - ITER = 0 - 120 ITER = ITER + 1 - IF( ITER.GT.MAXIT ) THEN - INFO = 2 - RETURN - END IF - GAMMA = ( ONE + TWO*TOL )*GAMMAL -C -C Compute R = GAMMA^2*Im - D'*D . -C - DO 140 J = 1, M - DO 130 I = 1, J - DWORK( IW4+I+(J-1)*M ) = -DWORK( IW2+I+(J-1)*M ) - 130 CONTINUE - DWORK( IW4+J+(J-1)*M ) = GAMMA**2 - DWORK( IW2+J+(J-1)*M ) - 140 CONTINUE -C -C Compute inv(R)*D'*C . -C - CALL DLACPY( 'Full', M, N, DWORK, M, DWORK( IW5+1 ), M ) - CALL DPOTRF( 'U', M, DWORK( IW4+1 ), M, INFO2 ) - IF( INFO2.GT.0 ) THEN - INFO = 2 - RETURN - END IF - CALL DPOTRS( 'U', M, N, DWORK( IW4+1 ), M, DWORK( IW5+1 ), M, - $ INFO2 ) -C -C Compute inv(R)*B' . -C - DO 160 J = 1, N - DO 150 I = 1, M - DWORK( IW6+I+(J-1)*M ) = B( J, I ) - 150 CONTINUE - 160 CONTINUE - CALL DPOTRS( 'U', M, N, DWORK( IW4+1 ), M, DWORK( IW6+1 ), M, - $ INFO2 ) -C -C Compute S = GAMMA^2*Ip - D*D' . -C - DO 180 J = 1, NP - DO 170 I = 1, J - DWORK( IW7+I+(J-1)*NP ) = -DWORK( IW3+I+(J-1)*NP ) - 170 CONTINUE - DWORK( IW7+J+(J-1)*NP ) = GAMMA**2 - DWORK( IW3+J+(J-1)*NP ) - 180 CONTINUE -C -C Compute inv(S)*C . -C - CALL DLACPY( 'Full', NP, N, C, LDC, DWORK( IW8+1 ), NP ) - CALL DPOSV( 'U', NP, N, DWORK( IW7+1 ), NP, DWORK( IW8+1 ), NP, - $ INFO2 ) - IF( INFO2.GT.0 ) THEN - INFO = 2 - RETURN - END IF -C -C Construct the Hamiltonian matrix . -C - CALL DLACPY( 'Full', N, N, A, LDA, DWORK( IW9+1 ), 2*N ) - CALL DGEMM( 'N', 'N', N, N, M, ONE, B, LDB, DWORK( IW5+1 ), M, - $ ONE, DWORK( IW9+1 ), 2*N ) - CALL MB01RX( 'Left', 'Upper', 'Transpose', N, NP, ZERO, -GAMMA, - $ DWORK( IW9+N+1 ), 2*N, C, LDC, DWORK( IW8+1 ), NP, - $ INFO2 ) - CALL MA02ED( 'Upper', N, DWORK( IW9+N+1 ), 2*N ) - CALL MB01RX( 'Left', 'Upper', 'NoTranspose', N, M, ZERO, GAMMA, - $ DWORK( IW9+2*N*N+1 ), 2*N, B, LDB, DWORK( IW6+1 ), M, - $ INFO2 ) - CALL MA02ED( 'Upper', N, DWORK( IW9+2*N*N+1 ), 2*N ) - DO 200 J = 1, N - DO 190 I = 1, N - DWORK( IW9+2*N*N+N+I+(J-1)*2*N ) = -DWORK( IW9+J+(I-1)*2*N ) - 190 CONTINUE - 200 CONTINUE -C -C Compute the eigenvalues of the Hamiltonian matrix. -C - CALL DGEES( 'N', 'S', SB02CX, 2*N, DWORK( IW9+1 ), 2*N, SDIM, - $ DWORK( IW10+1 ), DWORK( IW11+1 ), DWORK, 2*N, - $ DWORK( IWRK+1 ), LDWORK-IWRK, BWORK, INFO2 ) - IF( INFO2.GT.0 ) THEN - INFO = 3 - RETURN - END IF - LWAMAX = MAX( INT( DWORK( IWRK+1 ) ) + IWRK, LWAMAX ) -C - IF( SDIM.EQ.0 ) THEN - GAMMAU = GAMMA - GO TO 330 - END IF -C -C Store the positive imaginary parts. -C - J = 0 - DO 210 I = 1, SDIM-1, 2 - J = J + 1 - DWORK( IW10+J ) = DWORK( IW11+I ) - 210 CONTINUE - K = J -C - IF( K.GE.2 ) THEN -C -C Reorder the imaginary parts. -C - DO 230 J = 1, K-1 - DO 220 L = J+1, K - IF( DWORK( IW10+J ).LE. DWORK( IW10+L ) ) GO TO 220 - TEMP = DWORK( IW10+J ) - DWORK( IW10+J ) = DWORK( IW10+L ) - DWORK( IW10+L ) = TEMP - 220 CONTINUE - 230 CONTINUE -C -C Determine the next frequency. -C - DO 320 L = 1, K - 1 - OMEGA = ( DWORK( IW10+L ) + DWORK( IW10+L+1 ) )/TWO - DO 250 J = 1, N - DO 240 I = 1, N - CWORK( I+(J-1)*N ) = -A( I, J ) - 240 CONTINUE - CWORK( J+(J-1)*N ) = JIMAG*OMEGA - A( J, J ) - 250 CONTINUE - DO 270 J = 1, M - DO 260 I = 1, N - CWORK( ICW2+I+(J-1)*N ) = B( I, J ) - 260 CONTINUE - 270 CONTINUE - DO 290 J = 1, N - DO 280 I = 1, NP - CWORK( ICW3+I+(J-1)*NP ) = C( I, J ) - 280 CONTINUE - 290 CONTINUE - DO 310 J = 1, M - DO 300 I = 1, NP - CWORK( ICW4+I+(J-1)*NP ) = D( I, J ) - 300 CONTINUE - 310 CONTINUE - CALL ZGESV( N, M, CWORK, N, IWORK, CWORK( ICW2+1 ), N, - $ INFO2 ) - IF( INFO2.GT.0 ) THEN - INFO = 1 - RETURN - END IF - CALL ZGEMM( 'N', 'N', NP, M, N, CONE, CWORK( ICW3+1 ), NP, - $ CWORK( ICW2+1 ), N, CONE, CWORK( ICW4+1 ), NP ) - CALL ZGESVD( 'N', 'N', NP, M, CWORK( ICW4+1 ), NP, - $ DWORK( IW6+1 ), CWORK, NP, CWORK, M, - $ CWORK( ICWRK+1 ), LCWORK-ICWRK, - $ DWORK( IWRK+1 ), INFO2 ) - IF( INFO2.GT.0 ) THEN - INFO = 4 - RETURN - END IF - IF( GAMMAL.LT.DWORK( IW6+1 ) ) THEN - GAMMAL = DWORK( IW6+1 ) - FPEAK = OMEGA - END IF - LCWAMX = MAX( INT( CWORK( ICWRK+1 ) ) + ICWRK, LCWAMX ) - 320 CONTINUE - END IF - GO TO 120 - 330 AB13CD = ( GAMMAL + GAMMAU )/TWO -C - DWORK( 1 ) = LWAMAX - DWORK( 2 ) = FPEAK - CWORK( 1 ) = LCWAMX - RETURN -C *** End of AB13CD *** - END diff --git a/mex/sources/libslicot/AB13DD.f b/mex/sources/libslicot/AB13DD.f deleted file mode 100644 index e9df19f47..000000000 --- a/mex/sources/libslicot/AB13DD.f +++ /dev/null @@ -1,1870 +0,0 @@ - SUBROUTINE AB13DD( DICO, JOBE, EQUIL, JOBD, N, M, P, FPEAK, - $ A, LDA, E, LDE, B, LDB, C, LDC, D, LDD, GPEAK, - $ TOL, IWORK, DWORK, LDWORK, CWORK, LCWORK, - $ INFO ) -C -C SLICOT RELEASE 5.0. -C -C Copyright (c) 2002-2009 NICONET e.V. -C -C This program is free software: you can redistribute it and/or -C modify it under the terms of the GNU General Public License as -C published by the Free Software Foundation, either version 2 of -C the License, or (at your option) any later version. -C -C This program is distributed in the hope that it will be useful, -C but WITHOUT ANY WARRANTY; without even the implied warranty of -C MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the -C GNU General Public License for more details. -C -C You should have received a copy of the GNU General Public License -C along with this program. If not, see -C . -C -C PURPOSE -C -C To compute the L-infinity norm of a continuous-time or -C discrete-time system, either standard or in the descriptor form, -C -C -1 -C G(lambda) = C*( lambda*E - A ) *B + D . -C -C The norm is finite if and only if the matrix pair (A,E) has no -C eigenvalue on the boundary of the stability domain, i.e., the -C imaginary axis, or the unit circle, respectively. It is assumed -C that the matrix E is nonsingular. -C -C ARGUMENTS -C -C Mode Parameters -C -C DICO CHARACTER*1 -C Specifies the type of the system, as follows: -C = 'C': continuous-time system; -C = 'D': discrete-time system. -C -C JOBE CHARACTER*1 -C Specifies whether E is a general square or an identity -C matrix, as follows: -C = 'G': E is a general square matrix; -C = 'I': E is the identity matrix. -C -C EQUIL CHARACTER*1 -C Specifies whether the user wishes to preliminarily -C equilibrate the system (A,E,B,C) or (A,B,C), as follows: -C = 'S': perform equilibration (scaling); -C = 'N': do not perform equilibration. -C -C JOBD CHARACTER*1 -C Specifies whether or not a non-zero matrix D appears in -C the given state space model: -C = 'D': D is present; -C = 'Z': D is assumed a zero matrix. -C -C Input/Output Parameters -C -C N (input) INTEGER -C The order of the system. N >= 0. -C -C M (input) INTEGER -C The column size of the matrix B. M >= 0. -C -C P (input) INTEGER -C The row size of the matrix C. P >= 0. -C -C FPEAK (input/output) DOUBLE PRECISION array, dimension (2) -C On entry, this parameter must contain an estimate of the -C frequency where the gain of the frequency response would -C achieve its peak value. Setting FPEAK(2) = 0 indicates an -C infinite frequency. An accurate estimate could reduce the -C number of iterations of the iterative algorithm. If no -C estimate is available, set FPEAK(1) = 0, and FPEAK(2) = 1. -C FPEAK(1) >= 0, FPEAK(2) >= 0. -C On exit, if INFO = 0, this array contains the frequency -C OMEGA, where the gain of the frequency response achieves -C its peak value GPEAK, i.e., -C -C || G ( j*OMEGA ) || = GPEAK , if DICO = 'C', or -C -C j*OMEGA -C || G ( e ) || = GPEAK , if DICO = 'D', -C -C where OMEGA = FPEAK(1), if FPEAK(2) > 0, and OMEGA is -C infinite, if FPEAK(2) = 0. -C -C A (input) DOUBLE PRECISION array, dimension (LDA,N) -C The leading N-by-N part of this array must contain the -C state dynamics matrix A. -C -C LDA INTEGER -C The leading dimension of the array A. LDA >= max(1,N). -C -C E (input) DOUBLE PRECISION array, dimension (LDE,N) -C If JOBE = 'G', the leading N-by-N part of this array must -C contain the descriptor matrix E of the system. -C If JOBE = 'I', then E is assumed to be the identity -C matrix and is not referenced. -C -C LDE INTEGER -C The leading dimension of the array E. -C LDE >= MAX(1,N), if JOBE = 'G'; -C LDE >= 1, if JOBE = 'I'. -C -C B (input) DOUBLE PRECISION array, dimension (LDB,M) -C The leading N-by-M part of this array must contain the -C system input matrix B. -C -C LDB INTEGER -C The leading dimension of the array B. LDB >= max(1,N). -C -C C (input) DOUBLE PRECISION array, dimension (LDC,N) -C The leading P-by-N part of this array must contain the -C system output matrix C. -C -C LDC INTEGER -C The leading dimension of the array C. LDC >= max(1,P). -C -C D (input) DOUBLE PRECISION array, dimension (LDD,M) -C If JOBD = 'D', the leading P-by-M part of this array must -C contain the direct transmission matrix D. -C The array D is not referenced if JOBD = 'Z'. -C -C LDD INTEGER -C The leading dimension of array D. -C LDD >= MAX(1,P), if JOBD = 'D'; -C LDD >= 1, if JOBD = 'Z'. -C -C GPEAK (output) DOUBLE PRECISION array, dimension (2) -C The L-infinity norm of the system, i.e., the peak gain -C of the frequency response (as measured by the largest -C singular value in the MIMO case), coded in the same way -C as FPEAK. -C -C Tolerances -C -C TOL DOUBLE PRECISION -C Tolerance used to set the accuracy in determining the -C norm. 0 <= TOL < 1. -C -C Workspace -C -C IWORK INTEGER array, dimension (N) -C -C DWORK DOUBLE PRECISION array, dimension (LDWORK) -C On exit, if INFO = 0, DWORK(1) contains the optimal value -C of LDWORK. -C -C LDWORK INTEGER -C The dimension of the array DWORK. -C LDWORK >= K, where K can be computed using the following -C pseudo-code (or the Fortran code included in the routine) -C -C d = 6*MIN(P,M); -C c = MAX( 4*MIN(P,M) + MAX(P,M), d ); -C if ( MIN(P,M) = 0 ) then -C K = 1; -C else if( N = 0 or B = 0 or C = 0 ) then -C if( JOBD = 'D' ) then -C K = P*M + c; -C else -C K = 1; -C end -C else -C if ( DICO = 'D' ) then -C b = 0; e = d; -C else -C b = N*(N+M); e = c; -C if ( JOBD = Z' ) then b = b + P*M; end -C end -C if ( JOBD = 'D' ) then -C r = P*M; -C if ( JOBE = 'I', DICO = 'C', -C N > 0, B <> 0, C <> 0 ) then -C K = P*P + M*M; -C r = r + N*(P+M); -C else -C K = 0; -C end -C K = K + r + c; r = r + MIN(P,M); -C else -C r = 0; K = 0; -C end -C r = r + N*(N+P+M); -C if ( JOBE = 'G' ) then -C r = r + N*N; -C if ( EQUIL = 'S' ) then -C K = MAX( K, r + 9*N ); -C end -C K = MAX( K, r + 4*N + MAX( M, 2*N*N, N+b+e ) ); -C else -C K = MAX( K, r + N + -C MAX( M, P, N*N+2*N, 3*N+b+e ) ); -C end -C w = 0; -C if ( JOBE = 'I', DICO = 'C' ) then -C w = r + 4*N*N + 11*N; -C if ( JOBD = 'D' ) then -C w = w + MAX(M,P) + N*(P+M); -C end -C end -C if ( JOBE = 'E' or DICO = 'D' or JOBD = 'D' ) then -C w = MAX( w, r + 6*N + (2*N+P+M)*(2*N+P+M) + -C MAX( 2*(N+P+M), 8*N*N + 16*N ) ); -C end -C K = MAX( 1, K, w, r + 2*N + e ); -C end -C -C For good performance, LDWORK must generally be larger. -C -C An easily computable upper bound is -C -C K = MAX( 1, 15*N*N + P*P + M*M + (6*N+3)*(P+M) + 4*P*M + -C N*M + 22*N + 7*MIN(P,M) ). -C -C The smallest workspace is obtained for DICO = 'C', -C JOBE = 'I', and JOBD = 'Z', namely -C -C K = MAX( 1, N*N + N*P + N*M + N + -C MAX( N*N + N*M + P*M + 3*N + c, -C 4*N*N + 10*N ) ). -C -C for which an upper bound is -C -C K = MAX( 1, 6*N*N + N*P + 2*N*M + P*M + 11*N + MAX(P,M) + -C 6*MIN(P,M) ). -C -C CWORK COMPLEX*16 array, dimension (LCWORK) -C On exit, if INFO = 0, CWORK(1) contains the optimal -C LCWORK. -C -C LCWORK INTEGER -C The dimension of the array CWORK. -C LCWORK >= 1, if N = 0, or B = 0, or C = 0; -C LCWORK >= MAX(1, (N+M)*(N+P) + 2*MIN(P,M) + MAX(P,M)), -C otherwise. -C For good performance, LCWORK must generally be larger. -C -C Error Indicator -C -C INFO INTEGER -C = 0: successful exit; -C < 0: if INFO = -i, the i-th argument had an illegal -C value; -C = 1: the matrix E is (numerically) singular; -C = 2: the (periodic) QR (or QZ) algorithm for computing -C eigenvalues did not converge; -C = 3: the SVD algorithm for computing singular values did -C not converge; -C = 4: the tolerance is too small and the algorithm did -C not converge. -C -C METHOD -C -C The routine implements the method presented in [1], with -C extensions and refinements for improving numerical robustness and -C efficiency. Structure-exploiting eigenvalue computations for -C Hamiltonian matrices are used if JOBE = 'I', DICO = 'C', and the -C symmetric matrices to be implicitly inverted are not too ill- -C conditioned. Otherwise, generalized eigenvalue computations are -C used in the iterative algorithm of [1]. -C -C REFERENCES -C -C [1] Bruinsma, N.A. and Steinbuch, M. -C A fast algorithm to compute the Hinfinity-norm of a transfer -C function matrix. -C Systems & Control Letters, vol. 14, pp. 287-293, 1990. -C -C NUMERICAL ASPECTS -C -C If the algorithm does not converge in MAXIT = 30 iterations -C (INFO = 4), the tolerance must be increased. -C -C FURTHER COMMENTS -C -C If the matrix E is singular, other SLICOT Library routines -C could be used before calling AB13DD, for removing the singular -C part of the system. -C -C CONTRIBUTORS -C -C D. Sima, University of Bucharest, May 2001. -C V. Sima, Research Institute for Informatics, Bucharest, May 2001. -C Partly based on SLICOT Library routine AB13CD by P.Hr. Petkov, -C D.W. Gu and M.M. Konstantinov. -C -C REVISIONS -C -C V. Sima, Research Institute for Informatics, Bucharest, June 2001, -C May 2003, Aug. 2005, March 2008, May 2009, Sep. 2009. -C -C KEYWORDS -C -C H-infinity optimal control, robust control, system norm. -C -C ****************************************************************** -C -C .. Parameters .. - INTEGER MAXIT - PARAMETER ( MAXIT = 30 ) - COMPLEX*16 CONE - PARAMETER ( CONE = ( 1.0D0, 0.0D0 ) ) - DOUBLE PRECISION ZERO, ONE, TWO, FOUR, P25 - PARAMETER ( ZERO = 0.0D+0, ONE = 1.0D+0, TWO = 2.0D+0, - $ FOUR = 4.0D+0, P25 = 0.25D+0 ) - DOUBLE PRECISION TEN, HUNDRD, THOUSD - PARAMETER ( TEN = 1.0D+1, HUNDRD = 1.0D+2, - $ THOUSD = 1.0D+3 ) -C .. -C .. Scalar Arguments .. - CHARACTER DICO, EQUIL, JOBD, JOBE - INTEGER INFO, LCWORK, LDA, LDB, LDC, LDD, LDE, LDWORK, - $ M, N, P - DOUBLE PRECISION TOL -C .. -C .. Array Arguments .. - COMPLEX*16 CWORK( * ) - DOUBLE PRECISION A( LDA, * ), B( LDB, * ), C( LDC, * ), - $ D( LDD, * ), DWORK( * ), E( LDE, * ), - $ FPEAK( 2 ), GPEAK( 2 ) - INTEGER IWORK( * ) -C .. -C .. Local Scalars .. - CHARACTER VECT - LOGICAL DISCR, FULLE, ILASCL, ILESCL, LEQUIL, NODYN, - $ USEPEN, WITHD - INTEGER I, IA, IAR, IAS, IB, IBS, IBT, IBV, IC, ICU, - $ ID, IE, IERR, IES, IH, IH12, IHI, II, ILO, IM, - $ IMIN, IPA, IPE, IR, IS, ISB, ISC, ISL, ITAU, - $ ITER, IU, IV, IWRK, J, K, LW, MAXCWK, MAXWRK, - $ MINCWR, MINPM, MINWRK, N2, N2PM, NEI, NN, NWS, - $ NY, PM - DOUBLE PRECISION ANRM, ANRMTO, BIGNUM, BNORM, BOUND, CNORM, - $ ENRM, ENRMTO, EPS, FPEAKI, FPEAKS, GAMMA, - $ GAMMAL, GAMMAS, MAXRED, OMEGA, PI, RAT, RCOND, - $ RTOL, SAFMAX, SAFMIN, SMLNUM, TM, TOLER, WMAX, - $ WRMIN -C .. -C .. Local Arrays .. - DOUBLE PRECISION TEMP( 1 ) -C .. -C .. External Functions .. - DOUBLE PRECISION AB13DX, DLAMCH, DLANGE, DLAPY2 - LOGICAL LSAME - EXTERNAL AB13DX, DLAMCH, DLANGE, DLAPY2, LSAME -C .. -C .. External Subroutines .. - EXTERNAL DCOPY, DGEBAL, DGEHRD, DGEMM, DGEQRF, DGESVD, - $ DGGBAL, DGGEV, DHGEQZ, DHSEQR, DLABAD, DLACPY, - $ DLASCL, DLASRT, DORGQR, DORMHR, DSWAP, DSYRK, - $ DTRCON, MA02AD, MB01SD, MB03XD, TB01ID, TG01AD, - $ TG01BD, XERBLA -C .. -C .. Intrinsic Functions .. - INTRINSIC ABS, ATAN, ATAN2, COS, DBLE, INT, LOG, MAX, - $ MIN, SIN, SQRT -C .. -C .. Executable Statements .. -C -C Test the input scalar parameters. -C - N2 = 2*N - NN = N*N - PM = P + M - N2PM = N2 + PM - MINPM = MIN( P, M ) - INFO = 0 - DISCR = LSAME( DICO, 'D' ) - FULLE = LSAME( JOBE, 'G' ) - LEQUIL = LSAME( EQUIL, 'S' ) - WITHD = LSAME( JOBD, 'D' ) -C - IF( .NOT. ( DISCR .OR. LSAME( DICO, 'C' ) ) ) THEN - INFO = -1 - ELSE IF( .NOT. ( FULLE .OR. LSAME( JOBE, 'I' ) ) ) THEN - INFO = -2 - ELSE IF( .NOT. ( LEQUIL .OR. LSAME( EQUIL, 'N' ) ) ) THEN - INFO = -3 - ELSE IF( .NOT. ( WITHD .OR. LSAME( JOBD, 'Z' ) ) ) THEN - INFO = -4 - ELSE IF( N.LT.0 ) THEN - INFO = -5 - ELSE IF( M.LT.0 ) THEN - INFO = -6 - ELSE IF( P.LT.0 ) THEN - INFO = -7 - ELSE IF( MIN( FPEAK( 1 ), FPEAK( 2 ) ).LT.ZERO ) THEN - INFO = -8 - ELSE IF( LDA.LT.MAX( 1, N ) ) THEN - INFO = -10 - ELSE IF( LDE.LT.1 .OR. ( FULLE .AND. LDE.LT.N ) ) THEN - INFO = -12 - ELSE IF( LDB.LT.MAX( 1, N ) ) THEN - INFO = -14 - ELSE IF( LDC.LT.MAX( 1, P ) ) THEN - INFO = -16 - ELSE IF( LDD.LT.1 .OR. ( WITHD .AND. LDD.LT.P ) ) THEN - INFO = -18 - ELSE IF( TOL.LT.ZERO .OR. TOL.GE.ONE ) THEN - INFO = -20 - ELSE - BNORM = DLANGE( '1-norm', N, M, B, LDB, DWORK ) - CNORM = DLANGE( '1-norm', P, N, C, LDC, DWORK ) - NODYN = N.EQ.0 .OR. MIN( BNORM, CNORM ).EQ.ZERO - USEPEN = FULLE .OR. DISCR -C -C Compute workspace. -C - ID = 6*MINPM - IC = MAX( 4*MINPM + MAX( P, M ), ID ) - IF( MINPM.EQ.0 ) THEN - MINWRK = 1 - ELSE IF( NODYN ) THEN - IF( WITHD ) THEN - MINWRK = P*M + IC - ELSE - MINWRK = 1 - END IF - ELSE - IF ( DISCR ) THEN - IB = 0 - IE = ID - ELSE - IB = N*( N + M ) - IF ( .NOT.WITHD ) - $ IB = IB + P*M - IE = IC - END IF - IF ( WITHD ) THEN - IR = P*M - IF ( .NOT.USEPEN ) THEN - MINWRK = P*P + M*M - IR = IR + N*PM - ELSE - MINWRK = 0 - END IF - MINWRK = MINWRK + IR + IC - IR = IR + MINPM - ELSE - IR = 0 - MINWRK = 0 - END IF - IR = IR + N*( N + PM ) - IF ( FULLE ) THEN - IR = IR + NN - IF ( LEQUIL ) - $ MINWRK = MAX( MINWRK, IR + 9*N ) - MINWRK = MAX( MINWRK, IR + 4*N + MAX( M, 2*NN, - $ N + IB + IE ) ) - ELSE - MINWRK = MAX( MINWRK, IR + N + MAX( M, P, NN + N2, - $ 3*N + IB + IE ) ) - END IF - LW = 0 - IF ( .NOT.USEPEN ) THEN - LW = IR + 4*NN + 11*N - IF ( WITHD ) - $ LW = LW + MAX( M, P ) + N*PM - END IF - IF ( USEPEN .OR. WITHD ) - $ LW = MAX( LW, IR + 6*N + N2PM*N2PM + - $ MAX( N2PM + PM, 8*( NN + N2 ) ) ) - MINWRK = MAX( 1, MINWRK, LW, IR + N2 + IE ) - END IF -C - IF( LDWORK.LT.MINWRK ) THEN - INFO = -23 - ELSE - IF ( NODYN ) THEN - MINCWR = 1 - ELSE - MINCWR = MAX( 1, ( N + M )*( N + P ) + - $ 2*MINPM + MAX( P, M ) ) - END IF - IF( LCWORK.LT.MINCWR ) - $ INFO = -25 - END IF - END IF -C - IF( INFO.NE.0 ) THEN - CALL XERBLA( 'AB13DD', -INFO ) - RETURN - END IF -C -C Quick return if possible. -C - IF( M.EQ.0 .OR. P.EQ.0 ) THEN - GPEAK( 1 ) = ZERO - FPEAK( 1 ) = ZERO - GPEAK( 2 ) = ONE - FPEAK( 2 ) = ONE - DWORK( 1 ) = ONE - CWORK( 1 ) = ONE - RETURN - END IF -C -C Determine the maximum singular value of G(infinity) = D . -C If JOBE = 'I' and DICO = 'C', the full SVD of D, D = U*S*V', is -C computed and saved for later use. -C -C (Note: Comments in the code beginning "Workspace:" describe the -C minimal amount of real workspace needed at that point in the -C code, as well as the preferred amount for good performance. -C NB refers to the optimal block size for the immediately -C following subroutine, as returned by ILAENV.) -C - ID = 1 - IF ( WITHD ) THEN - IS = ID + P*M - IF ( USEPEN .OR. NODYN ) THEN - IU = IS + MINPM - IV = IU - IWRK = IV - VECT = 'N' - ELSE - IBV = IS + MINPM - ICU = IBV + N*M - IU = ICU + P*N - IV = IU + P*P - IWRK = IV + M*M - VECT = 'A' - END IF -C -C Workspace: need P*M + MIN(P,M) + V + -C MAX( 3*MIN(P,M) + MAX(P,M), 5*MIN(P,M) ), -C where V = N*(M+P) + P*P + M*M, -C if JOBE = 'I' and DICO = 'C', -C and N > 0, B <> 0, C <> 0, -C V = 0, otherwise; -C prefer larger. -C - CALL DLACPY( 'Full', P, M, D, LDD, DWORK( ID ), P ) - CALL DGESVD( VECT, VECT, P, M, DWORK( ID ), P, DWORK( IS ), - $ DWORK( IU ), P, DWORK( IV ), M, DWORK( IWRK ), - $ LDWORK-IWRK+1, IERR ) - IF( IERR.GT.0 ) THEN - INFO = 3 - RETURN - END IF - GAMMAL = DWORK( IS ) - MAXWRK = INT( DWORK( IWRK ) ) + IWRK - 1 -C -C Restore D for later calculations. -C - CALL DLACPY( 'Full', P, M, D, LDD, DWORK( ID ), P ) - ELSE - IWRK = 1 - GAMMAL = ZERO - MAXWRK = 1 - END IF -C -C Quick return if possible. -C - IF( NODYN ) THEN - GPEAK( 1 ) = GAMMAL - FPEAK( 1 ) = ZERO - GPEAK( 2 ) = ONE - FPEAK( 2 ) = ONE - DWORK( 1 ) = MAXWRK - CWORK( 1 ) = ONE - RETURN - END IF -C - IF ( .NOT.USEPEN .AND. WITHD ) THEN -C -C Standard continuous-time case, D <> 0: Compute B*V and C'*U . -C - CALL DGEMM( 'No Transpose', 'Transpose', N, M, M, ONE, B, LDB, - $ DWORK( IV ), M, ZERO, DWORK( IBV ), N ) - CALL DGEMM( 'Transpose', 'No Transpose', N, P, P, ONE, C, - $ LDC, DWORK( IU ), P, ZERO, DWORK( ICU ), N ) -C -C U and V are no longer needed: free their memory space. -C Total workspace here: need P*M + MIN(P,M) + N*(M+P) -C (JOBE = 'I', DICO = 'C', JOBD = 'D'). -C - IWRK = IU - END IF -C -C Get machine constants. -C - EPS = DLAMCH( 'Epsilon' ) - SAFMIN = DLAMCH( 'Safe minimum' ) - SAFMAX = ONE / SAFMIN - CALL DLABAD( SAFMIN, SAFMAX ) - SMLNUM = SQRT( SAFMIN ) / DLAMCH( 'Precision' ) - BIGNUM = ONE / SMLNUM - TOLER = SQRT( EPS ) -C -C Initiate the transformation of the system to an equivalent one, -C to be used for eigenvalue computations. -C -C Additional workspace: need N*N + N*M + P*N + 2*N, if JOBE = 'I'; -C 2*N*N + N*M + P*N + 2*N, if JOBE = 'G'. -C - IA = IWRK - IE = IA + NN - IF ( FULLE ) THEN - IB = IE + NN - ELSE - IB = IE - END IF - IC = IB + N*M - IR = IC + P*N - II = IR + N - IBT = II + N -C - CALL DLACPY( 'Full', N, N, A, LDA, DWORK( IA ), N ) - CALL DLACPY( 'Full', N, M, B, LDB, DWORK( IB ), N ) - CALL DLACPY( 'Full', P, N, C, LDC, DWORK( IC ), P ) -C -C Scale A if maximum element is outside the range [SMLNUM,BIGNUM]. -C - ANRM = DLANGE( 'Max', N, N, DWORK( IA ), N, DWORK ) - ILASCL = .FALSE. - IF( ANRM.GT.ZERO .AND. ANRM.LT.SMLNUM ) THEN - ANRMTO = SMLNUM - ILASCL = .TRUE. - ELSE IF( ANRM.GT.BIGNUM ) THEN - ANRMTO = BIGNUM - ILASCL = .TRUE. - END IF - IF( ILASCL ) - $ CALL DLASCL( 'General', 0, 0, ANRM, ANRMTO, N, N, DWORK( IA ), - $ N, IERR ) -C - IF ( FULLE ) THEN -C -C Descriptor system. -C -C Additional workspace: need N. -C - IWRK = IBT + N - CALL DLACPY( 'Full', N, N, E, LDE, DWORK( IE ), N ) -C -C Scale E if maximum element is outside the range -C [SMLNUM,BIGNUM]. -C - ENRM = DLANGE( 'Max', N, N, DWORK( IE ), N, DWORK ) - ILESCL = .FALSE. - IF( ENRM.GT.ZERO .AND. ENRM.LT.SMLNUM ) THEN - ENRMTO = SMLNUM - ILESCL = .TRUE. - ELSE IF( ENRM.GT.BIGNUM ) THEN - ENRMTO = BIGNUM - ILESCL = .TRUE. - ELSE IF( ENRM.EQ.ZERO ) THEN -C -C Error return: Matrix E is 0. -C - INFO = 1 - RETURN - END IF - IF( ILESCL ) - $ CALL DLASCL( 'General', 0, 0, ENRM, ENRMTO, N, N, - $ DWORK( IE ), N, IERR ) -C -C Equilibrate the system, if required. -C -C Additional workspace: need 6*N. -C - IF( LEQUIL ) - $ CALL TG01AD( 'All', N, N, M, P, ZERO, DWORK( IA ), N, - $ DWORK( IE ), N, DWORK( IB ), N, DWORK( IC ), P, - $ DWORK( II ), DWORK( IR ), DWORK( IWRK ), - $ IERR ) -C -C For efficiency of later calculations, the system (A,E,B,C) is -C reduced to an equivalent one with the state matrix A in -C Hessenberg form, and E upper triangular. -C First, permute (A,E) to make it more nearly triangular. -C - CALL DGGBAL( 'Permute', N, DWORK( IA ), N, DWORK( IE ), N, ILO, - $ IHI, DWORK( II ), DWORK( IR ), DWORK( IWRK ), - $ IERR ) -C -C Apply the permutations to (the copies of) B and C. -C - DO 10 I = N, IHI + 1, -1 - K = DWORK( II+I-1 ) - IF( K.NE.I ) - $ CALL DSWAP( M, DWORK( IB+I-1 ), N, - $ DWORK( IB+K-1 ), N ) - K = DWORK( IR+I-1 ) - IF( K.NE.I ) - $ CALL DSWAP( P, DWORK( IC+(I-1)*P ), 1, - $ DWORK( IC+(K-1)*P ), 1 ) - 10 CONTINUE -C - DO 20 I = 1, ILO - 1 - K = DWORK( II+I-1 ) - IF( K.NE.I ) - $ CALL DSWAP( M, DWORK( IB+I-1 ), N, - $ DWORK( IB+K-1 ), N ) - K = DWORK( IR+I-1 ) - IF( K.NE.I ) - $ CALL DSWAP( P, DWORK( IC+(I-1)*P ), 1, - $ DWORK( IC+(K-1)*P ), 1 ) - 20 CONTINUE -C -C Reduce (A,E) to generalized Hessenberg form and apply the -C transformations to B and C. -C Additional workspace: need N + MAX(N,M); -C prefer N + MAX(N,M)*NB. -C - CALL TG01BD( 'General', 'No Q', 'No Z', N, M, P, ILO, IHI, - $ DWORK( IA ), N, DWORK( IE ), N, DWORK( IB ), N, - $ DWORK( IC ), P, DWORK, 1, DWORK, 1, DWORK( IWRK ), - $ LDWORK-IWRK+1, IERR ) - MAXWRK = MAX( INT( DWORK( IWRK ) ) + IWRK - 1, MAXWRK ) -C -C Check whether matrix E is nonsingular. -C Additional workspace: need 3*N. -C - CALL DTRCON( '1-norm', 'Upper', 'Non Unit', N, DWORK( IE ), N, - $ RCOND, DWORK( IWRK ), IWORK, IERR ) - IF( RCOND.LE.TEN*DBLE( N )*EPS ) THEN -C -C Error return: Matrix E is numerically singular. -C - INFO = 1 - RETURN - END IF -C -C Perform QZ algorithm, computing eigenvalues. The generalized -C Hessenberg form is saved for later use. -C Additional workspace: need 2*N*N + N; -C prefer larger. -C - IAS = IWRK - IES = IAS + NN - IWRK = IES + NN - CALL DLACPY( 'Full', N, N, DWORK( IA ), N, DWORK( IAS ), N ) - CALL DLACPY( 'Full', N, N, DWORK( IE ), N, DWORK( IES ), N ) - CALL DHGEQZ( 'Eigenvalues', 'No Vectors', 'No Vectors', N, ILO, - $ IHI, DWORK( IAS ), N, DWORK( IES ), N, - $ DWORK( IR ), DWORK( II ), DWORK( IBT ), DWORK, N, - $ DWORK, N, DWORK( IWRK ), LDWORK-IWRK+1, IERR ) - IF( IERR.NE.0 ) THEN - INFO = 2 - RETURN - END IF - MAXWRK = MAX( INT( DWORK( IWRK ) ) + IWRK - 1, MAXWRK ) -C -C Check if unscaling would cause over/underflow; if so, rescale -C eigenvalues (DWORK( IR+I-1 ),DWORK( II+I-1 ),DWORK( IBT+I-1 )) -C so DWORK( IBT+I-1 ) is on the order of E(I,I) and -C DWORK( IR+I-1 ) and DWORK( II+I-1 ) are on the order of A(I,I). -C - IF( ILASCL ) THEN -C - DO 30 I = 1, N - IF( DWORK( II+I-1 ).NE.ZERO ) THEN - IF( ( DWORK( IR+I-1 ) / SAFMAX ).GT.( ANRMTO / ANRM ) - $ .OR. - $ ( SAFMIN / DWORK( IR+I-1 ) ).GT.( ANRM / ANRMTO ) - $ ) THEN - TM = ABS( DWORK( IA+(I-1)*N+I ) / DWORK( IR+I-1 ) ) - DWORK( IBT+I-1 ) = DWORK( IBT+I-1 )*TM - DWORK( IR+I-1 ) = DWORK( IR+I-1 )*TM - DWORK( II+I-1 ) = DWORK( II+I-1 )*TM - ELSE IF( ( DWORK( II+I-1 ) / SAFMAX ).GT. - $ ( ANRMTO / ANRM ) .OR. - $ ( SAFMIN / DWORK( II+I-1 ) ).GT.( ANRM / ANRMTO ) ) - $ THEN - TM = ABS( DWORK( IA+I*N+I ) / DWORK( II+I-1 ) ) - DWORK( IBT+I-1 ) = DWORK( IBT+I-1 )*TM - DWORK( IR+I-1 ) = DWORK( IR+I-1 )*TM - DWORK( II+I-1 ) = DWORK( II+I-1 )*TM - END IF - END IF - 30 CONTINUE -C - END IF -C - IF( ILESCL ) THEN -C - DO 40 I = 1, N - IF( DWORK( II+I-1 ).NE.ZERO ) THEN - IF( ( DWORK( IBT+I-1 ) / SAFMAX ).GT.( ENRMTO / ENRM ) - $ .OR. - $ ( SAFMIN / DWORK( IBT+I-1 ) ).GT.( ENRM / ENRMTO ) - $ ) THEN - TM = ABS( DWORK( IE+(I-1)*N+I ) / DWORK( IBT+I-1 )) - DWORK( IBT+I-1 ) = DWORK( IBT+I-1 )*TM - DWORK( IR+I-1 ) = DWORK( IR+I-1 )*TM - DWORK( II+I-1 ) = DWORK( II+I-1 )*TM - END IF - END IF - 40 CONTINUE -C - END IF -C -C Undo scaling. -C - IF( ILASCL ) THEN - CALL DLASCL( 'Hessenberg', 0, 0, ANRMTO, ANRM, N, N, - $ DWORK( IA ), N, IERR ) - CALL DLASCL( 'General', 0, 0, ANRMTO, ANRM, N, 1, - $ DWORK( IR ), N, IERR ) - CALL DLASCL( 'General', 0, 0, ANRMTO, ANRM, N, 1, - $ DWORK( II ), N, IERR ) - END IF -C - IF( ILESCL ) THEN - CALL DLASCL( 'Upper', 0, 0, ENRMTO, ENRM, N, N, - $ DWORK( IE ), N, IERR ) - CALL DLASCL( 'General', 0, 0, ENRMTO, ENRM, N, 1, - $ DWORK( IBT ), N, IERR ) - END IF -C - ELSE -C -C Standard state-space system. -C - IF( LEQUIL ) THEN -C -C Equilibrate the system. -C - MAXRED = HUNDRD - CALL TB01ID( 'All', N, M, P, MAXRED, DWORK( IA ), N, - $ DWORK( IB ), N, DWORK( IC ), P, DWORK( II ), - $ IERR ) - END IF -C -C For efficiency of later calculations, the system (A,B,C) is -C reduced to a similar one with the state matrix in Hessenberg -C form. -C -C First, permute the matrix A to make it more nearly triangular -C and apply the permutations to B and C. -C - CALL DGEBAL( 'Permute', N, DWORK( IA ), N, ILO, IHI, - $ DWORK( IR ), IERR ) -C - DO 50 I = N, IHI + 1, -1 - K = DWORK( IR+I-1 ) - IF( K.NE.I ) THEN - CALL DSWAP( M, DWORK( IB+I-1 ), N, - $ DWORK( IB+K-1 ), N ) - CALL DSWAP( P, DWORK( IC+(I-1)*P ), 1, - $ DWORK( IC+(K-1)*P ), 1 ) - END IF - 50 CONTINUE -C - DO 60 I = 1, ILO - 1 - K = DWORK( IR+I-1 ) - IF( K.NE.I ) THEN - CALL DSWAP( M, DWORK( IB+I-1 ), N, - $ DWORK( IB+K-1 ), N ) - CALL DSWAP( P, DWORK( IC+(I-1)*P ), 1, - $ DWORK( IC+(K-1)*P ), 1 ) - END IF - 60 CONTINUE -C -C Reduce A to upper Hessenberg form and apply the transformations -C to B and C. -C Additional workspace: need N; (from II) -C prefer N*NB. -C - ITAU = IR - IWRK = ITAU + N - CALL DGEHRD( N, ILO, IHI, DWORK( IA ), N, DWORK( ITAU ), - $ DWORK( IWRK ), LDWORK-IWRK+1, IERR ) - MAXWRK = MAX( INT( DWORK( IWRK ) ) + IWRK - 1, MAXWRK ) -C -C Additional workspace: need M; -C prefer M*NB. -C - CALL DORMHR( 'Left', 'Transpose', N, M, ILO, IHI, DWORK( IA ), - $ N, DWORK( ITAU ), DWORK( IB ), N, DWORK( IWRK ), - $ LDWORK-IWRK+1, IERR ) - MAXWRK = MAX( INT( DWORK( IWRK ) ) + IWRK - 1, MAXWRK ) -C -C Additional workspace: need P; -C prefer P*NB. -C - CALL DORMHR( 'Right', 'NoTranspose', P, N, ILO, IHI, - $ DWORK( IA ), N, DWORK( ITAU ), DWORK( IC ), P, - $ DWORK( IWRK ), LDWORK-IWRK+1, IERR ) - MAXWRK = MAX( INT( DWORK( IWRK ) ) + IWRK - 1, MAXWRK ) -C -C Compute the eigenvalues. The Hessenberg form is saved for -C later use. -C Additional workspace: need N*N + N; (from IBT) -C prefer larger. -C - IAS = IBT - IWRK = IAS + NN - CALL DLACPY( 'Full', N, N, DWORK( IA ), N, DWORK( IAS ), N ) - CALL DHSEQR( 'Eigenvalues', 'No Vectors', N, ILO, IHI, - $ DWORK( IAS ), N, DWORK( IR ), DWORK( II ), DWORK, - $ N, DWORK( IWRK ), LDWORK-IWRK+1, IERR ) - IF( IERR.GT.0 ) THEN - INFO = 2 - RETURN - END IF - MAXWRK = MAX( INT( DWORK( IWRK ) ) + IWRK - 1, MAXWRK ) -C - IF( ILASCL ) THEN -C -C Undo scaling for the Hessenberg form of A and eigenvalues. -C - CALL DLASCL( 'Hessenberg', 0, 0, ANRMTO, ANRM, N, N, - $ DWORK( IA ), N, IERR ) - CALL DLASCL( 'General', 0, 0, ANRMTO, ANRM, N, 1, - $ DWORK( IR ), N, IERR ) - CALL DLASCL( 'General', 0, 0, ANRMTO, ANRM, N, 1, - $ DWORK( II ), N, IERR ) - END IF -C - END IF -C -C Look for (generalized) eigenvalues on the boundary of the -C stability domain. (Their existence implies an infinite norm.) -C Additional workspace: need 2*N. (from IAS) -C - IM = IAS - IAR = IM + N - IMIN = II - WRMIN = SAFMAX - BOUND = EPS*THOUSD -C - IF ( DISCR ) THEN - GAMMAL = ZERO -C -C For discrete-time case, compute the logarithm of the non-zero -C eigenvalues and save their moduli and absolute real parts. -C (The logarithms are overwritten on the eigenvalues.) -C Also, find the minimum distance to the unit circle. -C - IF ( FULLE ) THEN -C - DO 70 I = 0, N - 1 - TM = DLAPY2( DWORK( IR+I ), DWORK( II+I ) ) - IF ( ( DWORK( IBT+I ).GE.ONE ) .OR. - $ ( DWORK( IBT+I ).LT.ONE .AND. - $ TM.LT.SAFMAX*DWORK( IBT+I ) ) ) THEN - TM = TM / DWORK( IBT+I ) - ELSE -C -C The pencil has too large eigenvalues. SAFMAX is used. -C - TM = SAFMAX - END IF - IF ( TM.NE.ZERO ) THEN - DWORK( II+I ) = ATAN2( DWORK( II+I ), DWORK( IR+I ) ) - DWORK( IR+I ) = LOG( TM ) - END IF - DWORK( IM ) = DLAPY2( DWORK( IR+I ), DWORK( II+I ) ) - TM = ABS( ONE - TM ) - IF( TM.LT.WRMIN ) THEN - IMIN = II + I - WRMIN = TM - END IF - IM = IM + 1 - DWORK( IAR+I ) = ABS( DWORK( IR+I ) ) - 70 CONTINUE -C - ELSE -C - DO 80 I = 0, N - 1 - TM = DLAPY2( DWORK( IR+I ), DWORK( II+I ) ) - IF ( TM.NE.ZERO ) THEN - DWORK( II+I ) = ATAN2( DWORK( II+I ), DWORK( IR+I ) ) - DWORK( IR+I ) = LOG( TM ) - END IF - DWORK( IM ) = DLAPY2( DWORK( IR+I ), DWORK( II+I ) ) - TM = ABS( ONE - TM ) - IF( TM.LT.WRMIN ) THEN - IMIN = II + I - WRMIN = TM - END IF - IM = IM + 1 - DWORK( IAR+I ) = ABS( DWORK( IR+I ) ) - 80 CONTINUE -C - END IF -C - ELSE -C -C For continuous-time case, save moduli of eigenvalues and -C absolute real parts and find the maximum modulus and minimum -C absolute real part. -C - WMAX = ZERO -C - IF ( FULLE ) THEN -C - DO 90 I = 0, N - 1 - TM = ABS( DWORK( IR+I ) ) - DWORK( IM ) = DLAPY2( DWORK( IR+I ), DWORK( II+I ) ) - IF ( ( DWORK( IBT+I ).GE.ONE ) .OR. - $ ( DWORK( IBT+I ).LT.ONE .AND. - $ DWORK( IM ).LT.SAFMAX*DWORK( IBT+I ) ) ) - $ THEN - TM = TM / DWORK( IBT+I ) - DWORK( IM ) = DWORK( IM ) / DWORK( IBT+I ) - ELSE - IF ( TM.LT.SAFMAX*DWORK( IBT+I ) ) THEN - TM = TM / DWORK( IBT+I ) - ELSE -C -C The pencil has too large eigenvalues. -C SAFMAX is used. -C - TM = SAFMAX - END IF - DWORK( IM ) = SAFMAX - END IF - IF( TM.LT.WRMIN ) THEN - IMIN = II + I - WRMIN = TM - END IF - DWORK( IAR+I ) = TM - IF( DWORK( IM ).GT.WMAX ) - $ WMAX = DWORK( IM ) - IM = IM + 1 - 90 CONTINUE -C - ELSE -C - DO 100 I = 0, N - 1 - TM = ABS( DWORK( IR+I ) ) - IF( TM.LT.WRMIN ) THEN - IMIN = II + I - WRMIN = TM - END IF - DWORK( IM ) = DLAPY2( DWORK( IR+I ), DWORK( II+I ) ) - IF( DWORK( IM ).GT.WMAX ) - $ WMAX = DWORK( IM ) - IM = IM + 1 - DWORK( IAR+I ) = TM - 100 CONTINUE -C - END IF -C - BOUND = BOUND + EPS*WMAX -C - END IF -C - IM = IM - N -C - IF( WRMIN.LT.BOUND ) THEN -C -C The L-infinity norm was found as infinite. -C - GPEAK( 1 ) = ONE - GPEAK( 2 ) = ZERO - TM = ABS( DWORK( IMIN ) ) - IF ( DISCR ) - $ TM = ABS( ATAN2( SIN( TM ), COS( TM ) ) ) - FPEAK( 1 ) = TM - IF ( TM.LT.SAFMAX ) THEN - FPEAK( 2 ) = ONE - ELSE - FPEAK( 2 ) = ZERO - END IF -C - DWORK( 1 ) = MAXWRK - CWORK( 1 ) = ONE - RETURN - END IF -C -C Determine the maximum singular value of -C G(lambda) = C*inv(lambda*E - A)*B + D, -C over a selected set of frequencies. Besides the frequencies w = 0, -C w = pi (if DICO = 'D'), and the given value FPEAK, this test set -C contains the peak frequency for each mode (or an approximation -C of it). The (generalized) Hessenberg form of the system is used. -C -C First, determine the maximum singular value of G(0) and set FPEAK -C accordingly. -C Additional workspace: -C complex: need 1, if DICO = 'C'; -C (N+M)*(N+P)+2*MIN(P,M)+MAX(P,M)), otherwise; -C prefer larger; -C real: need LDW0+LDW1+LDW2, where -C LDW0 = N*N+N*M, if DICO = 'C'; -C LDW0 = 0, if DICO = 'D'; -C LDW1 = P*M, if DICO = 'C', JOBD = 'Z'; -C LDW1 = 0, otherwise; -C LDW2 = MIN(P,M)+MAX(3*MIN(P,M)+MAX(P,M), -C 5*MIN(P,M)), -C if DICO = 'C'; -C LDW2 = 6*MIN(P,M), otherwise. -C prefer larger. -C - IF ( DISCR ) THEN - IAS = IA - IBS = IB - IWRK = IAR + N - ELSE - IAS = IAR + N - IBS = IAS + NN - IWRK = IBS + N*M - CALL DLACPY( 'Upper', N, N, DWORK( IA ), N, DWORK( IAS ), N ) - CALL DCOPY( N-1, DWORK( IA+1 ), N+1, DWORK( IAS+1 ), N+1 ) - CALL DLACPY( 'Full', N, M, DWORK( IB ), N, DWORK( IBS ), N ) - END IF - GAMMA = AB13DX( DICO, JOBE, JOBD, N, M, P, ZERO, DWORK( IAS ), N, - $ DWORK( IE ), N, DWORK( IBS ), N, DWORK( IC ), P, - $ DWORK( ID ), P, IWORK, DWORK( IWRK ), - $ LDWORK-IWRK+1, CWORK, LCWORK, IERR ) - MAXWRK = MAX( INT( DWORK( IWRK ) ) + IWRK - 1, MAXWRK ) - IF( IERR.GE.1 .AND. IERR.LE.N ) THEN - GPEAK( 1 ) = ONE - FPEAK( 1 ) = ZERO - GPEAK( 2 ) = ZERO - FPEAK( 2 ) = ONE - GO TO 340 - ELSE IF( IERR.EQ.N+1 ) THEN - INFO = 3 - RETURN - END IF -C - FPEAKS = FPEAK( 1 ) - FPEAKI = FPEAK( 2 ) - IF( GAMMAL.LT.GAMMA ) THEN - GAMMAL = GAMMA - FPEAK( 1 ) = ZERO - FPEAK( 2 ) = ONE - ELSE IF( .NOT.DISCR ) THEN - FPEAK( 1 ) = ONE - FPEAK( 2 ) = ZERO - END IF -C - MAXCWK = INT( CWORK( 1 ) ) -C - IF( DISCR ) THEN -C -C Try the frequency w = pi. -C - PI = FOUR*ATAN( ONE ) - GAMMA = AB13DX( DICO, JOBE, JOBD, N, M, P, PI, DWORK( IA ), - $ N, DWORK( IE ), N, DWORK( IB ), N, DWORK( IC ), - $ P, DWORK( ID ), P, IWORK, DWORK( IWRK ), - $ LDWORK-IWRK+1, CWORK, LCWORK, IERR ) - MAXCWK = MAX( INT( CWORK( 1 ) ), MAXCWK ) - MAXWRK = MAX( INT( DWORK( IWRK ) ) + IWRK - 1, MAXWRK ) - IF( IERR.GE.1 .AND. IERR.LE.N ) THEN - GPEAK( 1 ) = ONE - FPEAK( 1 ) = PI - GPEAK( 2 ) = ZERO - FPEAK( 2 ) = ONE - GO TO 340 - ELSE IF( IERR.EQ.N+1 ) THEN - INFO = 3 - RETURN - END IF -C - IF( GAMMAL.LT.GAMMA ) THEN - GAMMAL = GAMMA - FPEAK( 1 ) = PI - FPEAK( 2 ) = ONE - END IF -C - ELSE - IWRK = IAS -C -C Restore D, if needed. -C - IF ( WITHD ) - $ CALL DLACPY( 'Full', P, M, D, LDD, DWORK( ID ), P ) - END IF -C -C Build the remaining set of frequencies. -C Complex workspace: need (N+M)*(N+P)+2*MIN(P,M)+MAX(P,M)); -C prefer larger. -C Real workspace: need LDW2, see above; -C prefer larger. -C - IF ( MIN( FPEAKS, FPEAKI ).NE.ZERO ) THEN -C -C Compute also the norm at the given (finite) frequency. -C - GAMMA = AB13DX( DICO, JOBE, JOBD, N, M, P, FPEAKS, DWORK( IA ), - $ N, DWORK( IE ), N, DWORK( IB ), N, DWORK( IC ), - $ P, DWORK( ID ), P, IWORK, DWORK( IWRK ), - $ LDWORK-IWRK+1, CWORK, LCWORK, IERR ) - MAXCWK = MAX( INT( CWORK( 1 ) ), MAXCWK ) - MAXWRK = MAX( INT( DWORK( IWRK ) ) + IWRK - 1, MAXWRK ) - IF ( DISCR ) THEN - TM = ABS( ATAN2( SIN( FPEAKS ), COS( FPEAKS ) ) ) - ELSE - TM = FPEAKS - END IF - IF( IERR.GE.1 .AND. IERR.LE.N ) THEN - GPEAK( 1 ) = ONE - FPEAK( 1 ) = TM - GPEAK( 2 ) = ZERO - FPEAK( 2 ) = ONE - GO TO 340 - ELSE IF( IERR.EQ.N+1 ) THEN - INFO = 3 - RETURN - END IF -C - IF( GAMMAL.LT.GAMMA ) THEN - GAMMAL = GAMMA - FPEAK( 1 ) = TM - FPEAK( 2 ) = ONE - END IF -C - END IF -C - DO 110 I = 0, N - 1 - IF( DWORK( II+I ).GE.ZERO .AND. DWORK( IM+I ).GT.ZERO ) THEN - IF ( ( DWORK( IM+I ).GE.ONE ) .OR. ( DWORK( IM+I ).LT.ONE - $ .AND. DWORK( IAR+I ).LT.SAFMAX*DWORK( IM+I ) ) ) THEN - RAT = DWORK( IAR+I ) / DWORK( IM+I ) - ELSE - RAT = ONE - END IF - OMEGA = DWORK( IM+I )*SQRT( MAX( P25, ONE - TWO*RAT**2 ) ) -C - GAMMA = AB13DX( DICO, JOBE, JOBD, N, M, P, OMEGA, - $ DWORK( IA ), N, DWORK( IE ), N, DWORK( IB ), - $ N, DWORK( IC ), P, DWORK( ID ), P, IWORK, - $ DWORK( IWRK ), LDWORK-IWRK+1, CWORK, LCWORK, - $ IERR ) - MAXCWK = MAX( INT( CWORK( 1 ) ), MAXCWK ) - MAXWRK = MAX( INT( DWORK( IWRK ) ) + IWRK - 1, MAXWRK ) - IF ( DISCR ) THEN - TM = ABS( ATAN2( SIN( OMEGA ), COS( OMEGA ) ) ) - ELSE - TM = OMEGA - END IF - IF( IERR.GE.1 .AND. IERR.LE.N ) THEN - GPEAK( 1 ) = ONE - FPEAK( 1 ) = TM - GPEAK( 2 ) = ZERO - FPEAK( 2 ) = ONE - GO TO 340 - ELSE IF( IERR.EQ.N+1 ) THEN - INFO = 3 - RETURN - END IF -C - IF( GAMMAL.LT.GAMMA ) THEN - GAMMAL = GAMMA - FPEAK( 1 ) = TM - FPEAK( 2 ) = ONE - END IF -C - END IF - 110 CONTINUE -C -C Return if the lower bound is zero. -C - IF( GAMMAL.EQ.ZERO ) THEN - GPEAK( 1 ) = ZERO - FPEAK( 1 ) = ZERO - GPEAK( 2 ) = ONE - FPEAK( 2 ) = ONE - GO TO 340 - END IF -C -C Start the modified gamma iteration for the Bruinsma-Steinbuch -C algorithm. -C - IF ( .NOT.DISCR ) - $ RTOL = HUNDRD*TOLER - ITER = 0 -C -C WHILE ( Iteration may continue ) DO -C - 120 CONTINUE -C - ITER = ITER + 1 - GAMMA = ( ONE + TOL )*GAMMAL - USEPEN = FULLE .OR. DISCR - IF ( .NOT.USEPEN .AND. WITHD ) THEN -C -C Check whether one can use an explicit Hamiltonian matrix: -C compute -C min(rcond(GAMMA**2*Im - S'*S), rcond(GAMMA**2*Ip - S*S')). -C If P = M = 1, then GAMMA**2 - S(1)**2 is used instead. -C - IF ( M.NE.P ) THEN - RCOND = ONE - ( DWORK( IS ) / GAMMA )**2 - ELSE IF ( MINPM.GT.1 ) THEN - RCOND = ( GAMMA**2 - DWORK( IS )**2 ) / - $ ( GAMMA**2 - DWORK( IS+P-1 )**2 ) - ELSE - RCOND = GAMMA**2 - DWORK( IS )**2 - END IF -C - USEPEN = RCOND.LT.RTOL - END IF -C - IF ( USEPEN ) THEN -C -C Use the QZ algorithm on a pencil. -C Additional workspace here: need 6*N. (from IR) -C - II = IR + N2 - IBT = II + N2 - IH12 = IBT + N2 - IM = IH12 -C -C Set up the needed parts of the Hamiltonian pencil (H,J), -C -C ( H11 H12 ) -C H = ( ) , -C ( H21 H22 ) -C -C with -C -C ( A 0 ) ( 0 B ) ( E 0 ) -C H11 = ( ), H12 = ( )/nB, J11 = ( ), -C ( 0 -A' ) ( C' 0 ) ( 0 E' ) -C -C ( C 0 ) ( Ip D/g ) -C H21 = ( )*nB, H22 = ( ), -C ( 0 -B' ) ( D'/g Im ) -C -C if DICO = 'C', and -C -C ( A 0 ) ( B 0 ) ( E 0 ) -C H11 = ( ), H12 = ( )/nB, J11 = ( ), -C ( 0 E' ) ( 0 C' ) ( 0 A') -C -C ( 0 0 ) ( Im D'/g ) ( 0 B') -C H21 = ( )*nB, H22 = ( ), J21 = ( )*nB, -C ( C 0 ) ( D/g Ip ) ( 0 0 ) -C -C if DICO = 'D', where g = GAMMA, and nB = norm(B,1). -C First build [H12; H22]. -C - TEMP( 1 ) = ZERO - IH = IH12 -C - IF ( DISCR ) THEN -C - DO 150 J = 1, M -C - DO 130 I = 1, N - DWORK( IH ) = B( I, J ) / BNORM - IH = IH + 1 - 130 CONTINUE -C - CALL DCOPY( N+M, TEMP, 0, DWORK( IH ), 1 ) - DWORK( IH+N+J-1 ) = ONE - IH = IH + N + M -C - DO 140 I = 1, P - DWORK( IH ) = D( I, J ) / GAMMA - IH = IH + 1 - 140 CONTINUE -C - 150 CONTINUE -C - DO 180 J = 1, P - CALL DCOPY( N, TEMP, 0, DWORK( IH ), 1 ) - IH = IH + N -C - DO 160 I = 1, N - DWORK( IH ) = C( J, I ) / BNORM - IH = IH + 1 - 160 CONTINUE -C - DO 170 I = 1, M - DWORK( IH ) = D( J, I ) / GAMMA - IH = IH + 1 - 170 CONTINUE -C - CALL DCOPY( P, TEMP, 0, DWORK( IH ), 1 ) - DWORK( IH+J-1 ) = ONE - IH = IH + P - 180 CONTINUE -C - ELSE -C - DO 210 J = 1, P - CALL DCOPY( N, TEMP, 0, DWORK( IH ), 1 ) - IH = IH + N -C - DO 190 I = 1, N - DWORK( IH ) = C( J, I ) / BNORM - IH = IH + 1 - 190 CONTINUE -C - CALL DCOPY( P, TEMP, 0, DWORK( IH ), 1 ) - DWORK( IH+J-1 ) = ONE - IH = IH + P -C - DO 200 I = 1, M - DWORK( IH ) = D( J, I ) / GAMMA - IH = IH + 1 - 200 CONTINUE -C - 210 CONTINUE -C - DO 240 J = 1, M -C - DO 220 I = 1, N - DWORK( IH ) = B( I, J ) / BNORM - IH = IH + 1 - 220 CONTINUE -C - CALL DCOPY( N, TEMP, 0, DWORK( IH ), 1 ) - IH = IH + N -C - DO 230 I = 1, P - DWORK( IH ) = D( I, J ) / GAMMA - IH = IH + 1 - 230 CONTINUE -C - CALL DCOPY( M, TEMP, 0, DWORK( IH ), 1 ) - DWORK( IH+J-1 ) = ONE - IH = IH + M - 240 CONTINUE -C - END IF -C -C Compute the QR factorization of [H12; H22]. -C For large P and M, it could be more efficient to exploit the -C structure of [H12; H22] and use the factored form of Q. -C Additional workspace: need (2*N+P+M)*(2*N+P+M)+2*(P+M); -C prefer (2*N+P+M)*(2*N+P+M)+P+M+ -C (P+M)*NB. -C - ITAU = IH12 + N2PM*N2PM - IWRK = ITAU + PM - CALL DGEQRF( N2PM, PM, DWORK( IH12 ), N2PM, DWORK( ITAU ), - $ DWORK( IWRK ), LDWORK-IWRK+1, IERR ) - MAXWRK = MAX( INT( DWORK( IWRK ) ) + IWRK - 1, MAXWRK ) -C -C Apply part of the orthogonal transformation: -C Q1 = Q(:,P+M+(1:2*N))' to the matrix [H11; H21/GAMMA]. -C If DICO = 'C', apply Q(1:2*N,P+M+(1:2*N))' to the -C matrix J11. -C If DICO = 'D', apply Q1 to the matrix [J11; J21/GAMMA]. -C H11, H21, J11, and J21 are not fully built. -C First, build the (2*N+P+M)-by-(2*N+P+M) matrix Q. -C Using Q will often provide better efficiency than the direct -C use of the factored form of Q, especially when P+M < N. -C Additional workspace: need P+M+2*N+P+M; -C prefer P+M+(2*N+P+M)*NB. -C - CALL DORGQR( N2PM, N2PM, PM, DWORK( IH12 ), N2PM, - $ DWORK( ITAU ), DWORK( IWRK ), LDWORK-IWRK+1, - $ IERR ) - MAXWRK = MAX( INT( DWORK( IWRK ) ) + IWRK - 1, MAXWRK ) -C -C Additional workspace: need 8*N*N. -C - IPA = ITAU - IPE = IPA + 4*NN - IWRK = IPE + 4*NN - CALL DGEMM( 'Transpose', 'No Transpose', N2, N, N, ONE, - $ DWORK( IH12+PM*N2PM ), N2PM, A, LDA, ZERO, - $ DWORK( IPA ), N2 ) - IF ( DISCR ) THEN - CALL DGEMM( 'Transpose', 'No Transpose', N2, N, P, - $ BNORM/GAMMA, DWORK( IH12+PM*N2PM+N2+M), N2PM, - $ C, LDC, ONE, DWORK( IPA ), N2 ) - IF ( FULLE ) THEN - CALL DGEMM( 'Transpose', 'Transpose', N2, N, N, ONE, - $ DWORK( IH12+PM*N2PM+N ), N2PM, E, LDE, - $ ZERO, DWORK( IPA+2*NN ), N2 ) - ELSE - CALL MA02AD( 'Full', N, N2, DWORK( IH12+PM*N2PM+N ), - $ N2PM, DWORK( IPA+2*NN ), N2 ) - NY = N - END IF - ELSE - CALL DGEMM( 'Transpose', 'No Transpose', N2, N, P, - $ BNORM/GAMMA, DWORK( IH12+PM*N2PM+N2), N2PM, - $ C, LDC, ONE, DWORK( IPA ), N2 ) - CALL DGEMM( 'Transpose', 'Transpose', N2, N, N, -ONE, - $ DWORK( IH12+PM*N2PM+N ), N2PM, A, LDA, ZERO, - $ DWORK( IPA+2*NN ), N2 ) - CALL DGEMM( 'Transpose', 'Transpose', N2, N, M, - $ -BNORM/GAMMA, DWORK( IH12+PM*N2PM+N2+P), - $ N2PM, B, LDB, ONE, DWORK( IPA+2*NN ), N2 ) - NY = N2 - END IF -C - IF ( FULLE ) THEN - CALL DGEMM( 'Transpose', 'No Transpose', N2, N, N, ONE, - $ DWORK( IH12+PM*N2PM ), N2PM, E, LDE, ZERO, - $ DWORK( IPE ), N2 ) - ELSE - CALL MA02AD( 'Full', NY, N2, DWORK( IH12+PM*N2PM ), - $ N2PM, DWORK( IPE ), N2 ) - END IF - IF ( DISCR ) THEN - CALL DGEMM( 'Transpose', 'Transpose', N2, N, N, ONE, - $ DWORK( IH12+PM*N2PM+N ), N2PM, A, LDA, - $ ZERO, DWORK( IPE+2*NN ), N2 ) - CALL DGEMM( 'Transpose', 'Transpose', N2, N, M, - $ BNORM/GAMMA, DWORK( IH12+PM*N2PM+N2 ), N2PM, - $ B, LDB, ONE, DWORK( IPE+2*NN ), N2 ) - ELSE - IF ( FULLE ) - $ CALL DGEMM( 'Transpose', 'Transpose', N2, N, N, ONE, - $ DWORK( IH12+PM*N2PM+N ), N2PM, E, LDE, - $ ZERO, DWORK( IPE+2*NN ), N2 ) - END IF -C -C Compute the eigenvalues of the Hamiltonian pencil. -C Additional workspace: need 16*N; -C prefer larger. -C - CALL DGGEV( 'No Vectors', 'No Vectors', N2, DWORK( IPA ), - $ N2, DWORK( IPE ), N2, DWORK( IR ), DWORK( II ), - $ DWORK( IBT ), DWORK, N2, DWORK, N2, - $ DWORK( IWRK ), LDWORK-IWRK+1, IERR ) - IF( IERR.GT.0 ) THEN - INFO = 2 - RETURN - END IF - MAXWRK = MAX( INT( DWORK( IWRK ) ) + IWRK - 1, MAXWRK ) -C - ELSE IF ( .NOT.WITHD ) THEN -C -C Standard continuous-time case with D = 0. -C Form the needed part of the Hamiltonian matrix explicitly: -C H = H11 - H12*inv(H22)*H21/g. -C Additional workspace: need 2*N*N+N. (from IBT) -C - IH = IBT - IH12 = IH + NN - ISL = IH12 + NN + N - CALL DLACPY( 'Full', N, N, A, LDA, DWORK( IH ), N ) -C -C Compute triangles of -C'*C/GAMMA and B*B'/GAMMA. -C - CALL DSYRK( 'Lower', 'Transpose', N, P, -ONE/GAMMA, C, LDC, - $ ZERO, DWORK( IH12 ), N ) - CALL DSYRK( 'Upper', 'No Transpose', N, M, ONE/GAMMA, B, - $ LDB, ZERO, DWORK( IH12+N ), N ) -C - ELSE -C -C Standard continuous-time case with D <> 0 and the SVD of D -C can be used. Compute explicitly the needed part of the -C Hamiltonian matrix: -C -C (A+B1*S'*inv(g^2*Ip-S*S')*C1' g*B1*inv(g^2*Im-S'*S)*B1') -C H = ( ) -C ( -g*C1*inv(g^2*Ip-S*S')*C1' -H11' ) -C -C where g = GAMMA, B1 = B*V, C1 = C'*U, and H11 is the first -C block of H. -C Primary additional workspace: need 2*N*N+N (from IBT) -C (for building the relevant part of the Hamiltonian matrix). -C -C Compute C1*sqrt(inv(g^2*Ip-S*S')) . -C Additional workspace: need MAX(M,P)+N*P. -C - IH = IBT - IH12 = IH + NN - ISL = IH12 + NN + N -C - DO 250 I = 0, MINPM - 1 - DWORK( ISL+I ) = ONE/SQRT( GAMMA**2 - DWORK( IS+I )**2 ) - 250 CONTINUE -C - IF ( M.LT.P ) THEN - DWORK( ISL+M ) = ONE / GAMMA - CALL DCOPY( P-M-1, DWORK( ISL+M ), 0, DWORK( ISL+M+1 ), - $ 1 ) - END IF - ISC = ISL + MAX( M, P ) - CALL DLACPY( 'Full', N, P, DWORK( ICU ), N, DWORK( ISC ), - $ N ) - CALL MB01SD( 'Column', N, P, DWORK( ISC ), N, DWORK, - $ DWORK( ISL ) ) -C -C Compute B1*S' . -C Additional workspace: need N*M. -C - ISB = ISC + P*N - CALL DLACPY( 'Full', N, M, DWORK( IBV ), N, DWORK( ISB ), - $ N ) - CALL MB01SD( 'Column', N, MINPM, DWORK( ISB ), N, DWORK, - $ DWORK( IS ) ) -C -C Compute B1*S'*sqrt(inv(g^2*Ip-S*S')) . -C - CALL MB01SD( 'Column', N, MINPM, DWORK( ISB ), N, DWORK, - $ DWORK( ISL ) ) -C -C Compute H11 . -C - CALL DLACPY( 'Full', N, N, A, LDA, DWORK( IH ), N ) - CALL DGEMM( 'No Transpose', 'Transpose', N, N, MINPM, ONE, - $ DWORK( ISB ), N, DWORK( ISC ), N, ONE, - $ DWORK( IH ), N ) -C -C Compute B1*sqrt(inv(g^2*Im-S'*S)) . -C - IF ( P.LT.M ) THEN - DWORK( ISL+P ) = ONE / GAMMA - CALL DCOPY( M-P-1, DWORK( ISL+P ), 0, DWORK( ISL+P+1 ), - $ 1 ) - END IF - CALL DLACPY( 'Full', N, M, DWORK( IBV ), N, DWORK( ISB ), - $ N ) - CALL MB01SD( 'Column', N, M, DWORK( ISB ), N, DWORK, - $ DWORK( ISL ) ) -C -C Compute the lower triangle of H21 and the upper triangle -C of H12. -C - CALL DSYRK( 'Lower', 'No Transpose', N, P, -GAMMA, - $ DWORK( ISC ), N, ZERO, DWORK( IH12 ), N ) - CALL DSYRK( 'Upper', 'No Transpose', N, M, GAMMA, - $ DWORK( ISB ), N, ZERO, DWORK( IH12+N ), N ) - END IF -C - IF ( .NOT.USEPEN ) THEN -C -C Compute the eigenvalues of the Hamiltonian matrix by the -C symplectic URV and the periodic Schur decompositions. -C Additional workspace: need (2*N+8)*N; -C prefer larger. -C - IWRK = ISL + NN - CALL MB03XD( 'Both', 'Eigenvalues', 'No vectors', - $ 'No vectors', N, DWORK( IH ), N, DWORK( IH12 ), - $ N, DWORK( ISL ), N, TEMP, 1, TEMP, 1, TEMP, 1, - $ TEMP, 1, DWORK( IR ), DWORK( II ), ILO, - $ DWORK( IWRK ), DWORK( IWRK+N ), - $ LDWORK-IWRK-N+1, IERR ) - IF( IERR.GT.0 ) THEN - INFO = 2 - RETURN - END IF - MAXWRK = MAX( INT( DWORK( IWRK ) ) + IWRK + N - 1, MAXWRK ) - END IF -C -C Detect eigenvalues on the boundary of the stability domain, -C if any. The test is based on a round-off level of eps*rho(H) -C (after balancing) resulting in worst-case perturbations of -C order sqrt(eps*rho(H)), for continuous-time systems, on the -C real part of poles of multiplicity two (typical as GAMMA -C approaches the infinity norm). Similarly, in the discrete-time -C case. Above, rho(H) is the maximum modulus of eigenvalues -C (continuous-time case). -C -C Compute maximum eigenvalue modulus and check the absolute real -C parts (if DICO = 'C'), or moduli (if DICO = 'D'). -C - WMAX = ZERO -C - IF ( USEPEN ) THEN -C -C Additional workspace: need 2*N, if DICO = 'D'; (from IM) -C 0, if DICO = 'C'. -C - DO 260 I = 0, N2 - 1 - TM = DLAPY2( DWORK( IR+I ), DWORK( II+I ) ) - IF ( ( DWORK( IBT+I ).GE.ONE ) .OR. - $ ( DWORK( IBT+I ).LT.ONE .AND. - $ TM.LT.SAFMAX*DWORK( IBT+I ) ) ) THEN - TM = TM / DWORK( IBT+I ) - ELSE -C -C The pencil has too large eigenvalues. SAFMAX is used. -C - TM = SAFMAX - END IF - WMAX = MAX( WMAX, TM ) - IF ( DISCR ) - $ DWORK( IM+I ) = TM - 260 CONTINUE -C - ELSE -C - DO 270 I = 0, N - 1 - TM = DLAPY2( DWORK( IR+I ), DWORK( II+I ) ) - WMAX = MAX( WMAX, TM ) - 270 CONTINUE -C - END IF -C - NEI = 0 -C - IF ( USEPEN ) THEN -C - DO 280 I = 0, N2 - 1 - IF ( DISCR ) THEN - TM = ABS( ONE - DWORK( IM+I ) ) - ELSE - TM = ABS( DWORK( IR+I ) ) - IF ( ( DWORK( IBT+I ).GE.ONE ) .OR. - $ ( DWORK( IBT+I ).LT.ONE .AND. - $ TM.LT.SAFMAX*DWORK( IBT+I ) ) ) THEN - TM = TM / DWORK( IBT+I ) - ELSE -C -C The pencil has too large eigenvalues. -C SAFMAX is used. -C - TM = SAFMAX - END IF - END IF - IF ( TM.LE.TOLER*SQRT( HUNDRD + WMAX ) ) THEN - DWORK( IR+NEI ) = DWORK( IR+I ) / DWORK( IBT+I ) - DWORK( II+NEI ) = DWORK( II+I ) / DWORK( IBT+I ) - NEI = NEI + 1 - END IF - 280 CONTINUE -C - ELSE -C - DO 290 I = 0, N - 1 - TM = ABS( DWORK( IR+I ) ) - IF ( TM.LE.TOLER*SQRT( HUNDRD + WMAX ) ) THEN - DWORK( IR+NEI ) = DWORK( IR+I ) - DWORK( II+NEI ) = DWORK( II+I ) - NEI = NEI + 1 - END IF - 290 CONTINUE -C - END IF -C - IF( NEI.EQ.0 ) THEN -C -C There is no eigenvalue on the boundary of the stability -C domain for G = ( ONE + TOL )*GAMMAL. The norm was found. -C - GPEAK( 1 ) = GAMMAL - GPEAK( 2 ) = ONE - GO TO 340 - END IF -C -C Compute the frequencies where the gain G is attained and -C generate new test frequencies. -C - NWS = 0 -C - IF ( DISCR ) THEN -C - DO 300 I = 0, NEI - 1 - TM = ATAN2( DWORK( II+I ), DWORK( IR+I ) ) - DWORK( IR+I ) = MAX( EPS, TM ) - NWS = NWS + 1 - 300 CONTINUE -C - ELSE -C - J = 0 -C - DO 310 I = 0, NEI - 1 - IF ( DWORK( II+I ).GT.EPS ) THEN - DWORK( IR+NWS ) = DWORK( II+I ) - NWS = NWS + 1 - ELSE IF ( DWORK( II+I ).EQ.EPS ) THEN - J = J + 1 - IF ( J.EQ.1 ) THEN - DWORK( IR+NWS ) = EPS - NWS = NWS + 1 - END IF - END IF - 310 CONTINUE -C - END IF -C - CALL DLASRT( 'Increasing', NWS, DWORK( IR ), IERR ) - LW = 1 -C - DO 320 I = 0, NWS - 1 - IF ( DWORK( IR+LW-1 ).NE.DWORK( IR+I ) ) THEN - DWORK( IR+LW ) = DWORK( IR+I ) - LW = LW + 1 - END IF - 320 CONTINUE -C - IF ( LW.EQ.1 ) THEN - IF ( ITER.EQ.1 .AND. NWS.GE.1 ) THEN -C -C Duplicate the frequency trying to force iteration. -C - DWORK( IR+1 ) = DWORK( IR ) - LW = LW + 1 - ELSE -C -C The norm was found. -C - GPEAK( 1 ) = GAMMAL - GPEAK( 2 ) = ONE - GO TO 340 - END IF - END IF -C -C Form the vector of mid-points and compute the gain at new test -C frequencies. Save the current lower bound. -C - IWRK = IR + LW - GAMMAS = GAMMAL -C - DO 330 I = 0, LW - 2 - IF ( DISCR ) THEN - OMEGA = ( DWORK( IR+I ) + DWORK( IR+I+1 ) ) / TWO - ELSE - OMEGA = SQRT( DWORK( IR+I )*DWORK( IR+I+1 ) ) - END IF -C -C Additional workspace: need LDW2, see above; -C prefer larger. -C - GAMMA = AB13DX( DICO, JOBE, JOBD, N, M, P, OMEGA, - $ DWORK( IA ), N, DWORK( IE ), N, DWORK( IB ), - $ N, DWORK( IC ), P, DWORK( ID ), P, IWORK, - $ DWORK( IWRK ), LDWORK-IWRK+1, CWORK, LCWORK, - $ IERR ) - MAXCWK = MAX( INT( CWORK( 1 ) ), MAXCWK ) - MAXWRK = MAX( INT( DWORK( IWRK ) ) + IWRK - 1, MAXWRK ) - IF ( DISCR ) THEN - TM = ABS( ATAN2( SIN( OMEGA ), COS( OMEGA ) ) ) - ELSE - TM = OMEGA - END IF - IF( IERR.GE.1 .AND. IERR.LE.N ) THEN - GPEAK( 1 ) = ONE - FPEAK( 1 ) = TM - GPEAK( 2 ) = ZERO - FPEAK( 2 ) = ONE - GO TO 340 - ELSE IF( IERR.EQ.N+1 ) THEN - INFO = 3 - RETURN - END IF -C - IF( GAMMAL.LT.GAMMA ) THEN - GAMMAL = GAMMA - FPEAK( 1 ) = TM - FPEAK( 2 ) = ONE - END IF - 330 CONTINUE -C -C If the lower bound has not been improved, return. (This is a -C safeguard against undetected modes of Hamiltonian matrix on the -C boundary of the stability domain.) -C - IF ( GAMMAL.LT.GAMMAS*( ONE + TOL/TEN ) ) THEN - GPEAK( 1 ) = GAMMAL - GPEAK( 2 ) = ONE - GO TO 340 - END IF -C -C END WHILE -C - IF ( ITER.LE.MAXIT ) THEN - GO TO 120 - ELSE - INFO = 4 - RETURN - END IF -C - 340 CONTINUE - DWORK( 1 ) = MAXWRK - CWORK( 1 ) = MAXCWK - RETURN -C *** Last line of AB13DD *** - END diff --git a/mex/sources/libslicot/AB13DX.f b/mex/sources/libslicot/AB13DX.f deleted file mode 100644 index 09362b7c6..000000000 --- a/mex/sources/libslicot/AB13DX.f +++ /dev/null @@ -1,544 +0,0 @@ - DOUBLE PRECISION FUNCTION AB13DX( DICO, JOBE, JOBD, N, M, P, - $ OMEGA, A, LDA, E, LDE, B, LDB, - $ C, LDC, D, LDD, IWORK, DWORK, - $ LDWORK, CWORK, LCWORK, INFO ) -C -C SLICOT RELEASE 5.0. -C -C Copyright (c) 2002-2009 NICONET e.V. -C -C This program is free software: you can redistribute it and/or -C modify it under the terms of the GNU General Public License as -C published by the Free Software Foundation, either version 2 of -C the License, or (at your option) any later version. -C -C This program is distributed in the hope that it will be useful, -C but WITHOUT ANY WARRANTY; without even the implied warranty of -C MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the -C GNU General Public License for more details. -C -C You should have received a copy of the GNU General Public License -C along with this program. If not, see -C . -C -C PURPOSE -C -C To compute the maximum singular value of a given continuous-time -C or discrete-time transfer-function matrix, either standard or in -C the descriptor form, -C -C -1 -C G(lambda) = C*( lambda*E - A ) *B + D , -C -C for a given complex value lambda, where lambda = j*omega, in the -C continuous-time case, and lambda = exp(j*omega), in the -C discrete-time case. The matrices A, E, B, C, and D are real -C matrices of appropriate dimensions. Matrix A must be in an upper -C Hessenberg form, and if JOBE ='G', the matrix E must be upper -C triangular. The matrices B and C must correspond to the system -C in (generalized) Hessenberg form. -C -C FUNCTION VALUE -C -C AB13DX DOUBLE PRECISION -C The maximum singular value of G(lambda). -C -C ARGUMENTS -C -C Mode Parameters -C -C DICO CHARACTER*1 -C Specifies the type of the system, as follows: -C = 'C': continuous-time system; -C = 'D': discrete-time system. -C -C JOBE CHARACTER*1 -C Specifies whether E is an upper triangular or an identity -C matrix, as follows: -C = 'G': E is a general upper triangular matrix; -C = 'I': E is the identity matrix. -C -C JOBD CHARACTER*1 -C Specifies whether or not a non-zero matrix D appears in -C the given state space model: -C = 'D': D is present; -C = 'Z': D is assumed a zero matrix. -C -C Input/Output Parameters -C -C N (input) INTEGER -C The order of the system. N >= 0. -C -C M (input) INTEGER -C The column size of the matrix B. M >= 0. -C -C P (input) INTEGER -C The row size of the matrix C. P >= 0. -C -C OMEGA (input) DOUBLE PRECISION -C The frequency value for which the calculations should be -C done. -C -C A (input/output) DOUBLE PRECISION array, dimension (LDA,N) -C On entry, the leading N-by-N upper Hessenberg part of this -C array must contain the state dynamics matrix A in upper -C Hessenberg form. The elements below the subdiagonal are -C not referenced. -C On exit, if M > 0, P > 0, OMEGA = 0, DICO = 'C', B <> 0, -C and C <> 0, the leading N-by-N upper Hessenberg part of -C this array contains the factors L and U from the LU -C factorization of A (A = P*L*U); the unit diagonal elements -C of L are not stored, L is lower bidiagonal, and P is -C stored in IWORK (see SLICOT Library routine MB02SD). -C Otherwise, this array is unchanged on exit. -C -C LDA INTEGER -C The leading dimension of the array A. LDA >= max(1,N). -C -C E (input) DOUBLE PRECISION array, dimension (LDE,N) -C If JOBE = 'G', the leading N-by-N upper triangular part of -C this array must contain the upper triangular descriptor -C matrix E of the system. The elements of the strict lower -C triangular part of this array are not referenced. -C If JOBE = 'I', then E is assumed to be the identity -C matrix and is not referenced. -C -C LDE INTEGER -C The leading dimension of the array E. -C LDE >= MAX(1,N), if JOBE = 'G'; -C LDE >= 1, if JOBE = 'I'. -C -C B (input/output) DOUBLE PRECISION array, dimension (LDB,M) -C On entry, the leading N-by-M part of this array must -C contain the system input matrix B. -C On exit, if M > 0, P > 0, OMEGA = 0, DICO = 'C', B <> 0, -C C <> 0, and INFO = 0 or N+1, the leading N-by-M part of -C this array contains the solution of the system A*X = B. -C Otherwise, this array is unchanged on exit. -C -C LDB INTEGER -C The leading dimension of the array B. LDB >= max(1,N). -C -C C (input) DOUBLE PRECISION array, dimension (LDC,N) -C The leading P-by-N part of this array must contain the -C system output matrix C. -C -C LDC INTEGER -C The leading dimension of the array C. LDC >= max(1,P). -C -C D (input/output) DOUBLE PRECISION array, dimension (LDD,M) -C On entry, if JOBD = 'D', the leading P-by-M part of this -C array must contain the direct transmission matrix D. -C On exit, if (N = 0, or B = 0, or C = 0) and JOBD = 'D', -C or (OMEGA = 0, DICO = 'C', JOBD = 'D', and INFO = 0 or -C N+1), the contents of this array is destroyed. -C Otherwise, this array is unchanged on exit. -C This array is not referenced if JOBD = 'Z'. -C -C LDD INTEGER -C The leading dimension of array D. -C LDD >= MAX(1,P), if JOBD = 'D'; -C LDD >= 1, if JOBD = 'Z'. -C -C Workspace -C -C IWORK INTEGER array, dimension (LIWORK), where -C LIWORK = N, if N > 0, M > 0, P > 0, B <> 0, and C <> 0; -C LIWORK = 0, otherwise. -C This array contains the pivot indices in the LU -C factorization of the matrix lambda*E - A; for 1 <= i <= N, -C row i of the matrix was interchanged with row IWORK(i). -C -C DWORK DOUBLE PRECISION array, dimension (LDWORK) -C On exit, if INFO = 0, DWORK(1) contains the optimal value -C of LDWORK, and DWORK(2), ..., DWORK(MIN(P,M)) contain the -C singular values of G(lambda), except for the first one, -C which is returned in the function value AB13DX. -C If (N = 0, or B = 0, or C = 0) and JOBD = 'Z', the last -C MIN(P,M)-1 zero singular values of G(lambda) are not -C stored in DWORK(2), ..., DWORK(MIN(P,M)). -C -C LDWORK INTEGER -C The dimension of the array DWORK. -C LDWORK >= MAX(1, LDW1 + LDW2 ), -C LDW1 = P*M, if N > 0, B <> 0, C <> 0, OMEGA = 0, -C DICO = 'C', and JOBD = 'Z'; -C LDW1 = 0, otherwise; -C LDW2 = MIN(P,M) + MAX(3*MIN(P,M) + MAX(P,M), 5*MIN(P,M)), -C if (N = 0, or B = 0, or C = 0) and JOBD = 'D', -C or (N > 0, B <> 0, C <> 0, OMEGA = 0, and -C DICO = 'C'); -C LDW2 = 0, if (N = 0, or B = 0, or C = 0) and JOBD = 'Z', -C or MIN(P,M) = 0; -C LDW2 = 6*MIN(P,M), otherwise. -C For good performance, LDWORK must generally be larger. -C -C CWORK COMPLEX*16 array, dimension (LCWORK) -C On exit, if INFO = 0, CWORK(1) contains the optimal -C LCWORK. -C -C LCWORK INTEGER -C The dimension of the array CWORK. -C LCWORK >= 1, if N = 0, or B = 0, or C = 0, or (OMEGA = 0 -C and DICO = 'C') or MIN(P,M) = 0; -C LCWORK >= MAX(1, (N+M)*(N+P) + 2*MIN(P,M) + MAX(P,M)), -C otherwise. -C For good performance, LCWORK must generally be larger. -C -C Error Indicator -C -C INFO INTEGER -C = 0: successful exit; -C < 0: if INFO = -i, the i-th argument had an illegal -C value; -C > 0: if INFO = i, U(i,i) is exactly zero; the LU -C factorization of the matrix lambda*E - A has been -C completed, but the factor U is exactly singular, -C i.e., the matrix lambda*E - A is exactly singular; -C = N+1: the SVD algorithm for computing singular values -C did not converge. -C -C METHOD -C -C The routine implements standard linear algebra calculations, -C taking problem structure into account. LAPACK Library routines -C DGESVD and ZGESVD are used for finding the singular values. -C -C CONTRIBUTORS -C -C D. Sima, University of Bucharest, May 2001. -C V. Sima, Research Institute for Informatics, Bucharest, May 2001. -C -C REVISIONS -C -C V. Sima, Research Institute for Informatics, Bucharest, Sep. 2005. -C -C KEYWORDS -C -C H-infinity optimal control, robust control, system norm. -C -C ****************************************************************** -C -C .. Parameters .. - COMPLEX*16 CONE - PARAMETER ( CONE = ( 1.0D0, 0.0D0 ) ) - DOUBLE PRECISION ZERO, ONE - PARAMETER ( ZERO = 0.0D+0, ONE = 1.0D+0 ) -C .. -C .. Scalar Arguments .. - CHARACTER DICO, JOBD, JOBE - INTEGER INFO, LCWORK, LDA, LDB, LDC, LDD, LDE, LDWORK, - $ M, N, P - DOUBLE PRECISION OMEGA -C .. -C .. Array Arguments .. - COMPLEX*16 CWORK( * ) - DOUBLE PRECISION A( LDA, * ), B( LDB, * ), C( LDC, * ), - $ D( LDD, * ), DWORK( * ), E( LDE, * ) - INTEGER IWORK( * ) -C .. -C .. Local Scalars .. - LOGICAL DISCR, FULLE, NODYN, SPECL, WITHD - INTEGER I, ICB, ICC, ICD, ICWK, ID, IERR, IS, IWRK, J, - $ MAXWRK, MINCWR, MINPM, MINWRK - DOUBLE PRECISION BNORM, CNORM, LAMBDI, LAMBDR, UPD -C -C .. External Functions .. - DOUBLE PRECISION DLANGE - LOGICAL LSAME - EXTERNAL DLANGE, LSAME -C .. -C .. External Subroutines .. - EXTERNAL DGEMM, DGESVD, MB02RD, MB02RZ, MB02SD, MB02SZ, - $ XERBLA, ZGEMM, ZGESVD, ZLACP2 -C .. -C .. Intrinsic Functions .. - INTRINSIC COS, DCMPLX, INT, MAX, MIN, SIN -C .. -C .. Executable Statements .. -C -C Test the input scalar parameters. -C - INFO = 0 - DISCR = LSAME( DICO, 'D' ) - FULLE = LSAME( JOBE, 'G' ) - WITHD = LSAME( JOBD, 'D' ) -C - IF( .NOT. ( DISCR .OR. LSAME( DICO, 'C' ) ) ) THEN - INFO = -1 - ELSE IF( .NOT. ( FULLE .OR. LSAME( JOBE, 'I' ) ) ) THEN - INFO = -2 - ELSE IF( .NOT. ( WITHD .OR. LSAME( JOBD, 'Z' ) ) ) THEN - INFO = -3 - ELSE IF( N.LT.0 ) THEN - INFO = -4 - ELSE IF( M.LT.0 ) THEN - INFO = -5 - ELSE IF( P.LT.0 ) THEN - INFO = -6 - ELSE IF( LDA.LT.MAX( 1, N ) ) THEN - INFO = -9 - ELSE IF( LDE.LT.1 .OR. ( FULLE .AND. LDE.LT.N ) ) THEN - INFO = -11 - ELSE IF( LDB.LT.MAX( 1, N ) ) THEN - INFO = -13 - ELSE IF( LDC.LT.MAX( 1, P ) ) THEN - INFO = -15 - ELSE IF( LDD.LT.1 .OR. ( WITHD .AND. LDD.LT.P ) ) THEN - INFO = -17 - ELSE - BNORM = DLANGE( '1-norm', N, M, B, LDB, DWORK ) - CNORM = DLANGE( '1-norm', P, N, C, LDC, DWORK ) - NODYN = N.EQ.0 .OR. MIN( BNORM, CNORM ).EQ.ZERO - SPECL = .NOT.NODYN .AND. OMEGA.EQ.ZERO .AND. .NOT.DISCR - MINPM = MIN( P, M ) -C -C Compute workspace. -C - IF( MINPM.EQ.0 ) THEN - MINWRK = 0 - ELSE IF( SPECL .OR. ( NODYN .AND. WITHD ) ) THEN - MINWRK = MINPM + MAX( 3*MINPM + MAX( P, M ), 5*MINPM ) - IF ( SPECL .AND. .NOT.WITHD ) - $ MINWRK = MINWRK + P*M - ELSE IF ( NODYN .AND. .NOT.WITHD ) THEN - MINWRK = 0 - ELSE - MINWRK = 6*MINPM - END IF - MINWRK = MAX( 1, MINWRK ) -C - IF( LDWORK.LT.MINWRK ) THEN - INFO = -20 - ELSE - IF ( NODYN .OR. ( OMEGA.EQ.ZERO .AND. .NOT.DISCR ) .OR. - $ MINPM.EQ.0 ) THEN - MINCWR = 1 - ELSE - MINCWR = MAX( 1, ( N + M )*( N + P ) + - $ 2*MINPM + MAX( P, M ) ) - END IF - IF( LCWORK.LT.MINCWR ) - $ INFO = -22 - END IF - END IF -C - IF( INFO.NE.0 ) THEN - CALL XERBLA( 'AB13DX', -INFO ) - RETURN - END IF -C -C Quick return if possible. -C - IF( MINPM.EQ.0 ) THEN - AB13DX = ZERO -C - DWORK( 1 ) = ONE - CWORK( 1 ) = ONE - RETURN - END IF -C -C (Note: Comments in the code beginning "Workspace:" describe the -C minimal amount of real workspace needed at that point in the -C code, as well as the preferred amount for good performance.) -C - IS = 1 - IWRK = IS + MINPM -C - IF( NODYN ) THEN -C -C No dynamics: Determine the maximum singular value of G = D . -C - IF ( WITHD ) THEN -C -C Workspace: need MIN(P,M) + MAX(3*MIN(P,M) + MAX(P,M), -C 5*MIN(P,M)); -C prefer larger. -C - CALL DGESVD( 'No Vectors', 'No Vectors', P, M, D, LDD, - $ DWORK( IS ), DWORK, P, DWORK, M, DWORK( IWRK ), - $ LDWORK-IWRK+1, IERR ) - IF( IERR.GT.0 ) THEN - INFO = N + 1 - RETURN - END IF - AB13DX = DWORK( IS ) - MAXWRK = INT( DWORK( IWRK ) ) + IWRK - 1 - ELSE - AB13DX = ZERO - MAXWRK = 1 - END IF -C - DWORK( 1 ) = MAXWRK - CWORK( 1 ) = ONE - RETURN - END IF -C -C Determine the maximum singular value of -C G(lambda) = C*inv(lambda*E - A)*B + D. -C The (generalized) Hessenberg form of the system is used. -C - IF ( SPECL ) THEN -C -C Special continuous-time case: -C Determine the maximum singular value of the real matrix G(0). -C Workspace: need MIN(P,M) + MAX(3*MIN(P,M) + MAX(P,M), -C 5*MIN(P,M)); -C prefer larger. -C - CALL MB02SD( N, A, LDA, IWORK, IERR ) - IF( IERR.GT.0 ) THEN - INFO = IERR - DWORK( 1 ) = ONE - CWORK( 1 ) = ONE - RETURN - END IF - CALL MB02RD( 'No Transpose', N, M, A, LDA, IWORK, B, LDB, - $ IERR ) - IF ( WITHD ) THEN - CALL DGEMM( 'No Transpose', 'No Transpose', P, M, N, -ONE, - $ C, LDC, B, LDB, ONE, D, LDD ) - CALL DGESVD( 'No Vectors', 'No Vectors', P, M, D, LDD, - $ DWORK( IS ), DWORK, P, DWORK, M, DWORK( IWRK ), - $ LDWORK-IWRK+1, IERR ) - ELSE -C -C Additional workspace: need P*M. -C - ID = IWRK - IWRK = ID + P*M - CALL DGEMM( 'No Transpose', 'No Transpose', P, M, N, -ONE, - $ C, LDC, B, LDB, ZERO, DWORK( ID ), P ) - CALL DGESVD( 'No Vectors', 'No Vectors', P, M, DWORK( ID ), - $ P, DWORK( IS ), DWORK, P, DWORK, M, - $ DWORK( IWRK ), LDWORK-IWRK+1, IERR ) - END IF - IF( IERR.GT.0 ) THEN - INFO = N + 1 - RETURN - END IF -C - AB13DX = DWORK( IS ) - DWORK( 1 ) = INT( DWORK( IWRK ) ) + IWRK - 1 - CWORK( 1 ) = ONE - RETURN - END IF -C -C General case: Determine the maximum singular value of G(lambda). -C Complex workspace: need N*N + N*M + P*N + P*M. -C - ICB = 1 + N*N - ICC = ICB + N*M - ICD = ICC + P*N - ICWK = ICD + P*M -C - IF ( WITHD ) THEN - UPD = ONE - ELSE - UPD = ZERO - END IF -C - IF ( DISCR ) THEN - LAMBDR = COS( OMEGA ) - LAMBDI = SIN( OMEGA ) -C -C Build lambda*E - A . -C - IF ( FULLE ) THEN -C - DO 20 J = 1, N -C - DO 10 I = 1, J - CWORK( I+(J-1)*N ) = - $ DCMPLX( LAMBDR*E( I, J ) - A( I, J ), - $ LAMBDI*E( I, J ) ) - 10 CONTINUE -C - IF( J.LT.N ) - $ CWORK( J+1+(J-1)*N ) = DCMPLX( -A( J+1, J ), ZERO ) - 20 CONTINUE -C - ELSE -C - DO 40 J = 1, N -C - DO 30 I = 1, MIN( J+1, N ) - CWORK( I+(J-1)*N ) = -A( I, J ) - 30 CONTINUE -C - CWORK( J+(J-1)*N ) = DCMPLX( LAMBDR - A( J, J ), LAMBDI ) - 40 CONTINUE -C - END IF -C - ELSE -C -C Build j*omega*E - A. -C - IF ( FULLE ) THEN -C - DO 60 J = 1, N -C - DO 50 I = 1, J - CWORK( I+(J-1)*N ) = - $ DCMPLX( -A( I, J ), OMEGA*E( I, J ) ) - 50 CONTINUE -C - IF( J.LT.N ) - $ CWORK( J+1+(J-1)*N ) = DCMPLX( -A( J+1, J ), ZERO ) - 60 CONTINUE -C - ELSE -C - DO 80 J = 1, N -C - DO 70 I = 1, MIN( J+1, N ) - CWORK( I+(J-1)*N ) = -A( I, J ) - 70 CONTINUE -C - CWORK( J+(J-1)*N ) = DCMPLX( -A( J, J ), OMEGA ) - 80 CONTINUE -C - END IF -C - END IF -C -C Build G(lambda) . -C - CALL ZLACP2( 'Full', N, M, B, LDB, CWORK( ICB ), N ) - CALL ZLACP2( 'Full', P, N, C, LDC, CWORK( ICC ), P ) - IF ( WITHD ) - $ CALL ZLACP2( 'Full', P, M, D, LDD, CWORK( ICD ), P ) -C - CALL MB02SZ( N, CWORK, N, IWORK, IERR ) - IF( IERR.GT.0 ) THEN - INFO = IERR - DWORK( 1 ) = ONE - CWORK( 1 ) = ICWK - 1 - RETURN - END IF - CALL MB02RZ( 'No Transpose', N, M, CWORK, N, IWORK, - $ CWORK( ICB ), N, IERR ) - CALL ZGEMM( 'No Transpose', 'No Transpose', P, M, N, CONE, - $ CWORK( ICC ), P, CWORK( ICB ), N, - $ DCMPLX( UPD, ZERO ), CWORK( ICD ), P ) -C -C Additional workspace, complex: need 2*MIN(P,M) + MAX(P,M); -C prefer larger; -C real: need 5*MIN(P,M). -C - CALL ZGESVD( 'No Vectors', 'No Vectors', P, M, CWORK( ICD ), P, - $ DWORK( IS ), CWORK, P, CWORK, M, CWORK( ICWK ), - $ LCWORK-ICWK+1, DWORK( IWRK ), IERR ) - IF( IERR.GT.0 ) THEN - INFO = N + 1 - RETURN - END IF - AB13DX = DWORK( IS ) -C - DWORK( 1 ) = 6*MINPM - CWORK( 1 ) = INT( CWORK( ICWK ) ) + ICWK - 1 -C - RETURN -C *** Last line of AB13DX *** - END diff --git a/mex/sources/libslicot/AB13ED.f b/mex/sources/libslicot/AB13ED.f deleted file mode 100644 index a757b84e2..000000000 --- a/mex/sources/libslicot/AB13ED.f +++ /dev/null @@ -1,347 +0,0 @@ - SUBROUTINE AB13ED( N, A, LDA, LOW, HIGH, TOL, DWORK, LDWORK, - $ INFO ) -C -C SLICOT RELEASE 5.0. -C -C Copyright (c) 2002-2009 NICONET e.V. -C -C This program is free software: you can redistribute it and/or -C modify it under the terms of the GNU General Public License as -C published by the Free Software Foundation, either version 2 of -C the License, or (at your option) any later version. -C -C This program is distributed in the hope that it will be useful, -C but WITHOUT ANY WARRANTY; without even the implied warranty of -C MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the -C GNU General Public License for more details. -C -C You should have received a copy of the GNU General Public License -C along with this program. If not, see -C . -C -C PURPOSE -C -C To estimate beta(A), the 2-norm distance from a real matrix A to -C the nearest complex matrix with an eigenvalue on the imaginary -C axis. The estimate is given as -C -C LOW <= beta(A) <= HIGH, -C -C where either -C -C (1 + TOL) * LOW >= HIGH, -C -C or -C -C LOW = 0 and HIGH = delta, -C -C and delta is a small number approximately equal to the square root -C of machine precision times the Frobenius norm (Euclidean norm) -C of A. If A is stable in the sense that all eigenvalues of A lie -C in the open left half complex plane, then beta(A) is the distance -C to the nearest unstable complex matrix, i.e., the complex -C stability radius. -C -C ARGUMENTS -C -C Input/Output Parameters -C -C N (input) INTEGER -C The order of the matrix A. N >= 0. -C -C A (input) DOUBLE PRECISION array, dimension (LDA,N) -C The leading N-by-N part of this array must contain the -C matrix A. -C -C LDA INTEGER -C The leading dimension of array A. LDA >= MAX(1,N). -C -C LOW (output) DOUBLE PRECISION -C A lower bound for beta(A). -C -C HIGH (output) DOUBLE PRECISION -C An upper bound for beta(A). -C -C Tolerances -C -C TOL DOUBLE PRECISION -C Specifies the accuracy with which LOW and HIGH approximate -C beta(A). If the user sets TOL to be less than SQRT(EPS), -C where EPS is the machine precision (see LAPACK Library -C Routine DLAMCH), then the tolerance is taken to be -C SQRT(EPS). -C The recommended value is TOL = 9, which gives an estimate -C of beta(A) correct to within an order of magnitude. -C -C Workspace -C -C DWORK DOUBLE PRECISION array, dimension (LDWORK) -C On exit, if INFO = 0, DWORK(1) returns the optimal value -C of LDWORK. -C -C LDWORK INTEGER -C The length of the array DWORK. -C LDWORK >= MAX( 1, 3*N*(N+1) ). -C For optimum performance LDWORK should be larger. -C -C Error Indicator -C -C INFO INTEGER -C = 0: successful exit; -C < 0: if INFO = -i, the i-th argument had an illegal -C value; -C = 1: the QR algorithm (LAPACK Library routine DHSEQR) -C fails to converge; this error is very rare. -C -C METHOD -C -C Let beta(A) be the 2-norm distance from a real matrix A to the -C nearest complex matrix with an eigenvalue on the imaginary axis. -C It is known that beta(A) = minimum of the smallest singular -C value of (A - jwI), where I is the identity matrix and j**2 = -1, -C and the minimum is taken over all real w. -C The algorithm computes a lower bound LOW and an upper bound HIGH -C for beta(A) by a bisection method in the following way. Given a -C non-negative real number sigma, the Hamiltonian matrix H(sigma) -C is constructed: -C -C | A -sigma*I | | A G | -C H(sigma) = | | := | | . -C | sigma*I -A' | | F -A' | -C -C It can be shown [1] that H(sigma) has an eigenvalue whose real -C part is zero if and only if sigma >= beta. Any lower and upper -C bounds on beta(A) can be improved by choosing a number between -C them and checking to see if H(sigma) has an eigenvalue with zero -C real part. This decision is made by computing the eigenvalues of -C H(sigma) using the square reduced algorithm of Van Loan [2]. -C -C REFERENCES -C -C [1] Byers, R. -C A bisection method for measuring the distance of a stable -C matrix to the unstable matrices. -C SIAM J. Sci. Stat. Comput., Vol. 9, No. 5, pp. 875-880, 1988. -C -C [2] Van Loan, C.F. -C A symplectic method for approximating all the eigenvalues of a -C Hamiltonian matrix. -C Linear Algebra and its Applications, Vol 61, 233-251, 1984. -C -C NUMERICAL ASPECTS -C -C Due to rounding errors the computed values of LOW and HIGH can be -C proven to satisfy -C -C LOW - p(n) * sqrt(e) * norm(A) <= beta(A) -C and -C beta(A) <= HIGH + p(n) * sqrt(e) * norm(A), -C -C where p(n) is a modest polynomial of degree 3, e is the machine -C precision and norm(A) is the Frobenius norm of A, see [1]. -C The recommended value for TOL is 9 which gives an estimate of -C beta(A) correct to within an order of magnitude. -C AB13ED requires approximately 38*N**3 flops for TOL = 9. -C -C CONTRIBUTOR -C -C R. Byers, the routines BISEC and BISEC0 (January, 1995). -C -C REVISIONS -C -C Release 4.0: V. Sima, Katholieke Univ. Leuven, Belgium, Dec. 1999. -C V. Sima, Research Institute for Informatics, Bucharest, Jan. 2003. -C -C KEYWORDS -C -C Distances, eigenvalue, eigenvalue perturbation, norms, stability -C radius. -C -C ****************************************************************** -C -C .. Parameters .. - DOUBLE PRECISION ZERO, ONE - PARAMETER ( ZERO = 0.0D0, ONE = 1.0D0 ) -C .. Scalar Arguments .. - DOUBLE PRECISION HIGH, LOW, TOL - INTEGER INFO, LDA, LDWORK, N -C .. Array Arguments .. - DOUBLE PRECISION A(LDA,*), DWORK(*) -C .. Local Scalars .. - INTEGER I, IA2, IAA, IGF, IHI, ILO, IWI, IWK, IWR, - $ JWORK, MINWRK, N2 - DOUBLE PRECISION ANRM, SEPS, SFMN, SIGMA, TAU, TEMP, TOL1, TOL2 - LOGICAL RNEG, SUFWRK -C .. Local Arrays .. - DOUBLE PRECISION DUMMY(1), DUMMY2(1,1) -C .. External Functions .. - DOUBLE PRECISION DLAMCH, DLANGE - EXTERNAL DLAMCH, DLANGE -C .. External Subroutines .. - EXTERNAL DCOPY, DGEBAL, DGEMM, DHSEQR, DLACPY, DSYMM, - $ DSYMV, MA02ED, MB04ZD, XERBLA -C .. Intrinsic Functions .. - INTRINSIC ABS, DBLE, MAX, SQRT -C .. Executable Statements .. -C -C Test the input scalar arguments. -C - INFO = 0 - MINWRK = 3*N*( N + 1 ) -C - IF( N.LT.0 ) THEN - INFO = -1 - ELSE IF( LDA.LT.MAX( 1, N ) ) THEN - INFO = -3 - ELSE IF( LDWORK.LT.MAX( 1, MINWRK ) ) THEN - INFO = -8 - END IF -C - IF ( INFO.NE.0 ) THEN -C -C Error return. -C - CALL XERBLA( 'AB13ED', -INFO ) - RETURN - END IF -C -C Quick return if possible. -C - LOW = ZERO - IF ( N.EQ.0 ) THEN - HIGH = ZERO - DWORK(1) = ONE - RETURN - END IF -C -C Indices for splitting the work array. -C (Note: Comments in the code beginning "Workspace:" describe the -C minimal amount of real workspace needed at that point in the -C code, as well as the preferred amount for good performance.) -C - N2 = N*N - IGF = 1 - IA2 = IGF + N2 + N - IAA = IA2 + N2 - IWK = IAA + N2 - IWR = IAA - IWI = IWR + N -C - SUFWRK = LDWORK-IWK.GE.N2 -C -C Computation of the tolerances and the threshold for termination of -C the bisection method. SEPS is the square root of the machine -C precision. -C - SFMN = DLAMCH( 'Safe minimum' ) - SEPS = SQRT( DLAMCH( 'Epsilon' ) ) - TAU = ONE + MAX( TOL, SEPS ) - ANRM = DLANGE( 'Frobenius', N, N, A, LDA, DWORK ) - TOL1 = SEPS * ANRM - TOL2 = TOL1 * DBLE( 2*N ) -C -C Initialization of the bisection method. -C - HIGH = ANRM -C -C WHILE ( HIGH > TAU*MAX( TOL1, LOW ) ) DO - 10 IF ( HIGH.GT.( TAU*MAX( TOL1, LOW ) ) ) THEN - SIGMA = SQRT( HIGH ) * SQRT( MAX( TOL1, LOW ) ) -C -C Set up H(sigma). -C Workspace: N*(N+1)+2*N*N. -C - CALL DLACPY( 'Full', N, N, A, LDA, DWORK(IAA), N ) - DWORK(IGF) = SIGMA - DWORK(IGF+N) = -SIGMA - DUMMY(1) = ZERO - CALL DCOPY( N-1, DUMMY, 0, DWORK(IGF+1), 1 ) -C - DO 20 I = IGF, IA2 - N - 2, N + 1 - CALL DCOPY( N+1, DWORK(I), 1, DWORK(I+N+1), 1 ) - 20 CONTINUE -C -C Computation of the eigenvalues by the square reduced algorithm. -C Workspace: N*(N+1)+2*N*N+2*N. -C - CALL MB04ZD( 'No vectors', N, DWORK(IAA), N, DWORK(IGF), N, - $ DUMMY2, 1, DWORK(IWK), INFO ) -C -C Form the matrix A*A + F*G. -C Workspace: need N*(N+1)+2*N*N+N; -C prefer N*(N+1)+3*N*N. -C - JWORK = IA2 - IF ( SUFWRK ) - $ JWORK = IWK -C - CALL DLACPY( 'Lower', N, N, DWORK(IGF), N, DWORK(JWORK), N ) - CALL MA02ED( 'Lower', N, DWORK(JWORK), N ) -C - IF ( SUFWRK ) THEN -C -C Use BLAS 3 calculation. -C - CALL DSYMM( 'Left', 'Upper', N, N, ONE, DWORK(IGF+N), N, - $ DWORK(JWORK), N, ZERO, DWORK(IA2), N ) - ELSE -C -C Use BLAS 2 calculation. -C - DO 30 I = 1, N - CALL DSYMV( 'Upper', N, ONE, DWORK(IGF+N), N, - $ DWORK(IA2+N*(I-1)), 1, ZERO, DWORK(IWK), 1 ) - CALL DCOPY( N, DWORK(IWK), 1, DWORK(IA2+N*(I-1)), 1 ) - 30 CONTINUE -C - END IF -C - CALL DGEMM( 'NoTranspose', 'NoTranspose', N, N, N, ONE, - $ DWORK(IAA), N, DWORK(IAA), N, ONE, DWORK(IA2), N ) -C -C Find the eigenvalues of A*A + F*G. -C Workspace: N*(N+1)+N*N+3*N. -C - JWORK = IWI + N - CALL DGEBAL( 'Scale', N, DWORK(IA2), N, ILO, IHI, DWORK(JWORK), - $ I ) - CALL DHSEQR( 'Eigenvalues', 'NoSchurVectors', N, ILO, IHI, - $ DWORK(IA2), N, DWORK(IWR), DWORK(IWI), DUMMY2, 1, - $ DWORK(JWORK), N, INFO ) -C - IF ( INFO.NE.0 ) THEN - INFO = 1 - RETURN - END IF -C -C (DWORK(IWR+i), DWORK(IWI+i)), i = 0,...,N-1, contain the -C squares of the eigenvalues of H(sigma). -C - I = 0 - RNEG = .FALSE. -C WHILE ( ( DWORK(IWR+i),DWORK(IWI+i) ) not real positive -C .AND. I < N ) DO - 40 IF ( .NOT.RNEG .AND. I.LT.N ) THEN - TEMP = ABS( DWORK(IWI+I) ) - IF ( TOL1.GT.SFMN ) TEMP = TEMP / TOL1 - RNEG = ( ( DWORK(IWR+I).LT.ZERO ) .AND. ( TEMP.LE.TOL2 ) ) - I = I + 1 - GO TO 40 -C END WHILE 40 - END IF - - IF ( RNEG ) THEN - HIGH = SIGMA - ELSE - LOW = SIGMA - END IF - GO TO 10 -C END WHILE 10 - END IF -C -C Set optimal workspace dimension. -C - DWORK(1) = DBLE( MAX( 4*N2 + N, MINWRK ) ) -C -C *** Last line of AB13ED *** - END diff --git a/mex/sources/libslicot/AB13FD.f b/mex/sources/libslicot/AB13FD.f deleted file mode 100644 index 44628b470..000000000 --- a/mex/sources/libslicot/AB13FD.f +++ /dev/null @@ -1,403 +0,0 @@ - SUBROUTINE AB13FD( N, A, LDA, BETA, OMEGA, TOL, DWORK, LDWORK, - $ CWORK, LCWORK, INFO ) -C -C SLICOT RELEASE 5.0. -C -C Copyright (c) 2002-2009 NICONET e.V. -C -C This program is free software: you can redistribute it and/or -C modify it under the terms of the GNU General Public License as -C published by the Free Software Foundation, either version 2 of -C the License, or (at your option) any later version. -C -C This program is distributed in the hope that it will be useful, -C but WITHOUT ANY WARRANTY; without even the implied warranty of -C MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the -C GNU General Public License for more details. -C -C You should have received a copy of the GNU General Public License -C along with this program. If not, see -C . -C -C PURPOSE -C -C To compute beta(A), the 2-norm distance from a real matrix A to -C the nearest complex matrix with an eigenvalue on the imaginary -C axis. If A is stable in the sense that all eigenvalues of A lie -C in the open left half complex plane, then beta(A) is the complex -C stability radius, i.e., the distance to the nearest unstable -C complex matrix. The value of beta(A) is the minimum of the -C smallest singular value of (A - jwI), taken over all real w. -C The value of w corresponding to the minimum is also computed. -C -C ARGUMENTS -C -C Input/Output Parameters -C -C N (input) INTEGER -C The order of the matrix A. N >= 0. -C -C A (input) DOUBLE PRECISION array, dimension (LDA,N) -C The leading N-by-N part of this array must contain the -C matrix A. -C -C LDA INTEGER -C The leading dimension of array A. LDA >= MAX(1,N). -C -C BETA (output) DOUBLE PRECISION -C The computed value of beta(A), which actually is an upper -C bound. -C -C OMEGA (output) DOUBLE PRECISION -C The value of w such that the smallest singular value of -C (A - jwI) equals beta(A). -C -C Tolerances -C -C TOL DOUBLE PRECISION -C Specifies the accuracy with which beta(A) is to be -C calculated. (See the Numerical Aspects section below.) -C If the user sets TOL to be less than EPS, where EPS is the -C machine precision (see LAPACK Library Routine DLAMCH), -C then the tolerance is taken to be EPS. -C -C Workspace -C -C DWORK DOUBLE PRECISION array, dimension (LDWORK) -C On exit, if INFO = 0, DWORK(1) returns the optimal value -C of LDWORK. -C If DWORK(1) is not needed, the first 2*N*N entries of -C DWORK may overlay CWORK. -C -C LDWORK INTEGER -C The length of the array DWORK. -C LDWORK >= MAX( 1, 3*N*(N+2) ). -C For optimum performance LDWORK should be larger. -C -C CWORK COMPLEX*16 array, dimension (LCWORK) -C On exit, if INFO = 0, CWORK(1) returns the optimal value -C of LCWORK. -C If CWORK(1) is not needed, the first N*N entries of -C CWORK may overlay DWORK. -C -C LCWORK INTEGER -C The length of the array CWORK. -C LCWORK >= MAX( 1, N*(N+3) ). -C For optimum performance LCWORK should be larger. -C -C Error Indicator -C -C INFO INTEGER -C = 0: successful exit; -C < 0: if INFO = -i, the i-th argument had an illegal -C value; -C = 1: the routine fails to compute beta(A) within the -C specified tolerance. Nevertheless, the returned -C value is an upper bound on beta(A); -C = 2: either the QR or SVD algorithm (LAPACK Library -C routines DHSEQR, DGESVD or ZGESVD) fails to -C converge; this error is very rare. -C -C METHOD -C -C AB13FD combines the methods of [1] and [2] into a provably -C reliable, quadratically convergent algorithm. It uses the simple -C bisection strategy of [1] to find an interval which contains -C beta(A), and then switches to the modified bisection strategy of -C [2] which converges quadratically to a minimizer. Note that the -C efficiency of the strategy degrades if there are several local -C minima that are near or equal the global minimum. -C -C REFERENCES -C -C [1] Byers, R. -C A bisection method for measuring the distance of a stable -C matrix to the unstable matrices. -C SIAM J. Sci. Stat. Comput., Vol. 9, No. 5, pp. 875-880, 1988. -C -C [2] Boyd, S. and Balakrishnan, K. -C A regularity result for the singular values of a transfer -C matrix and a quadratically convergent algorithm for computing -C its L-infinity norm. -C Systems and Control Letters, Vol. 15, pp. 1-7, 1990. -C -C NUMERICAL ASPECTS -C -C In the presence of rounding errors, the computed function value -C BETA satisfies -C -C beta(A) <= BETA + epsilon, -C -C BETA/(1+TOL) - delta <= MAX(beta(A), SQRT(2*N*EPS)*norm(A)), -C -C where norm(A) is the Frobenius norm of A, -C -C epsilon = p(N) * EPS * norm(A), -C and -C delta = p(N) * SQRT(EPS) * norm(A), -C -C and p(N) is a low degree polynomial. It is recommended to choose -C TOL greater than SQRT(EPS). Although rounding errors can cause -C AB13FD to fail for smaller values of TOL, nevertheless, it usually -C succeeds. Regardless of success or failure, the first inequality -C holds. -C -C CONTRIBUTORS -C -C R. Byers, the routines QSEC and QSEC0 (January, 1995). -C -C REVISIONS -C -C Release 4.0: V. Sima, Katholieke Univ. Leuven, Belgium, Dec. 1999. -C V. Sima, Research Institute for Informatics, Bucharest, Apr. 2002, -C Jan. 2003. -C -C KEYWORDS -C -C complex stability radius, distances, eigenvalue, eigenvalue -C perturbation, norms. -C -C ****************************************************************** -C -C .. Parameters .. - INTEGER MAXIT - PARAMETER ( MAXIT = 50 ) - DOUBLE PRECISION ZERO, ONE, TWO - PARAMETER ( ZERO = 0.0D0, ONE = 1.0D0, TWO = 2.0D0 ) - COMPLEX*16 CONE - PARAMETER ( CONE = ( 1.0D0, 0.0D0 ) ) -C .. Scalar Arguments .. - INTEGER INFO, LCWORK, LDA, LDWORK, N - DOUBLE PRECISION BETA, OMEGA, TOL -C .. Array Arguments .. - DOUBLE PRECISION A(LDA,*), DWORK(*) - COMPLEX*16 CWORK(*) -C .. Local Scalars .. - INTEGER I, IA2, IAA, IGF, IHI, ILO, ITNUM, IWI, IWK, - $ IWR, JWORK, KOM, LBEST, MINWRK, N2 - DOUBLE PRECISION EPS, LOW, OM, OM1, OM2, SFMN, SIGMA, SV, TAU, - $ TEMP, TOL1 - LOGICAL SUFWRK -C .. Local Arrays .. - DOUBLE PRECISION DUMMY(1), DUMMY2(1,1) -C .. External Functions .. - DOUBLE PRECISION DLAMCH, DLANGE, MB03NY - EXTERNAL DLAMCH, DLANGE, MB03NY -C .. External Subroutines .. - EXTERNAL DCOPY, DGEBAL, DGEMM, DHSEQR, DLACPY, DSYMM, - $ DSYMV, MA02ED, MB04ZD, XERBLA -C .. Intrinsic Functions .. - INTRINSIC ABS, DBLE, INT, MAX, SQRT -C .. Executable Statements .. -C -C Test the input scalar arguments. -C - INFO = 0 - MINWRK = 3*N*( N + 2 ) -C - IF( N.LT.0 ) THEN - INFO = -1 - ELSE IF( LDA.LT.MAX( 1, N ) ) THEN - INFO = -3 - ELSE IF( LDWORK.LT.MAX( 1, MINWRK ) ) THEN - INFO = -8 - ELSE IF( LCWORK.LT.MAX( 1, N*( N + 3 ) ) ) THEN - INFO = -10 - END IF -C - IF ( INFO.NE.0 ) THEN -C -C Error return. -C - CALL XERBLA( 'AB13FD', -INFO ) - RETURN - END IF -C -C Quick return if possible. -C - OMEGA = ZERO - IF ( N.EQ.0 ) THEN - BETA = ZERO - DWORK(1) = ONE - CWORK(1) = CONE - RETURN - END IF -C -C Indices for splitting the work array. -C (Note: Comments in the code beginning "Workspace:" describe the -C minimal amount of workspace needed at that point in the code, -C as well as the preferred amount for good performance.) -C - N2 = N*N - IGF = 1 - IA2 = IGF + N2 + N - IAA = IA2 + N2 - IWK = IAA + N2 - IWR = IAA - IWI = IWR + N -C - SUFWRK = LDWORK-IWK.GE.N2 -C -C Computation of the tolerances. EPS is the machine precision. -C - SFMN = DLAMCH( 'Safe minimum' ) - EPS = DLAMCH( 'Epsilon' ) - TOL1 = SQRT( EPS * DBLE( 2*N ) ) * - $ DLANGE( 'Frobenius', N, N, A, LDA, DWORK ) - TAU = ONE + MAX( TOL, EPS ) -C -C Initialization, upper bound at known critical point. -C Workspace: need N*(N+1)+5*N; prefer larger. -C - KOM = 2 - LOW = ZERO - CALL DLACPY( 'All', N, N, A, LDA, DWORK(IGF), N ) - BETA = MB03NY( N, OMEGA, DWORK(IGF), N, DWORK(IGF+N2), - $ DWORK(IA2), LDWORK-IA2, CWORK, LCWORK, INFO ) - IF ( INFO.NE.0 ) - $ RETURN - LBEST = MAX( MINWRK, INT( DWORK(IA2) ) - IA2 + 1, 4*N2 + N ) -C - ITNUM = 1 -C WHILE ( ITNUM <= MAXIT and BETA > TAU*MAX( TOL1, LOW ) ) DO - 10 IF ( ( ITNUM.LE.MAXIT ) .AND. - $ ( BETA.GT.TAU*MAX( TOL1, LOW ) ) ) THEN - IF ( KOM.EQ.2 ) THEN - SIGMA = BETA/TAU - ELSE - SIGMA = SQRT( BETA ) * SQRT( MAX( TOL1, LOW ) ) - END IF -C -C Set up H(sigma). -C Workspace: N*(N+1)+2*N*N. -C - CALL DLACPY( 'Full', N, N, A, LDA, DWORK(IAA), N ) - DWORK(IGF) = SIGMA - DWORK(IGF+N) = -SIGMA - DUMMY(1) = ZERO - CALL DCOPY( N-1, DUMMY, 0, DWORK(IGF+1), 1 ) -C - DO 20 I = IGF, IA2 - N - 2, N + 1 - CALL DCOPY( N+1, DWORK(I), 1, DWORK(I+N+1), 1 ) - 20 CONTINUE -C -C Computation of the eigenvalues by the square reduced algorithm. -C Workspace: N*(N+1)+2*N*N+2*N. -C - CALL MB04ZD( 'No vectors', N, DWORK(IAA), N, DWORK(IGF), N, - $ DUMMY2, 1, DWORK(IWK), INFO ) -C -C Form the matrix A*A + F*G. -C Workspace: need N*(N+1)+2*N*N+N; -C prefer N*(N+1)+3*N*N. -C - JWORK = IA2 - IF ( SUFWRK ) - $ JWORK = IWK -C - CALL DLACPY( 'Lower', N, N, DWORK(IGF), N, DWORK(JWORK), N ) - CALL MA02ED( 'Lower', N, DWORK(JWORK), N ) -C - IF ( SUFWRK ) THEN -C -C Use BLAS 3 calculation. -C - CALL DSYMM( 'Left', 'Upper', N, N, ONE, DWORK(IGF+N), N, - $ DWORK(JWORK), N, ZERO, DWORK(IA2), N ) - ELSE -C -C Use BLAS 2 calculation. -C - DO 30 I = 1, N - CALL DSYMV( 'Upper', N, ONE, DWORK(IGF+N), N, - $ DWORK(IA2+N*(I-1)), 1, ZERO, DWORK(IWK), 1 ) - CALL DCOPY( N, DWORK(IWK), 1, DWORK(IA2+N*(I-1)), 1 ) - 30 CONTINUE -C - END IF -C - CALL DGEMM( 'NoTranspose', 'NoTranspose', N, N, N, ONE, - $ DWORK(IAA), N, DWORK(IAA), N, ONE, DWORK(IA2), N ) -C -C Find the eigenvalues of A*A + F*G. -C Workspace: N*(N+1)+N*N+3*N. -C - JWORK = IWI + N - CALL DGEBAL( 'Scale', N, DWORK(IA2), N, ILO, IHI, DWORK(JWORK), - $ I ) - CALL DHSEQR( 'Eigenvalues', 'NoSchurVectors', N, ILO, IHI, - $ DWORK(IA2), N, DWORK(IWR), DWORK(IWI), DUMMY2, 1, - $ DWORK(JWORK), N, INFO ) -C - IF ( INFO.NE.0 ) THEN - INFO = 2 - RETURN - END IF -C -C Count negative real axis squared eigenvalues. If there are two, -C then the valley is isolated, and next approximate minimizer is -C mean of the square roots. -C - KOM = 0 - DO 40 I = 0, N - 1 - TEMP = ABS( DWORK(IWI+I) ) - IF ( TOL1.GT.SFMN ) TEMP = TEMP / TOL1 - IF ( ( DWORK(IWR+I).LT.ZERO ) .AND. ( TEMP.LE.TOL1 ) ) THEN - KOM = KOM + 1 - OM = SQRT( -DWORK(IWR+I) ) - IF ( KOM.EQ.1 ) OM1 = OM - IF ( KOM.EQ.2 ) OM2 = OM - END IF - 40 CONTINUE -C - IF ( KOM.EQ.0 ) THEN - LOW = SIGMA - ELSE -C -C In exact arithmetic KOM = 1 is impossible, but if tau is -C close enough to one, MB04ZD may miss the initial near zero -C eigenvalue. -C Workspace, real: need 3*N*(N+2); prefer larger; -C complex: need N*(N+3); prefer larger. -C - IF ( KOM.EQ.2 ) THEN - OM = OM1 + ( OM2 - OM1 ) / TWO - ELSE IF ( KOM.EQ.1 .AND. ITNUM.EQ.1 ) THEN - OM = OM1 / TWO - KOM = 2 - END IF -C - CALL DLACPY( 'All', N, N, A, LDA, DWORK(IGF), N ) - SV = MB03NY( N, OM, DWORK(IGF), N, DWORK(IGF+N2), - $ DWORK(IA2), LDWORK-IA2, CWORK, LCWORK, INFO ) - IF ( INFO.NE.0 ) - $ RETURN - IF ( BETA.GT.SV ) THEN - BETA = SV - OMEGA = OM - ELSE - INFO = 1 - RETURN - END IF - END IF - ITNUM = ITNUM + 1 - GO TO 10 -C END WHILE 10 - END IF -C - IF ( BETA .GT. TAU*MAX( TOL1, LOW ) ) THEN -C -C Failed to meet bounds within MAXIT iterations. -C - INFO = 1 - RETURN - END IF -C -C Set optimal real workspace dimension (complex workspace is already -C set by MB03NY). -C - DWORK(1) = LBEST -C - RETURN -C *** Last line of AB13FD *** - END diff --git a/mex/sources/libslicot/AB13MD.f b/mex/sources/libslicot/AB13MD.f deleted file mode 100644 index e0e0d4724..000000000 --- a/mex/sources/libslicot/AB13MD.f +++ /dev/null @@ -1,1782 +0,0 @@ - SUBROUTINE AB13MD( FACT, N, Z, LDZ, M, NBLOCK, ITYPE, X, BOUND, D, - $ G, IWORK, DWORK, LDWORK, ZWORK, LZWORK, INFO ) -C -C SLICOT RELEASE 5.0. -C -C Copyright (c) 2002-2009 NICONET e.V. -C -C This program is free software: you can redistribute it and/or -C modify it under the terms of the GNU General Public License as -C published by the Free Software Foundation, either version 2 of -C the License, or (at your option) any later version. -C -C This program is distributed in the hope that it will be useful, -C but WITHOUT ANY WARRANTY; without even the implied warranty of -C MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the -C GNU General Public License for more details. -C -C You should have received a copy of the GNU General Public License -C along with this program. If not, see -C . -C -C PURPOSE -C -C To compute an upper bound on the structured singular value for a -C given square complex matrix and a given block structure of the -C uncertainty. -C -C ARGUMENTS -C -C Mode Parameters -C -C FACT CHARACTER*1 -C Specifies whether or not an information from the -C previous call is supplied in the vector X. -C = 'F': On entry, X contains information from the -C previous call. -C = 'N': On entry, X does not contain an information from -C the previous call. -C -C Input/Output Parameters -C -C N (input) INTEGER -C The order of the matrix Z. N >= 0. -C -C Z (input) COMPLEX*16 array, dimension (LDZ,N) -C The leading N-by-N part of this array must contain the -C complex matrix Z for which the upper bound on the -C structured singular value is to be computed. -C -C LDZ INTEGER -C The leading dimension of the array Z. LDZ >= max(1,N). -C -C M (input) INTEGER -C The number of diagonal blocks in the block structure of -C the uncertainty. M >= 1. -C -C NBLOCK (input) INTEGER array, dimension (M) -C The vector of length M containing the block structure -C of the uncertainty. NBLOCK(I), I = 1:M, is the size of -C each block. -C -C ITYPE (input) INTEGER array, dimension (M) -C The vector of length M indicating the type of each block. -C For I = 1:M, -C ITYPE(I) = 1 indicates that the corresponding block is a -C real block, and -C ITYPE(I) = 2 indicates that the corresponding block is a -C complex block. -C NBLOCK(I) must be equal to 1 if ITYPE(I) is equal to 1. -C -C X (input/output) DOUBLE PRECISION array, dimension -C ( M + MR - 1 ), where MR is the number of the real blocks. -C On entry, if FACT = 'F' and NBLOCK(1) < N, this array -C must contain information from the previous call to AB13MD. -C If NBLOCK(1) = N, this array is not used. -C On exit, if NBLOCK(1) < N, this array contains information -C that can be used in the next call to AB13MD for a matrix -C close to Z. -C -C BOUND (output) DOUBLE PRECISION -C The upper bound on the structured singular value. -C -C D, G (output) DOUBLE PRECISION arrays, dimension (N) -C The vectors of length N containing the diagonal entries -C of the diagonal N-by-N matrices D and G, respectively, -C such that the matrix -C Z'*D^2*Z + sqrt(-1)*(G*Z-Z'*G) - BOUND^2*D^2 -C is negative semidefinite. -C -C Workspace -C -C IWORK INTEGER array, dimension MAX(4*M-2,N) -C -C DWORK DOUBLE PRECISION array, dimension (LDWORK) -C On exit, if INFO = 0, DWORK(1) contains the optimal value -C of LDWORK. -C -C LDWORK INTEGER -C The dimension of the array DWORK. -C LDWORK >= 2*N*N*M - N*N + 9*M*M + N*M + 11*N + 33*M - 11. -C For best performance -C LDWORK >= 2*N*N*M - N*N + 9*M*M + N*M + 6*N + 33*M - 11 + -C MAX( 5*N,2*N*NB ) -C where NB is the optimal blocksize returned by ILAENV. -C -C ZWORK COMPLEX*16 array, dimension (LZWORK) -C On exit, if INFO = 0, ZWORK(1) contains the optimal value -C of LZWORK. -C -C LZWORK INTEGER -C The dimension of the array ZWORK. -C LZWORK >= 6*N*N*M + 12*N*N + 6*M + 6*N - 3. -C For best performance -C LZWORK >= 6*N*N*M + 12*N*N + 6*M + 3*N - 3 + -C MAX( 3*N,N*NB ) -C where NB is the optimal blocksize returned by ILAENV. -C -C Error Indicator -C -C INFO INTEGER -C = 0: successful exit; -C < 0: if INFO = -i, the i-th argument had an illegal -C value; -C = 1: the block sizes must be positive integers; -C = 2: the sum of block sizes must be equal to N; -C = 3: the size of a real block must be equal to 1; -C = 4: the block type must be either 1 or 2; -C = 5: errors in solving linear equations or in matrix -C inversion; -C = 6: errors in computing eigenvalues or singular values. -C -C METHOD -C -C The routine computes the upper bound proposed in [1]. -C -C REFERENCES -C -C [1] Fan, M.K.H., Tits, A.L., and Doyle, J.C. -C Robustness in the presence of mixed parametric uncertainty -C and unmodeled dynamics. -C IEEE Trans. Automatic Control, vol. AC-36, 1991, pp. 25-38. -C -C NUMERICAL ASPECTS -C -C The accuracy and speed of computation depend on the value of -C the internal threshold TOL. -C -C CONTRIBUTORS -C -C P.Hr. Petkov, F. Delebecque, D.W. Gu, M.M. Konstantinov and -C S. Steer with the assistance of V. Sima, September 2000. -C -C REVISIONS -C -C V. Sima, Katholieke Universiteit Leuven, February 2001. -C -C KEYWORDS -C -C H-infinity optimal control, Robust control, Structured singular -C value. -C -C ****************************************************************** -C -C .. Parameters .. - COMPLEX*16 CZERO, CONE, CIMAG - PARAMETER ( CZERO = ( 0.0D+0, 0.0D+0 ), - $ CONE = ( 1.0D+0, 0.0D+0 ), - $ CIMAG = ( 0.0D+0, 1.0D+0 ) ) - DOUBLE PRECISION ZERO, ONE, TWO, FOUR, FIVE, EIGHT, TEN, FORTY, - $ FIFTY - PARAMETER ( ZERO = 0.0D+0, ONE = 1.0D+0, TWO = 2.0D+0, - $ FOUR = 4.0D+0, FIVE = 5.0D+0, EIGHT = 8.0D+0, - $ TEN = 1.0D+1, FORTY = 4.0D+1, FIFTY = 5.0D+1 - $ ) - DOUBLE PRECISION ALPHA, BETA, THETA - PARAMETER ( ALPHA = 100.0D+0, BETA = 1.0D-2, - $ THETA = 1.0D-2 ) - DOUBLE PRECISION C1, C2, C3, C4, C5, C6, C7, C8, C9 - PARAMETER ( C1 = 1.0D-3, C2 = 1.0D-2, C3 = 0.25D+0, - $ C4 = 0.9D+0, C5 = 1.5D+0, C6 = 1.0D+1, - $ C7 = 1.0D+2, C8 = 1.0D+3, C9 = 1.0D+4 ) -C .. -C .. Scalar Arguments .. - CHARACTER FACT - INTEGER INFO, LDWORK, LDZ, LZWORK, M, N - DOUBLE PRECISION BOUND -C .. -C .. Array Arguments .. - INTEGER ITYPE( * ), IWORK( * ), NBLOCK( * ) - COMPLEX*16 Z( LDZ, * ), ZWORK( * ) - DOUBLE PRECISION D( * ), DWORK( * ), G( * ), X( * ) -C .. -C .. Local Scalars .. - INTEGER I, INFO2, ISUM, ITER, IW2, IW3, IW4, IW5, IW6, - $ IW7, IW8, IW9, IW10, IW11, IW12, IW13, IW14, - $ IW15, IW16, IW17, IW18, IW19, IW20, IW21, IW22, - $ IW23, IW24, IW25, IW26, IW27, IW28, IW29, IW30, - $ IW31, IW32, IW33, IWRK, IZ2, IZ3, IZ4, IZ5, - $ IZ6, IZ7, IZ8, IZ9, IZ10, IZ11, IZ12, IZ13, - $ IZ14, IZ15, IZ16, IZ17, IZ18, IZ19, IZ20, IZ21, - $ IZ22, IZ23, IZ24, IZWRK, J, K, L, LWA, LWAMAX, - $ LZA, LZAMAX, MINWRK, MINZRK, MR, MT, NSUM, SDIM - COMPLEX*16 DETF, TEMPIJ, TEMPJI - DOUBLE PRECISION C, COLSUM, DELTA, DLAMBD, E, EMAX, EMIN, EPS, - $ HN, HNORM, HNORM1, PHI, PP, PROD, RAT, RCOND, - $ REGPAR, ROWSUM, SCALE, SNORM, STSIZE, SVLAM, - $ T1, T2, T3, TAU, TEMP, TOL, TOL2, TOL3, TOL4, - $ TOL5, YNORM1, YNORM2, ZNORM, ZNORM2 - LOGICAL GTEST, POS, XFACT -C .. -C .. Local Arrays .. - LOGICAL BWORK( 1 ) -C .. -C .. External Functions - DOUBLE PRECISION DDOT, DLAMCH, DLANGE, ZLANGE - LOGICAL LSAME, SELECT - EXTERNAL DDOT, DLAMCH, DLANGE, LSAME, SELECT, ZLANGE -C .. -C .. External Subroutines .. - EXTERNAL DCOPY, DGEMV, DLACPY, DLASET, DSCAL, DSYCON, - $ DSYSV, DSYTRF, DSYTRS, XERBLA, ZCOPY, ZGEES, - $ ZGEMM, ZGEMV, ZGESVD, ZGETRF, ZGETRI, ZLACPY, - $ ZLASCL -C .. -C .. Intrinsic Functions .. - INTRINSIC ABS, DCMPLX, DCONJG, DFLOAT, DREAL, INT, LOG, - $ MAX, SQRT -C .. -C .. Executable Statements .. -C -C Compute workspace. -C - MINWRK = 2*N*N*M - N*N + 9*M*M + N*M + 11*N + 33*M - 11 - MINZRK = 6*N*N*M + 12*N*N + 6*M + 6*N - 3 -C -C Decode and Test input parameters. -C - INFO = 0 - XFACT = LSAME( FACT, 'F' ) - IF( .NOT.XFACT .AND. .NOT.LSAME( FACT, 'N' ) ) THEN - INFO = -1 - ELSE IF( N.LT.0 ) THEN - INFO = -2 - ELSE IF( LDZ.LT.MAX( 1, N ) ) THEN - INFO = -4 - ELSE IF( M.LT.1 ) THEN - INFO = -5 - ELSE IF( LDWORK.LT.MINWRK ) THEN - INFO = -14 - ELSE IF( LZWORK.LT.MINZRK ) THEN - INFO = -16 - END IF - IF( INFO.NE.0 ) THEN - CALL XERBLA( 'AB13MD', -INFO ) - RETURN - END IF -C - NSUM = 0 - ISUM = 0 - MR = 0 - DO 10 I = 1, M - IF( NBLOCK( I ).LT.1 ) THEN - INFO = 1 - RETURN - END IF - IF( ITYPE( I ).EQ.1 .AND. NBLOCK( I ).GT.1 ) THEN - INFO = 3 - RETURN - END IF - NSUM = NSUM + NBLOCK( I ) - IF( ITYPE( I ).EQ.1 ) MR = MR + 1 - IF( ITYPE( I ).EQ.1 .OR. ITYPE( I ).EQ.2 ) ISUM = ISUM + 1 - 10 CONTINUE - IF( NSUM.NE.N ) THEN - INFO = 2 - RETURN - END IF - IF( ISUM.NE.M ) THEN - INFO = 4 - RETURN - END IF - MT = M + MR - 1 -C - LWAMAX = 0 - LZAMAX = 0 -C -C Set D = In, G = 0. -C - CALL DLASET( 'Full', N, 1, ONE, ONE, D, N ) - CALL DLASET( 'Full', N, 1, ZERO, ZERO, G, N ) -C -C Quick return if possible. -C - ZNORM = ZLANGE( 'F', N, N, Z, LDZ, DWORK ) - IF( ZNORM.EQ.ZERO ) THEN - BOUND = ZERO - DWORK( 1 ) = ONE - ZWORK( 1 ) = CONE - RETURN - END IF -C -C Copy Z into ZWORK. -C - CALL ZLACPY( 'Full', N, N, Z, LDZ, ZWORK, N ) -C -C Exact bound for the case NBLOCK( 1 ) = N. -C - IF( NBLOCK( 1 ).EQ.N ) THEN - IF( ITYPE( 1 ).EQ.1 ) THEN -C -C 1-by-1 real block. -C - BOUND = ZERO - DWORK( 1 ) = ONE - ZWORK( 1 ) = CONE - ELSE -C -C N-by-N complex block. -C - CALL ZGESVD( 'N', 'N', N, N, ZWORK, N, DWORK, ZWORK, 1, - $ ZWORK, 1, ZWORK( N*N+1 ), LZWORK, - $ DWORK( N+1 ), INFO2 ) - IF( INFO2.GT.0 ) THEN - INFO = 6 - RETURN - END IF - BOUND = DWORK( 1 ) - LZA = N*N + INT( ZWORK( N*N+1 ) ) - DWORK( 1 ) = 5*N - ZWORK( 1 ) = DCMPLX( LZA ) - END IF - RETURN - END IF -C -C Get machine precision. -C - EPS = DLAMCH( 'P' ) -C -C Set tolerances. -C - TOL = C7*SQRT( EPS ) - TOL2 = C9*EPS - TOL3 = C6*EPS - TOL4 = C1 - TOL5 = C1 - REGPAR = C8*EPS -C -C Real workspace usage. -C - IW2 = M*M - IW3 = IW2 + M - IW4 = IW3 + N - IW5 = IW4 + M - IW6 = IW5 + M - IW7 = IW6 + N - IW8 = IW7 + N - IW9 = IW8 + N*( M - 1 ) - IW10 = IW9 + N*N*MT - IW11 = IW10 + MT - IW12 = IW11 + MT*MT - IW13 = IW12 + N - IW14 = IW13 + MT + 1 - IW15 = IW14 + MT + 1 - IW16 = IW15 + MT + 1 - IW17 = IW16 + MT + 1 - IW18 = IW17 + MT + 1 - IW19 = IW18 + MT - IW20 = IW19 + MT - IW21 = IW20 + MT - IW22 = IW21 + N - IW23 = IW22 + M - 1 - IW24 = IW23 + MR - IW25 = IW24 + N - IW26 = IW25 + 2*MT - IW27 = IW26 + MT - IW28 = IW27 + MT - IW29 = IW28 + M - 1 - IW30 = IW29 + MR - IW31 = IW30 + N + 2*MT - IW32 = IW31 + MT*MT - IW33 = IW32 + MT - IWRK = IW33 + MT + 1 -C -C Double complex workspace usage. -C - IZ2 = N*N - IZ3 = IZ2 + N*N - IZ4 = IZ3 + N*N - IZ5 = IZ4 + N*N - IZ6 = IZ5 + N*N - IZ7 = IZ6 + N*N*MT - IZ8 = IZ7 + N*N - IZ9 = IZ8 + N*N - IZ10 = IZ9 + N*N - IZ11 = IZ10 + MT - IZ12 = IZ11 + N*N - IZ13 = IZ12 + N - IZ14 = IZ13 + N*N - IZ15 = IZ14 + N - IZ16 = IZ15 + N*N - IZ17 = IZ16 + N - IZ18 = IZ17 + N*N - IZ19 = IZ18 + N*N*MT - IZ20 = IZ19 + MT - IZ21 = IZ20 + N*N*MT - IZ22 = IZ21 + N*N - IZ23 = IZ22 + N*N - IZ24 = IZ23 + N*N - IZWRK = IZ24 + MT -C -C Compute the cumulative sums of blocks dimensions. -C - IWORK( 1 ) = 0 - DO 20 I = 2, M+1 - IWORK( I ) = IWORK( I - 1 ) + NBLOCK( I - 1 ) - 20 CONTINUE -C -C Find Osborne scaling if initial scaling is not given. -C - IF( .NOT.XFACT ) THEN - CALL DLASET( 'Full', M, M, ZERO, ZERO, DWORK, M ) - CALL DLASET( 'Full', M, 1, ONE, ONE, DWORK( IW2+1 ), M ) - ZNORM = ZLANGE( 'F', N, N, ZWORK, N, DWORK ) - DO 40 J = 1, M - DO 30 I = 1, M - IF( I.NE.J ) THEN - CALL ZLACPY( 'Full', IWORK( I+1 )-IWORK( I ), - $ IWORK( J+1 )-IWORK( J ), - $ Z( IWORK( I )+1, IWORK( J )+1 ), LDZ, - $ ZWORK( IZ2+1 ), N ) - CALL ZGESVD( 'N', 'N', IWORK( I+1 )-IWORK( I ), - $ IWORK( J+1 )-IWORK( J ), ZWORK( IZ2+1 ), - $ N, DWORK( IW3+1 ), ZWORK, 1, ZWORK, 1, - $ ZWORK( IZWRK+1 ), LZWORK-IZWRK, - $ DWORK( IWRK+1 ), INFO2 ) - IF( INFO2.GT.0 ) THEN - INFO = 6 - RETURN - END IF - LZA = INT( ZWORK( IZWRK+1 ) ) - LZAMAX = MAX( LZA, LZAMAX ) - ZNORM2 = DWORK( IW3+1 ) - DWORK( I+(J-1)*M ) = ZNORM2 + ZNORM*TOL2 - END IF - 30 CONTINUE - 40 CONTINUE - CALL DLASET( 'Full', M, 1, ZERO, ZERO, DWORK( IW4+1 ), M ) - 50 DO 60 I = 1, M - DWORK( IW5+I ) = DWORK( IW4+I ) - ONE - 60 CONTINUE - HNORM = DLANGE( 'F', M, 1, DWORK( IW5+1 ), M, DWORK ) - IF( HNORM.LE.TOL2 ) GO TO 120 - DO 110 K = 1, M - COLSUM = ZERO - DO 70 I = 1, M - COLSUM = COLSUM + DWORK( I+(K-1)*M ) - 70 CONTINUE - ROWSUM = ZERO - DO 80 J = 1, M - ROWSUM = ROWSUM + DWORK( K+(J-1)*M ) - 80 CONTINUE - RAT = SQRT( COLSUM / ROWSUM ) - DWORK( IW4+K ) = RAT - DO 90 I = 1, M - DWORK( I+(K-1)*M ) = DWORK( I+(K-1)*M ) / RAT - 90 CONTINUE - DO 100 J = 1, M - DWORK( K+(J-1)*M ) = DWORK( K+(J-1)*M )*RAT - 100 CONTINUE - DWORK( IW2+K ) = DWORK( IW2+K )*RAT - 110 CONTINUE - GO TO 50 - 120 SCALE = ONE / DWORK( IW2+1 ) - CALL DSCAL( M, SCALE, DWORK( IW2+1 ), 1 ) - ELSE - DWORK( IW2+1 ) = ONE - DO 130 I = 2, M - DWORK( IW2+I ) = SQRT( X( I-1 ) ) - 130 CONTINUE - END IF - DO 150 J = 1, M - DO 140 I = 1, M - IF( I.NE.J ) THEN - CALL ZLASCL( 'G', M, M, DWORK( IW2+J ), DWORK( IW2+I ), - $ IWORK( I+1 )-IWORK( I ), - $ IWORK( J+1 )-IWORK( J ), - $ ZWORK( IWORK( I )+1+IWORK( J )*N ), N, - $ INFO2 ) - END IF - 140 CONTINUE - 150 CONTINUE -C -C Scale Z by its 2-norm. -C - CALL ZLACPY( 'Full', N, N, ZWORK, N, ZWORK( IZ2+1 ), N ) - CALL ZGESVD( 'N', 'N', N, N, ZWORK( IZ2+1 ), N, DWORK( IW3+1 ), - $ ZWORK, 1, ZWORK, 1, ZWORK( IZWRK+1 ), LZWORK-IZWRK, - $ DWORK( IWRK+1 ), INFO2 ) - IF( INFO2.GT.0 ) THEN - INFO = 6 - RETURN - END IF - LZA = INT( ZWORK( IZWRK+1 ) ) - LZAMAX = MAX( LZA, LZAMAX ) - ZNORM = DWORK( IW3+1 ) - CALL ZLASCL( 'G', M, M, ZNORM, ONE, N, N, ZWORK, N, INFO2 ) -C -C Set BB. -C - CALL DLASET( 'Full', N*N, MT, ZERO, ZERO, DWORK( IW9+1 ), N*N ) -C -C Set P. -C - DO 160 I = 1, NBLOCK( 1 ) - DWORK( IW6+I ) = ONE - 160 CONTINUE - DO 170 I = NBLOCK( 1 )+1, N - DWORK( IW6+I ) = ZERO - 170 CONTINUE -C -C Compute P*Z. -C - DO 190 J = 1, N - DO 180 I = 1, N - ZWORK( IZ3+I+(J-1)*N ) = DCMPLX( DWORK( IW6+I ) )* - $ ZWORK( I+(J-1)*N ) - 180 CONTINUE - 190 CONTINUE -C -C Compute Z'*P*Z. -C - CALL ZGEMM( 'C', 'N', N, N, N, CONE, ZWORK, N, ZWORK( IZ3+1 ), N, - $ CZERO, ZWORK( IZ4+1 ), N ) -C -C Copy Z'*P*Z into A0. -C - CALL ZLACPY( 'Full', N, N, ZWORK( IZ4+1 ), N, ZWORK( IZ5+1 ), N ) -C -C Copy diag(P) into B0d. -C - CALL DCOPY( N, DWORK( IW6+1 ), 1, DWORK( IW7+1 ), 1 ) -C - DO 270 K = 2, M -C -C Set P. -C - DO 200 I = 1, IWORK( K ) - DWORK( IW6+I ) = ZERO - 200 CONTINUE - DO 210 I = IWORK( K )+1, IWORK( K )+NBLOCK( K ) - DWORK( IW6+I ) = ONE - 210 CONTINUE - IF( K.LT.M ) THEN - DO 220 I = IWORK( K+1 )+1, N - DWORK( IW6+I ) = ZERO - 220 CONTINUE - END IF -C -C Compute P*Z. -C - DO 240 J = 1, N - DO 230 I = 1, N - ZWORK( IZ3+I+(J-1)*N ) = DCMPLX( DWORK( IW6+I ) )* - $ ZWORK( I+(J-1)*N ) - 230 CONTINUE - 240 CONTINUE -C -C Compute t = Z'*P*Z. -C - CALL ZGEMM( 'C', 'N', N, N, N, CONE, ZWORK, N, ZWORK( IZ3+1 ), - $ N, CZERO, ZWORK( IZ4+1 ), N ) -C -C Copy t(:) into the (k-1)-th column of AA. -C - CALL ZCOPY( N*N, ZWORK( IZ4+1 ), 1, ZWORK( IZ6+1+(K-2)*N*N ), - $ 1 ) -C -C Copy diag(P) into the (k-1)-th column of BBd. -C - CALL DCOPY( N, DWORK( IW6+1 ), 1, DWORK( IW8+1+(K-2)*N ), 1 ) -C -C Copy P(:) into the (k-1)-th column of BB. -C - DO 260 I = 1, N - DWORK( IW9+I+(I-1)*N+(K-2)*N*N ) = DWORK( IW6+I ) - 260 CONTINUE - 270 CONTINUE -C - L = 0 -C - DO 350 K = 1, M - IF( ITYPE( K ).EQ.1 ) THEN - L = L + 1 -C -C Set P. -C - DO 280 I = 1, IWORK( K ) - DWORK( IW6+I ) = ZERO - 280 CONTINUE - DO 290 I = IWORK( K )+1, IWORK( K )+NBLOCK( K ) - DWORK( IW6+I ) = ONE - 290 CONTINUE - IF( K.LT.M ) THEN - DO 300 I = IWORK( K+1 )+1, N - DWORK( IW6+I ) = ZERO - 300 CONTINUE - END IF -C -C Compute P*Z. -C - DO 320 J = 1, N - DO 310 I = 1, N - ZWORK( IZ3+I+(J-1)*N ) = DCMPLX( DWORK( IW6+I ) )* - $ ZWORK( I+(J-1)*N ) - 310 CONTINUE - 320 CONTINUE -C -C Compute t = sqrt(-1)*( P*Z - Z'*P ). -C - DO 340 J = 1, N - DO 330 I = 1, J - TEMPIJ = ZWORK( IZ3+I+(J-1)*N ) - TEMPJI = ZWORK( IZ3+J+(I-1)*N ) - ZWORK( IZ4+I+(J-1)*N ) = CIMAG*( TEMPIJ - - $ DCONJG( TEMPJI ) ) - ZWORK( IZ4+J+(I-1)*N ) = CIMAG*( TEMPJI - - $ DCONJG( TEMPIJ ) ) - 330 CONTINUE - 340 CONTINUE -C -C Copy t(:) into the (m-1+l)-th column of AA. -C - CALL ZCOPY( N*N, ZWORK( IZ4+1 ), 1, - $ ZWORK( IZ6+1+(M-2+L)*N*N ), 1 ) - END IF - 350 CONTINUE -C -C Set initial X. -C - DO 360 I = 1, M - 1 - X( I ) = ONE - 360 CONTINUE - IF( MR.GT.0 ) THEN - IF( .NOT.XFACT ) THEN - DO 370 I = 1, MR - X( M-1+I ) = ZERO - 370 CONTINUE - ELSE - L = 0 - DO 380 K = 1, M - IF( ITYPE( K ).EQ.1 ) THEN - L = L + 1 - X( M-1+L ) = X( M-1+L ) / DWORK( IW2+K )**2 - END IF - 380 CONTINUE - END IF - END IF -C -C Set constants. -C - SVLAM = ONE / EPS - C = ONE -C -C Set H. -C - CALL DLASET( 'Full', MT, MT, ZERO, ONE, DWORK( IW11+1 ), MT ) -C - ITER = -1 -C -C Main iteration loop. -C - 390 ITER = ITER + 1 -C -C Compute A(:) = A0 + AA*x. -C - DO 400 I = 1, MT - ZWORK( IZ10+I ) = DCMPLX( X( I ) ) - 400 CONTINUE - CALL ZCOPY( N*N, ZWORK( IZ5+1 ), 1, ZWORK( IZ7+1 ), 1 ) - CALL ZGEMV( 'N', N*N, MT, CONE, ZWORK( IZ6+1 ), N*N, - $ ZWORK( IZ10+1 ), 1, CONE, ZWORK( IZ7+1 ), 1 ) -C -C Compute diag( Binv ). -C - CALL DCOPY( N, DWORK( IW7+1 ), 1, DWORK( IW12+1 ), 1 ) - CALL DGEMV( 'N', N, M-1, ONE, DWORK( IW8+1 ), N, X, 1, ONE, - $ DWORK( IW12+1 ), 1 ) - DO 410 I = 1, N - DWORK( IW12+I ) = ONE / DWORK( IW12+I ) - 410 CONTINUE -C -C Compute Binv*A. -C - DO 430 J = 1, N - DO 420 I = 1, N - ZWORK( IZ11+I+(J-1)*N ) = DCMPLX( DWORK( IW12+I ) )* - $ ZWORK( IZ7+I+(J-1)*N ) - 420 CONTINUE - 430 CONTINUE -C -C Compute eig( Binv*A ). -C - CALL ZGEES( 'N', 'N', SELECT, N, ZWORK( IZ11+1 ), N, SDIM, - $ ZWORK( IZ12+1 ), ZWORK, N, ZWORK( IZWRK+1 ), - $ LZWORK-IZWRK, DWORK( IWRK+1 ), BWORK, INFO2 ) - IF( INFO2.GT.0 ) THEN - INFO = 6 - RETURN - END IF - LZA = INT( ZWORK( IZWRK+1 ) ) - LZAMAX = MAX( LZA, LZAMAX ) - E = DREAL( ZWORK( IZ12+1 ) ) - IF( N.GT.1 ) THEN - DO 440 I = 2, N - IF( DREAL( ZWORK( IZ12+I ) ).GT.E ) - $ E = DREAL( ZWORK( IZ12+I ) ) - 440 CONTINUE - END IF -C -C Set tau. -C - IF( MR.GT.0 ) THEN - SNORM = ABS( X( M ) ) - IF( MR.GT.1 ) THEN - DO 450 I = M+1, MT - IF( ABS( X( I ) ).GT.SNORM ) SNORM = ABS( X( I ) ) - 450 CONTINUE - END IF - IF( SNORM.GT.FORTY ) THEN - TAU = C7 - ELSE IF( SNORM.GT.EIGHT ) THEN - TAU = FIFTY - ELSE IF( SNORM.GT.FOUR ) THEN - TAU = TEN - ELSE IF( SNORM.GT.ONE ) THEN - TAU = FIVE - ELSE - TAU = TWO - END IF - END IF - IF( ITER.EQ.0 ) THEN - DLAMBD = E + C1 - ELSE - DWORK( IW13+1 ) = E - CALL DCOPY( MT, X, 1, DWORK( IW13+2 ), 1 ) - DLAMBD = ( ONE - THETA )*DWORK( IW13+1 ) + - $ THETA*DWORK( IW14+1 ) - CALL DCOPY( MT, DWORK( IW13+2 ), 1, DWORK( IW18+1 ), 1 ) - CALL DCOPY( MT, DWORK( IW14+2 ), 1, DWORK( IW19+1 ), 1 ) - L = 0 - 460 DO 470 I = 1, MT - X( I ) = ( ONE - THETA / TWO**L )*DWORK( IW18+I ) + - $ ( THETA / TWO**L )*DWORK( IW19+I ) - 470 CONTINUE -C -C Compute At(:) = A0 + AA*x. -C - DO 480 I = 1, MT - ZWORK( IZ10+I ) = DCMPLX( X( I ) ) - 480 CONTINUE - CALL ZCOPY( N*N, ZWORK( IZ5+1 ), 1, ZWORK( IZ9+1 ), 1 ) - CALL ZGEMV( 'N', N*N, MT, CONE, ZWORK( IZ6+1 ), N*N, - $ ZWORK( IZ10+1 ), 1, CONE, ZWORK( IZ9+1 ), 1 ) -C -C Compute diag(Bt). -C - CALL DCOPY( N, DWORK( IW7+1 ), 1, DWORK( IW21+1 ), 1 ) - CALL DGEMV( 'N', N, M-1, ONE, DWORK( IW8+1 ), N, X, 1, ONE, - $ DWORK( IW21+1 ), 1 ) -C -C Compute W. -C - DO 500 J = 1, N - DO 490 I = 1, N - IF( I.EQ.J ) THEN - ZWORK( IZ13+I+(I-1)*N ) = DCMPLX( THETA*BETA* - $ ( DWORK( IW14+1 ) - DWORK( IW13+1 ) ) /TWO - - $ DLAMBD*DWORK( IW21+I ) ) + - $ ZWORK( IZ9+I+(I-1)*N ) - ELSE - ZWORK( IZ13+I+(J-1)*N ) = ZWORK( IZ9+I+(J-1)*N ) - END IF - 490 CONTINUE - 500 CONTINUE -C -C Compute eig( W ). -C - CALL ZGEES( 'N', 'N', SELECT, N, ZWORK( IZ13+1 ), N, SDIM, - $ ZWORK( IZ14+1 ), ZWORK, N, ZWORK( IZWRK+1 ), - $ LZWORK-IZWRK, DWORK( IWRK+1 ), BWORK, INFO2 ) - IF( INFO2.GT.0 ) THEN - INFO = 6 - RETURN - END IF - LZA = INT( ZWORK( IZWRK+1 ) ) - LZAMAX = MAX( LZA, LZAMAX ) - EMAX = DREAL( ZWORK( IZ14+1 ) ) - IF( N.GT.1 ) THEN - DO 510 I = 2, N - IF( DREAL( ZWORK( IZ14+I ) ).GT.EMAX ) - $ EMAX = DREAL( ZWORK( IZ14+I ) ) - 510 CONTINUE - END IF - IF( EMAX.LE.ZERO ) THEN - GO TO 515 - ELSE - L = L + 1 - GO TO 460 - END IF - END IF -C -C Set y. -C - 515 DWORK( IW13+1 ) = DLAMBD - CALL DCOPY( MT, X, 1, DWORK( IW13+2 ), 1 ) -C - IF( ( SVLAM - DLAMBD ).LT.TOL ) THEN - BOUND = SQRT( MAX( E, ZERO ) )*ZNORM - DO 520 I = 1, M - 1 - X( I ) = X( I )*DWORK( IW2+I+1 )**2 - 520 CONTINUE -C -C Compute sqrt( x ). -C - DO 530 I = 1, M-1 - DWORK( IW20+I ) = SQRT( X( I ) ) - 530 CONTINUE -C -C Compute diag( D ). -C - CALL DCOPY( N, DWORK( IW7+1 ), 1, D, 1 ) - CALL DGEMV( 'N', N, M-1, ONE, DWORK( IW8+1 ), N, - $ DWORK( IW20+1 ), 1, ONE, D, 1 ) -C -C Compute diag( G ). -C - J = 0 - L = 0 - DO 540 K = 1, M - J = J + NBLOCK( K ) - IF( ITYPE( K ).EQ.1 ) THEN - L = L + 1 - X( M-1+L ) = X( M-1+L )*DWORK( IW2+K )**2 - G( J ) = X( M-1+L ) - END IF - 540 CONTINUE - CALL DSCAL( N, ZNORM, G, 1 ) - DWORK( 1 ) = DFLOAT( MINWRK - 5*N + LWAMAX ) - ZWORK( 1 ) = DCMPLX( MINZRK - 3*N + LZAMAX ) - RETURN - END IF - SVLAM = DLAMBD - DO 800 K = 1, M -C -C Store xD. -C - CALL DCOPY( M-1, X, 1, DWORK( IW22+1 ), 1 ) - IF( MR.GT.0 ) THEN -C -C Store xG. -C - CALL DCOPY( MR, X( M ), 1, DWORK( IW23+1 ), 1 ) - END IF -C -C Compute A(:) = A0 + AA*x. -C - DO 550 I = 1, MT - ZWORK( IZ10+I ) = DCMPLX( X( I ) ) - 550 CONTINUE - CALL ZCOPY( N*N, ZWORK( IZ5+1 ), 1, ZWORK( IZ7+1 ), 1 ) - CALL ZGEMV( 'N', N*N, MT, CONE, ZWORK( IZ6+1 ), N*N, - $ ZWORK( IZ10+1 ), 1, CONE, ZWORK( IZ7+1 ), 1 ) -C -C Compute B = B0d + BBd*xD. -C - CALL DCOPY( N, DWORK( IW7+1 ), 1, DWORK( IW24+1 ), 1 ) - CALL DGEMV( 'N', N, M-1, ONE, DWORK( IW8+1 ), N, - $ DWORK( IW22+1 ), 1, ONE, DWORK( IW24+1 ), 1 ) -C -C Compute F. -C - DO 556 J = 1, N - DO 555 I = 1, N - IF( I.EQ.J ) THEN - ZWORK( IZ15+I+(I-1)*N ) = DCMPLX( DLAMBD* - $ DWORK( IW24+I ) ) - ZWORK( IZ7+I+(I-1)*N ) - ELSE - ZWORK( IZ15+I+(J-1)*N ) = -ZWORK( IZ7+I+(J-1)*N ) - END IF - 555 CONTINUE - 556 CONTINUE - CALL ZLACPY( 'Full', N, N, ZWORK( IZ15+1 ), N, - $ ZWORK( IZ17+1 ), N ) -C -C Compute det( F ). -C - CALL ZGEES( 'N', 'N', SELECT, N, ZWORK( IZ15+1 ), N, SDIM, - $ ZWORK( IZ16+1 ), ZWORK, N, ZWORK( IZWRK+1 ), - $ LZWORK-IZWRK, DWORK( IWRK+1 ), BWORK, INFO2 ) - IF( INFO2.GT.0 ) THEN - INFO = 6 - RETURN - END IF - LZA = INT( ZWORK( IZWRK+1 ) ) - LZAMAX = MAX( LZA, LZAMAX ) - DETF = CONE - DO 560 I = 1, N - DETF = DETF*ZWORK( IZ16+I ) - 560 CONTINUE -C -C Compute Finv. -C - CALL ZGETRF( N, N, ZWORK( IZ17+1 ), N, IWORK, INFO2 ) - IF( INFO2.GT.0 ) THEN - INFO = 5 - RETURN - END IF - CALL ZGETRI( N, ZWORK( IZ17+1 ), N, IWORK, ZWORK( IZWRK+1 ), - $ LDWORK-IWRK, INFO2 ) - LZA = INT( ZWORK( IZWRK+1 ) ) - LZAMAX = MAX( LZA, LZAMAX ) -C -C Compute phi. -C - DO 570 I = 1, M-1 - DWORK( IW25+I ) = DWORK( IW22+I ) - BETA - DWORK( IW25+M-1+I ) = ALPHA - DWORK( IW22+I ) - 570 CONTINUE - IF( MR.GT.0 ) THEN - DO 580 I = 1, MR - DWORK( IW25+2*(M-1)+I ) = DWORK( IW23+I ) + TAU - DWORK( IW25+2*(M-1)+MR+I ) = TAU - DWORK( IW23+I ) - 580 CONTINUE - END IF - PROD = ONE - DO 590 I = 1, 2*MT - PROD = PROD*DWORK( IW25+I ) - 590 CONTINUE - TEMP = DREAL( DETF ) - IF( TEMP.LT.EPS ) TEMP = EPS - PHI = -LOG( TEMP ) - LOG( PROD ) -C -C Compute g. -C - DO 610 J = 1, MT - DO 600 I = 1, N*N - ZWORK( IZ18+I+(J-1)*N*N ) = DCMPLX( DLAMBD* - $ DWORK( IW9+I+(J-1)*N*N ) ) - ZWORK( IZ6+I+(J-1)*N*N ) - 600 CONTINUE - 610 CONTINUE - CALL ZGEMV( 'C', N*N, MT, CONE, ZWORK( IZ18+1 ), N*N, - $ ZWORK( IZ17+1 ), 1, CZERO, ZWORK( IZ19+1 ), 1 ) - DO 620 I = 1, M-1 - DWORK( IW26+I ) = ONE / ( DWORK( IW22+I ) - BETA ) - - $ ONE / ( ALPHA - DWORK( IW22+I ) ) - 620 CONTINUE - IF( MR.GT.0 ) THEN - DO 630 I = 1, MR - DWORK( IW26+M-1+I ) = ONE / ( DWORK( IW23+I ) + TAU ) - $ -ONE / ( TAU - DWORK( IW23+I ) ) - 630 CONTINUE - END IF - DO 640 I = 1, MT - DWORK( IW26+I ) = -DREAL( ZWORK( IZ19+I ) ) - - $ DWORK( IW26+I ) - 640 CONTINUE -C -C Compute h. -C - CALL DLACPY( 'Full', MT, MT, DWORK( IW11+1 ), MT, - $ DWORK( IW31+1 ), MT ) - CALL DCOPY( MT, DWORK( IW26+1 ), 1, DWORK( IW27+1 ), 1 ) - CALL DSYSV( 'U', MT, 1, DWORK( IW31+1 ), MT, IWORK, - $ DWORK( IW27+1 ), MT, DWORK( IWRK+1 ), - $ LDWORK-IWRK, INFO2 ) - IF( INFO2.GT.0 ) THEN - INFO = 5 - RETURN - END IF - LWA = INT( DWORK( IWRK+1 ) ) - LWAMAX = MAX( LWA, LWAMAX ) - STSIZE = ONE -C -C Store hD. -C - CALL DCOPY( M-1, DWORK( IW27+1 ), 1, DWORK( IW28+1 ), 1 ) -C -C Determine stepsize. -C - L = 0 - DO 650 I = 1, M-1 - IF( DWORK( IW28+I ).GT.ZERO ) THEN - L = L + 1 - IF( L.EQ.1 ) THEN - TEMP = ( DWORK( IW22+I ) - BETA ) / DWORK( IW28+I ) - ELSE - TEMP = MIN( TEMP, ( DWORK( IW22+I ) - BETA ) / - $ DWORK( IW28+I ) ) - END IF - END IF - 650 CONTINUE - IF( L.GT.0 ) STSIZE = MIN( STSIZE, TEMP ) - L = 0 - DO 660 I = 1, M-1 - IF( DWORK( IW28+I ).LT.ZERO ) THEN - L = L + 1 - IF( L.EQ.1 ) THEN - TEMP = ( ALPHA - DWORK( IW22+I ) ) / - $ ( -DWORK( IW28+I ) ) - ELSE - TEMP = MIN( TEMP, ( ALPHA - DWORK( IW22+I ) ) / - $ ( -DWORK( IW28+I ) ) ) - END IF - END IF - 660 CONTINUE - IF( L.GT.0 ) STSIZE = MIN( STSIZE, TEMP ) - IF( MR.GT.0 ) THEN -C -C Store hG. -C - CALL DCOPY( MR, DWORK( IW27+M ), 1, DWORK( IW29+1 ), 1 ) -C -C Determine stepsize. -C - L = 0 - DO 670 I = 1, MR - IF( DWORK( IW29+I ).GT.ZERO ) THEN - L = L + 1 - IF( L.EQ.1 ) THEN - TEMP = ( DWORK( IW23+I ) + TAU ) / - $ DWORK( IW29+I ) - ELSE - TEMP = MIN( TEMP, ( DWORK( IW23+I ) + TAU ) / - $ DWORK( IW29+I ) ) - END IF - END IF - 670 CONTINUE - IF( L.GT.0 ) STSIZE = MIN( STSIZE, TEMP ) - L = 0 - DO 680 I = 1, MR - IF( DWORK( IW29+I ).LT.ZERO ) THEN - L = L + 1 - IF( L.EQ.1 ) THEN - TEMP = ( TAU - DWORK( IW23+I ) ) / - $ ( -DWORK( IW29+I ) ) - ELSE - TEMP = MIN( TEMP, ( TAU - DWORK( IW23+I ) ) / - $ ( -DWORK( IW29+I ) ) ) - END IF - END IF - 680 CONTINUE - END IF - IF( L.GT.0 ) STSIZE = MIN( STSIZE, TEMP ) - STSIZE = C4*STSIZE - IF( STSIZE.GE.TOL4 ) THEN -C -C Compute x_new. -C - DO 700 I = 1, MT - DWORK( IW20+I ) = X( I ) - STSIZE*DWORK( IW27+I ) - 700 CONTINUE -C -C Store xD. -C - CALL DCOPY( M-1, DWORK( IW20+1 ), 1, DWORK( IW22+1 ), 1 ) - IF( MR.GT.0 ) THEN -C -C Store xG. -C - CALL DCOPY( MR, DWORK( IW20+M ), 1, DWORK( IW23+1 ), - $ 1 ) - END IF -C -C Compute A(:) = A0 + AA*x_new. -C - DO 710 I = 1, MT - ZWORK( IZ10+I ) = DCMPLX( DWORK( IW20+I ) ) - 710 CONTINUE - CALL ZCOPY( N*N, ZWORK( IZ5+1 ), 1, ZWORK( IZ7+1 ), 1 ) - CALL ZGEMV( 'N', N*N, MT, CONE, ZWORK( IZ6+1 ), N*N, - $ ZWORK( IZ10+1 ), 1, CONE, ZWORK( IZ7+1 ), 1 ) -C -C Compute B = B0d + BBd*xD. -C - CALL DCOPY( N, DWORK( IW7+1 ), 1, DWORK( IW24+1 ), 1 ) - CALL DGEMV( 'N', N, M-1, ONE, DWORK( IW8+1 ), N, - $ DWORK( IW22+1 ), 1, ONE, DWORK( IW24+1 ), 1 ) -C -C Compute lambda*diag(B) - A. -C - DO 730 J = 1, N - DO 720 I = 1, N - IF( I.EQ.J ) THEN - ZWORK( IZ15+I+(I-1)*N ) = DCMPLX( DLAMBD* - $ DWORK( IW24+I ) ) - ZWORK( IZ7+I+(I-1)*N ) - ELSE - ZWORK( IZ15+I+(J-1)*N ) = - $ -ZWORK( IZ7+I+(J-1)*N ) - END IF - 720 CONTINUE - 730 CONTINUE -C -C Compute eig( lambda*diag(B)-A ). -C - CALL ZGEES( 'N', 'N', SELECT, N, ZWORK( IZ15+1 ), N, - $ SDIM, ZWORK( IZ16+1 ), ZWORK, N, - $ ZWORK( IZWRK+1 ), LZWORK-IZWRK, - $ DWORK( IWRK+1 ), BWORK, INFO2 ) - IF( INFO2.GT.0 ) THEN - INFO = 6 - RETURN - END IF - LZA = INT( ZWORK( IZWRK+1 ) ) - LZAMAX = MAX( LZA, LZAMAX ) - EMIN = DREAL( ZWORK( IZ16+1 ) ) - IF( N.GT.1 ) THEN - DO 740 I = 2, N - IF( DREAL( ZWORK( IZ16+I ) ).LT.EMIN ) - $ EMIN = DREAL( ZWORK( IZ16+I ) ) - 740 CONTINUE - END IF - DO 750 I = 1, N - DWORK( IW30+I ) = DREAL( ZWORK( IZ16+I ) ) - 750 CONTINUE - DO 760 I = 1, M-1 - DWORK( IW30+N+I ) = DWORK( IW22+I ) - BETA - DWORK( IW30+N+M-1+I ) = ALPHA - DWORK( IW22+I ) - 760 CONTINUE - IF( MR.GT.0 ) THEN - DO 770 I = 1, MR - DWORK( IW30+N+2*(M-1)+I ) = DWORK( IW23+I ) + TAU - DWORK( IW30+N+2*(M-1)+MR+I ) = TAU - - $ DWORK( IW23+I ) - 770 CONTINUE - END IF - PROD = ONE - DO 780 I = 1, N+2*MT - PROD = PROD*DWORK( IW30+I ) - 780 CONTINUE - IF( EMIN.LE.ZERO .OR. ( -LOG( PROD ) ).GE.PHI ) THEN - STSIZE = STSIZE / TEN - ELSE - CALL DCOPY( MT, DWORK( IW20+1 ), 1, X, 1 ) - END IF - END IF - IF( STSIZE.LT.TOL4 ) GO TO 810 - 800 CONTINUE -C - 810 CONTINUE -C -C Store xD. -C - CALL DCOPY( M-1, X, 1, DWORK( IW22+1 ), 1 ) - IF( MR.GT.0 ) THEN -C -C Store xG. -C - CALL DCOPY( MR, X( M ), 1, DWORK( IW23+1 ), 1 ) - END IF -C -C Compute A(:) = A0 + AA*x. -C - DO 820 I = 1, MT - ZWORK( IZ10+I ) = DCMPLX( X( I ) ) - 820 CONTINUE - CALL ZCOPY( N*N, ZWORK( IZ5+1 ), 1, ZWORK( IZ7+1 ), 1 ) - CALL ZGEMV( 'N', N*N, MT, CONE, ZWORK( IZ6+1 ), N*N, - $ ZWORK( IZ10+1 ), 1, CONE, ZWORK( IZ7+1 ), 1 ) -C -C Compute diag( B ) = B0d + BBd*xD. -C - CALL DCOPY( N, DWORK( IW7+1 ), 1, DWORK( IW24+1 ), 1 ) - CALL DGEMV( 'N', N, M-1, ONE, DWORK( IW8+1 ), N, - $ DWORK( IW22+1 ), 1, ONE, DWORK( IW24+1 ), 1 ) -C -C Compute F. -C - DO 840 J = 1, N - DO 830 I = 1, N - IF( I.EQ.J ) THEN - ZWORK( IZ15+I+(I-1)*N ) = DCMPLX( DLAMBD* - $ DWORK( IW24+I ) ) - ZWORK( IZ7+I+(I-1)*N ) - ELSE - ZWORK( IZ15+I+(J-1)*N ) = -ZWORK( IZ7+I+(J-1)*N ) - END IF - 830 CONTINUE - 840 CONTINUE - CALL ZLACPY( 'Full', N, N, ZWORK( IZ15+1 ), N, - $ ZWORK( IZ17+1 ), N ) -C -C Compute det( F ). -C - CALL ZGEES( 'N', 'N', SELECT, N, ZWORK( IZ15+1 ), N, SDIM, - $ ZWORK( IZ16+1 ), ZWORK, N, ZWORK( IZWRK+1 ), - $ LZWORK-IZWRK, DWORK( IWRK+1 ), BWORK, INFO2 ) - IF( INFO2.GT.0 ) THEN - INFO = 6 - RETURN - END IF - LZA = INT( ZWORK( IZWRK+1 ) ) - LZAMAX = MAX( LZA, LZAMAX ) - DETF = CONE - DO 850 I = 1, N - DETF = DETF*ZWORK( IZ16+I ) - 850 CONTINUE -C -C Compute Finv. -C - CALL ZGETRF( N, N, ZWORK( IZ17+1 ), N, IWORK, INFO2 ) - IF( INFO2.GT.0 ) THEN - INFO = 5 - RETURN - END IF - CALL ZGETRI( N, ZWORK( IZ17+1 ), N, IWORK, ZWORK( IZWRK+1 ), - $ LDWORK-IWRK, INFO2 ) - LZA = INT( ZWORK( IZWRK+1 ) ) - LZAMAX = MAX( LZA, LZAMAX ) -C -C Compute the barrier function. -C - DO 860 I = 1, M-1 - DWORK( IW25+I ) = DWORK( IW22+I ) - BETA - DWORK( IW25+M-1+I ) = ALPHA - DWORK( IW22+I ) - 860 CONTINUE - IF( MR.GT.0 ) THEN - DO 870 I = 1, MR - DWORK( IW25+2*(M-1)+I ) = DWORK( IW23+I ) + TAU - DWORK( IW25+2*(M-1)+MR+I ) = TAU - DWORK( IW23+I ) - 870 CONTINUE - END IF - PROD = ONE - DO 880 I = 1, 2*MT - PROD = PROD*DWORK( IW25+I ) - 880 CONTINUE - TEMP = DREAL( DETF ) - IF( TEMP.LT.EPS ) TEMP = EPS - PHI = -LOG( TEMP ) - LOG( PROD ) -C -C Compute the gradient of the barrier function. -C - DO 900 J = 1, MT - DO 890 I = 1, N*N - ZWORK( IZ18+I+(J-1)*N*N ) = DCMPLX( DLAMBD* - $ DWORK( IW9+I+(J-1)*N*N ) ) - ZWORK( IZ6+I+(J-1)*N*N ) - 890 CONTINUE - 900 CONTINUE - CALL ZGEMV( 'C', N*N, MT, CONE, ZWORK( IZ18+1 ), N*N, - $ ZWORK( IZ17+1 ), 1, CZERO, ZWORK( IZ19+1 ), 1 ) - DO 910 I = 1, M-1 - DWORK( IW26+I ) = ONE / ( DWORK( IW22+I ) - BETA ) - - $ ONE / ( ALPHA - DWORK( IW22+I ) ) - 910 CONTINUE - IF( MR.GT.0 ) THEN - DO 920 I = 1, MR - DWORK( IW26+M-1+I ) = ONE / ( DWORK( IW23+I ) + TAU ) - $ -ONE / ( TAU - DWORK( IW23+I ) ) - 920 CONTINUE - END IF - DO 925 I = 1, MT - DWORK( IW26+I ) = -DREAL( ZWORK( IZ19+I ) ) - - $ DWORK( IW26+I ) - 925 CONTINUE -C -C Compute the Hessian of the barrier function. -C - CALL ZGEMM( 'N', 'N', N, N*MT, N, CONE, ZWORK( IZ17+1 ), N, - $ ZWORK( IZ18+1 ), N, CZERO, ZWORK( IZ20+1 ), N ) - - CALL DLASET( 'Full', MT, MT, ZERO, ZERO, DWORK( IW11+1 ), - $ MT ) - DO 960 K = 1, MT - CALL ZCOPY( N*N, ZWORK( IZ20+1+(K-1)*N*N ), 1, - $ ZWORK( IZ22+1 ), 1 ) - DO 940 J = 1, N - DO 930 I = 1, N - ZWORK( IZ23+I+(J-1)*N ) = - $ DCONJG( ZWORK( IZ22+J+(I-1)*N ) ) - 930 CONTINUE - 940 CONTINUE - CALL ZGEMV( 'C', N*N, K, CONE, ZWORK( IZ20+1 ), N*N, - $ ZWORK( IZ23+1 ), 1, CZERO, ZWORK( IZ24+1 ), - $ 1 ) - DO 950 J = 1, K - DWORK( IW11+K+(J-1)*MT ) = - $ DREAL( DCONJG( ZWORK( IZ24+J ) ) ) - 950 CONTINUE - 960 CONTINUE - DO 970 I = 1, M-1 - DWORK( IW10+I ) = ONE / ( DWORK( IW22+I ) - BETA )**2 + - $ ONE / ( ALPHA - DWORK( IW22+I ) )**2 - 970 CONTINUE - IF( MR.GT.0 ) THEN - DO 980 I = 1, MR - DWORK( IW10+M-1+I ) = - $ ONE / ( DWORK( IW23+I ) + TAU )**2 + - $ ONE / ( TAU - DWORK( IW23+I ) )**2 - 980 CONTINUE - END IF - DO 990 I = 1, MT - DWORK( IW11+I+(I-1)*MT ) = DWORK( IW11+I+(I-1)*MT ) + - $ DWORK( IW10+I ) - 990 CONTINUE - DO 1100 J = 1, MT - DO 1000 I = 1, J - IF( I.NE.J ) THEN - T1 = DWORK( IW11+I+(J-1)*MT ) - T2 = DWORK( IW11+J+(I-1)*MT ) - DWORK( IW11+I+(J-1)*MT ) = T1 + T2 - DWORK( IW11+J+(I-1)*MT ) = T1 + T2 - END IF - 1000 CONTINUE - 1100 CONTINUE -C -C Compute norm( H ). -C - 1110 HNORM = DLANGE( 'F', MT, MT, DWORK( IW11+1 ), MT, DWORK ) -C -C Compute rcond( H ). -C - CALL DLACPY( 'Full', MT, MT, DWORK( IW11+1 ), MT, - $ DWORK( IW31+1 ), MT ) - HNORM1 = DLANGE( '1', MT, MT, DWORK( IW31+1 ), MT, DWORK ) - CALL DSYTRF( 'U', MT, DWORK( IW31+1 ), MT, IWORK, - $ DWORK( IWRK+1 ), LDWORK-IWRK, INFO2 ) - IF( INFO2.GT.0 ) THEN - INFO = 5 - RETURN - END IF - LWA = INT( DWORK( IWRK+1 ) ) - LWAMAX = MAX( LWA, LWAMAX ) - CALL DSYCON( 'U', MT, DWORK( IW31+1 ), MT, IWORK, HNORM1, - $ RCOND, DWORK( IWRK+1 ), IWORK( MT+1 ), INFO2 ) - IF( RCOND.LT.TOL3 ) THEN - DO 1120 I = 1, MT - DWORK( IW11+I+(I-1)*MT ) = DWORK( IW11+I+(I-1)*MT ) + - $ HNORM*REGPAR - 1120 CONTINUE - GO TO 1110 - END IF -C -C Compute the tangent line to path of center. -C - CALL DCOPY( MT, DWORK( IW26+1 ), 1, DWORK( IW27+1 ), 1 ) - CALL DSYTRS( 'U', MT, 1, DWORK( IW31+1 ), MT, IWORK, - $ DWORK( IW27+1 ), MT, INFO2 ) -C -C Check if x-h satisfies the Goldstein test. -C - GTEST = .FALSE. - DO 1130 I = 1, MT - DWORK( IW20+I ) = X( I ) - DWORK( IW27+I ) - 1130 CONTINUE -C -C Store xD. -C - CALL DCOPY( M-1, DWORK( IW20+1 ), 1, DWORK( IW22+1 ), 1 ) - IF( MR.GT.0 ) THEN -C -C Store xG. -C - CALL DCOPY( MR, DWORK( IW20+M ), 1, DWORK( IW23+1 ), 1 ) - END IF -C -C Compute A(:) = A0 + AA*x_new. -C - DO 1140 I = 1, MT - ZWORK( IZ10+I ) = DCMPLX( DWORK( IW20+I ) ) - 1140 CONTINUE - CALL ZCOPY( N*N, ZWORK( IZ5+1 ), 1, ZWORK( IZ7+1 ), 1 ) - CALL ZGEMV( 'N', N*N, MT, CONE, ZWORK( IZ6+1 ), N*N, - $ ZWORK( IZ10+1 ), 1, CONE, ZWORK( IZ7+1 ), 1 ) -C -C Compute diag( B ) = B0d + BBd*xD. -C - CALL DCOPY( N, DWORK( IW7+1 ), 1, DWORK( IW24+1 ), 1 ) - CALL DGEMV( 'N', N, M-1, ONE, DWORK( IW8+1 ), N, - $ DWORK( IW22+1 ), 1, ONE, DWORK( IW24+1 ), 1 ) -C -C Compute lambda*diag(B) - A. -C - DO 1160 J = 1, N - DO 1150 I = 1, N - IF( I.EQ.J ) THEN - ZWORK( IZ15+I+(I-1)*N ) = DCMPLX( DLAMBD* - $ DWORK( IW24+I ) ) - ZWORK( IZ7+I+(I-1)*N ) - ELSE - ZWORK( IZ15+I+(J-1)*N ) = -ZWORK( IZ7+I+(J-1)*N ) - END IF - 1150 CONTINUE - 1160 CONTINUE -C -C Compute eig( lambda*diag(B)-A ). -C - CALL ZGEES( 'N', 'N', SELECT, N, ZWORK( IZ15+1 ), N, SDIM, - $ ZWORK( IZ16+1 ), ZWORK, N, ZWORK( IZWRK+1 ), - $ LZWORK-IZWRK, DWORK( IWRK+1 ), BWORK, INFO2 ) - IF( INFO2.GT.0 ) THEN - INFO = 6 - RETURN - END IF - LZA = INT( ZWORK( IZWRK+1 ) ) - LZAMAX = MAX( LZA, LZAMAX ) - DO 1190 I = 1, N - DWORK( IW30+I ) = DREAL( ZWORK( IZ16+I ) ) - 1190 CONTINUE - DO 1200 I = 1, M-1 - DWORK( IW30+N+I ) = DWORK( IW22+I ) - BETA - DWORK( IW30+N+M-1+I ) = ALPHA - DWORK( IW22+I ) - 1200 CONTINUE - IF( MR.GT.0 ) THEN - DO 1210 I = 1, MR - DWORK( IW30+N+2*(M-1)+I ) = DWORK( IW23+I ) + TAU - DWORK( IW30+N+2*(M-1)+MR+I ) = TAU - DWORK( IW23+I ) - 1210 CONTINUE - END IF - EMIN = DWORK( IW30+1 ) - DO 1220 I = 1, N+2*MT - IF( DWORK( IW30+I ).LT.EMIN ) EMIN = DWORK( IW30+I ) - 1220 CONTINUE - IF( EMIN.LE.ZERO ) THEN - GTEST = .FALSE. - ELSE - PP = DDOT( MT, DWORK( IW26+1 ), 1, DWORK( IW27+1 ), 1 ) - PROD = ONE - DO 1230 I = 1, N+2*MT - PROD = PROD*DWORK( IW30+I ) - 1230 CONTINUE - T1 = -LOG( PROD ) - T2 = PHI - C2*PP - T3 = PHI - C4*PP - IF( T1.GE.T3 .AND. T1.LT.T2 ) GTEST = .TRUE. - END IF -C -C Use x-h if Goldstein test is satisfied. Otherwise use -C Nesterov-Nemirovsky's stepsize length. -C - PP = DDOT( MT, DWORK( IW26+1 ), 1, DWORK( IW27+1 ), 1 ) - DELTA = SQRT( PP ) - IF( GTEST .OR. DELTA.LE.C3 ) THEN - DO 1240 I = 1, MT - X( I ) = X( I ) - DWORK( IW27+I ) - 1240 CONTINUE - ELSE - DO 1250 I = 1, MT - X( I ) = X( I ) - DWORK( IW27+I ) / ( ONE + DELTA ) - 1250 CONTINUE - END IF -C -C Analytic center is found if delta is sufficiently small. -C - IF( DELTA.LT.TOL5 ) GO TO 1260 - GO TO 810 -C -C Set yf. -C - 1260 DWORK( IW14+1 ) = DLAMBD - CALL DCOPY( MT, X, 1, DWORK( IW14+2 ), 1 ) -C -C Set yw. -C - CALL DCOPY( MT+1, DWORK( IW14+1 ), 1, DWORK( IW15+1 ), 1 ) -C -C Compute Fb. -C - DO 1280 J = 1, N - DO 1270 I = 1, N - ZWORK( IZ21+I+(J-1)*N ) = DCMPLX( DWORK( IW24+I ) )* - $ DCONJG( ZWORK( IZ17+J+(I-1)*N ) ) - 1270 CONTINUE - 1280 CONTINUE - CALL ZGEMV( 'C', N*N, MT, CONE, ZWORK( IZ20+1 ), N*N, - $ ZWORK( IZ21+1 ), 1, CZERO, ZWORK( IZ24+1 ), 1 ) - DO 1300 I = 1, MT - DWORK( IW32+I ) = DREAL( ZWORK( IZ24+I ) ) - 1300 CONTINUE -C -C Compute h1. -C - CALL DLACPY( 'Full', MT, MT, DWORK( IW11+1 ), MT, - $ DWORK( IW31+1 ), MT ) - CALL DSYSV( 'U', MT, 1, DWORK( IW31+1 ), MT, IWORK, - $ DWORK( IW32+1 ), MT, DWORK( IWRK+1 ), - $ LDWORK-IWRK, INFO2 ) - IF( INFO2.GT.0 ) THEN - INFO = 5 - RETURN - END IF - LWA = INT( DWORK( IWRK+1 ) ) - LWAMAX = MAX( LWA, LWAMAX ) -C -C Compute hn. -C - HN = DLANGE( 'F', MT, 1, DWORK( IW32+1 ), MT, DWORK ) -C -C Compute y. -C - DWORK( IW13+1 ) = DLAMBD - C / HN - DO 1310 I = 1, MT - DWORK( IW13+1+I ) = X( I ) + C*DWORK( IW32+I ) / HN - 1310 CONTINUE -C -C Store xD. -C - CALL DCOPY( M-1, DWORK( IW13+2 ), 1, DWORK( IW22+1 ), 1 ) - IF( MR.GT.0 ) THEN -C -C Store xG. -C - CALL DCOPY( MR, DWORK( IW13+M+1 ), 1, DWORK( IW23+1 ), 1 ) - END IF -C -C Compute A(:) = A0 + AA*y(2:mt+1). -C - DO 1320 I = 1, MT - ZWORK( IZ10+I ) = DCMPLX( DWORK( IW13+1+I ) ) - 1320 CONTINUE - CALL ZCOPY( N*N, ZWORK( IZ5+1 ), 1, ZWORK( IZ7+1 ), 1 ) - CALL ZGEMV( 'N', N*N, MT, CONE, ZWORK( IZ6+1 ), N*N, - $ ZWORK( IZ10+1 ), 1, CONE, ZWORK( IZ7+1 ), 1 ) -C -C Compute B = B0d + BBd*xD. -C - CALL DCOPY( N, DWORK( IW7+1 ), 1, DWORK( IW24+1 ), 1 ) - CALL DGEMV( 'N', N, M-1, ONE, DWORK( IW8+1 ), N, - $ DWORK( IW22+1 ), 1, ONE, DWORK( IW24+1 ), 1 ) -C -C Compute y(1)*diag(B) - A. -C - DO 1340 J = 1, N - DO 1330 I = 1, N - IF( I.EQ.J ) THEN - ZWORK( IZ15+I+(I-1)*N ) = DCMPLX( DWORK( IW13+1 )* - $ DWORK( IW24+I ) ) - ZWORK( IZ7+I+(I-1)*N ) - ELSE - ZWORK( IZ15+I+(J-1)*N ) = -ZWORK( IZ7+I+(J-1)*N ) - END IF - 1330 CONTINUE - 1340 CONTINUE -C -C Compute eig( y(1)*diag(B)-A ). -C - CALL ZGEES( 'N', 'N', SELECT, N, ZWORK( IZ15+1 ), N, SDIM, - $ ZWORK( IZ16+1 ), ZWORK, N, ZWORK( IZWRK+1 ), - $ LZWORK-IZWRK, DWORK( IWRK+1 ), BWORK, INFO2 ) - IF( INFO2.GT.0 ) THEN - INFO = 6 - RETURN - END IF - LZA = INT( ZWORK( IZWRK+1 ) ) - LZAMAX = MAX( LZA, LZAMAX ) - EMIN = DREAL( ZWORK( IZ16+1 ) ) - IF( N.GT.1 ) THEN - DO 1350 I = 2, N - IF( DREAL( ZWORK( IZ16+I ) ).LT.EMIN ) - $ EMIN = DREAL( ZWORK( IZ16+I ) ) - 1350 CONTINUE - END IF - POS = .TRUE. - DO 1360 I = 1, M-1 - DWORK( IW25+I ) = DWORK( IW22+I ) - BETA - DWORK( IW25+M-1+I ) = ALPHA - DWORK( IW22+I ) - 1360 CONTINUE - IF( MR.GT.0 ) THEN - DO 1370 I = 1, MR - DWORK( IW25+2*(M-1)+I ) = DWORK( IW23+I ) + TAU - DWORK( IW25+2*(M-1)+MR+I ) = TAU - DWORK( IW23+I ) - 1370 CONTINUE - END IF - TEMP = DWORK( IW25+1 ) - DO 1380 I = 2, 2*MT - IF( DWORK( IW25+I ).LT.TEMP ) TEMP = DWORK( IW25+I ) - 1380 CONTINUE - IF( TEMP.LE.ZERO .OR. EMIN.LE.ZERO ) POS = .FALSE. - 1390 IF( POS ) THEN -C -C Set y2 = y. -C - CALL DCOPY( MT+1, DWORK( IW13+1 ), 1, DWORK( IW17+1 ), 1 ) -C -C Compute y = y + 1.5*( y - yw ). -C - DO 1400 I = 1, MT+1 - DWORK( IW13+I ) = DWORK( IW13+I ) + - $ C5*( DWORK( IW13+I ) - DWORK( IW15+I ) ) - 1400 CONTINUE -C -C Store xD. -C - CALL DCOPY( M-1, DWORK( IW13+2 ), 1, DWORK( IW22+1 ), 1 ) - IF( MR.GT.0 ) THEN -C -C Store xG. -C - CALL DCOPY( MR, DWORK( IW13+M+1 ), 1, - $ DWORK( IW23+1 ), 1 ) - END IF -C -C Compute A(:) = A0 + AA*y(2:mt+1). -C - DO 1420 I = 1, MT - ZWORK( IZ10+I ) = DCMPLX( DWORK( IW13+1+I ) ) - 1420 CONTINUE - CALL ZCOPY( N*N, ZWORK( IZ5+1 ), 1, ZWORK( IZ7+1 ), 1 ) - CALL ZGEMV( 'N', N*N, MT, CONE, ZWORK( IZ6+1 ), N*N, - $ ZWORK( IZ10+1 ), 1, CONE, ZWORK( IZ7+1 ), 1 ) -C -C Compute diag( B ) = B0d + BBd*xD. -C - CALL DCOPY( N, DWORK( IW7+1 ), 1, DWORK( IW24+1 ), 1 ) - CALL DGEMV( 'N', N, M-1, ONE, DWORK( IW8+1 ), N, - $ DWORK( IW22+1 ), 1, ONE, DWORK( IW24+1 ), 1 ) -C -C Set yw = y2. -C - CALL DCOPY( MT+1, DWORK( IW17+1 ), 1, DWORK( IW15+1 ), 1 ) -C -C Compute y(1)*diag(B) - A. -C - DO 1440 J = 1, N - DO 1430 I = 1, N - IF( I.EQ.J ) THEN - ZWORK( IZ15+I+(I-1)*N ) = DCMPLX( DWORK( IW13+1 )* - $ DWORK( IW24+I ) ) - ZWORK( IZ7+I+(I-1)*N ) - ELSE - ZWORK( IZ15+I+(J-1)*N ) = -ZWORK( IZ7+I+(J-1)*N ) - END IF - 1430 CONTINUE - 1440 CONTINUE -C -C Compute eig( y(1)*diag(B)-A ). -C - CALL ZGEES( 'N', 'N', SELECT, N, ZWORK( IZ15+1 ), N, SDIM, - $ ZWORK( IZ16+1 ), ZWORK, N, ZWORK( IZWRK+1 ), - $ LZWORK-IZWRK, DWORK( IWRK+1 ), BWORK, INFO2 ) - IF( INFO2.GT.0 ) THEN - INFO = 6 - RETURN - END IF - LZA = INT( ZWORK( IZWRK+1 ) ) - LZAMAX = MAX( LZA, LZAMAX ) - EMIN = DREAL( ZWORK( IZ16+1 ) ) - IF( N.GT.1 ) THEN - DO 1450 I = 2, N - IF( DREAL( ZWORK( IZ16+I ) ).LT.EMIN ) - $ EMIN = DREAL( ZWORK( IZ16+I ) ) - 1450 CONTINUE - END IF - POS = .TRUE. - DO 1460 I = 1, M-1 - DWORK( IW25+I ) = DWORK( IW22+I ) - BETA - DWORK( IW25+M-1+I ) = ALPHA - DWORK( IW22+I ) - 1460 CONTINUE - IF( MR.GT.0 ) THEN - DO 1470 I = 1, MR - DWORK( IW25+2*(M-1)+I ) = DWORK( IW23+I ) + TAU - DWORK( IW25+2*(M-1)+MR+I ) = TAU - DWORK( IW23+I ) - 1470 CONTINUE - END IF - TEMP = DWORK( IW25+1 ) - DO 1480 I = 2, 2*MT - IF( DWORK( IW25+I ).LT.TEMP ) TEMP = DWORK( IW25+I ) - 1480 CONTINUE - IF( TEMP.LE.ZERO .OR. EMIN.LE.ZERO ) POS = .FALSE. - GO TO 1390 - END IF - 1490 CONTINUE -C -C Set y1 = ( y + yw ) / 2. -C - DO 1500 I = 1, MT+1 - DWORK( IW16+I ) = ( DWORK( IW13+I ) + DWORK( IW15+I ) ) - $ / TWO - 1500 CONTINUE -C -C Store xD. -C - CALL DCOPY( M-1, DWORK( IW16+2 ), 1, DWORK( IW22+1 ), 1 ) - IF( MR.GT.0 ) THEN -C -C Store xG. -C - CALL DCOPY( MR, DWORK( IW16+M+1 ), 1, DWORK( IW23+1 ), 1 ) - END IF -C -C Compute A(:) = A0 + AA*y1(2:mt+1). -C - DO 1510 I = 1, MT - ZWORK( IZ10+I ) = DCMPLX( DWORK( IW16+1+I ) ) - 1510 CONTINUE - CALL ZCOPY( N*N, ZWORK( IZ5+1 ), 1, ZWORK( IZ7+1 ), 1 ) - CALL ZGEMV( 'N', N*N, MT, CONE, ZWORK( IZ6+1 ), N*N, - $ ZWORK( IZ10+1 ), 1, CONE, ZWORK( IZ7+1 ), 1 ) -C -C Compute diag( B ) = B0d + BBd*xD. -C - CALL DCOPY( N, DWORK( IW7+1 ), 1, DWORK( IW24+1 ), 1 ) - CALL DGEMV( 'N', N, M-1, ONE, DWORK( IW8+1 ), N, - $ DWORK( IW22+1 ), 1, ONE, DWORK( IW24+1 ), 1 ) -C -C Compute y1(1)*diag(B) - A. -C - DO 1530 J = 1, N - DO 1520 I = 1, N - IF( I.EQ.J ) THEN - ZWORK( IZ15+I+(I-1)*N ) = DCMPLX( DWORK( IW16+1 )* - $ DWORK( IW24+I ) ) - ZWORK( IZ7+I+(I-1)*N ) - ELSE - ZWORK( IZ15+I+(J-1)*N ) = -ZWORK( IZ7+I+(J-1)*N ) - END IF - 1520 CONTINUE - 1530 CONTINUE -C -C Compute eig( y1(1)*diag(B)-A ). -C - CALL ZGEES( 'N', 'N', SELECT, N, ZWORK( IZ15+1 ), N, SDIM, - $ ZWORK( IZ16+1 ), ZWORK, N, ZWORK( IZWRK+1 ), - $ LZWORK-IZWRK, DWORK( IWRK+1 ), BWORK, INFO2 ) - IF( INFO2.GT.0 ) THEN - INFO = 6 - RETURN - END IF - LZA = INT( ZWORK( IZWRK+1 ) ) - LZAMAX = MAX( LZA, LZAMAX ) - EMIN = DREAL( ZWORK( IZ16+1 ) ) - IF( N.GT.1 ) THEN - DO 1540 I = 2, N - IF( DREAL( ZWORK( IZ16+I ) ).LT.EMIN ) - $ EMIN = DREAL( ZWORK( IZ16+I ) ) - 1540 CONTINUE - END IF - POS = .TRUE. - DO 1550 I = 1, M-1 - DWORK( IW25+I ) = DWORK( IW22+I ) - BETA - DWORK( IW25+M-1+I ) = ALPHA - DWORK( IW22+I ) - 1550 CONTINUE - IF( MR.GT.0 ) THEN - DO 1560 I = 1, MR - DWORK( IW25+2*(M-1)+I ) = DWORK( IW23+I ) + TAU - DWORK( IW25+2*(M-1)+MR+I ) = TAU - DWORK( IW23+I ) - 1560 CONTINUE - END IF - TEMP = DWORK( IW25+1 ) - DO 1570 I = 2, 2*MT - IF( DWORK( IW25+I ).LT.TEMP ) TEMP = DWORK( IW25+I ) - 1570 CONTINUE - IF( TEMP.LE.ZERO .OR. EMIN.LE.ZERO ) POS = .FALSE. - IF( POS ) THEN -C -C Set yw = y1. -C - CALL DCOPY( MT+1, DWORK( IW16+1 ), 1, DWORK( IW15+1 ), 1 ) - ELSE -C -C Set y = y1. -C - CALL DCOPY( MT+1, DWORK( IW16+1 ), 1, DWORK( IW13+1 ), 1 ) - END IF - DO 1580 I = 1, MT+1 - DWORK( IW33+I ) = DWORK( IW13+I ) - DWORK( IW15+I ) - 1580 CONTINUE - YNORM1 = DLANGE( 'F', MT+1, 1, DWORK( IW33+1 ), MT+1, DWORK ) - DO 1590 I = 1, MT+1 - DWORK( IW33+I ) = DWORK( IW13+I ) - DWORK( IW14+I ) - 1590 CONTINUE - YNORM2 = DLANGE( 'F', MT+1, 1, DWORK( IW33+1 ), MT+1, DWORK ) - IF( YNORM1.LT.YNORM2*THETA ) GO TO 1600 - GO TO 1490 -C -C Compute c. -C - 1600 DO 1610 I = 1, MT+1 - DWORK( IW33+I ) = DWORK( IW15+I ) - DWORK( IW14+I ) - 1610 CONTINUE - C = DLANGE( 'F', MT+1, 1, DWORK( IW33+1 ), MT+1, DWORK ) -C -C Set x = yw(2:mt+1). -C - CALL DCOPY( MT, DWORK( IW15+2 ), 1, X, 1 ) - GO TO 390 -C -C *** Last line of AB13MD *** - END diff --git a/mex/sources/libslicot/AB8NXZ.f b/mex/sources/libslicot/AB8NXZ.f deleted file mode 100644 index 9ec0da563..000000000 --- a/mex/sources/libslicot/AB8NXZ.f +++ /dev/null @@ -1,456 +0,0 @@ - SUBROUTINE AB8NXZ( N, M, P, RO, SIGMA, SVLMAX, ABCD, LDABCD, - $ NINFZ, INFZ, KRONL, MU, NU, NKROL, TOL, IWORK, - $ DWORK, ZWORK, LZWORK, INFO ) -C -C SLICOT RELEASE 5.0. -C -C Copyright (c) 2002-2009 NICONET e.V. -C -C This program is free software: you can redistribute it and/or -C modify it under the terms of the GNU General Public License as -C published by the Free Software Foundation, either version 2 of -C the License, or (at your option) any later version. -C -C This program is distributed in the hope that it will be useful, -C but WITHOUT ANY WARRANTY; without even the implied warranty of -C MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the -C GNU General Public License for more details. -C -C You should have received a copy of the GNU General Public License -C along with this program. If not, see -C . -C -C PURPOSE -C -C To extract from the (N+P)-by-(M+N) system -C ( B A ) -C ( D C ) -C an (NU+MU)-by-(M+NU) "reduced" system -C ( B' A') -C ( D' C') -C having the same transmission zeros but with D' of full row rank. -C -C ARGUMENTS -C -C Input/Output Parameters -C -C N (input) INTEGER -C The number of state variables. N >= 0. -C -C M (input) INTEGER -C The number of system inputs. M >= 0. -C -C P (input) INTEGER -C The number of system outputs. P >= 0. -C -C RO (input/output) INTEGER -C On entry, -C = P for the original system; -C = MAX(P-M, 0) for the pertransposed system. -C On exit, RO contains the last computed rank. -C -C SIGMA (input/output) INTEGER -C On entry, -C = 0 for the original system; -C = M for the pertransposed system. -C On exit, SIGMA contains the last computed value sigma in -C the algorithm. -C -C SVLMAX (input) DOUBLE PRECISION -C During each reduction step, the rank-revealing QR -C factorization of a matrix stops when the estimated minimum -C singular value is smaller than TOL * MAX(SVLMAX,EMSV), -C where EMSV is the estimated maximum singular value. -C SVLMAX >= 0. -C -C ABCD (input/output) COMPLEX*16 array, dimension (LDABCD,M+N) -C On entry, the leading (N+P)-by-(M+N) part of this array -C must contain the compound input matrix of the system. -C On exit, the leading (NU+MU)-by-(M+NU) part of this array -C contains the reduced compound input matrix of the system. -C -C LDABCD INTEGER -C The leading dimension of array ABCD. -C LDABCD >= MAX(1,N+P). -C -C NINFZ (input/output) INTEGER -C On entry, the currently computed number of infinite zeros. -C It should be initialized to zero on the first call. -C NINFZ >= 0. -C On exit, the number of infinite zeros. -C -C INFZ (input/output) INTEGER array, dimension (N) -C On entry, INFZ(i) must contain the current number of -C infinite zeros of degree i, where i = 1,2,...,N, found in -C the previous call(s) of the routine. It should be -C initialized to zero on the first call. -C On exit, INFZ(i) contains the number of infinite zeros of -C degree i, where i = 1,2,...,N. -C -C KRONL (input/output) INTEGER array, dimension (N+1) -C On entry, this array must contain the currently computed -C left Kronecker (row) indices found in the previous call(s) -C of the routine. It should be initialized to zero on the -C first call. -C On exit, the leading NKROL elements of this array contain -C the left Kronecker (row) indices. -C -C MU (output) INTEGER -C The normal rank of the transfer function matrix of the -C original system. -C -C NU (output) INTEGER -C The dimension of the reduced system matrix and the number -C of (finite) invariant zeros if D' is invertible. -C -C NKROL (output) INTEGER -C The number of left Kronecker indices. -C -C Tolerances -C -C TOL DOUBLE PRECISION -C A tolerance used in rank decisions to determine the -C effective rank, which is defined as the order of the -C largest leading (or trailing) triangular submatrix in the -C QR (or RQ) factorization with column (or row) pivoting -C whose estimated condition number is less than 1/TOL. -C NOTE that when SVLMAX > 0, the estimated ranks could be -C less than those defined above (see SVLMAX). -C -C Workspace -C -C IWORK INTEGER array, dimension (MAX(M,P)) -C -C DWORK DOUBLE PRECISION array, dimension (2*MAX(M,P)) -C -C ZWORK COMPLEX*16 array, dimension (LZWORK) -C On exit, if INFO = 0, ZWORK(1) returns the optimal value -C of LZWORK. -C -C LZWORK INTEGER -C The length of the array ZWORK. -C LZWORK >= MAX( 1, MIN(P,M) + MAX(3*M-1,N), -C MIN(P,N) + MAX(3*P-1,N+P,N+M) ). -C For optimum performance LZWORK should be larger. -C -C If LZWORK = -1, then a workspace query is assumed; -C the routine only calculates the optimal size of the -C ZWORK array, returns this value as the first entry of -C the ZWORK array, and no error message related to LZWORK -C is issued by XERBLA. -C -C Error Indicator -C -C INFO INTEGER -C = 0: successful exit; -C < 0: if INFO = -i, the i-th argument had an illegal -C value. -C -C REFERENCES -C -C [1] Svaricek, F. -C Computation of the Structural Invariants of Linear -C Multivariable Systems with an Extended Version of -C the Program ZEROS. -C System & Control Letters, 6, pp. 261-266, 1985. -C -C [2] Emami-Naeini, A. and Van Dooren, P. -C Computation of Zeros of Linear Multivariable Systems. -C Automatica, 18, pp. 415-430, 1982. -C -C NUMERICAL ASPECTS -C -C The algorithm is backward stable. -C -C CONTRIBUTOR -C -C V. Sima, Katholieke Univ. Leuven, Belgium, Nov. 1996. -C Complex version: V. Sima, Research Institute for Informatics, -C Bucharest, Nov. 2008 with suggestions from P. Gahinet, -C The MathWorks. -C -C REVISIONS -C -C V. Sima, Research Institute for Informatics, Bucharest, Apr. 2009. -C -C KEYWORDS -C -C Generalized eigenvalue problem, Kronecker indices, multivariable -C system, unitary transformation, structural invariant. -C -C ****************************************************************** -C -C .. Parameters .. - COMPLEX*16 ZERO - PARAMETER ( ZERO = ( 0.0D+0, 0.0D+0 ) ) - DOUBLE PRECISION DZERO - PARAMETER ( DZERO = 0.0D0 ) -C .. Scalar Arguments .. - INTEGER INFO, LDABCD, LZWORK, M, MU, N, NINFZ, NKROL, - $ NU, P, RO, SIGMA - DOUBLE PRECISION SVLMAX, TOL -C .. Array Arguments .. - INTEGER INFZ(*), IWORK(*), KRONL(*) - COMPLEX*16 ABCD(LDABCD,*), ZWORK(*) - DOUBLE PRECISION DWORK(*) -C .. Local Scalars .. - LOGICAL LQUERY - INTEGER I1, IK, IROW, ITAU, IZ, JWORK, MM1, MNTAU, MNU, - $ MPM, NB, NP, RANK, RO1, TAU, WRKOPT - COMPLEX*16 TC -C .. Local Arrays .. - DOUBLE PRECISION SVAL(3) -C .. External Functions .. - INTEGER ILAENV - EXTERNAL ILAENV -C .. External Subroutines .. - EXTERNAL MB3OYZ, MB3PYZ, XERBLA, ZLAPMT, ZLARFG, ZLASET, - $ ZLATZM, ZUNMQR, ZUNMRQ -C .. Intrinsic Functions .. - INTRINSIC DCONJG, INT, MAX, MIN -C .. Executable Statements .. -C - NP = N + P - MPM = MIN( P, M ) - INFO = 0 - LQUERY = ( LZWORK.EQ.-1 ) -C -C Test the input scalar arguments. -C - IF( N.LT.0 ) THEN - INFO = -1 - ELSE IF( M.LT.0 ) THEN - INFO = -2 - ELSE IF( P.LT.0 ) THEN - INFO = -3 - ELSE IF( RO.NE.P .AND. RO.NE.MAX( P-M, 0 ) ) THEN - INFO = -4 - ELSE IF( SIGMA.NE.0 .AND. SIGMA.NE.M ) THEN - INFO = -5 - ELSE IF( SVLMAX.LT.DZERO ) THEN - INFO = -6 - ELSE IF( LDABCD.LT.MAX( 1, NP ) ) THEN - INFO = -8 - ELSE IF( NINFZ.LT.0 ) THEN - INFO = -9 - ELSE - JWORK = MAX( 1, MPM + MAX( 3*M - 1, N ), - $ MIN( P, N ) + MAX( 3*P - 1, NP, N+M ) ) - IF( LQUERY ) THEN - IF( M.GT.0 ) THEN - NB = MIN( 64, ILAENV( 1, 'ZUNMQR', 'LC', P, N, MPM, - $ -1 ) ) - WRKOPT = MAX( JWORK, MPM + MAX( 1, N )*NB ) - ELSE - WRKOPT = JWORK - END IF - NB = MIN( 64, ILAENV( 1, 'ZUNMRQ', 'RC', NP, N, MIN( P, N ), - $ -1 ) ) - WRKOPT = MAX( WRKOPT, MIN( P, N ) + MAX( 1, NP )*NB ) - NB = MIN( 64, ILAENV( 1, 'ZUNMRQ', 'LN', N, M+N, - $ MIN( P, N ), -1 ) ) - WRKOPT = MAX( WRKOPT, MIN( P, N ) + MAX( 1, M+N )*NB ) - ELSE IF( LZWORK.LT.JWORK ) THEN - INFO = -19 - END IF - END IF -C - IF ( INFO.NE.0 ) THEN -C -C Error return. -C - CALL XERBLA( 'AB8NXZ', -INFO ) - RETURN - ELSE IF( LQUERY ) THEN - ZWORK(1) = WRKOPT - RETURN - END IF -C - MU = P - NU = N -C - IZ = 0 - IK = 1 - MM1 = M + 1 - ITAU = 1 - NKROL = 0 - WRKOPT = 1 -C -C Main reduction loop: -C -C M NU M NU -C NU [ B A ] NU [ B A ] -C MU [ D C ] --> SIGMA [ RD C1 ] (SIGMA = rank(D) = -C TAU [ 0 C2 ] row size of RD) -C -C M NU-RO RO -C NU-RO [ B1 A11 A12 ] -C --> RO [ B2 A21 A22 ] (RO = rank(C2) = -C SIGMA [ RD C11 C12 ] col size of LC) -C TAU [ 0 0 LC ] -C -C M NU-RO -C NU-RO [ B1 A11 ] NU := NU - RO -C [----------] MU := RO + SIGMA -C --> RO [ B2 A21 ] D := [B2;RD] -C SIGMA [ RD C11 ] C := [A21;C11] -C - 20 IF ( MU.EQ.0 ) - $ GO TO 80 -C -C (Note: Comments in the code beginning "xWorkspace:", where x is -C I, D, or C, describe the minimal amount of integer, real and -C complex workspace needed at that point in the code, respectively, -C as well as the preferred amount for good performance.) -C - RO1 = RO - MNU = M + NU - IF ( M.GT.0 ) THEN - IF ( SIGMA.NE.0 ) THEN - IROW = NU + 1 -C -C Compress rows of D. First exploit triangular shape. -C CWorkspace: need M+N-1. -C - DO 40 I1 = 1, SIGMA - CALL ZLARFG( RO+1, ABCD(IROW,I1), ABCD(IROW+1,I1), 1, - $ TC ) - CALL ZLATZM( 'L', RO+1, MNU-I1, ABCD(IROW+1,I1), 1, - $ DCONJG( TC ), ABCD(IROW,I1+1), - $ ABCD(IROW+1,I1+1), LDABCD, ZWORK ) - IROW = IROW + 1 - 40 CONTINUE - CALL ZLASET( 'Lower', RO+SIGMA-1, SIGMA, ZERO, ZERO, - $ ABCD(NU+2,1), LDABCD ) - END IF -C -C Continue with Householder with column pivoting. -C -C The rank of D is the number of (estimated) singular values -C that are greater than TOL * MAX(SVLMAX,EMSV). This number -C includes the singular values of the first SIGMA columns. -C IWorkspace: need M; -C RWorkspace: need 2*M; -C CWorkspace: need min(RO1,M) + 3*M - 1. RO1 <= P. -C - IF ( SIGMA.LT.M ) THEN - JWORK = ITAU + MIN( RO1, M ) - I1 = SIGMA + 1 - IROW = NU + I1 - CALL MB3OYZ( RO1, M-SIGMA, ABCD(IROW,I1), LDABCD, TOL, - $ SVLMAX, RANK, SVAL, IWORK, ZWORK(ITAU), DWORK, - $ ZWORK(JWORK), INFO ) - WRKOPT = MAX( WRKOPT, JWORK + 3*M - 2 ) -C -C Apply the column permutations to matrices B and part of D. -C - CALL ZLAPMT( .TRUE., NU+SIGMA, M-SIGMA, ABCD(1,I1), LDABCD, - $ IWORK ) -C - IF ( RANK.GT.0 ) THEN -C -C Apply the Householder transformations to the submatrix C. -C CWorkspace: need min(RO1,M) + NU; -C prefer min(RO1,M) + NU*NB. -C - CALL ZUNMQR( 'Left', 'Conjugate', RO1, NU, RANK, - $ ABCD(IROW,I1), LDABCD, ZWORK(ITAU), - $ ABCD(IROW,MM1), LDABCD, ZWORK(JWORK), - $ LZWORK-JWORK+1, INFO ) - WRKOPT = MAX( WRKOPT, INT( ZWORK(JWORK) ) + JWORK - 1 ) - IF ( RO1.GT.1 ) - $ CALL ZLASET( 'Lower', RO1-1, MIN( RO1-1, RANK ), ZERO, - $ ZERO, ABCD(IROW+1,I1), LDABCD ) - RO1 = RO1 - RANK - END IF - END IF - END IF -C - TAU = RO1 - SIGMA = MU - TAU -C -C Determination of the orders of the infinite zeros. -C - IF ( IZ.GT.0 ) THEN - INFZ(IZ) = INFZ(IZ) + RO - TAU - NINFZ = NINFZ + IZ*( RO - TAU ) - END IF - IF ( RO1.EQ.0 ) - $ GO TO 80 - IZ = IZ + 1 -C - IF ( NU.LE.0 ) THEN - MU = SIGMA - NU = 0 - RO = 0 - ELSE -C -C Compress the columns of C2 using RQ factorization with row -C pivoting, P * C2 = R * Q. -C - I1 = NU + SIGMA + 1 - MNTAU = MIN( TAU, NU ) - JWORK = ITAU + MNTAU -C -C The rank of C2 is the number of (estimated) singular values -C greater than TOL * MAX(SVLMAX,EMSV). -C IWorkspace: need TAU; -C RWorkspace: need 2*TAU; -C CWorkspace: need min(TAU,NU) + 3*TAU - 1. -C - CALL MB3PYZ( TAU, NU, ABCD(I1,MM1), LDABCD, TOL, SVLMAX, RANK, - $ SVAL, IWORK, ZWORK(ITAU), DWORK, ZWORK(JWORK), - $ INFO ) - WRKOPT = MAX( WRKOPT, JWORK + 3*TAU - 1 ) - IF ( RANK.GT.0 ) THEN - IROW = I1 + TAU - RANK -C -C Apply Q' to the first NU columns of [A; C1] from the right. -C CWorkspace: need min(TAU,NU) + NU + SIGMA; SIGMA <= P; -C prefer min(TAU,NU) + (NU + SIGMA)*NB. -C - CALL ZUNMRQ( 'Right', 'ConjTranspose', I1-1, NU, RANK, - $ ABCD(IROW,MM1), LDABCD, ZWORK(MNTAU-RANK+1), - $ ABCD(1,MM1), LDABCD, ZWORK(JWORK), - $ LZWORK-JWORK+1, INFO ) - WRKOPT = MAX( WRKOPT, INT( ZWORK(JWORK) ) + JWORK - 1 ) -C -C Apply Q to the first NU rows and M + NU columns of [ B A ] -C from the left. -C CWorkspace: need min(TAU,NU) + M + NU; -C prefer min(TAU,NU) + (M + NU)*NB. -C - CALL ZUNMRQ( 'Left', 'NoTranspose', NU, MNU, RANK, - $ ABCD(IROW,MM1), LDABCD, ZWORK(MNTAU-RANK+1), - $ ABCD, LDABCD, ZWORK(JWORK), LZWORK-JWORK+1, - $ INFO ) - WRKOPT = MAX( WRKOPT, INT( ZWORK(JWORK) ) + JWORK - 1 ) -C - CALL ZLASET( 'Full', RANK, NU-RANK, ZERO, ZERO, - $ ABCD(IROW,MM1), LDABCD ) - IF ( RANK.GT.1 ) - $ CALL ZLASET( 'Lower', RANK-1, RANK-1, ZERO, ZERO, - $ ABCD(IROW+1,MM1+NU-RANK), LDABCD ) - END IF -C - RO = RANK - END IF -C -C Determine the left Kronecker indices (row indices). -C - KRONL(IK) = KRONL(IK) + TAU - RO - NKROL = NKROL + KRONL(IK) - IK = IK + 1 -C -C C and D are updated to [A21 ; C11] and [B2 ; RD]. -C - NU = NU - RO - MU = SIGMA + RO - IF ( RO.NE.0 ) - $ GO TO 20 -C - 80 CONTINUE - ZWORK(1) = WRKOPT - RETURN -C *** Last line of AB8NXZ *** - END diff --git a/mex/sources/libslicot/AG07BD.f b/mex/sources/libslicot/AG07BD.f deleted file mode 100644 index 5a7ab4c5a..000000000 --- a/mex/sources/libslicot/AG07BD.f +++ /dev/null @@ -1,273 +0,0 @@ - SUBROUTINE AG07BD( JOBE, N, M, A, LDA, E, LDE, B, LDB, C, LDC, - $ D, LDD, AI, LDAI, EI, LDEI, BI, LDBI, CI, LDCI, - $ DI, LDDI, INFO ) -C -C SLICOT RELEASE 5.0. -C -C Copyright (c) 2002-2009 NICONET e.V. -C -C This program is free software: you can redistribute it and/or -C modify it under the terms of the GNU General Public License as -C published by the Free Software Foundation, either version 2 of -C the License, or (at your option) any later version. -C -C This program is distributed in the hope that it will be useful, -C but WITHOUT ANY WARRANTY; without even the implied warranty of -C MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the -C GNU General Public License for more details. -C -C You should have received a copy of the GNU General Public License -C along with this program. If not, see -C . -C -C PURPOSE -C -C To compute the inverse (Ai-lambda*Ei,Bi,Ci,Di) of a given -C descriptor system (A-lambda*E,B,C,D). -C -C ARGUMENTS -C -C Mode Parameters -C -C JOBE CHARACTER*1 -C Specifies whether E is a general square or an identity -C matrix as follows: -C = 'G': E is a general square matrix; -C = 'I': E is the identity matrix. -C -C Input/Output Parameters -C -C N (input) INTEGER -C The order of the square matrices A and E; -C also the number of rows of matrix B and the number of -C columns of matrix C. N >= 0. -C -C M (input) INTEGER -C The number of system inputs and outputs, i.e., the number -C of columns of matrices B and D and the number of rows of -C matrices C and D. M >= 0. -C -C A (input) DOUBLE PRECISION array, dimension (LDA,N) -C The leading N-by-N part of this array must contain the -C state matrix A of the original system. -C -C LDA INTEGER -C The leading dimension of the array A. LDA >= MAX(1,N). -C -C E (input) DOUBLE PRECISION array, dimension (LDE,N) -C If JOBE = 'G', the leading N-by-N part of this array must -C contain the descriptor matrix E of the original system. -C If JOBE = 'I', then E is assumed to be the identity -C matrix and is not referenced. -C -C LDE INTEGER -C The leading dimension of the array E. -C LDE >= MAX(1,N), if JOBE = 'G'; -C LDE >= 1, if JOBE = 'I'. -C -C B (input) DOUBLE PRECISION array, dimension (LDB,M) -C The leading N-by-M part of this array must contain the -C input matrix B of the original system. -C -C LDB INTEGER -C The leading dimension of the array B. LDB >= MAX(1,N). -C -C C (input) DOUBLE PRECISION array, dimension (LDC,N) -C The leading M-by-N part of this array must contain the -C output matrix C of the original system. -C -C LDC INTEGER -C The leading dimension of the array C. LDC >= MAX(1,M). -C -C D (input) DOUBLE PRECISION array, dimension (LDD,M) -C The leading M-by-M part of this array must contain the -C feedthrough matrix D of the original system. -C -C LDD INTEGER -C The leading dimension of the array D. LDD >= MAX(1,M). -C -C AI (output) DOUBLE PRECISION array, dimension (LDAI,N+M) -C The leading (N+M)-by-(N+M) part of this array contains -C the state matrix Ai of the inverse system. -C If LDAI = LDA >= N+M, then AI and A can share the same -C storage locations. -C -C LDAI INTEGER -C The leading dimension of the array AI. -C LDAI >= MAX(1,N+M). -C -C EI (output) DOUBLE PRECISION array, dimension (LDEI,N+M) -C The leading (N+M)-by-(N+M) part of this array contains -C the descriptor matrix Ei of the inverse system. -C If LDEI = LDE >= N+M, then EI and E can share the same -C storage locations. -C -C LDEI INTEGER -C The leading dimension of the array EI. -C LDEI >= MAX(1,N+M). -C -C BI (output) DOUBLE PRECISION array, dimension (LDBI,M) -C The leading (N+M)-by-M part of this array contains -C the input matrix Bi of the inverse system. -C If LDBI = LDB >= N+M, then BI and B can share the same -C storage locations. -C -C LDBI INTEGER -C The leading dimension of the array BI. -C LDBI >= MAX(1,N+M). -C -C CI (output) DOUBLE PRECISION array, dimension (LDCI,N+M) -C The leading M-by-(N+M) part of this array contains -C the output matrix Ci of the inverse system. -C If LDCI = LDC, CI and C can share the same storage -C locations. -C -C LDCI INTEGER -C The leading dimension of the array CI. LDCI >= MAX(1,M). -C -C DI (output) DOUBLE PRECISION array, dimension (LDDI,M) -C The leading M-by-M part of this array contains -C the feedthrough matrix Di = 0 of the inverse system. -C DI and D can share the same storage locations. -C -C LDDI INTEGER -C The leading dimension of the array DI. LDDI >= MAX(1,M). -C -C Error Indicator -C -C INFO INTEGER -C = 0: successful exit; -C < 0: if INFO = -i, the i-th argument had an illegal -C value. -C -C METHOD -C -C The matrices of the inverse system are computed with the formulas -C -C ( E 0 ) ( A B ) ( 0 ) -C Ei = ( ) , Ai = ( ) , Bi = ( ), -C ( 0 0 ) ( C D ) ( -I ) -C -C Ci = ( 0 I ), Di = 0. -C -C FURTHER COMMENTS -C -C The routine does not perform an invertibility test. This check can -C be performed by using the SLICOT routines AB08NX or AG08BY. -C -C CONTRIBUTORS -C -C A. Varga, German Aerospace Center, Oberpfaffenhofen, July 2000. -C -C REVISIONS -C -C V. Sima, Research Institute for Informatics, Bucharest, Mar. 2001. -C -C KEYWORDS -C -C Descriptor system, inverse system, state-space representation. -C -C ****************************************************************** -C -C .. Parameters .. - DOUBLE PRECISION ZERO, ONE - PARAMETER ( ZERO = 0.0D0, ONE = 1.0D0 ) -C .. Scalar Arguments .. - CHARACTER JOBE - INTEGER INFO, LDA, LDAI, LDB, LDBI, LDC, LDCI, - $ LDD, LDDI, LDE, LDEI, M, N -C .. Array Arguments .. - DOUBLE PRECISION A(LDA,*), AI(LDAI,*), B(LDB,*), BI(LDBI,*), - $ C(LDC,*), CI(LDCI,*), D(LDD,*), DI(LDDI,*), - $ E(LDE,*), EI(LDEI,*) -C .. Local Scalars .. - LOGICAL UNITE -C .. External Functions .. - LOGICAL LSAME - EXTERNAL LSAME -C .. External Subroutines .. - EXTERNAL DLACPY, DLASET, XERBLA -C .. Intrinsic Functions .. - INTRINSIC MAX -C .. Executable Statements .. -C - INFO = 0 -C -C Test the input scalar arguments. -C - UNITE = LSAME( JOBE, 'I' ) - IF( .NOT. ( LSAME( JOBE, 'G' ) .OR. UNITE ) ) THEN - INFO = -1 - ELSE IF( N.LT.0 ) THEN - INFO = -2 - ELSE IF( M.LT.0 ) THEN - INFO = -3 - ELSE IF( LDA.LT.MAX( 1, N ) ) THEN - INFO = -5 - ELSE IF( LDE.LT.1 .OR. ( .NOT.UNITE .AND. LDE.LT.N ) ) THEN - INFO = -7 - ELSE IF( LDB.LT.MAX( 1, N ) ) THEN - INFO = -9 - ELSE IF( LDC.LT.MAX( 1, M ) ) THEN - INFO = -11 - ELSE IF( LDD.LT.MAX( 1, M ) ) THEN - INFO = -13 - ELSE IF( LDAI.LT.MAX( 1, N+M ) ) THEN - INFO = -15 - ELSE IF( LDEI.LT.MAX( 1, N+M ) ) THEN - INFO = -17 - ELSE IF( LDBI.LT.MAX( 1, N+M ) ) THEN - INFO = -19 - ELSE IF( LDCI.LT.MAX( 1, M ) ) THEN - INFO = -21 - ELSE IF( LDDI.LT.MAX( 1, M ) ) THEN - INFO = -23 - END IF -C - IF ( INFO.NE.0 ) THEN -C -C Error return. -C - CALL XERBLA( 'AG07BD', -INFO ) - RETURN - END IF -C -C Quick return if possible. -C - IF ( M.EQ.0 ) - $ RETURN -C -C Form Ai. -C - CALL DLACPY( 'Full', N, N, A, LDA, AI, LDAI ) - CALL DLACPY( 'Full', M, N, C, LDC, AI(N+1,1), LDAI ) - CALL DLACPY( 'Full', N, M, B, LDB, AI(1,N+1), LDAI ) - CALL DLACPY( 'Full', M, M, D, LDD, AI(N+1,N+1), LDAI ) -C -C Form Ei. -C - IF( UNITE ) THEN - CALL DLASET( 'Full', N+M, N, ZERO, ONE, EI, LDEI ) - ELSE - CALL DLACPY( 'Full', N, N, E, LDE, EI, LDEI ) - CALL DLASET( 'Full', M, N, ZERO, ZERO, EI(N+1,1), LDEI ) - END IF - CALL DLASET( 'Full', N+M, M, ZERO, ZERO, EI(1,N+1), LDEI ) -C -C Form Bi. -C - CALL DLASET( 'Full', N, M, ZERO, ZERO, BI, LDBI ) - CALL DLASET( 'Full', M, M, ZERO, -ONE, BI(N+1,1), LDBI ) -C -C Form Ci. -C - CALL DLASET( 'Full', M, N, ZERO, ZERO, CI, LDCI ) - CALL DLASET( 'Full', M, M, ZERO, ONE, CI(1,N+1), LDCI ) -C -C Set Di. -C - CALL DLASET( 'Full', M, M, ZERO, ZERO, DI, LDDI ) -C - RETURN -C *** Last line of AG07BD *** - END diff --git a/mex/sources/libslicot/AG08BD.f b/mex/sources/libslicot/AG08BD.f deleted file mode 100644 index ff0cdcc81..000000000 --- a/mex/sources/libslicot/AG08BD.f +++ /dev/null @@ -1,628 +0,0 @@ - SUBROUTINE AG08BD( EQUIL, L, N, M, P, A, LDA, E, LDE, B, LDB, - $ C, LDC, D, LDD, NFZ, NRANK, NIZ, DINFZ, NKROR, - $ NINFE, NKROL, INFZ, KRONR, INFE, KRONL, - $ TOL, IWORK, DWORK, LDWORK, INFO ) -C -C SLICOT RELEASE 5.0. -C -C Copyright (c) 2002-2009 NICONET e.V. -C -C This program is free software: you can redistribute it and/or -C modify it under the terms of the GNU General Public License as -C published by the Free Software Foundation, either version 2 of -C the License, or (at your option) any later version. -C -C This program is distributed in the hope that it will be useful, -C but WITHOUT ANY WARRANTY; without even the implied warranty of -C MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the -C GNU General Public License for more details. -C -C You should have received a copy of the GNU General Public License -C along with this program. If not, see -C . -C -C PURPOSE -C -C To extract from the system pencil -C -C ( A-lambda*E B ) -C S(lambda) = ( ) -C ( C D ) -C -C a regular pencil Af-lambda*Ef which has the finite Smith zeros of -C S(lambda) as generalized eigenvalues. The routine also computes -C the orders of the infinite Smith zeros and determines the singular -C and infinite Kronecker structure of system pencil, i.e., the right -C and left Kronecker indices, and the multiplicities of infinite -C eigenvalues. -C -C ARGUMENTS -C -C Mode Parameters -C -C EQUIL CHARACTER*1 -C Specifies whether the user wishes to balance the system -C matrix as follows: -C = 'S': Perform balancing (scaling); -C = 'N': Do not perform balancing. -C -C Input/Output Parameters -C -C L (input) INTEGER -C The number of rows of matrices A, B, and E. L >= 0. -C -C N (input) INTEGER -C The number of columns of matrices A, E, and C. N >= 0. -C -C M (input) INTEGER -C The number of columns of matrix B. M >= 0. -C -C P (input) INTEGER -C The number of rows of matrix C. P >= 0. -C -C A (input/output) DOUBLE PRECISION array, dimension (LDA,N) -C On entry, the leading L-by-N part of this array must -C contain the state dynamics matrix A of the system. -C On exit, the leading NFZ-by-NFZ part of this array -C contains the matrix Af of the reduced pencil. -C -C LDA INTEGER -C The leading dimension of array A. LDA >= MAX(1,L). -C -C E (input/output) DOUBLE PRECISION array, dimension (LDE,N) -C On entry, the leading L-by-N part of this array must -C contain the descriptor matrix E of the system. -C On exit, the leading NFZ-by-NFZ part of this array -C contains the matrix Ef of the reduced pencil. -C -C LDE INTEGER -C The leading dimension of array E. LDE >= MAX(1,L). -C -C B (input/output) DOUBLE PRECISION array, dimension (LDB,M) -C On entry, the leading L-by-M part of this array must -C contain the input/state matrix B of the system. -C On exit, this matrix does not contain useful information. -C -C LDB INTEGER -C The leading dimension of array B. -C LDB >= MAX(1,L) if M > 0; -C LDB >= 1 if M = 0. -C -C C (input/output) DOUBLE PRECISION array, dimension (LDC,N) -C On entry, the leading P-by-N part of this array must -C contain the state/output matrix C of the system. -C On exit, this matrix does not contain useful information. -C -C LDC INTEGER -C The leading dimension of array C. LDC >= MAX(1,P). -C -C D (input) DOUBLE PRECISION array, dimension (LDD,M) -C The leading P-by-M part of this array must contain the -C direct transmission matrix D of the system. -C -C LDD INTEGER -C The leading dimension of array D. LDD >= MAX(1,P). -C -C NFZ (output) INTEGER -C The number of finite zeros. -C -C NRANK (output) INTEGER -C The normal rank of the system pencil. -C -C NIZ (output) INTEGER -C The number of infinite zeros. -C -C DINFZ (output) INTEGER -C The maximal multiplicity of infinite Smith zeros. -C -C NKROR (output) INTEGER -C The number of right Kronecker indices. -C -C NINFE (output) INTEGER -C The number of elementary infinite blocks. -C -C NKROL (output) INTEGER -C The number of left Kronecker indices. -C -C INFZ (output) INTEGER array, dimension (N+1) -C The leading DINFZ elements of INFZ contain information -C on the infinite elementary divisors as follows: -C the system has INFZ(i) infinite elementary divisors of -C degree i in the Smith form, where i = 1,2,...,DINFZ. -C -C KRONR (output) INTEGER array, dimension (N+M+1) -C The leading NKROR elements of this array contain the -C right Kronecker (column) indices. -C -C INFE (output) INTEGER array, dimension (1+MIN(L+P,N+M)) -C The leading NINFE elements of INFE contain the -C multiplicities of infinite eigenvalues. -C -C KRONL (output) INTEGER array, dimension (L+P+1) -C The leading NKROL elements of this array contain the -C left Kronecker (row) indices. -C -C Tolerances -C -C TOL DOUBLE PRECISION -C A tolerance used in rank decisions to determine the -C effective rank, which is defined as the order of the -C largest leading (or trailing) triangular submatrix in the -C QR (or RQ) factorization with column (or row) pivoting -C whose estimated condition number is less than 1/TOL. -C If the user sets TOL <= 0, then default tolerances are -C used instead, as follows: TOLDEF = L*N*EPS in TG01FD -C (to determine the rank of E) and TOLDEF = (L+P)*(N+M)*EPS -C in the rest, where EPS is the machine precision -C (see LAPACK Library routine DLAMCH). TOL < 1. -C -C Workspace -C -C IWORK INTEGER array, dimension N+max(1,M) -C On output, IWORK(1) contains the normal rank of the -C transfer function matrix. -C -C DWORK DOUBLE PRECISION array, dimension (LDWORK) -C On exit, if INFO = 0, DWORK(1) returns the optimal value -C of LDWORK. -C -C LDWORK INTEGER -C The length of the array DWORK. -C LDWORK >= max( 4*(L+N), LDW ), if EQUIL = 'S', -C LDWORK >= LDW, if EQUIL = 'N', where -C LDW = max(L+P,M+N)*(M+N) + max(1,5*max(L+P,M+N)). -C For optimum performance LDWORK should be larger. -C -C If LDWORK = -1, then a workspace query is assumed; -C the routine only calculates the optimal size of the -C DWORK array, returns this value as the first entry of -C the DWORK array, and no error message related to LDWORK -C is issued by XERBLA. -C -C Error Indicator -C -C INFO INTEGER -C = 0: successful exit; -C < 0: if INFO = -i, the i-th argument had an illegal -C value. -C -C METHOD -C -C The routine extracts from the system matrix of a descriptor -C system (A-lambda*E,B,C,D) a regular pencil Af-lambda*Ef which -C has the finite zeros of the system as generalized eigenvalues. -C The procedure has the following main computational steps: -C -C (a) construct the (L+P)-by-(N+M) system pencil -C -C S(lambda) = ( B A )-lambda*( 0 E ); -C ( D C ) ( 0 0 ) -C -C (b) reduce S(lambda) to S1(lambda) with the same finite -C zeros and right Kronecker structure but with E -C upper triangular and nonsingular; -C -C (c) reduce S1(lambda) to S2(lambda) with the same finite -C zeros and right Kronecker structure but with D of -C full row rank; -C -C (d) reduce S2(lambda) to S3(lambda) with the same finite zeros -C and with D square invertible; -C -C (e) perform a unitary transformation on the columns of -C -C S3(lambda) = (A-lambda*E B) in order to reduce it to -C ( C D) -C -C (Af-lambda*Ef X), with Y and Ef square invertible; -C ( 0 Y) -C -C (f) compute the right and left Kronecker indices of the system -C matrix, which together with the multiplicities of the -C finite and infinite eigenvalues constitute the -C complete set of structural invariants under strict -C equivalence transformations of a linear system. -C -C REFERENCES -C -C [1] P. Misra, P. Van Dooren and A. Varga. -C Computation of structural invariants of generalized -C state-space systems. -C Automatica, 30, pp. 1921-1936, 1994. -C -C NUMERICAL ASPECTS -C -C The algorithm is backward stable (see [1]). -C -C FURTHER COMMENTS -C -C In order to compute the finite Smith zeros of the system -C explicitly, a call to this routine may be followed by a -C call to the LAPACK Library routines DGEGV or DGGEV. -C -C CONTRIBUTOR -C -C A. Varga, German Aerospace Center, DLR Oberpfaffenhofen, -C May 1999. -C -C REVISIONS -C -C V. Sima, Research Institute for Informatics, Bucharest, Sep. 1999, -C Jan. 2009, Mar. 2009, Apr. 2009. -C A. Varga, DLR Oberpfaffenhofen, Nov. 1999, Feb. 2002, Mar. 2002. -C -C KEYWORDS -C -C Generalized eigenvalue problem, Kronecker indices, multivariable -C system, orthogonal transformation, structural invariant. -C -C ****************************************************************** -C -C .. Parameters .. - DOUBLE PRECISION ONE, ZERO - PARAMETER ( ONE = 1.0D0, ZERO = 0.0D0 ) -C .. Scalar Arguments .. - CHARACTER EQUIL - INTEGER DINFZ, INFO, L, LDA, LDB, LDC, LDD, LDE, LDWORK, - $ M, N, NFZ, NINFE, NIZ, NKROL, NKROR, NRANK, P - DOUBLE PRECISION TOL -C .. Array Arguments .. - INTEGER INFE(*), INFZ(*), IWORK(*), KRONL(*), KRONR(*) - DOUBLE PRECISION A(LDA,*), B(LDB,*), C(LDC,*), D(LDD,*), - $ DWORK(*), E(LDE,*) -C .. Local Scalars .. - LOGICAL LEQUIL, LQUERY - INTEGER I, I0, I1, II, IPD, ITAU, J, JWORK, KABCD, - $ LABCD2, LDABCD, LDW, MM, MU, N2, NB, NN, NSINFE, - $ NU, NUMU, PP, WRKOPT - DOUBLE PRECISION SVLMAX, TOLER -C .. Local Arrays .. - DOUBLE PRECISION DUM(1) -C .. External Functions .. - LOGICAL LSAME - INTEGER ILAENV - DOUBLE PRECISION DLAMCH, DLANGE - EXTERNAL DLAMCH, DLANGE, ILAENV, LSAME -C .. External Subroutines .. - EXTERNAL AG08BY, DLACPY, DLASET, DORMRZ, DTZRZF, MA02BD, - $ MA02CD, TB01XD, TG01AD, TG01FD, XERBLA -C .. Intrinsic Functions .. - INTRINSIC DBLE, INT, MAX, MIN -C .. Executable Statements .. -C - INFO = 0 - LDABCD = MAX( L+P, N+M ) - LABCD2 = LDABCD*( N+M ) - LEQUIL = LSAME( EQUIL, 'S' ) - LQUERY = ( LDWORK.EQ.-1 ) -C -C Test the input scalar arguments. -C - IF( .NOT.LEQUIL .AND. .NOT.LSAME( EQUIL, 'N' ) ) THEN - INFO = -1 - ELSE IF( L.LT.0 ) THEN - INFO = -2 - ELSE IF( N.LT.0 ) THEN - INFO = -3 - ELSE IF( M.LT.0 ) THEN - INFO = -4 - ELSE IF( P.LT.0 ) THEN - INFO = -5 - ELSE IF( LDA.LT.MAX( 1, L ) ) THEN - INFO = -7 - ELSE IF( LDE.LT.MAX( 1, L ) ) THEN - INFO = -9 - ELSE IF( LDB.LT.1 .OR. ( M.GT.0 .AND. LDB.LT.L ) ) THEN - INFO = -11 - ELSE IF( LDC.LT.MAX( 1, P ) ) THEN - INFO = -13 - ELSE IF( LDD.LT.MAX( 1, P ) ) THEN - INFO = -15 - ELSE IF( TOL.GE.ONE ) THEN - INFO = -27 - ELSE - I0 = MIN( L+P, M+N ) - I1 = MIN( L, N ) - II = MIN( M, P ) - LDW = LABCD2 + MAX( 1, 5*LDABCD ) - IF( LEQUIL ) - $ LDW = MAX( 4*( L + N ), LDW ) - IF( LQUERY ) THEN - CALL TG01FD( 'N', 'N', 'N', L, N, M, P, A, LDA, E, LDE, B, - $ LDB, C, LDC, DUM, 1, DUM, 1, NN, N2, TOL, - $ IWORK, DWORK, -1, INFO ) - WRKOPT = MAX( LDW, INT( DWORK(1) ) ) - SVLMAX = ZERO - CALL AG08BY( .TRUE., I1, M+N, P+L, SVLMAX, DWORK, LDABCD+I1, - $ E, LDE, NU, MU, NIZ, DINFZ, NKROL, INFZ, KRONL, - $ TOL, IWORK, DWORK, -1, INFO ) - WRKOPT = MAX( WRKOPT, LABCD2 + INT( DWORK(1) ) ) - CALL AG08BY( .FALSE., I1, II, M+N, SVLMAX, DWORK, LDABCD+I1, - $ E, LDE, NU, MU, NIZ, DINFZ, NKROL, INFZ, KRONL, - $ TOL, IWORK, DWORK, -1, INFO ) - WRKOPT = MAX( WRKOPT, LABCD2 + INT( DWORK(1) ) ) - NB = ILAENV( 1, 'ZGERQF', ' ', II, I1+II, -1, -1 ) - WRKOPT = MAX( WRKOPT, LABCD2 + II + II*NB ) - NB = MIN( 64, ILAENV( 1, 'DORMRQ', 'RT', I1, I1+II, II, - $ -1 ) ) - WRKOPT = MAX( WRKOPT, LABCD2 + II + I1*NB ) - ELSE IF( LDWORK.LT.LDW ) THEN - INFO = -30 - END IF - END IF -C - IF( INFO.NE.0 ) THEN -C -C Error return. -C - CALL XERBLA( 'AG08BD', -INFO ) - RETURN - ELSE IF( LQUERY ) THEN - DWORK(1) = WRKOPT - RETURN - END IF -C - NIZ = 0 - NKROL = 0 - NKROR = 0 -C -C Quick return if possible. -C - IF( MAX( L, N, M, P ).EQ.0 ) THEN - NFZ = 0 - DINFZ = 0 - NINFE = 0 - NRANK = 0 - IWORK(1) = 0 - DWORK(1) = ONE - RETURN - END IF -C -C (Note: Comments in the code beginning "Workspace:" describe the -C minimal amount of real workspace needed at that point in the -C code, as well as the preferred amount for good performance.) -C - WRKOPT = 1 - KABCD = 1 - JWORK = KABCD + LABCD2 -C -C If required, balance the system pencil. -C Workspace: need 4*(L+N). -C - IF( LEQUIL ) THEN - CALL TG01AD( 'A', L, N, M, P, ZERO, A, LDA, E, LDE, B, LDB, - $ C, LDC, DWORK, DWORK(L+1), DWORK(L+N+1), INFO ) - WRKOPT = 4*(L+N) - END IF - SVLMAX = DLANGE( 'Frobenius', L, N, E, LDE, DWORK ) -C -C Reduce the system matrix to QR form, -C -C ( A11-lambda*E11 A12 B1 ) -C ( A21 A22 B2 ) , -C ( C1 C2 D ) -C -C with E11 invertible and upper triangular. -C Real workspace: need max( 1, N+P, min(L,N)+max(3*N-1,M,L) ); -C prefer larger. -C Integer workspace: N. -C - CALL TG01FD( 'N', 'N', 'N', L, N, M, P, A, LDA, E, LDE, B, LDB, - $ C, LDC, DUM, 1, DUM, 1, NN, N2, TOL, IWORK, DWORK, - $ LDWORK, INFO ) - WRKOPT = MAX( WRKOPT, INT( DWORK(1) ) ) -C -C Construct the system pencil -C -C MM NN -C ( B1 A12 A11-lambda*E11 ) NN -C S1(lambda) = ( B2 A22 A21 ) L-NN -C ( D C2 C1 ) P -C -C of dimension (L+P)-by-(M+N). -C Workspace: need LABCD2 = max( L+P, N+M )*( N+M ). -C - N2 = N - NN - MM = M + N2 - PP = P + ( L - NN ) - CALL DLACPY( 'Full', L, M, B, LDB, DWORK(KABCD), LDABCD ) - CALL DLACPY( 'Full', P, M, D, LDD, DWORK(KABCD+L), LDABCD ) - CALL DLACPY( 'Full', L, N2, A(1,NN+1), LDA, - $ DWORK(KABCD+LDABCD*M), LDABCD ) - CALL DLACPY( 'Full', P, N2, C(1,NN+1), LDC, - $ DWORK(KABCD+LDABCD*M+L), LDABCD ) - CALL DLACPY( 'Full', L, NN, A, LDA, - $ DWORK(KABCD+LDABCD*MM), LDABCD ) - CALL DLACPY( 'Full', P, NN, C, LDC, - $ DWORK(KABCD+LDABCD*MM+L), LDABCD ) -C -C If required, set tolerance. -C - TOLER = TOL - IF( TOLER.LE.ZERO ) THEN - TOLER = DBLE( ( L + P )*( M + N ) ) * DLAMCH( 'Precision' ) - END IF - SVLMAX = MAX( SVLMAX, - $ DLANGE( 'Frobenius', NN+PP, NN+MM, DWORK(KABCD), - $ LDABCD, DWORK(JWORK) ) ) -C -C Extract the reduced pencil S2(lambda) -C -C ( Bc Ac-lambda*Ec ) -C ( Dc Cc ) -C -C having the same finite Smith zeros as the system pencil -C S(lambda) but with Dc, a MU-by-MM full row rank -C left upper trapezoidal matrix, and Ec, an NU-by-NU -C upper triangular nonsingular matrix. -C -C Real workspace: need max( min(P+L,M+N)+max(min(L,N),3*(M+N)-1), -C 5*(P+L), 1 ) + LABCD2; -C prefer larger. -C Integer workspace: MM, MM <= M+N; PP <= P+L. -C - CALL AG08BY( .TRUE., NN, MM, PP, SVLMAX, DWORK(KABCD), LDABCD, - $ E, LDE, NU, MU, NIZ, DINFZ, NKROL, INFZ, KRONL, - $ TOLER, IWORK, DWORK(JWORK), LDWORK-JWORK+1, INFO ) -C - WRKOPT = MAX( WRKOPT, INT( DWORK(JWORK) ) + JWORK - 1 ) -C -C Set the number of simple (nondynamic) infinite eigenvalues -C and the normal rank of the system pencil. -C - NSINFE = MU - NRANK = NN + MU -C -C Pertranspose the system. -C - CALL TB01XD( 'D', NU, MM, MM, MAX( 0, NU-1 ), MAX( 0, NU-1 ), - $ DWORK(KABCD+LDABCD*MM), LDABCD, - $ DWORK(KABCD), LDABCD, - $ DWORK(KABCD+LDABCD*MM+NU), LDABCD, - $ DWORK(KABCD+NU), LDABCD, INFO ) - CALL MA02BD( 'Right', NU+MM, MM, DWORK(KABCD), LDABCD ) - CALL MA02BD( 'Left', MM, NU+MM, DWORK(KABCD+NU), LDABCD ) - CALL MA02CD( NU, 0, MAX( 0, NU-1 ), E, LDE ) -C - IF( MU.NE.MM ) THEN - NN = NU - PP = MM - MM = MU - KABCD = KABCD + ( PP - MM )*LDABCD -C -C Extract the reduced pencil S3(lambda), -C -C ( Br Ar-lambda*Er ) , -C ( Dr Cr ) -C -C having the same finite Smith zeros as the pencil S(lambda), -C but with Dr, an MU-by-MU invertible upper triangular matrix, -C and Er, an NU-by-NU upper triangular nonsingular matrix. -C -C Workspace: need max( 1, 5*(M+N) ) + LABCD2. -C prefer larger. -C No integer workspace necessary. -C - CALL AG08BY( .FALSE., NN, MM, PP, SVLMAX, DWORK(KABCD), LDABCD, - $ E, LDE, NU, MU, I0, I1, NKROR, IWORK, KRONR, - $ TOLER, IWORK, DWORK(JWORK), LDWORK-JWORK+1, INFO ) -C - WRKOPT = MAX( WRKOPT, INT( DWORK(JWORK) ) + JWORK - 1 ) - END IF -C - IF( NU.NE.0 ) THEN -C -C Perform a unitary transformation on the columns of -C ( Br Ar-lambda*Er ) -C ( Dr Cr ) -C in order to reduce it to -C ( * Af-lambda*Ef ) -C ( Y 0 ) -C with Y and Ef square invertible. -C -C Compute Af by reducing ( Br Ar ) to ( * Af ) . -C ( Dr Cr ) ( Y 0 ) -C - NUMU = NU + MU - IPD = KABCD + NU - ITAU = JWORK - JWORK = ITAU + MU -C -C Workspace: need LABCD2 + 2*min(M,P); -C prefer LABCD2 + min(M,P) + min(M,P)*NB. -C - CALL DTZRZF( MU, NUMU, DWORK(IPD), LDABCD, DWORK(ITAU), - $ DWORK(JWORK), LDWORK-JWORK+1, INFO ) - WRKOPT = MAX( WRKOPT, INT( DWORK(JWORK) ) + JWORK - 1 ) -C -C Workspace: need LABCD2 + min(M,P) + min(L,N); -C prefer LABCD2 + min(M,P) + min(L,N)*NB. -C - CALL DORMRZ( 'Right', 'Transpose', NU, NUMU, MU, NU, - $ DWORK(IPD), LDABCD, DWORK(ITAU), DWORK(KABCD), - $ LDABCD, DWORK(JWORK), LDWORK-JWORK+1, INFO ) - WRKOPT = MAX( WRKOPT, INT( DWORK(JWORK) ) + JWORK - 1 ) -C -C Save Af. -C - CALL DLACPY( 'Full', NU, NU, DWORK(KABCD+LDABCD*MU), LDABCD, A, - $ LDA ) -C -C Compute Ef by applying the saved transformations from previous -C reduction to ( 0 Er ) . -C - CALL DLASET( 'Full', NU, MU, ZERO, ZERO, DWORK(KABCD), LDABCD ) - CALL DLACPY( 'Full', NU, NU, E, LDE, DWORK(KABCD+LDABCD*MU), - $ LDABCD ) -C - CALL DORMRZ( 'Right', 'Transpose', NU, NUMU, MU, NU, - $ DWORK(IPD), LDABCD, DWORK(ITAU), DWORK(KABCD), - $ LDABCD, DWORK(JWORK), LDWORK-JWORK+1, INFO ) -C -C Save Ef. -C - CALL DLACPY( 'Full', NU, NU, DWORK(KABCD+LDABCD*MU), LDABCD, E, - $ LDE ) - END IF -C - NFZ = NU -C -C Set right Kronecker indices (column indices). -C - DO 10 I = 1, NKROR - IWORK(I) = KRONR(I) - 10 CONTINUE -C - J = 0 - DO 30 I = 1, NKROR - DO 20 II = J + 1, J + IWORK(I) - KRONR(II) = I - 1 - 20 CONTINUE - J = J + IWORK(I) - 30 CONTINUE -C - NKROR = J -C -C Set left Kronecker indices (row indices). -C - DO 40 I = 1, NKROL - IWORK(I) = KRONL(I) - 40 CONTINUE -C - J = 0 - DO 60 I = 1, NKROL - DO 50 II = J + 1, J + IWORK(I) - KRONL(II) = I - 1 - 50 CONTINUE - J = J + IWORK(I) - 60 CONTINUE -C - NKROL = J -C -C Determine the number of simple infinite blocks -C as the difference between the number of infinite blocks -C of order greater than one and the order of Dr. -C - NINFE = 0 - DO 70 I = 1, DINFZ - NINFE = NINFE + INFZ(I) - 70 CONTINUE - NINFE = NSINFE - NINFE - DO 80 I = 1, NINFE - INFE(I) = 1 - 80 CONTINUE -C -C Set the structure of infinite eigenvalues. -C - DO 100 I = 1, DINFZ - DO 90 II = NINFE + 1, NINFE + INFZ(I) - INFE(II) = I + 1 - 90 CONTINUE - NINFE = NINFE + INFZ(I) - 100 CONTINUE -C - IWORK(1) = NSINFE - DWORK(1) = WRKOPT - RETURN -C *** Last line of AG08BD *** - END diff --git a/mex/sources/libslicot/AG08BY.f b/mex/sources/libslicot/AG08BY.f deleted file mode 100644 index 7e980bf87..000000000 --- a/mex/sources/libslicot/AG08BY.f +++ /dev/null @@ -1,680 +0,0 @@ - SUBROUTINE AG08BY( FIRST, N, M, P, SVLMAX, ABCD, LDABCD, E, LDE, - $ NR, PR, NINFZ, DINFZ, NKRONL, INFZ, KRONL, - $ TOL, IWORK, DWORK, LDWORK, INFO ) -C -C SLICOT RELEASE 5.0. -C -C Copyright (c) 2002-2009 NICONET e.V. -C -C This program is free software: you can redistribute it and/or -C modify it under the terms of the GNU General Public License as -C published by the Free Software Foundation, either version 2 of -C the License, or (at your option) any later version. -C -C This program is distributed in the hope that it will be useful, -C but WITHOUT ANY WARRANTY; without even the implied warranty of -C MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the -C GNU General Public License for more details. -C -C You should have received a copy of the GNU General Public License -C along with this program. If not, see -C . -C -C PURPOSE -C -C To extract from the (N+P)-by-(M+N) descriptor system pencil -C -C S(lambda) = ( B A - lambda*E ) -C ( D C ) -C -C with E nonsingular and upper triangular a -C (NR+PR)-by-(M+NR) "reduced" descriptor system pencil -C -C ( Br Ar-lambda*Er ) -C Sr(lambda) = ( ) -C ( Dr Cr ) -C -C having the same finite Smith zeros as the pencil -C S(lambda) but with Dr, a PR-by-M full row rank -C left upper trapezoidal matrix, and Er, an NR-by-NR -C upper triangular nonsingular matrix. -C -C ARGUMENTS -C -C Mode Parameters -C -C FIRST LOGICAL -C Specifies if AG08BY is called first time or it is called -C for an already reduced system, with D full column rank -C with the last M rows in upper triangular form: -C FIRST = .TRUE., first time called; -C FIRST = .FALSE., not first time called. -C -C Input/Output Parameters -C -C N (input) INTEGER -C The number of rows of matrix B, the number of columns of -C matrix C and the order of square matrices A and E. -C N >= 0. -C -C M (input) INTEGER -C The number of columns of matrices B and D. M >= 0. -C M <= P if FIRST = .FALSE. . -C -C P (input) INTEGER -C The number of rows of matrices C and D. P >= 0. -C -C SVLMAX (input) DOUBLE PRECISION -C During each reduction step, the rank-revealing QR -C factorization of a matrix stops when the estimated minimum -C singular value is smaller than TOL * MAX(SVLMAX,EMSV), -C where EMSV is the estimated maximum singular value. -C SVLMAX >= 0. -C -C ABCD (input/output) DOUBLE PRECISION array, dimension -C (LDABCD,M+N) -C On entry, the leading (N+P)-by-(M+N) part of this array -C must contain the compound matrix -C ( B A ) , -C ( D C ) -C where A is an N-by-N matrix, B is an N-by-M matrix, -C C is a P-by-N matrix and D is a P-by-M matrix. -C If FIRST = .FALSE., then D must be a full column -C rank matrix with the last M rows in upper triangular form. -C On exit, the leading (NR+PR)-by-(M+NR) part of ABCD -C contains the reduced compound matrix -C ( Br Ar ) , -C ( Dr Cr ) -C where Ar is an NR-by-NR matrix, Br is an NR-by-M matrix, -C Cr is a PR-by-NR matrix, Dr is a PR-by-M full row rank -C left upper trapezoidal matrix with the first PR columns -C in upper triangular form. -C -C LDABCD INTEGER -C The leading dimension of array ABCD. -C LDABCD >= MAX(1,N+P). -C -C E (input/output) DOUBLE PRECISION array, dimension (LDE,N) -C On entry, the leading N-by-N part of this array must -C contain the upper triangular nonsingular matrix E. -C On exit, the leading NR-by-NR part contains the reduced -C upper triangular nonsingular matrix Er. -C -C LDE INTEGER -C The leading dimension of array E. LDE >= MAX(1,N). -C -C NR (output) INTEGER -C The order of the reduced matrices Ar and Er; also the -C number of rows of the reduced matrix Br and the number -C of columns of the reduced matrix Cr. -C If Dr is invertible, NR is also the number of finite -C Smith zeros. -C -C PR (output) INTEGER -C The rank of the resulting matrix Dr; also the number of -C rows of reduced matrices Cr and Dr. -C -C NINFZ (output) INTEGER -C Number of infinite zeros. NINFZ = 0 if FIRST = .FALSE. . -C -C DINFZ (output) INTEGER -C The maximal multiplicity of infinite zeros. -C DINFZ = 0 if FIRST = .FALSE. . -C -C NKRONL (output) INTEGER -C The maximal dimension of left elementary Kronecker blocks. -C -C INFZ (output) INTEGER array, dimension (N) -C INFZ(i) contains the number of infinite zeros of -C degree i, where i = 1,2,...,DINFZ. -C INFZ is not referenced if FIRST = .FALSE. . -C -C KRONL (output) INTEGER array, dimension (N+1) -C KRONL(i) contains the number of left elementary Kronecker -C blocks of dimension i-by-(i-1), where i = 1,2,...,NKRONL. -C -C Tolerances -C -C TOL DOUBLE PRECISION -C A tolerance used in rank decisions to determine the -C effective rank, which is defined as the order of the -C largest leading (or trailing) triangular submatrix in the -C QR (or RQ) factorization with column (or row) pivoting -C whose estimated condition number is less than 1/TOL. -C If the user sets TOL <= 0, then an implicitly computed, -C default tolerance TOLDEF = (N+P)*(N+M)*EPS, is used -C instead, where EPS is the machine precision -C (see LAPACK Library routine DLAMCH). -C NOTE that when SVLMAX > 0, the estimated ranks could be -C less than those defined above (see SVLMAX). TOL <= 1. -C -C Workspace -C -C IWORK INTEGER array, dimension (M) -C If FIRST = .FALSE., IWORK is not referenced. -C -C DWORK DOUBLE PRECISION array, dimension (LDWORK) -C On exit, if INFO = 0, DWORK(1) returns the optimal value -C of LDWORK. -C -C LDWORK INTEGER -C The length of the array DWORK. -C LDWORK >= 1, if P = 0; otherwise -C LDWORK >= MAX( 1, N+M-1, MIN(P,M) + MAX(3*M-1,N), 5*P ), -C if FIRST = .TRUE.; -C LDWORK >= MAX( 1, N+M-1, 5*P ), if FIRST = .FALSE. . -C The second term is not needed if M = 0. -C For optimum performance LDWORK should be larger. -C -C If LDWORK = -1, then a workspace query is assumed; -C the routine only calculates the optimal size of the -C DWORK array, returns this value as the first entry of -C the DWORK array, and no error message related to LDWORK -C is issued by XERBLA. -C -C Error Indicator -C -C INFO INTEGER -C = 0: successful exit; -C < 0: if INFO = -i, the i-th argument had an illegal -C value. -C -C METHOD -C -C The subroutine is based on the reduction algorithm of [1]. -C -C REFERENCES -C -C [1] P. Misra, P. Van Dooren and A. Varga. -C Computation of structural invariants of generalized -C state-space systems. -C Automatica, 30, pp. 1921-1936, 1994. -C -C NUMERICAL ASPECTS -C -C The algorithm is numerically backward stable and requires -C 0( (P+N)*(M+N)*N ) floating point operations. -C -C FURTHER COMMENTS -C -C The number of infinite zeros is computed as -C -C DINFZ -C NINFZ = Sum (INFZ(i)*i) . -C i=1 -C Note that each infinite zero of multiplicity k corresponds to -C an infinite eigenvalue of multiplicity k+1. -C The multiplicities of the infinite eigenvalues can be determined -C from PR, DINFZ and INFZ(i), i = 1, ..., DINFZ, as follows: -C -C DINFZ -C - there are PR - Sum (INFZ(i)) simple infinite eigenvalues; -C i=1 -C -C - there are INFZ(i) infinite eigenvalues with multiplicity i+1, -C for i = 1, ..., DINFZ. -C -C The left Kronecker indices are: -C -C [ 0 0 ... 0 | 1 1 ... 1 | .... | NKRONL ... NKRONL ] -C |<- KRONL(1) ->|<- KRONL(2) ->| |<- KRONL(NKRONL) ->| -C -C CONTRIBUTOR -C -C A. Varga, German Aerospace Center, DLR Oberpfaffenhofen. -C May 1999. Based on the RASP routine SRISEP. -C -C REVISIONS -C -C V. Sima, Research Institute for Informatics, Bucharest, Sep. 1999, -C Jan. 2009, Apr. 2009. -C A. Varga, DLR Oberpfaffenhofen, March 2002. -C -C KEYWORDS -C -C Generalized eigenvalue problem, Kronecker indices, multivariable -C system, orthogonal transformation, structural invariant. -C -C ****************************************************************** -C -C .. Parameters .. - INTEGER IMAX, IMIN - PARAMETER ( IMAX = 1, IMIN = 2 ) - DOUBLE PRECISION ONE, P05, ZERO - PARAMETER ( ONE = 1.0D0, P05 = 0.05D0, ZERO = 0.0D0 ) -C .. Scalar Arguments .. - INTEGER DINFZ, INFO, LDABCD, LDE, LDWORK, M, N, NINFZ, - $ NKRONL, NR, P, PR - DOUBLE PRECISION SVLMAX, TOL - LOGICAL FIRST -C .. Array Arguments .. - INTEGER INFZ( * ), IWORK(*), KRONL( * ) - DOUBLE PRECISION ABCD( LDABCD, * ), DWORK( * ), E( LDE, * ) -C .. Local Scalars .. - LOGICAL LQUERY - INTEGER I, ICOL, ILAST, IRC, IROW, ISMAX, ISMIN, ITAU, - $ J, JLAST, JWORK1, JWORK2, K, MN, MN1, MNR, - $ MNTAU, MP1, MPM, MUI, MUIM1, N1, NB, NBLCKS, - $ PN, RANK, RO, RO1, SIGMA, TAUI, WRKOPT - DOUBLE PRECISION C, C1, C2, RCOND, S, S1, S2, SMAX, SMAXPR, - $ SMIN, SMINPR, T, TT -C .. Local Arrays .. - DOUBLE PRECISION DUM(1), SVAL(3) -C .. External Functions .. - INTEGER IDAMAX, ILAENV - DOUBLE PRECISION DLAMCH, DNRM2 - EXTERNAL DLAMCH, DNRM2, IDAMAX, ILAENV -C .. External Subroutines .. - EXTERNAL DCOPY, DLAIC1, DLAPMT, DLARFG, DLARTG, DLASET, - $ DLATZM, DORMQR, DROT, DSWAP, MB03OY, XERBLA -C .. Intrinsic Functions .. - INTRINSIC ABS, DBLE, INT, MAX, MIN, SQRT -C .. Executable Statements .. -C -C Test the input parameters. -C - LQUERY = ( LDWORK.EQ.-1 ) - INFO = 0 - PN = P + N - MN = M + N - MPM = MIN( P, M ) - IF( N.LT.0 ) THEN - INFO = -2 - ELSE IF( M.LT.0 .OR. ( .NOT.FIRST .AND. M.GT.P ) ) THEN - INFO = -3 - ELSE IF( P.LT.0 ) THEN - INFO = -4 - ELSE IF( SVLMAX.LT.ZERO ) THEN - INFO = -5 - ELSE IF( LDABCD.LT.MAX( 1, PN ) ) THEN - INFO = -7 - ELSE IF( LDE.LT.MAX( 1, N ) ) THEN - INFO = -9 - ELSE IF( TOL.GT.ONE ) THEN - INFO = -17 - ELSE - WRKOPT = MAX( 1, 5*P ) - IF( P.GT.0 ) THEN - IF( M.GT.0 ) THEN - WRKOPT = MAX( WRKOPT, MN-1 ) - IF( FIRST ) THEN - WRKOPT = MAX( WRKOPT, MPM + MAX( 3*M-1, N ) ) - IF( LQUERY ) THEN - NB = MIN( 64, ILAENV( 1, 'DORMQR', 'LT', P, N, - $ MPM, -1 ) ) - WRKOPT = MAX( WRKOPT, MPM + MAX( 1, N )*NB ) - END IF - END IF - END IF - END IF - IF( LDWORK.LT.WRKOPT .AND. .NOT.LQUERY ) THEN - INFO = -20 - END IF - END IF - IF( INFO.NE.0 ) THEN - CALL XERBLA( 'AG08BY', -INFO ) - RETURN - ELSE IF( LQUERY ) THEN - DWORK(1) = WRKOPT - RETURN - END IF -C -C Initialize output variables. -C - PR = P - NR = N - DINFZ = 0 - NINFZ = 0 - NKRONL = 0 -C -C Quick return if possible. -C - IF( P.EQ.0 ) THEN - DWORK(1) = ONE - RETURN - END IF - IF( N.EQ.0 .AND. M.EQ.0 ) THEN - PR = 0 - NKRONL = 1 - KRONL(1) = P - DWORK(1) = ONE - RETURN - END IF -C - RCOND = TOL - IF( RCOND.LE.ZERO ) THEN -C -C Use the default tolerance in rank determination. -C - RCOND = DBLE( PN*MN )*DLAMCH( 'EPSILON' ) - END IF -C -C The D matrix is (RO+SIGMA)-by-M, where RO = P - SIGMA and -C SIGMA = 0 for FIRST = .TRUE. and SIGMA = M for FIRST = .FALSE.. -C The leading (RO+SIGMA)-by-SIGMA submatrix of D has full column -C rank, with the trailing SIGMA-by-SIGMA submatrix upper triangular. -C - IF( FIRST ) THEN - SIGMA = 0 - ELSE - SIGMA = M - END IF - RO = P - SIGMA - MP1 = M + 1 - MUI = 0 - DUM(1) = ZERO -C - ITAU = 1 - JWORK1 = ITAU + MPM - ISMIN = 2*P + 1 - ISMAX = ISMIN + P - JWORK2 = ISMAX + P - NBLCKS = 0 - WRKOPT = 1 -C - 10 IF( PR.EQ.0 ) GO TO 90 -C -C (NR+1,ICOL+1) points to the current position of matrix D. -C - RO1 = RO - MNR = M + NR - IF( M.GT.0 ) THEN -C -C Compress rows of D; first exploit the trapezoidal shape of the -C (RO+SIGMA)-by-SIGMA matrix in the first SIGMA columns of D; -C compress the first SIGMA columns without column pivoting: -C -C ( x x x x x ) ( x x x x x ) -C ( x x x x x ) ( 0 x x x x ) -C ( x x x x x ) - > ( 0 0 x x x ) -C ( 0 x x x x ) ( 0 0 0 x x ) -C ( 0 0 x x x ) ( 0 0 0 x x ) -C -C where SIGMA = 3 and RO = 2. -C Workspace: need maximum M+N-1. -C - IROW = NR - DO 20 ICOL = 1, SIGMA - IROW = IROW + 1 - CALL DLARFG( RO+1, ABCD(IROW,ICOL), ABCD(IROW+1,ICOL), 1, - $ T ) - CALL DLATZM( 'L', RO+1, MNR-ICOL, ABCD(IROW+1,ICOL), 1, T, - $ ABCD(IROW,ICOL+1), ABCD(IROW+1,ICOL+1), - $ LDABCD, DWORK ) - CALL DCOPY( PR-ICOL, DUM, 0, ABCD(IROW+1,ICOL), 1 ) - 20 CONTINUE - WRKOPT = MAX( WRKOPT, MN - 1 ) -C - IF( FIRST ) THEN -C -C Continue with Householder with column pivoting. -C -C ( x x x x x ) ( x x x x x ) -C ( 0 x x x x ) ( 0 x x x x ) -C ( 0 0 x x x ) - > ( 0 0 x x x ) -C ( 0 0 0 x x ) ( 0 0 0 x x ) -C ( 0 0 0 x x ) ( 0 0 0 0 0 ) -C -C Real workspace: need maximum min(P,M)+3*M-1; -C Integer workspace: need maximum M. -C - IROW = MIN( NR+SIGMA+1, PN ) - ICOL = MIN( SIGMA+1, M ) - CALL MB03OY( RO1, M-SIGMA, ABCD(IROW,ICOL), LDABCD, - $ RCOND, SVLMAX, RANK, SVAL, IWORK, DWORK(ITAU), - $ DWORK(JWORK1), INFO ) - WRKOPT = MAX( WRKOPT, JWORK1 + 3*M - 2 ) -C -C Apply the column permutations to B and part of D. -C - CALL DLAPMT( .TRUE., NR+SIGMA, M-SIGMA, ABCD(1,ICOL), - $ LDABCD, IWORK ) -C - IF( RANK.GT.0 ) THEN -C -C Apply the Householder transformations to the submatrix C. -C Workspace: need maximum min(P,M) + N; -C prefer maximum min(P,M) + N*NB. -C - CALL DORMQR( 'Left', 'Transpose', RO1, NR, RANK, - $ ABCD(IROW,ICOL), LDABCD, DWORK(ITAU), - $ ABCD(IROW,MP1), LDABCD, DWORK(JWORK1), - $ LDWORK-JWORK1+1, INFO ) - WRKOPT = MAX( WRKOPT, JWORK1 + INT( DWORK(JWORK1) ) - 1 ) - CALL DLASET( 'Lower', RO1-1, MIN( RO1-1, RANK ), ZERO, - $ ZERO, ABCD(MIN( IROW+1, PN ),ICOL), LDABCD ) - RO1 = RO1 - RANK - END IF - END IF -C -C Terminate if Dr has maximal row rank. -C - IF( RO1.EQ.0 ) GO TO 90 -C - END IF -C -C Update SIGMA. -C - SIGMA = PR - RO1 -C - NBLCKS = NBLCKS + 1 - TAUI = RO1 -C -C Compress the columns of current C to separate a TAUI-by-MUI -C full column rank block. -C - IF( NR.EQ.0 ) THEN -C -C Finish for zero state dimension. -C - PR = SIGMA - RANK = 0 - ELSE -C -C Perform RQ-decomposition with row pivoting on the current C -C while keeping E upper triangular. -C The current C is the TAUI-by-NR matrix delimited by rows -C IRC+1 to IRC+TAUI and columns M+1 to M+NR of ABCD. -C The rank of current C is computed in MUI. -C Workspace: need maximum 5*P. -C - IRC = NR + SIGMA - N1 = NR - IF( TAUI.GT.1 ) THEN -C -C Compute norms. -C - DO 30 I = 1, TAUI - DWORK(I) = DNRM2( NR, ABCD(IRC+I,MP1), LDABCD ) - DWORK(P+I) = DWORK(I) - 30 CONTINUE - END IF -C - RANK = 0 - MNTAU = MIN( TAUI, NR ) -C -C ICOL and IROW will point to the current pivot position in C. -C - ILAST = NR + PR - JLAST = M + NR - IROW = ILAST - ICOL = JLAST - I = TAUI - 40 IF( RANK.LT.MNTAU ) THEN - MN1 = M + N1 -C -C Pivot if necessary. -C - IF( I.NE.1 ) THEN - J = IDAMAX( I, DWORK, 1 ) - IF( J.NE.I ) THEN - DWORK(J) = DWORK(I) - DWORK(P+J) = DWORK(P+I) - CALL DSWAP( N1, ABCD(IROW,MP1), LDABCD, - $ ABCD(IRC+J,MP1), LDABCD ) - END IF - END IF -C -C Zero elements left to ABCD(IROW,ICOL). -C - DO 50 K = 1, N1-1 - J = M + K -C -C Rotate columns J, J+1 to zero ABCD(IROW,J). -C - T = ABCD(IROW,J+1) - CALL DLARTG( T, ABCD(IROW,J), C, S, ABCD(IROW,J+1) ) - ABCD(IROW,J) = ZERO - CALL DROT( IROW-1, ABCD(1,J+1), 1, ABCD(1,J), 1, C, S ) - CALL DROT( K+1, E(1,K+1), 1, E(1,K), 1, C, S ) -C -C Rotate rows K, K+1 to zero E(K+1,K). -C - T = E(K,K) - CALL DLARTG( T, E(K+1,K), C, S, E(K,K) ) - E(K+1,K) = ZERO - CALL DROT( N1-K, E(K,K+1), LDE, E(K+1,K+1), LDE, C, S ) - CALL DROT( MN1, ABCD(K,1), LDABCD, ABCD(K+1,1), LDABCD, - $ C, S ) - 50 CONTINUE -C - IF( RANK.EQ.0 ) THEN -C -C Initialize; exit if matrix is zero (RANK = 0). -C - SMAX = ABS( ABCD(ILAST,JLAST) ) - IF ( SMAX.EQ.ZERO ) GO TO 80 - SMIN = SMAX - SMAXPR = SMAX - SMINPR = SMIN - C1 = ONE - C2 = ONE - ELSE -C -C One step of incremental condition estimation. -C - CALL DCOPY( RANK, ABCD(IROW,ICOL+1), LDABCD, - $ DWORK(JWORK2), 1 ) - CALL DLAIC1( IMIN, RANK, DWORK( ISMIN ), SMIN, - $ DWORK(JWORK2), ABCD(IROW,ICOL), SMINPR, S1, - $ C1 ) - CALL DLAIC1( IMAX, RANK, DWORK( ISMAX ), SMAX, - $ DWORK(JWORK2), ABCD(IROW,ICOL), SMAXPR, S2, - $ C2 ) - WRKOPT = MAX( WRKOPT, 5*P ) - END IF -C -C Check the rank; finish the loop if rank loss occurs. -C - IF( SVLMAX*RCOND.LE.SMAXPR ) THEN - IF( SVLMAX*RCOND.LE.SMINPR ) THEN - IF( SMAXPR*RCOND.LE.SMINPR ) THEN -C -C Finish the loop if last row. -C - IF( N1.EQ.0 ) THEN - RANK = RANK + 1 - GO TO 80 - END IF -C - IF( N1.GT.1 ) THEN -C -C Update norms. -C - IF( I-1.GT.1 ) THEN - DO 60 J = 1, I - 1 - IF( DWORK(J).NE.ZERO ) THEN - T = ONE - ( ABS( ABCD(IRC+J,ICOL) ) - $ /DWORK(J) )**2 - T = MAX( T, ZERO ) - TT = ONE + - $ P05*T*( DWORK(J)/DWORK(P+J) )**2 - IF( TT.NE.ONE ) THEN - DWORK(J) = DWORK(J)*SQRT( T ) - ELSE - DWORK(J) = DNRM2( N1-1, - $ ABCD(IRC+J,MP1), LDABCD ) - DWORK(P+J) = DWORK(J) - END IF - END IF - 60 CONTINUE - END IF - END IF -C - DO 70 J = 1, RANK - DWORK( ISMIN+J-1 ) = S1*DWORK( ISMIN+J-1 ) - DWORK( ISMAX+J-1 ) = S2*DWORK( ISMAX+J-1 ) - 70 CONTINUE -C - DWORK( ISMIN+RANK ) = C1 - DWORK( ISMAX+RANK ) = C2 - SMIN = SMINPR - SMAX = SMAXPR - RANK = RANK + 1 - ICOL = ICOL - 1 - IROW = IROW - 1 - N1 = N1 - 1 - I = I - 1 - GO TO 40 - END IF - END IF - END IF - END IF - END IF -C - 80 CONTINUE - MUI = RANK - NR = NR - MUI - PR = SIGMA + MUI -C -C Set number of left Kronecker blocks of order (i-1)-by-i. -C - KRONL(NBLCKS) = TAUI - MUI -C -C Set number of infinite divisors of order i-1. -C - IF( FIRST .AND. NBLCKS.GT.1 ) - $ INFZ(NBLCKS-1) = MUIM1 - TAUI - MUIM1 = MUI - RO = MUI -C -C Continue reduction if rank of current C is positive. -C - IF( MUI.GT.0 ) - $ GO TO 10 -C -C Determine the maximal degree of infinite zeros and -C the number of infinite zeros. -C - 90 CONTINUE - IF( FIRST ) THEN - IF( MUI.EQ.0 ) THEN - DINFZ = MAX( 0, NBLCKS - 1 ) - ELSE - DINFZ = NBLCKS - INFZ(NBLCKS) = MUI - END IF - K = DINFZ - DO 100 I = K, 1, -1 - IF( INFZ(I).NE.0 ) GO TO 110 - DINFZ = DINFZ - 1 - 100 CONTINUE - 110 CONTINUE - DO 120 I = 1, DINFZ - NINFZ = NINFZ + INFZ(I)*I - 120 CONTINUE - END IF -C -C Determine the maximal order of left elementary Kronecker blocks. -C - NKRONL = NBLCKS - DO 130 I = NBLCKS, 1, -1 - IF( KRONL(I).NE.0 ) GO TO 140 - NKRONL = NKRONL - 1 - 130 CONTINUE - 140 CONTINUE -C - DWORK(1) = WRKOPT - RETURN -C *** Last line of AG08BY *** - END diff --git a/mex/sources/libslicot/AG08BZ.f b/mex/sources/libslicot/AG08BZ.f deleted file mode 100644 index 6292b0554..000000000 --- a/mex/sources/libslicot/AG08BZ.f +++ /dev/null @@ -1,641 +0,0 @@ - SUBROUTINE AG08BZ( EQUIL, L, N, M, P, A, LDA, E, LDE, B, LDB, - $ C, LDC, D, LDD, NFZ, NRANK, NIZ, DINFZ, NKROR, - $ NINFE, NKROL, INFZ, KRONR, INFE, KRONL, - $ TOL, IWORK, DWORK, ZWORK, LZWORK, INFO ) -C -C SLICOT RELEASE 5.0. -C -C Copyright (c) 2002-2009 NICONET e.V. -C -C This program is free software: you can redistribute it and/or -C modify it under the terms of the GNU General Public License as -C published by the Free Software Foundation, either version 2 of -C the License, or (at your option) any later version. -C -C This program is distributed in the hope that it will be useful, -C but WITHOUT ANY WARRANTY; without even the implied warranty of -C MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the -C GNU General Public License for more details. -C -C You should have received a copy of the GNU General Public License -C along with this program. If not, see -C . -C -C PURPOSE -C -C To extract from the system pencil -C -C ( A-lambda*E B ) -C S(lambda) = ( ) -C ( C D ) -C -C a regular pencil Af-lambda*Ef which has the finite Smith zeros of -C S(lambda) as generalized eigenvalues. The routine also computes -C the orders of the infinite Smith zeros and determines the singular -C and infinite Kronecker structure of system pencil, i.e., the right -C and left Kronecker indices, and the multiplicities of infinite -C eigenvalues. -C -C ARGUMENTS -C -C Mode Parameters -C -C EQUIL CHARACTER*1 -C Specifies whether the user wishes to balance the system -C matrix as follows: -C = 'S': Perform balancing (scaling); -C = 'N': Do not perform balancing. -C -C Input/Output Parameters -C -C L (input) INTEGER -C The number of rows of matrices A, B, and E. L >= 0. -C -C N (input) INTEGER -C The number of columns of matrices A, E, and C. N >= 0. -C -C M (input) INTEGER -C The number of columns of matrix B. M >= 0. -C -C P (input) INTEGER -C The number of rows of matrix C. P >= 0. -C -C A (input/output) COMPLEX*16 array, dimension (LDA,N) -C On entry, the leading L-by-N part of this array must -C contain the state dynamics matrix A of the system. -C On exit, the leading NFZ-by-NFZ part of this array -C contains the matrix Af of the reduced pencil. -C -C LDA INTEGER -C The leading dimension of array A. LDA >= MAX(1,L). -C -C E (input/output) COMPLEX*16 array, dimension (LDE,N) -C On entry, the leading L-by-N part of this array must -C contain the descriptor matrix E of the system. -C On exit, the leading NFZ-by-NFZ part of this array -C contains the matrix Ef of the reduced pencil. -C -C LDE INTEGER -C The leading dimension of array E. LDE >= MAX(1,L). -C -C B (input/output) COMPLEX*16 array, dimension (LDB,M) -C On entry, the leading L-by-M part of this array must -C contain the input/state matrix B of the system. -C On exit, this matrix does not contain useful information. -C -C LDB INTEGER -C The leading dimension of array B. -C LDB >= MAX(1,L) if M > 0; -C LDB >= 1 if M = 0. -C -C C (input/output) COMPLEX*16 array, dimension (LDC,N) -C On entry, the leading P-by-N part of this array must -C contain the state/output matrix C of the system. -C On exit, this matrix does not contain useful information. -C -C LDC INTEGER -C The leading dimension of array C. LDC >= MAX(1,P). -C -C D (input) COMPLEX*16 array, dimension (LDD,M) -C The leading P-by-M part of this array must contain the -C direct transmission matrix D of the system. -C -C LDD INTEGER -C The leading dimension of array D. LDD >= MAX(1,P). -C -C NFZ (output) INTEGER -C The number of finite zeros. -C -C NRANK (output) INTEGER -C The normal rank of the system pencil. -C -C NIZ (output) INTEGER -C The number of infinite zeros. -C -C DINFZ (output) INTEGER -C The maximal multiplicity of infinite Smith zeros. -C -C NKROR (output) INTEGER -C The number of right Kronecker indices. -C -C NINFE (output) INTEGER -C The number of elementary infinite blocks. -C -C NKROL (output) INTEGER -C The number of left Kronecker indices. -C -C INFZ (output) INTEGER array, dimension (N+1) -C The leading DINFZ elements of INFZ contain information -C on the infinite elementary divisors as follows: -C the system has INFZ(i) infinite elementary divisors of -C degree i in the Smith form, where i = 1,2,...,DINFZ. -C -C KRONR (output) INTEGER array, dimension (N+M+1) -C The leading NKROR elements of this array contain the -C right Kronecker (column) indices. -C -C INFE (output) INTEGER array, dimension (1+MIN(L+P,N+M)) -C The leading NINFE elements of INFE contain the -C multiplicities of infinite eigenvalues. -C -C KRONL (output) INTEGER array, dimension (L+P+1) -C The leading NKROL elements of this array contain the -C left Kronecker (row) indices. -C -C Tolerances -C -C TOL DOUBLE PRECISION -C A tolerance used in rank decisions to determine the -C effective rank, which is defined as the order of the -C largest leading (or trailing) triangular submatrix in the -C QR (or RQ) factorization with column (or row) pivoting -C whose estimated condition number is less than 1/TOL. -C If the user sets TOL <= 0, then default tolerances are -C used instead, as follows: TOLDEF = L*N*EPS in TG01FZ -C (to determine the rank of E) and TOLDEF = (L+P)*(N+M)*EPS -C in the rest, where EPS is the machine precision -C (see LAPACK Library routine DLAMCH). TOL < 1. -C -C Workspace -C -C IWORK INTEGER array, dimension N+max(1,M) -C On output, IWORK(1) contains the normal rank of the -C transfer function matrix. -C -C DWORK DOUBLE PRECISION array, dimension (LDWORK) -C LDWORK >= max(4*(L+N), 2*max(L+P,M+N))), if EQUIL = 'S', -C LDWORK >= 2*max(L+P,M+N)), if EQUIL = 'N'. -C -C ZWORK COMPLEX*16 array, dimension (LZWORK) -C On exit, if INFO = 0, ZWORK(1) returns the optimal value -C of LZWORK. -C -C LZWORK INTEGER -C The length of the array ZWORK. -C LZWORK >= max( max(L+P,M+N)*(M+N) + -C max(min(L+P,M+N) + max(min(L,N),3*(M+N)-1), -C 3*(L+P), 1)) -C For optimum performance LZWORK should be larger. -C -C If LZWORK = -1, then a workspace query is assumed; -C the routine only calculates the optimal size of the -C ZWORK array, returns this value as the first entry of -C the ZWORK array, and no error message related to LZWORK -C is issued by XERBLA. -C -C Error Indicator -C -C INFO INTEGER -C = 0: successful exit; -C < 0: if INFO = -i, the i-th argument had an illegal -C value. -C -C METHOD -C -C The routine extracts from the system matrix of a descriptor -C system (A-lambda*E,B,C,D) a regular pencil Af-lambda*Ef which -C has the finite zeros of the system as generalized eigenvalues. -C The procedure has the following main computational steps: -C -C (a) construct the (L+P)-by-(N+M) system pencil -C -C S(lambda) = ( B A )-lambda*( 0 E ); -C ( D C ) ( 0 0 ) -C -C (b) reduce S(lambda) to S1(lambda) with the same finite -C zeros and right Kronecker structure but with E -C upper triangular and nonsingular; -C -C (c) reduce S1(lambda) to S2(lambda) with the same finite -C zeros and right Kronecker structure but with D of -C full row rank; -C -C (d) reduce S2(lambda) to S3(lambda) with the same finite zeros -C and with D square invertible; -C -C (e) perform a unitary transformation on the columns of -C -C S3(lambda) = (A-lambda*E B) in order to reduce it to -C ( C D) -C -C (Af-lambda*Ef X), with Y and Ef square invertible; -C ( 0 Y) -C -C (f) compute the right and left Kronecker indices of the system -C matrix, which together with the multiplicities of the -C finite and infinite eigenvalues constitute the -C complete set of structural invariants under strict -C equivalence transformations of a linear system. -C -C REFERENCES -C -C [1] P. Misra, P. Van Dooren and A. Varga. -C Computation of structural invariants of generalized -C state-space systems. -C Automatica, 30, pp. 1921-1936, 1994. -C -C NUMERICAL ASPECTS -C -C The algorithm is backward stable (see [1]). -C -C FURTHER COMMENTS -C -C In order to compute the finite Smith zeros of the system -C explicitly, a call to this routine may be followed by a -C call to the LAPACK Library routines ZGEGV or ZGGEV. -C -C CONTRIBUTOR -C -C A. Varga, German Aerospace Center, DLR Oberpfaffenhofen, -C May 1999. -C Complex version: V. Sima, Research Institute for Informatics, -C Bucharest, Nov. 2008. -C -C REVISIONS -C -C V. Sima, Research Institute for Informatics, Bucharest, Mar. 2009, -C Apr. 2009. -C -C KEYWORDS -C -C Generalized eigenvalue problem, Kronecker indices, multivariable -C system, unitary transformation, structural invariant. -C -C ****************************************************************** -C -C .. Parameters .. - DOUBLE PRECISION ONE, ZERO - PARAMETER ( ONE = 1.0D0, ZERO = 0.0D0 ) - COMPLEX*16 CZERO - PARAMETER ( CZERO = ( 0.0D+0, 0.0D+0 ) ) -C .. Scalar Arguments .. - CHARACTER EQUIL - INTEGER DINFZ, INFO, L, LDA, LDB, LDC, LDD, LDE, LZWORK, - $ M, N, NFZ, NINFE, NIZ, NKROL, NKROR, NRANK, P - DOUBLE PRECISION TOL -C .. Array Arguments .. - INTEGER INFE(*), INFZ(*), IWORK(*), KRONL(*), KRONR(*) - DOUBLE PRECISION DWORK(*) - COMPLEX*16 A(LDA,*), B(LDB,*), C(LDC,*), D(LDD,*), - $ E(LDE,*), ZWORK(*) -C .. Local Scalars .. - LOGICAL LEQUIL, LQUERY - INTEGER I, I0, I1, II, IPD, ITAU, J, JWORK, KABCD, - $ LABCD2, LDABCD, LZW, MM, MU, N2, NB, NN, NSINFE, - $ NU, NUMU, PP, WRKOPT - DOUBLE PRECISION SVLMAX, TOLER -C .. Local Arrays .. - COMPLEX*16 DUM(1) -C .. External Functions .. - LOGICAL LSAME - INTEGER ILAENV - DOUBLE PRECISION DLAMCH, ZLANGE - EXTERNAL DLAMCH, ILAENV, LSAME, ZLANGE -C .. External Subroutines .. - EXTERNAL AG8BYZ, MA02BZ, MA02CZ, TB01XZ, TG01AZ, TG01FZ, - $ XERBLA, ZLACPY, ZLASET, ZTZRZF, ZUNMRZ -C .. Intrinsic Functions .. - INTRINSIC DBLE, INT, MAX, MIN -C .. Executable Statements .. -C - INFO = 0 - LDABCD = MAX( L+P, N+M ) - LABCD2 = LDABCD*( N+M ) - LEQUIL = LSAME( EQUIL, 'S' ) - LQUERY = ( LZWORK.EQ.-1 ) -C -C Test the input scalar arguments. -C - IF( .NOT.LEQUIL .AND. .NOT.LSAME( EQUIL, 'N' ) ) THEN - INFO = -1 - ELSE IF( L.LT.0 ) THEN - INFO = -2 - ELSE IF( N.LT.0 ) THEN - INFO = -3 - ELSE IF( M.LT.0 ) THEN - INFO = -4 - ELSE IF( P.LT.0 ) THEN - INFO = -5 - ELSE IF( LDA.LT.MAX( 1, L ) ) THEN - INFO = -7 - ELSE IF( LDE.LT.MAX( 1, L ) ) THEN - INFO = -9 - ELSE IF( LDB.LT.1 .OR. ( M.GT.0 .AND. LDB.LT.L ) ) THEN - INFO = -11 - ELSE IF( LDC.LT.MAX( 1, P ) ) THEN - INFO = -13 - ELSE IF( LDD.LT.MAX( 1, P ) ) THEN - INFO = -15 - ELSE IF( TOL.GE.ONE ) THEN - INFO = -27 - ELSE - I0 = MIN( L+P, M+N ) - I1 = MIN( L, N ) - II = MIN( M, P ) - LZW = MAX( 1, LABCD2 + MAX( I0 + MAX( I1, 3*( M+N ) - 1 ), - $ 3*( L+P ) ) ) - IF( LQUERY ) THEN - CALL TG01FZ( 'N', 'N', 'N', L, N, M, P, A, LDA, E, LDE, B, - $ LDB, C, LDC, DUM, 1, DUM, 1, NN, N2, TOL, - $ IWORK, DWORK, ZWORK, -1, INFO ) - WRKOPT = MAX( LZW, INT( ZWORK(1) ) ) - SVLMAX = ZERO - CALL AG8BYZ( .TRUE., I1, M+N, P+L, SVLMAX, ZWORK, LDABCD+I1, - $ E, LDE, NU, MU, NIZ, DINFZ, NKROL, INFZ, KRONL, - $ TOL, IWORK, DWORK, ZWORK, -1, INFO ) - WRKOPT = MAX( WRKOPT, LABCD2 + INT( ZWORK(1) ) ) - CALL AG8BYZ( .FALSE., I1, II, M+N, SVLMAX, ZWORK, LDABCD+I1, - $ E, LDE, NU, MU, NIZ, DINFZ, NKROL, INFZ, KRONL, - $ TOL, IWORK, DWORK, ZWORK, -1, INFO ) - WRKOPT = MAX( WRKOPT, LABCD2 + INT( ZWORK(1) ) ) - NB = ILAENV( 1, 'ZGERQF', ' ', II, I1+II, -1, -1 ) - WRKOPT = MAX( WRKOPT, LABCD2 + II + II*NB ) - NB = MIN( 64, ILAENV( 1, 'ZUNMRQ', 'RC', I1, I1+II, II, - $ -1 ) ) - WRKOPT = MAX( WRKOPT, LABCD2 + II + I1*NB ) - ELSE IF( LZWORK.LT.LZW ) THEN - INFO = -31 - END IF - END IF -C - IF( INFO.NE.0 ) THEN -C -C Error return. -C - CALL XERBLA( 'AG08BZ', -INFO ) - RETURN - ELSE IF( LQUERY ) THEN - ZWORK(1) = WRKOPT - RETURN - END IF -C - NIZ = 0 - NKROL = 0 - NKROR = 0 -C -C Quick return if possible. -C - IF( MAX( L, N, M, P ).EQ.0 ) THEN - NFZ = 0 - DINFZ = 0 - NINFE = 0 - NRANK = 0 - IWORK(1) = 0 - ZWORK(1) = ONE - RETURN - END IF -C -C (Note: Comments in the code beginning "CWorkspace:", "RWorkspace:" -C and "IWorkspace:" describe the minimal amount of complex, real and -C integer workspace, respectively, needed at that point in the code, -C as well as the preferred amount for good performance.) -C - WRKOPT = 1 - KABCD = 1 - JWORK = KABCD + LABCD2 -C -C If required, balance the system pencil. -C RWorkspace: need 4*(L+N). -C - IF( LEQUIL ) THEN - CALL TG01AZ( 'A', L, N, M, P, ZERO, A, LDA, E, LDE, B, LDB, - $ C, LDC, DWORK, DWORK(L+1), DWORK(L+N+1), INFO ) - END IF - SVLMAX = ZLANGE( 'Frobenius', L, N, E, LDE, DWORK ) -C -C Reduce the system matrix to QR form, -C -C ( A11-lambda*E11 A12 B1 ) -C ( A21 A22 B2 ) , -C ( C1 C2 D ) -C -C with E11 invertible and upper triangular. -C IWorkspace: need N. -C RWorkspace: need 2*N. -C CWorkspace: need max( 1, N+P, min(L,N)+max(3*N-1,M,L) ); -C prefer larger. -C - CALL TG01FZ( 'N', 'N', 'N', L, N, M, P, A, LDA, E, LDE, B, LDB, - $ C, LDC, DUM, 1, DUM, 1, NN, N2, TOL, IWORK, DWORK, - $ ZWORK, LZWORK, INFO ) - WRKOPT = MAX( WRKOPT, INT( ZWORK(1) ) ) -C -C Construct the system pencil -C -C MM NN -C ( B1 A12 A11-lambda*E11 ) NN -C S1(lambda) = ( B2 A22 A21 ) L-NN -C ( D C2 C1 ) P -C -C of dimension (L+P)-by-(M+N). -C CWorkspace: need LABCD2 = max( L+P, N+M )*( N+M ). -C - N2 = N - NN - MM = M + N2 - PP = P + ( L - NN ) - CALL ZLACPY( 'Full', L, M, B, LDB, ZWORK(KABCD), LDABCD ) - CALL ZLACPY( 'Full', P, M, D, LDD, ZWORK(KABCD+L), LDABCD ) - CALL ZLACPY( 'Full', L, N2, A(1,NN+1), LDA, - $ ZWORK(KABCD+LDABCD*M), LDABCD ) - CALL ZLACPY( 'Full', P, N2, C(1,NN+1), LDC, - $ ZWORK(KABCD+LDABCD*M+L), LDABCD ) - CALL ZLACPY( 'Full', L, NN, A, LDA, - $ ZWORK(KABCD+LDABCD*MM), LDABCD ) - CALL ZLACPY( 'Full', P, NN, C, LDC, - $ ZWORK(KABCD+LDABCD*MM+L), LDABCD ) -C -C If required, set tolerance. -C - TOLER = TOL - IF( TOLER.LE.ZERO ) THEN - TOLER = DBLE( ( L + P )*( M + N ) ) * DLAMCH( 'Precision' ) - END IF - SVLMAX = MAX( SVLMAX, - $ ZLANGE( 'Frobenius', NN+PP, NN+MM, ZWORK(KABCD), - $ LDABCD, DWORK ) ) -C -C Extract the reduced pencil S2(lambda) -C -C ( Bc Ac-lambda*Ec ) -C ( Dc Cc ) -C -C having the same finite Smith zeros as the system pencil -C S(lambda) but with Dc, a MU-by-MM full row rank -C left upper trapezoidal matrix, and Ec, an NU-by-NU -C upper triangular nonsingular matrix. -C -C IWorkspace: need MM, MM <= M+N; -C RWorkspace: need 2*max(MM,PP); PP <= P+L; -C CWorkspace: need max( min(P+L,M+N)+max(min(L,N),3*(M+N)-1), -C 3*(P+L), 1 ) + LABCD2; -C prefer larger. -C - CALL AG8BYZ( .TRUE., NN, MM, PP, SVLMAX, ZWORK(KABCD), LDABCD, - $ E, LDE, NU, MU, NIZ, DINFZ, NKROL, INFZ, KRONL, - $ TOLER, IWORK, DWORK, ZWORK(JWORK), LZWORK-JWORK+1, - $ INFO ) -C - WRKOPT = MAX( WRKOPT, INT( ZWORK(JWORK) ) + JWORK - 1 ) -C -C Set the number of simple (nondynamic) infinite eigenvalues -C and the normal rank of the system pencil. -C - NSINFE = MU - NRANK = NN + MU -C -C Pertranspose the system. -C - CALL TB01XZ( 'D', NU, MM, MM, MAX( 0, NU-1 ), MAX( 0, NU-1 ), - $ ZWORK(KABCD+LDABCD*MM), LDABCD, - $ ZWORK(KABCD), LDABCD, - $ ZWORK(KABCD+LDABCD*MM+NU), LDABCD, - $ ZWORK(KABCD+NU), LDABCD, INFO ) - CALL MA02BZ( 'Right', NU+MM, MM, ZWORK(KABCD), LDABCD ) - CALL MA02BZ( 'Left', MM, NU+MM, ZWORK(KABCD+NU), LDABCD ) - CALL MA02CZ( NU, 0, MAX( 0, NU-1 ), E, LDE ) -C - IF( MU.NE.MM ) THEN - NN = NU - PP = MM - MM = MU - KABCD = KABCD + ( PP - MM )*LDABCD -C -C Extract the reduced pencil S3(lambda), -C -C ( Br Ar-lambda*Er ) , -C ( Dr Cr ) -C -C having the same finite Smith zeros as the pencil S(lambda), -C but with Dr, an MU-by-MU invertible upper triangular matrix, -C and Er, an NU-by-NU upper triangular nonsingular matrix. -C -C IWorkspace: need 0; -C RWorkspace: need 2*(M+N); -C CWorkspace: need max( 1, 3*(M+N) ) + LABCD2. -C prefer larger. -C - CALL AG8BYZ( .FALSE., NN, MM, PP, SVLMAX, ZWORK(KABCD), LDABCD, - $ E, LDE, NU, MU, I0, I1, NKROR, IWORK, KRONR, - $ TOLER, IWORK, DWORK, ZWORK(JWORK), LZWORK-JWORK+1, - $ INFO ) -C - WRKOPT = MAX( WRKOPT, INT( ZWORK(JWORK) ) + JWORK - 1 ) - END IF -C - IF( NU.NE.0 ) THEN -C -C Perform a unitary transformation on the columns of -C ( Br Ar-lambda*Er ) -C ( Dr Cr ) -C in order to reduce it to -C ( * Af-lambda*Ef ) -C ( Y 0 ) -C with Y and Ef square invertible. -C -C Compute Af by reducing ( Br Ar ) to ( * Af ) . -C ( Dr Cr ) ( Y 0 ) -C - NUMU = NU + MU - IPD = KABCD + NU - ITAU = JWORK - JWORK = ITAU + MU -C -C CWorkspace: need LABCD2 + 2*min(M,P); -C prefer LABCD2 + min(M,P) + min(M,P)*NB. -C - CALL ZTZRZF( MU, NUMU, ZWORK(IPD), LDABCD, ZWORK(ITAU), - $ ZWORK(JWORK), LZWORK-JWORK+1, INFO ) - WRKOPT = MAX( WRKOPT, INT( ZWORK(JWORK) ) + JWORK - 1 ) -C -C CWorkspace: need LABCD2 + min(M,P) + min(L,N); -C prefer LABCD2 + min(M,P) + min(L,N)*NB. -C - CALL ZUNMRZ( 'Right', 'Conjugate transpose', NU, NUMU, MU, NU, - $ ZWORK(IPD), LDABCD, ZWORK(ITAU), ZWORK(KABCD), - $ LDABCD, ZWORK(JWORK), LZWORK-JWORK+1, INFO ) - WRKOPT = MAX( WRKOPT, INT( ZWORK(JWORK) ) + JWORK - 1 ) -C -C Save Af. -C - CALL ZLACPY( 'Full', NU, NU, ZWORK(KABCD+LDABCD*MU), LDABCD, A, - $ LDA ) -C -C Compute Ef by applying the saved transformations from previous -C reduction to ( 0 Er ) . -C - CALL ZLASET( 'Full', NU, MU, CZERO, CZERO, ZWORK(KABCD), - $ LDABCD ) - CALL ZLACPY( 'Full', NU, NU, E, LDE, ZWORK(KABCD+LDABCD*MU), - $ LDABCD ) -C - CALL ZUNMRZ( 'Right', 'Conjugate transpose', NU, NUMU, MU, NU, - $ ZWORK(IPD), LDABCD, ZWORK(ITAU), ZWORK(KABCD), - $ LDABCD, ZWORK(JWORK), LZWORK-JWORK+1, INFO ) -C -C Save Ef. -C - CALL ZLACPY( 'Full', NU, NU, ZWORK(KABCD+LDABCD*MU), LDABCD, E, - $ LDE ) - END IF -C - NFZ = NU -C -C Set right Kronecker indices (column indices). -C - DO 10 I = 1, NKROR - IWORK(I) = KRONR(I) - 10 CONTINUE -C - J = 0 - DO 30 I = 1, NKROR - DO 20 II = J + 1, J + IWORK(I) - KRONR(II) = I - 1 - 20 CONTINUE - J = J + IWORK(I) - 30 CONTINUE -C - NKROR = J -C -C Set left Kronecker indices (row indices). -C - DO 40 I = 1, NKROL - IWORK(I) = KRONL(I) - 40 CONTINUE -C - J = 0 - DO 60 I = 1, NKROL - DO 50 II = J + 1, J + IWORK(I) - KRONL(II) = I - 1 - 50 CONTINUE - J = J + IWORK(I) - 60 CONTINUE -C - NKROL = J -C -C Determine the number of simple infinite blocks -C as the difference between the number of infinite blocks -C of order greater than one and the order of Dr. -C - NINFE = 0 - DO 70 I = 1, DINFZ - NINFE = NINFE + INFZ(I) - 70 CONTINUE - NINFE = NSINFE - NINFE - DO 80 I = 1, NINFE - INFE(I) = 1 - 80 CONTINUE -C -C Set the structure of infinite eigenvalues. -C - DO 100 I = 1, DINFZ - DO 90 II = NINFE + 1, NINFE + INFZ(I) - INFE(II) = I + 1 - 90 CONTINUE - NINFE = NINFE + INFZ(I) - 100 CONTINUE -C - IWORK(1) = NSINFE - ZWORK(1) = WRKOPT - RETURN -C *** Last line of AG08BZ *** - END diff --git a/mex/sources/libslicot/AG8BYZ.f b/mex/sources/libslicot/AG8BYZ.f deleted file mode 100644 index c2dc7d5e4..000000000 --- a/mex/sources/libslicot/AG8BYZ.f +++ /dev/null @@ -1,692 +0,0 @@ - SUBROUTINE AG8BYZ( FIRST, N, M, P, SVLMAX, ABCD, LDABCD, E, LDE, - $ NR, PR, NINFZ, DINFZ, NKRONL, INFZ, KRONL, - $ TOL, IWORK, DWORK, ZWORK, LZWORK, INFO ) -C -C SLICOT RELEASE 5.0. -C -C Copyright (c) 2002-2009 NICONET e.V. -C -C This program is free software: you can redistribute it and/or -C modify it under the terms of the GNU General Public License as -C published by the Free Software Foundation, either version 2 of -C the License, or (at your option) any later version. -C -C This program is distributed in the hope that it will be useful, -C but WITHOUT ANY WARRANTY; without even the implied warranty of -C MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the -C GNU General Public License for more details. -C -C You should have received a copy of the GNU General Public License -C along with this program. If not, see -C . -C -C PURPOSE -C -C To extract from the (N+P)-by-(M+N) descriptor system pencil -C -C S(lambda) = ( B A - lambda*E ) -C ( D C ) -C -C with E nonsingular and upper triangular a -C (NR+PR)-by-(M+NR) "reduced" descriptor system pencil -C -C ( Br Ar-lambda*Er ) -C Sr(lambda) = ( ) -C ( Dr Cr ) -C -C having the same finite Smith zeros as the pencil -C S(lambda) but with Dr, a PR-by-M full row rank -C left upper trapezoidal matrix, and Er, an NR-by-NR -C upper triangular nonsingular matrix. -C -C ARGUMENTS -C -C Mode Parameters -C -C FIRST LOGICAL -C Specifies if AG8BYZ is called first time or it is called -C for an already reduced system, with D full column rank -C with the last M rows in upper triangular form: -C FIRST = .TRUE., first time called; -C FIRST = .FALSE., not first time called. -C -C Input/Output Parameters -C -C N (input) INTEGER -C The number of rows of matrix B, the number of columns of -C matrix C and the order of square matrices A and E. -C N >= 0. -C -C M (input) INTEGER -C The number of columns of matrices B and D. M >= 0. -C M <= P if FIRST = .FALSE. . -C -C P (input) INTEGER -C The number of rows of matrices C and D. P >= 0. -C -C SVLMAX (input) DOUBLE PRECISION -C During each reduction step, the rank-revealing QR -C factorization of a matrix stops when the estimated minimum -C singular value is smaller than TOL * MAX(SVLMAX,EMSV), -C where EMSV is the estimated maximum singular value. -C SVLMAX >= 0. -C -C ABCD (input/output) COMPLEX*16 array, dimension (LDABCD,M+N) -C On entry, the leading (N+P)-by-(M+N) part of this array -C must contain the compound matrix -C ( B A ) , -C ( D C ) -C where A is an N-by-N matrix, B is an N-by-M matrix, -C C is a P-by-N matrix and D is a P-by-M matrix. -C If FIRST = .FALSE., then D must be a full column -C rank matrix with the last M rows in upper triangular form. -C On exit, the leading (NR+PR)-by-(M+NR) part of ABCD -C contains the reduced compound matrix -C ( Br Ar ) , -C ( Dr Cr ) -C where Ar is an NR-by-NR matrix, Br is an NR-by-M matrix, -C Cr is a PR-by-NR matrix, Dr is a PR-by-M full row rank -C left upper trapezoidal matrix with the first PR columns -C in upper triangular form. -C -C LDABCD INTEGER -C The leading dimension of array ABCD. -C LDABCD >= MAX(1,N+P). -C -C E (input/output) COMPLEX*16 array, dimension (LDE,N) -C On entry, the leading N-by-N part of this array must -C contain the upper triangular nonsingular matrix E. -C On exit, the leading NR-by-NR part contains the reduced -C upper triangular nonsingular matrix Er. -C -C LDE INTEGER -C The leading dimension of array E. LDE >= MAX(1,N). -C -C NR (output) INTEGER -C The order of the reduced matrices Ar and Er; also the -C number of rows of the reduced matrix Br and the number -C of columns of the reduced matrix Cr. -C If Dr is invertible, NR is also the number of finite -C Smith zeros. -C -C PR (output) INTEGER -C The rank of the resulting matrix Dr; also the number of -C rows of reduced matrices Cr and Dr. -C -C NINFZ (output) INTEGER -C Number of infinite zeros. NINFZ = 0 if FIRST = .FALSE. . -C -C DINFZ (output) INTEGER -C The maximal multiplicity of infinite zeros. -C DINFZ = 0 if FIRST = .FALSE. . -C -C NKRONL (output) INTEGER -C The maximal dimension of left elementary Kronecker blocks. -C -C INFZ (output) INTEGER array, dimension (N) -C INFZ(i) contains the number of infinite zeros of -C degree i, where i = 1,2,...,DINFZ. -C INFZ is not referenced if FIRST = .FALSE. . -C -C KRONL (output) INTEGER array, dimension (N+1) -C KRONL(i) contains the number of left elementary Kronecker -C blocks of dimension i-by-(i-1), where i = 1,2,...,NKRONL. -C -C Tolerances -C -C TOL DOUBLE PRECISION -C A tolerance used in rank decisions to determine the -C effective rank, which is defined as the order of the -C largest leading (or trailing) triangular submatrix in the -C QR (or RQ) factorization with column (or row) pivoting -C whose estimated condition number is less than 1/TOL. -C If the user sets TOL <= 0, then an implicitly computed, -C default tolerance TOLDEF = (N+P)*(N+M)*EPS, is used -C instead, where EPS is the machine precision -C (see LAPACK Library routine DLAMCH). -C NOTE that when SVLMAX > 0, the estimated ranks could be -C less than those defined above (see SVLMAX). TOL <= 1. -C -C Workspace -C -C IWORK INTEGER array, dimension (M) -C If FIRST = .FALSE., IWORK is not referenced. -C -C DWORK DOUBLE PRECISION array, dimension (LDWORK) -C LDWORK >= 2*MAX(M,P), if FIRST = .TRUE.; -C LDWORK >= 2*P, if FIRST = .FALSE. . -C -C ZWORK COMPLEX*16 array, dimension (LZWORK) -C On exit, if INFO = 0, ZWORK(1) returns the optimal value -C of LZWORK. -C -C LZWORK INTEGER -C The length of the array ZWORK. -C LZWORK >= 1, if P = 0; otherwise -C LZWORK >= MAX( 1, N+M-1, MIN(P,M) + MAX(3*M-1,N), 3*P ), -C if FIRST = .TRUE.; -C LZWORK >= MAX( 1, N+M-1, 3*P ), if FIRST = .FALSE. . -C The second term is not needed if M = 0. -C For optimum performance LZWORK should be larger. -C -C If LZWORK = -1, then a workspace query is assumed; -C the routine only calculates the optimal size of the -C ZWORK array, returns this value as the first entry of -C the ZWORK array, and no error message related to LZWORK -C is issued by XERBLA. -C -C Error Indicator -C -C INFO INTEGER -C = 0: successful exit; -C < 0: if INFO = -i, the i-th argument had an illegal -C value. -C -C METHOD -C -C The subroutine is based on the reduction algorithm of [1]. -C -C REFERENCES -C -C [1] P. Misra, P. Van Dooren and A. Varga. -C Computation of structural invariants of generalized -C state-space systems. -C Automatica, 30, pp. 1921-1936, 1994. -C -C NUMERICAL ASPECTS -C -C The algorithm is numerically backward stable and requires -C 0( (P+N)*(M+N)*N ) floating point operations. -C -C FURTHER COMMENTS -C -C The number of infinite zeros is computed as -C -C DINFZ -C NINFZ = Sum (INFZ(i)*i) . -C i=1 -C Note that each infinite zero of multiplicity k corresponds to -C an infinite eigenvalue of multiplicity k+1. -C The multiplicities of the infinite eigenvalues can be determined -C from PR, DINFZ and INFZ(i), i = 1, ..., DINFZ, as follows: -C -C DINFZ -C - there are PR - Sum (INFZ(i)) simple infinite eigenvalues; -C i=1 -C -C - there are INFZ(i) infinite eigenvalues with multiplicity i+1, -C for i = 1, ..., DINFZ. -C -C The left Kronecker indices are: -C -C [ 0 0 ... 0 | 1 1 ... 1 | .... | NKRONL ... NKRONL ] -C |<- KRONL(1) ->|<- KRONL(2) ->| |<- KRONL(NKRONL) ->| -C -C CONTRIBUTOR -C -C A. Varga, German Aerospace Center, DLR Oberpfaffenhofen. -C May 1999. -C Complex version: V. Sima, Research Institute for Informatics, -C Bucharest, Nov. 2008. -C -C REVISIONS -C -C V. Sima, Research Institute for Informatics, Bucharest, Apr. 2009. -C -C KEYWORDS -C -C Generalized eigenvalue problem, Kronecker indices, multivariable -C system, unitary transformation, structural invariant. -C -C ****************************************************************** -C -C .. Parameters .. - INTEGER IMAX, IMIN - PARAMETER ( IMAX = 1, IMIN = 2 ) - DOUBLE PRECISION ONE, P05, ZERO - PARAMETER ( ONE = 1.0D0, P05 = 0.05D0, ZERO = 0.0D0 ) - COMPLEX*16 CONE, CZERO - PARAMETER ( CONE = ( 1.0D+0, 0.0D+0 ), - $ CZERO = ( 0.0D+0, 0.0D+0 ) ) -C .. Scalar Arguments .. - INTEGER DINFZ, INFO, LDABCD, LDE, LZWORK, M, N, NINFZ, - $ NKRONL, NR, P, PR - DOUBLE PRECISION SVLMAX, TOL - LOGICAL FIRST -C .. Array Arguments .. - INTEGER INFZ( * ), IWORK(*), KRONL( * ) - DOUBLE PRECISION DWORK( * ) - COMPLEX*16 ABCD( LDABCD, * ), E( LDE, * ), ZWORK( * ) -C .. Local Scalars .. - LOGICAL LQUERY - INTEGER I, ICOL, ILAST, IRC, IROW, ISMAX, ISMIN, ITAU, - $ J, JLAST, JWORK1, JWORK2, K, MN, MN1, MNR, - $ MNTAU, MP1, MPM, MUI, MUIM1, N1, NB, NBLCKS, - $ PN, RANK, RO, RO1, SIGMA, TAUI, WRKOPT - DOUBLE PRECISION C, RCOND, SMAX, SMAXPR, SMIN, SMINPR, T, TT - COMPLEX*16 C1, C2, S, S1, S2, TC -C .. Local Arrays .. - DOUBLE PRECISION SVAL(3) - COMPLEX*16 DUM(1) -C .. External Functions .. - INTEGER IDAMAX, ILAENV - DOUBLE PRECISION DLAMCH, DZNRM2 - EXTERNAL DLAMCH, DZNRM2, IDAMAX, ILAENV -C .. External Subroutines .. - EXTERNAL MB3OYZ, XERBLA, ZCOPY, ZLAIC1, ZLAPMT, ZLARFG, - $ ZLARTG, ZLASET, ZLATZM, ZROT, ZSWAP, ZUNMQR -C .. Intrinsic Functions .. - INTRINSIC ABS, DBLE, DCONJG, INT, MAX, MIN, SQRT -C .. Executable Statements .. -C -C Test the input parameters. -C - LQUERY = ( LZWORK.EQ.-1 ) - INFO = 0 - PN = P + N - MN = M + N - MPM = MIN( P, M ) - IF( N.LT.0 ) THEN - INFO = -2 - ELSE IF( M.LT.0 .OR. ( .NOT.FIRST .AND. M.GT.P ) ) THEN - INFO = -3 - ELSE IF( P.LT.0 ) THEN - INFO = -4 - ELSE IF( SVLMAX.LT.ZERO ) THEN - INFO = -5 - ELSE IF( LDABCD.LT.MAX( 1, PN ) ) THEN - INFO = -7 - ELSE IF( LDE.LT.MAX( 1, N ) ) THEN - INFO = -9 - ELSE IF( TOL.GT.ONE ) THEN - INFO = -17 - ELSE - WRKOPT = MAX( 1, 3*P ) - IF( P.GT.0 ) THEN - IF( M.GT.0 ) THEN - WRKOPT = MAX( WRKOPT, MN-1 ) - IF( FIRST ) THEN - WRKOPT = MAX( WRKOPT, MPM + MAX( 3*M-1, N ) ) - IF( LQUERY ) THEN - NB = MIN( 64, ILAENV( 1, 'ZUNMQR', 'LC', P, N, - $ MPM, -1 ) ) - WRKOPT = MAX( WRKOPT, MPM + MAX( 1, N )*NB ) - END IF - END IF - END IF - END IF - IF( LZWORK.LT.WRKOPT .AND. .NOT.LQUERY ) THEN - INFO = -21 - END IF - END IF - IF( INFO.NE.0 ) THEN - CALL XERBLA( 'AG8BYZ', -INFO ) - RETURN - ELSE IF( LQUERY ) THEN - ZWORK(1) = WRKOPT - RETURN - END IF -C -C Initialize output variables. -C - PR = P - NR = N - DINFZ = 0 - NINFZ = 0 - NKRONL = 0 -C -C Quick return if possible. -C - IF( P.EQ.0 ) THEN - ZWORK(1) = CONE - RETURN - END IF - IF( N.EQ.0 .AND. M.EQ.0 ) THEN - PR = 0 - NKRONL = 1 - KRONL(1) = P - ZWORK(1) = CONE - RETURN - END IF -C - RCOND = TOL - IF( RCOND.LE.ZERO ) THEN -C -C Use the default tolerance in rank determination. -C - RCOND = DBLE( PN*MN )*DLAMCH( 'EPSILON' ) - END IF -C -C The D matrix is (RO+SIGMA)-by-M, where RO = P - SIGMA and -C SIGMA = 0 for FIRST = .TRUE. and SIGMA = M for FIRST = .FALSE.. -C The leading (RO+SIGMA)-by-SIGMA submatrix of D has full column -C rank, with the trailing SIGMA-by-SIGMA submatrix upper triangular. -C - IF( FIRST ) THEN - SIGMA = 0 - ELSE - SIGMA = M - END IF - RO = P - SIGMA - MP1 = M + 1 - MUI = 0 - DUM(1) = CZERO -C - ITAU = 1 - JWORK1 = ITAU + MPM - ISMIN = 1 - ISMAX = ISMIN + P - JWORK2 = ISMAX + P - NBLCKS = 0 - WRKOPT = 1 -C - 10 IF( PR.EQ.0 ) GO TO 90 -C -C (NR+1,ICOL+1) points to the current position of matrix D. -C - RO1 = RO - MNR = M + NR - IF( M.GT.0 ) THEN -C -C Compress rows of D; first exploit the trapezoidal shape of the -C (RO+SIGMA)-by-SIGMA matrix in the first SIGMA columns of D; -C compress the first SIGMA columns without column pivoting: -C -C ( x x x x x ) ( x x x x x ) -C ( x x x x x ) ( 0 x x x x ) -C ( x x x x x ) - > ( 0 0 x x x ) -C ( 0 x x x x ) ( 0 0 0 x x ) -C ( 0 0 x x x ) ( 0 0 0 x x ) -C -C where SIGMA = 3 and RO = 2. -C Complex workspace: need maximum M+N-1. -C - IROW = NR - DO 20 ICOL = 1, SIGMA - IROW = IROW + 1 - CALL ZLARFG( RO+1, ABCD(IROW,ICOL), ABCD(IROW+1,ICOL), 1, - $ TC ) - CALL ZLATZM( 'L', RO+1, MNR-ICOL, ABCD(IROW+1,ICOL), 1, - $ DCONJG( TC ), ABCD(IROW,ICOL+1), - $ ABCD(IROW+1,ICOL+1), LDABCD, ZWORK ) - CALL ZCOPY( PR-ICOL, DUM, 0, ABCD(IROW+1,ICOL), 1 ) - 20 CONTINUE - WRKOPT = MAX( WRKOPT, MN - 1 ) -C - IF( FIRST ) THEN -C -C Continue with Householder with column pivoting. -C -C ( x x x x x ) ( x x x x x ) -C ( 0 x x x x ) ( 0 x x x x ) -C ( 0 0 x x x ) - > ( 0 0 x x x ) -C ( 0 0 0 x x ) ( 0 0 0 x x ) -C ( 0 0 0 x x ) ( 0 0 0 0 0 ) -C -C Real workspace: need maximum 2*M; -C Complex workspace: need maximum min(P,M)+3*M-1; -C Integer workspace: need maximum M. -C - IROW = MIN( NR+SIGMA+1, PN ) - ICOL = MIN( SIGMA+1, M ) - CALL MB3OYZ( RO1, M-SIGMA, ABCD(IROW,ICOL), LDABCD, - $ RCOND, SVLMAX, RANK, SVAL, IWORK, ZWORK(ITAU), - $ DWORK, ZWORK(JWORK1), INFO ) - WRKOPT = MAX( WRKOPT, JWORK1 + 3*M - 2 ) -C -C Apply the column permutations to B and part of D. -C - CALL ZLAPMT( .TRUE., NR+SIGMA, M-SIGMA, ABCD(1,ICOL), - $ LDABCD, IWORK ) -C - IF( RANK.GT.0 ) THEN -C -C Apply the Householder transformations to the submatrix C. -C Complex workspace: need maximum min(P,M) + N; -C prefer maximum min(P,M) + N*NB. -C - CALL ZUNMQR( 'Left', 'ConjTranspose', RO1, NR, RANK, - $ ABCD(IROW,ICOL), LDABCD, ZWORK(ITAU), - $ ABCD(IROW,MP1), LDABCD, ZWORK(JWORK1), - $ LZWORK-JWORK1+1, INFO ) - WRKOPT = MAX( WRKOPT, JWORK1 + INT( ZWORK(JWORK1) ) - 1 ) - CALL ZLASET( 'Lower', RO1-1, MIN( RO1-1, RANK ), CZERO, - $ CZERO, ABCD(MIN( IROW+1, PN ),ICOL), - $ LDABCD ) - RO1 = RO1 - RANK - END IF - END IF -C -C Terminate if Dr has maximal row rank. -C - IF( RO1.EQ.0 ) GO TO 90 -C - END IF -C -C Update SIGMA. -C - SIGMA = PR - RO1 -C - NBLCKS = NBLCKS + 1 - TAUI = RO1 -C -C Compress the columns of current C to separate a TAUI-by-MUI -C full column rank block. -C - IF( NR.EQ.0 ) THEN -C -C Finish for zero state dimension. -C - PR = SIGMA - RANK = 0 - ELSE -C -C Perform RQ-decomposition with row pivoting on the current C -C while keeping E upper triangular. -C The current C is the TAUI-by-NR matrix delimited by rows -C IRC+1 to IRC+TAUI and columns M+1 to M+NR of ABCD. -C The rank of current C is computed in MUI. -C Real workspace: need maximum 2*P; -C Complex workspace: need maximum 3*P. -C - IRC = NR + SIGMA - N1 = NR - IF( TAUI.GT.1 ) THEN -C -C Compute norms. -C - DO 30 I = 1, TAUI - DWORK(I) = DZNRM2( NR, ABCD(IRC+I,MP1), LDABCD ) - DWORK(P+I) = DWORK(I) - 30 CONTINUE - END IF -C - RANK = 0 - MNTAU = MIN( TAUI, NR ) -C -C ICOL and IROW will point to the current pivot position in C. -C - ILAST = NR + PR - JLAST = M + NR - IROW = ILAST - ICOL = JLAST - I = TAUI - 40 IF( RANK.LT.MNTAU ) THEN - MN1 = M + N1 -C -C Pivot if necessary. -C - IF( I.NE.1 ) THEN - J = IDAMAX( I, DWORK, 1 ) - IF( J.NE.I ) THEN - DWORK(J) = DWORK(I) - DWORK(P+J) = DWORK(P+I) - CALL ZSWAP( N1, ABCD(IROW,MP1), LDABCD, - $ ABCD(IRC+J,MP1), LDABCD ) - END IF - END IF -C -C Zero elements left to ABCD(IROW,ICOL). -C - DO 50 K = 1, N1-1 - J = M + K -C -C Rotate columns J, J+1 to zero ABCD(IROW,J). -C - TC = ABCD(IROW,J+1) - CALL ZLARTG( TC, ABCD(IROW,J), C, S, ABCD(IROW,J+1) ) - ABCD(IROW,J) = CZERO - CALL ZROT( IROW-1, ABCD(1,J+1), 1, ABCD(1,J), 1, C, S ) - CALL ZROT( K+1, E(1,K+1), 1, E(1,K), 1, C, S ) -C -C Rotate rows K, K+1 to zero E(K+1,K). -C - TC = E(K,K) - CALL ZLARTG( TC, E(K+1,K), C, S, E(K,K) ) - E(K+1,K) = CZERO - CALL ZROT( N1-K, E(K,K+1), LDE, E(K+1,K+1), LDE, C, S ) - CALL ZROT( MN1, ABCD(K,1), LDABCD, ABCD(K+1,1), LDABCD, - $ C, S ) - 50 CONTINUE -C - IF( RANK.EQ.0 ) THEN -C -C Initialize; exit if matrix is zero (RANK = 0). -C - SMAX = ABS( ABCD(ILAST,JLAST) ) - IF ( SMAX.EQ.ZERO ) GO TO 80 - SMIN = SMAX - SMAXPR = SMAX - SMINPR = SMIN - C1 = CONE - C2 = CONE - ELSE -C -C One step of incremental condition estimation. -C Complex workspace: need maximum 3*P. -C - CALL ZCOPY( RANK, ABCD(IROW,ICOL+1), LDABCD, - $ ZWORK(JWORK2), 1 ) - CALL ZLAIC1( IMIN, RANK, ZWORK(ISMIN), SMIN, - $ ZWORK(JWORK2), ABCD(IROW,ICOL), SMINPR, S1, - $ C1 ) - CALL ZLAIC1( IMAX, RANK, ZWORK(ISMAX), SMAX, - $ ZWORK(JWORK2), ABCD(IROW,ICOL), SMAXPR, S2, - $ C2 ) - WRKOPT = MAX( WRKOPT, 3*P ) - END IF -C -C Check the rank; finish the loop if rank loss occurs. -C - IF( SVLMAX*RCOND.LE.SMAXPR ) THEN - IF( SVLMAX*RCOND.LE.SMINPR ) THEN - IF( SMAXPR*RCOND.LE.SMINPR ) THEN -C -C Finish the loop if last row. -C - IF( N1.EQ.0 ) THEN - RANK = RANK + 1 - GO TO 80 - END IF -C - IF( N1.GT.1 ) THEN -C -C Update norms. -C - IF( I-1.GT.1 ) THEN - DO 60 J = 1, I - 1 - IF( DWORK(J).NE.ZERO ) THEN - T = ONE - ( ABS( ABCD(IRC+J,ICOL) ) - $ /DWORK(J) )**2 - T = MAX( T, ZERO ) - TT = ONE + - $ P05*T*( DWORK(J)/DWORK(P+J) )**2 - IF( TT.NE.ONE ) THEN - DWORK(J) = DWORK(J)*SQRT( T ) - ELSE - DWORK(J) = DZNRM2( N1-1, - $ ABCD(IRC+J,MP1), LDABCD ) - DWORK(P+J) = DWORK(J) - END IF - END IF - 60 CONTINUE - END IF - END IF -C - DO 70 J = 1, RANK - ZWORK(ISMIN+J-1) = S1*ZWORK(ISMIN+J-1) - ZWORK(ISMAX+J-1) = S2*ZWORK(ISMAX+J-1) - 70 CONTINUE -C - ZWORK(ISMIN+RANK) = C1 - ZWORK(ISMAX+RANK) = C2 - SMIN = SMINPR - SMAX = SMAXPR - RANK = RANK + 1 - ICOL = ICOL - 1 - IROW = IROW - 1 - N1 = N1 - 1 - I = I - 1 - GO TO 40 - END IF - END IF - END IF - END IF - END IF -C - 80 CONTINUE - MUI = RANK - NR = NR - MUI - PR = SIGMA + MUI -C -C Set number of left Kronecker blocks of order (i-1)-by-i. -C - KRONL(NBLCKS) = TAUI - MUI -C -C Set number of infinite divisors of order i-1. -C - IF( FIRST .AND. NBLCKS.GT.1 ) - $ INFZ(NBLCKS-1) = MUIM1 - TAUI - MUIM1 = MUI - RO = MUI -C -C Continue reduction if rank of current C is positive. -C - IF( MUI.GT.0 ) - $ GO TO 10 -C -C Determine the maximal degree of infinite zeros and -C the number of infinite zeros. -C - 90 CONTINUE - IF( FIRST ) THEN - IF( MUI.EQ.0 ) THEN - DINFZ = MAX( 0, NBLCKS - 1 ) - ELSE - DINFZ = NBLCKS - INFZ(NBLCKS) = MUI - END IF - K = DINFZ - DO 100 I = K, 1, -1 - IF( INFZ(I).NE.0 ) GO TO 110 - DINFZ = DINFZ - 1 - 100 CONTINUE - 110 CONTINUE - DO 120 I = 1, DINFZ - NINFZ = NINFZ + INFZ(I)*I - 120 CONTINUE - END IF -C -C Determine the maximal order of left elementary Kronecker blocks. -C - NKRONL = NBLCKS - DO 130 I = NBLCKS, 1, -1 - IF( KRONL(I).NE.0 ) GO TO 140 - NKRONL = NKRONL - 1 - 130 CONTINUE - 140 CONTINUE -C - ZWORK(1) = WRKOPT - RETURN -C *** Last line of AG8BYZ *** - END diff --git a/mex/sources/libslicot/BB01AD.f b/mex/sources/libslicot/BB01AD.f deleted file mode 100644 index 8eafe1f32..000000000 --- a/mex/sources/libslicot/BB01AD.f +++ /dev/null @@ -1,1286 +0,0 @@ - SUBROUTINE BB01AD(DEF, NR, DPAR, IPAR, BPAR, CHPAR, VEC, N, M, P, - 1 A, LDA, B, LDB, C, LDC, G, LDG, Q, LDQ, X, LDX, - 2 DWORK, LDWORK, INFO) -C -C SLICOT RELEASE 5.0. -C -C Copyright (c) 2002-2009 NICONET e.V. -C -C This program is free software: you can redistribute it and/or -C modify it under the terms of the GNU General Public License as -C published by the Free Software Foundation, either version 2 of -C the License, or (at your option) any later version. -C -C This program is distributed in the hope that it will be useful, -C but WITHOUT ANY WARRANTY; without even the implied warranty of -C MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the -C GNU General Public License for more details. -C -C You should have received a copy of the GNU General Public License -C along with this program. If not, see -C . -C -C PURPOSE -C -C To generate the benchmark examples for the numerical solution of -C continuous-time algebraic Riccati equations (CAREs) of the form -C -C 0 = Q + A'X + XA - XGX -C -C corresponding to the Hamiltonian matrix -C -C ( A G ) -C H = ( T ). -C ( Q -A ) -C -C A,G,Q,X are real N-by-N matrices, Q and G are symmetric and may -C be given in factored form -C -C -1 T T -C (I) G = B R B , (II) Q = C W C . -C -C Here, C is P-by-N, W P-by-P, B N-by-M, and R M-by-M, where W -C and R are symmetric. In linear-quadratic optimal control problems, -C usually W is positive semidefinite and R positive definite. The -C factorized form can be used if the CARE is solved using the -C deflating subspaces of the extended Hamiltonian pencil -C -C ( A 0 B ) ( I 0 0 ) -C ( T ) ( ) -C H - s K = ( Q A 0 ) - s ( 0 -I 0 ) , -C ( T ) ( ) -C ( 0 B R ) ( 0 0 0 ) -C -C where I and 0 denote the identity and zero matrix, respectively, -C of appropriate dimensions. -C -C NOTE: the formulation of the CARE and the related matrix (pencils) -C used here does not include CAREs as they arise in robust -C control (H_infinity optimization). -C -C ARGUMENTS -C -C Mode Parameters -C -C DEF CHARACTER -C This parameter specifies if the default parameters are -C to be used or not. -C = 'N' or 'n' : The parameters given in the input vectors -C xPAR (x = 'D', 'I', 'B', 'CH') are used. -C = 'D' or 'd' : The default parameters for the example -C are used. -C This parameter is not meaningful if NR(1) = 1. -C -C Input/Output Parameters -C -C NR (input) INTEGER array, dimension (2) -C This array determines the example for which CAREX returns -C data. NR(1) is the group of examples. -C NR(1) = 1 : parameter-free problems of fixed size. -C NR(1) = 2 : parameter-dependent problems of fixed size. -C NR(1) = 3 : parameter-free problems of scalable size. -C NR(1) = 4 : parameter-dependent problems of scalable size. -C NR(2) is the number of the example in group NR(1). -C Let NEXi be the number of examples in group i. Currently, -C NEX1 = 6, NEX2 = 9, NEX3 = 2, NEX4 = 4. -C 1 <= NR(1) <= 4; -C 1 <= NR(2) <= NEXi , where i = NR(1). -C -C DPAR (input/output) DOUBLE PRECISION array, dimension (7) -C Double precision parameter vector. For explanation of the -C parameters see [1]. -C DPAR(1) : defines the parameters -C 'delta' for NR(1) = 3, -C 'q' for NR(1).NR(2) = 4.1, -C 'a' for NR(1).NR(2) = 4.2, and -C 'mu' for NR(1).NR(2) = 4.3. -C DPAR(2) : defines parameters -C 'r' for NR(1).NR(2) = 4.1, -C 'b' for NR(1).NR(2) = 4.2, and -C 'delta' for NR(1).NR(2) = 4.3. -C DPAR(3) : defines parameters -C 'c' for NR(1).NR(2) = 4.2 and -C 'kappa' for NR(1).NR(2) = 4.3. -C DPAR(j), j=4,5,6,7: These arguments are only used to -C generate Example 4.2 and define in -C consecutive order the intervals -C ['beta_1', 'beta_2'], -C ['gamma_1', 'gamma_2']. -C NOTE that if DEF = 'D' or 'd', the values of DPAR entries -C on input are ignored and, on output, they are overwritten -C with the default parameters. -C -C IPAR (input/output) INTEGER array, dimension (3) -C On input, IPAR(1) determines the actual state dimension, -C i.e., the order of the matrix A as follows, where -C NO = NR(1).NR(2). -C NR(1) = 1 or 2.1-2.8: IPAR(1) is ignored. -C NO = 2.9 : IPAR(1) = 1 generates the CARE for -C optimal state feedback (default); -C IPAR(1) = 2 generates the Kalman -C filter CARE. -C NO = 3.1 : IPAR(1) is the number of vehicles -C (parameter 'l' in the description -C in [1]). -C NO = 3.2, 4.1 or 4.2: IPAR(1) is the order of the matrix -C A. -C NO = 4.3 or 4.4 : IPAR(1) determines the dimension of -C the second-order system, i.e., the -C order of the stiffness matrix for -C Examples 4.3 and 4.4 (parameter 'l' -C in the description in [1]). -C -C The order of the output matrix A is N = 2*IPAR(1) for -C Example 4.3 and N = 2*IPAR(1)-1 for Examples 3.1 and 4.4. -C NOTE that IPAR(1) is overwritten for Examples 1.1-2.8. For -C the other examples, IPAR(1) is overwritten if the default -C parameters are to be used. -C On output, IPAR(1) contains the order of the matrix A. -C -C On input, IPAR(2) is the number of colums in the matrix B -C in (I) (in control problems, the number of inputs of the -C system). Currently, IPAR(2) is fixed or determined by -C IPAR(1) for all examples and thus is not referenced on -C input. -C On output, IPAR(2) is the number of columns of the -C matrix B from (I). -C NOTE that currently IPAR(2) is overwritten and that -C rank(G) <= IPAR(2). -C -C On input, IPAR(3) is the number of rows in the matrix C -C in (II) (in control problems, the number of outputs of the -C system). Currently, IPAR(3) is fixed or determined by -C IPAR(1) for all examples and thus is not referenced on -C input. -C On output, IPAR(3) contains the number of rows of the -C matrix C in (II). -C NOTE that currently IPAR(3) is overwritten and that -C rank(Q) <= IPAR(3). -C -C BPAR (input) BOOLEAN array, dimension (6) -C This array defines the form of the output of the examples -C and the storage mode of the matrices G and Q. -C BPAR(1) = .TRUE. : G is returned. -C BPAR(1) = .FALSE. : G is returned in factored form, i.e., -C B and R from (I) are returned. -C BPAR(2) = .TRUE. : The matrix returned in array G (i.e., -C G if BPAR(1) = .TRUE. and R if -C BPAR(1) = .FALSE.) is stored as full -C matrix. -C BPAR(2) = .FALSE. : The matrix returned in array G is -C provided in packed storage mode. -C BPAR(3) = .TRUE. : If BPAR(2) = .FALSE., the matrix -C returned in array G is stored in upper -C packed mode, i.e., the upper triangle -C of a symmetric n-by-n matrix is stored -C by columns, e.g., the matrix entry -C G(i,j) is stored in the array entry -C G(i+j*(j-1)/2) for i <= j. -C Otherwise, this entry is ignored. -C BPAR(3) = .FALSE. : If BPAR(2) = .FALSE., the matrix -C returned in array G is stored in lower -C packed mode, i.e., the lower triangle -C of a symmetric n-by-n matrix is stored -C by columns, e.g., the matrix entry -C G(i,j) is stored in the array entry -C G(i+(2*n-j)*(j-1)/2) for j <= i. -C Otherwise, this entry is ignored. -C BPAR(4) = .TRUE. : Q is returned. -C BPAR(4) = .FALSE. : Q is returned in factored form, i.e., -C C and W from (II) are returned. -C BPAR(5) = .TRUE. : The matrix returned in array Q (i.e., -C Q if BPAR(4) = .TRUE. and W if -C BPAR(4) = .FALSE.) is stored as full -C matrix. -C BPAR(5) = .FALSE. : The matrix returned in array Q is -C provided in packed storage mode. -C BPAR(6) = .TRUE. : If BPAR(5) = .FALSE., the matrix -C returned in array Q is stored in upper -C packed mode (see above). -C Otherwise, this entry is ignored. -C BPAR(6) = .FALSE. : If BPAR(5) = .FALSE., the matrix -C returned in array Q is stored in lower -C packed mode (see above). -C Otherwise, this entry is ignored. -C NOTE that there are no default values for BPAR. If all -C entries are declared to be .TRUE., then matrices G and Q -C are returned in conventional storage mode, i.e., as -C N-by-N arrays where the array element Z(I,J) contains the -C matrix entry Z_{i,j}. -C -C CHPAR (input/output) CHARACTER*255 -C On input, this is the name of a data file supplied by the -C user. -C In the current version, only Example 4.4 allows a -C user-defined data file. This file must contain -C consecutively DOUBLE PRECISION vectors mu, delta, gamma, -C and kappa. The length of these vectors is determined by -C the input value for IPAR(1). -C If on entry, IPAR(1) = L, then mu and delta must each -C contain L DOUBLE PRECISION values, and gamma and kappa -C must each contain L-1 DOUBLE PRECISION values. -C On output, this string contains short information about -C the chosen example. -C -C VEC (output) LOGICAL array, dimension (9) -C Flag vector which displays the availability of the output -C data: -C VEC(j), j=1,2,3, refer to N, M, and P, respectively, and -C are always .TRUE. -C VEC(4) refers to A and is always .TRUE. -C VEC(5) is .TRUE. if BPAR(1) = .FALSE., i.e., the factors B -C and R from (I) are returned. -C VEC(6) is .TRUE. if BPAR(4) = .FALSE., i.e., the factors C -C and W from (II) are returned. -C VEC(7) refers to G and is always .TRUE. -C VEC(8) refers to Q and is always .TRUE. -C VEC(9) refers to X and is .TRUE. if the exact solution -C matrix is available. -C NOTE that VEC(i) = .FALSE. for i = 1 to 9 if on exit -C INFO .NE. 0. -C -C N (output) INTEGER -C The order of the matrices A, X, G if BPAR(1) = .TRUE., and -C Q if BPAR(4) = .TRUE. -C -C M (output) INTEGER -C The number of columns in the matrix B (or the dimension of -C the control input space of the underlying dynamical -C system). -C -C P (output) INTEGER -C The number of rows in the matrix C (or the dimension of -C the output space of the underlying dynamical system). -C -C A (output) DOUBLE PRECISION array, dimension (LDA,N) -C The leading N-by-N part of this array contains the -C coefficient matrix A of the CARE. -C -C LDA INTEGER -C The leading dimension of array A. LDA >= N. -C -C B (output) DOUBLE PRECISION array, dimension (LDB,M) -C If (BPAR(1) = .FALSE.), then the leading N-by-M part of -C this array contains the matrix B of the factored form (I) -C of G. Otherwise, B is used as workspace. -C -C LDB INTEGER -C The leading dimension of array B. LDB >= N. -C -C C (output) DOUBLE PRECISION array, dimension (LDC,N) -C If (BPAR(4) = .FALSE.), then the leading P-by-N part of -C this array contains the matrix C of the factored form (II) -C of Q. Otherwise, C is used as workspace. -C -C LDC INTEGER -C The leading dimension of array C. -C LDC >= P, where P is the number of rows of the matrix C, -C i.e., the output value of IPAR(3). (For all examples, -C P <= N, where N equals the output value of the argument -C IPAR(1), i.e., LDC >= LDA is always safe.) -C -C G (output) DOUBLE PRECISION array, dimension (NG) -C If (BPAR(2) = .TRUE.) then NG = LDG*N. -C If (BPAR(2) = .FALSE.) then NG = N*(N+1)/2. -C If (BPAR(1) = .TRUE.), then array G contains the -C coefficient matrix G of the CARE. -C If (BPAR(1) = .FALSE.), then array G contains the 'control -C weighting matrix' R of G's factored form as in (I). (For -C all examples, M <= N.) The symmetric matrix contained in -C array G is stored according to BPAR(2) and BPAR(3). -C -C LDG INTEGER -C If conventional storage mode is used for G, i.e., -C BPAR(2) = .TRUE., then G is stored like a 2-dimensional -C array with leading dimension LDG. If packed symmetric -C storage mode is used, then LDG is not referenced. -C LDG >= N if BPAR(2) = .TRUE.. -C -C Q (output) DOUBLE PRECISION array, dimension (NQ) -C If (BPAR(5) = .TRUE.) then NQ = LDQ*N. -C If (BPAR(5) = .FALSE.) then NQ = N*(N+1)/2. -C If (BPAR(4) = .TRUE.), then array Q contains the -C coefficient matrix Q of the CARE. -C If (BPAR(4) = .FALSE.), then array Q contains the 'output -C weighting matrix' W of Q's factored form as in (II). -C The symmetric matrix contained in array Q is stored -C according to BPAR(5) and BPAR(6). -C -C LDQ INTEGER -C If conventional storage mode is used for Q, i.e., -C BPAR(5) = .TRUE., then Q is stored like a 2-dimensional -C array with leading dimension LDQ. If packed symmetric -C storage mode is used, then LDQ is not referenced. -C LDQ >= N if BPAR(5) = .TRUE.. -C -C X (output) DOUBLE PRECISION array, dimension (LDX,IPAR(1)) -C If an exact solution is available (NR = 1.1, 1.2, 2.1, -C 2.3-2.6, 3.2), then the leading N-by-N part of this array -C contains the solution matrix X in conventional storage -C mode. Otherwise, X is not referenced. -C -C LDX INTEGER -C The leading dimension of array X. LDX >= 1, and -C LDX >= N if NR = 1.1, 1.2, 2.1, 2.3-2.6, 3.2. -C -C Workspace -C -C DWORK DOUBLE PRECISION array, dimension (LDWORK) -C -C LDWORK INTEGER -C The length of the array DWORK. -C LDWORK >= N*MAX(4,N). -C -C Error Indicator -C -C INFO INTEGER -C = 0 : successful exit; -C < 0 : if INFO = -i, the i-th argument had an illegal -C value; -C = 1 : data file could not be opened or had wrong format; -C = 2 : division by zero; -C = 3 : G can not be computed as in (I) due to a singular R -C matrix. -C -C REFERENCES -C -C [1] Abels, J. and Benner, P. -C CAREX - A Collection of Benchmark Examples for Continuous-Time -C Algebraic Riccati Equations (Version 2.0). -C SLICOT Working Note 1999-14, November 1999. Available from -C http://www.win.tue.nl/niconet/NIC2/reports.html. -C -C This is an updated and extended version of -C -C [2] Benner, P., Laub, A.J., and Mehrmann, V. -C A Collection of Benchmark Examples for the Numerical Solution -C of Algebraic Riccati Equations I: Continuous-Time Case. -C Technical Report SPC 95_22, Fak. f. Mathematik, -C TU Chemnitz-Zwickau (Germany), October 1995. -C -C NUMERICAL ASPECTS -C -C If the original data as taken from the literature is given via -C matrices G and Q, but factored forms are requested as output, then -C these factors are obtained from Cholesky or LDL' decompositions of -C G and Q, i.e., the output data will be corrupted by roundoff -C errors. -C -C FURTHER COMMENTS -C -C Some benchmark examples read data from the data files provided -C with the collection. -C -C CONTRIBUTOR -C -C Peter Benner (Universitaet Bremen), November 15, 1999. -C -C For questions concerning the collection or for the submission of -C test examples, please send e-mail to benner@math.uni-bremen.de. -C -C REVISIONS -C -C 1999, December 23 (V. Sima). -C -C KEYWORDS -C -C Algebraic Riccati equation, Hamiltonian matrix. -C -C ****************************************************************** -C -C .. Parameters .. -C . # of examples available , # of examples with fixed size. . - INTEGER NEX1, NEX2, NEX3, NEX4, NMAX - PARAMETER ( NMAX = 9, NEX1 = 6, NEX2 = 9, NEX3 = 2, - 1 NEX4 = 4 ) - DOUBLE PRECISION ZERO, ONE, TWO, THREE, FOUR, PI - PARAMETER ( ZERO = 0.0D0, ONE = 1.0D0, TWO = 2.0D0, - 1 THREE = 3.0D0, FOUR = 4.0D0, - 2 PI = .3141592653589793D1 ) -C -C .. Scalar Arguments .. - INTEGER INFO, LDA, LDB, LDC, LDG, LDQ, LDWORK, LDX, M, N, - $ P - CHARACTER DEF -C -C .. Array Arguments .. - INTEGER IPAR(3), NR(2) - DOUBLE PRECISION A(LDA,*), B(LDB,*), C(LDC,*), DPAR(*), DWORK(*), - 1 G(*), Q(*), X(LDX,*) - CHARACTER CHPAR*255 - LOGICAL BPAR(6), VEC(9) -C -C .. Local Scalars .. - INTEGER GDIMM, I, IOS, ISYMM, J, K, L, MSYMM, NSYMM, POS, - 1 PSYMM, QDIMM - DOUBLE PRECISION APPIND, B1, B2, C1, C2, SUM, TEMP, TTEMP -C -C ..Local Arrays .. - INTEGER MDEF(2,NMAX), NDEF(4,NMAX), NEX(4), PDEF(2,NMAX) - DOUBLE PRECISION PARDEF(4,NMAX) - CHARACTER IDENT*4 - CHARACTER*255 NOTES(4,NMAX) -C -C .. External Functions .. -C . BLAS . - DOUBLE PRECISION DDOT - EXTERNAL DDOT -C . LAPACK . - LOGICAL LSAME - DOUBLE PRECISION DLAPY2 - EXTERNAL LSAME, DLAPY2 -C -C .. External Subroutines .. -C . BLAS . - EXTERNAL DCOPY, DGEMV, DSCAL, DSPMV, DSPR, DSYMM, DSYRK -C . LAPACK . - EXTERNAL DLASET, DPPTRF, DPPTRI, DPTTRF, DPTTRS, XERBLA -C . SLICOT . - EXTERNAL MA02DD, MA02ED -C -C .. Intrinsic Functions .. - INTRINSIC COS, MAX, MIN, MOD, SQRT -C -C .. Data Statements .. -C . default values for dimensions . - DATA (NEX(I), I = 1, 4) /NEX1, NEX2, NEX3, NEX4/ - DATA (NDEF(1,I), I = 1, NEX1) /2, 2, 4, 8, 9, 30/ - DATA (NDEF(2,I), I = 1, NEX2) /2, 2, 2, 2, 2, 3, 4, 4, 55/ - DATA (NDEF(3,I), I = 1, NEX3) /20, 64/ - DATA (NDEF(4,I), I = 1, NEX4) /21, 100, 30, 211/ - DATA (MDEF(1,I), I = 1, NEX1) /1, 1, 2, 2, 3, 3/ - DATA (MDEF(2,I), I = 1, NEX2) /1, 2, 1, 2, 1, 3, 1, 1, 2/ - DATA (PDEF(1,I), I = 1, NEX1) /2, 2, 4, 8, 9, 5/ - DATA (PDEF(2,I), I = 1, NEX2) /1, 1, 2, 2, 2, 3, 2, 1, 10/ -C . default values for parameters . - DATA (PARDEF(1,I), I = 1, NEX1) /ZERO, ZERO, ZERO, ZERO, ZERO, - 1 ZERO/ - DATA (PARDEF(2,I), I = 1, NEX2) /.1D-5, .1D-7, .1D7, .1D-6, ZERO, - 1 .1D7, .1D-5, .1D-5, .1D1/ - DATA (PARDEF(3,I), I = 1, NEX3) /ZERO, ZERO/ - DATA (PARDEF(4,I), I = 1, NEX4) /ONE, .1D-1, FOUR, ZERO/ -C . comments on examples . - DATA (NOTES(1,I), I = 1, NEX1) / - 1'Laub 1979, Ex.1', 'Laub 1979, Ex.2: uncontrollable-unobservable d - 2ata', 'Beale/Shafai 1989: model of L-1011 aircraft', 'Bhattacharyy - 3a et al. 1983: binary distillation column', 'Patnaik et al. 1980: - 4tubular ammonia reactor', 'Davison/Gesing 1978: J-100 jet engine'/ - DATA (NOTES(2,I), I = 1, NEX2) / - 1'Arnold/Laub 1984, Ex.1: (A,B) unstabilizable as EPS -> 0', 'Arnol - 2d/Laub 1984, Ex.3: control weighting matrix singular as EPS -> 0', - 3'Kenney/Laub/Wette 1989, Ex.2: ARE ill conditioned for EPS -> oo', - 4'Bai/Qian 1994: ill-conditioned Hamiltonian for EPS -> 0', 'Laub 1 - 5992: H-infinity problem, eigenvalues +/- EPS +/- i', 'Petkov et a - 6l. 1987: increasingly badly scaled Hamiltonian as EPS -> oo', 'Cho - 7w/Kokotovic 1976: magnetic tape control system', 'Arnold/Laub 1984 - 8, Ex.2: poor sep. of closed-loop spectrum as EPS -> 0', 'IFAC Benc - 9hmark Problem #90-06: LQG design for modified Boing B-767 at flutt - 1er condition'/ - DATA (NOTES(3,I), I = 1, NEX3) / - 1'Laub 1979, Ex.4: string of high speed vehicles', 'Laub 1979, Ex.5 - 2: circulant matrices'/ - DATA (NOTES(4,I), I = 1, NEX4) / - 1'Laub 1979, Ex.6: ill-conditioned Riccati equation', 'Rosen/Wang 1 - 2992: lq control of 1-dimensional heat flow','Hench et al. 1995: co - 3upled springs, dashpots and masses','Lang/Penzl 1994: rotating axl - 4e' / -C -C .. Executable Statements .. -C - INFO = 0 - DO 5 I = 1, 9 - VEC(I) = .FALSE. - 5 CONTINUE -C - IF ((NR(1) .NE. 1) .AND. (.NOT. (LSAME(DEF,'N') - 1 .OR. LSAME(DEF,'D')))) THEN - INFO = -1 - ELSE IF ((NR(1) .LT. 1) .OR. (NR(2) .LT. 1) .OR. - 1 (NR(1) .GT. 4) .OR. (NR(2) .GT. NEX(NR(1)))) THEN - INFO = -2 - ELSE IF (NR(1) .GT. 2) THEN - IF (.NOT. LSAME(DEF,'N')) IPAR(1) = NDEF(NR(1),NR(2)) - IF (NR(1) .EQ. 3) THEN - IF (NR(2) .EQ. 1) THEN - IPAR(2) = IPAR(1) - IPAR(3) = IPAR(1) - 1 - IPAR(1) = 2*IPAR(1) - 1 - ELSE IF (NR(2) .EQ. 2) THEN - IPAR(2) = IPAR(1) - IPAR(3) = IPAR(1) - ELSE - IPAR(2) = 1 - IPAR(3) = 1 - END IF - ELSE IF (NR(1) .EQ. 4) THEN - IF (NR(2) .EQ. 3) THEN - L = IPAR(1) - IPAR(2) = 2 - IPAR(3) = 2*L - IPAR(1) = 2*L - ELSE IF (NR(2) .EQ. 4) THEN - L = IPAR(1) - IPAR(2) = L - IPAR(3) = L - IPAR(1) = 2*L-1 - ELSE - IPAR(2) = 1 - IPAR(3) = 1 - END IF - END IF - ELSE IF ((NR(1) .EQ. 2) .AND. (NR(2) .EQ. 9) .AND. - 1 (IPAR(1) . EQ. 2)) THEN - IPAR(1) = NDEF(NR(1),NR(2)) - IPAR(2) = MDEF(NR(1),NR(2)) - IPAR(3) = 3 - ELSE - IPAR(1) = NDEF(NR(1),NR(2)) - IPAR(2) = MDEF(NR(1),NR(2)) - IPAR(3) = PDEF(NR(1),NR(2)) - END IF - IF (INFO .NE. 0) GOTO 7 -C - IF (IPAR(1) .LT. 1) THEN - INFO = -4 - ELSE IF (IPAR(1) .GT. LDA) THEN - INFO = -12 - ELSE IF (IPAR(1) .GT. LDB) THEN - INFO = -14 - ELSE IF (IPAR(3) .GT. LDC) THEN - INFO = -16 - ELSE IF (BPAR(2) .AND. (IPAR(1).GT. LDG)) THEN - INFO = -18 - ELSE IF (BPAR(5) .AND. (IPAR(1).GT. LDQ)) THEN - INFO = -20 - ELSE IF (LDX.LT.1) THEN - INFO = -22 - ELSE IF ((NR(1) .EQ. 1) .AND. - $ ((NR(2) .EQ. 1) .OR. (NR(2) .EQ.2))) THEN - IF (IPAR(1) .GT. LDX) INFO = -22 - ELSE IF ((NR(1) .EQ. 2) .AND. (NR(2) .EQ. 1)) THEN - IF (IPAR(1) .GT. LDX) INFO = -22 - ELSE IF ((NR(1) .EQ. 2) .AND. ((NR(2) .GE. 3) .AND. - 1 (NR(2) .LE. 6))) THEN - IF (IPAR(1) .GT. LDX) INFO = -22 - ELSE IF ((NR(1) .EQ. 3) .AND. (NR(2) .EQ. 2)) THEN - IF (IPAR(1) .GT. LDX) INFO = -22 - ELSE IF (LDWORK .LT. N*(MAX(4,N))) THEN - INFO = -24 - END IF -C - 7 CONTINUE - IF (INFO .NE. 0) THEN - CALL XERBLA( 'BB01AD', -INFO ) - RETURN - END IF -C - NSYMM = (IPAR(1)*(IPAR(1)+1))/2 - MSYMM = (IPAR(2)*(IPAR(2)+1))/2 - PSYMM = (IPAR(3)*(IPAR(3)+1))/2 - IF (.NOT. LSAME(DEF,'N')) DPAR(1) = PARDEF(NR(1),NR(2)) -C - CALL DLASET('A', IPAR(1), IPAR(1), ZERO, ZERO, A, LDA) - CALL DLASET('A', IPAR(1), IPAR(2), ZERO, ZERO, B, LDB) - CALL DLASET('A', IPAR(3), IPAR(1), ZERO, ZERO, C, LDC) - CALL DLASET('L', MSYMM, 1, ZERO, ZERO, G, 1) - CALL DLASET('L', PSYMM, 1, ZERO, ZERO, Q, 1) -C - IF (NR(1) .EQ. 1) THEN - IF (NR(2) .EQ. 1) THEN - A(1,2) = ONE - B(2,1) = ONE - Q(1) = ONE - Q(3) = TWO - IDENT = '0101' - CALL DLASET('A', IPAR(1), IPAR(1), ONE, TWO, X, LDX) -C - ELSE IF (NR(2) .EQ. 2) THEN - A(1,1) = FOUR - A(2,1) = -.45D1 - A(1,2) = THREE - A(2,2) = -.35D1 - CALL DLASET('A', IPAR(1), IPAR(2), -ONE, ONE, B, LDB) - Q(1) = 9.0D0 - Q(2) = 6.0D0 - Q(3) = FOUR - IDENT = '0101' - TEMP = ONE + SQRT(TWO) - CALL DLASET('A', IPAR(1), IPAR(1), 6.0D0*TEMP, FOUR*TEMP, X, - 1 LDX) - X(1,1) = 9.0D0*TEMP -C - ELSE IF ((NR(2) .GE. 3) .AND. (NR(2) .LE. 6)) THEN - WRITE (CHPAR(1:11), '(A,I1,A,I1,A)') 'BB01', NR(1), '0', - 1 NR(2) , '.dat' - IF ((NR(2) .EQ. 3) .OR. (NR(2) .EQ. 4)) THEN - IDENT = '0101' - ELSE IF (NR(2) .EQ. 5) THEN - IDENT = '0111' - ELSE IF (NR(2) .EQ. 6) THEN - IDENT = '0011' - END IF - OPEN(1, IOSTAT = IOS, STATUS = 'OLD', FILE = CHPAR(1:11)) - IF (IOS .NE. 0) THEN - INFO = 1 - ELSE IF (NR(2) .LE. 6) THEN - DO 10 I = 1, IPAR(1) - READ (1, FMT = *, IOSTAT = IOS) - 1 (A(I,J), J = 1, IPAR(1)) - IF (IOS .NE. 0) INFO = 1 - 10 CONTINUE - DO 20 I = 1, IPAR(1) - READ (1, FMT = *, IOSTAT = IOS) - 1 (B(I,J), J = 1, IPAR(2)) - IF (IOS .NE. 0) INFO = 1 - 20 CONTINUE - IF (NR(2) .LE. 4) THEN - DO 30 I = 1, IPAR(1) - POS = (I-1)*IPAR(1) - READ (1, FMT = *, IOSTAT = IOS) (DWORK(POS+J), - 1 J = 1,IPAR(1)) - 30 CONTINUE - IF (IOS .NE. 0) THEN - INFO = 1 - ELSE - CALL MA02DD('Pack', 'Lower', IPAR(1), DWORK, IPAR(1), Q) - END IF - ELSE IF (NR(2) .EQ. 6) THEN - DO 35 I = 1, IPAR(3) - READ (1, FMT = *, IOSTAT = IOS) - 1 (C(I,J), J = 1, IPAR(1)) - IF (IOS .NE. 0) INFO = 1 - 35 CONTINUE - END IF - CLOSE(1) - END IF - END IF -C - ELSE IF (NR(1) .EQ. 2) THEN - IF (NR(2) .EQ. 1) THEN - A(1,1) = ONE - A(2,2) = -TWO - B(1,1) = DPAR(1) - CALL DLASET('U', IPAR(3), IPAR(1), ONE, ONE, C, LDC) - IDENT = '0011' - IF (DPAR(1) .NE. ZERO) THEN - TEMP = DLAPY2(ONE, DPAR(1)) - X(1,1) = (ONE + TEMP)/DPAR(1)/DPAR(1) - X(2,1) = ONE/(TWO + TEMP) - X(1,2) = X(2,1) - TTEMP = DPAR(1)*X(1,2) - TEMP = (ONE - TTEMP) * (ONE + TTEMP) - X(2,2) = TEMP / FOUR - ELSE - INFO = 2 - END IF -C - ELSE IF (NR(2) .EQ. 2) THEN - A(1,1) = -.1D0 - A(2,2) = -.2D-1 - B(1,1) = .1D0 - B(2,1) = .1D-2 - B(2,2) = .1D-1 - CALL DLASET('L', MSYMM, 1, ONE, ONE, G, MSYMM) - G(1) = G(1) + DPAR(1) - C(1,1) = .1D2 - C(1,2) = .1D3 - IDENT = '0010' -C - ELSE IF (NR(2) .EQ. 3) THEN - A(1,2) = DPAR(1) - B(2,1) = ONE - IDENT = '0111' - IF (DPAR(1) .NE. ZERO) THEN - TEMP = SQRT(ONE + TWO*DPAR(1)) - CALL DLASET('A', IPAR(1), IPAR(1), ONE, TEMP, X, LDX) - X(1,1) = X(1,1)/DPAR(1) - ELSE - INFO = 2 - END IF -C - ELSE IF (NR(2) .EQ. 4) THEN - TEMP = DPAR(1) + ONE - CALL DLASET('A', IPAR(1), IPAR(1), ONE, TEMP, A, LDA) - Q(1) = DPAR(1)**2 - Q(3) = Q(1) - IDENT = '1101' - X(1,1) = TWO*TEMP + SQRT(TWO)*(SQRT(TEMP**2 + ONE) + DPAR(1)) - X(1,1) = X(1,1)/TWO - X(2,2) = X(1,1) - TTEMP = X(1,1) - TEMP - IF (TTEMP .NE. ZERO) THEN - X(2,1) = X(1,1) / TTEMP - X(1,2) = X(2,1) - ELSE - INFO = 2 - END IF -C - ELSE IF (NR(2) .EQ. 5) THEN - A(1,1) = THREE - DPAR(1) - A(2,1) = FOUR - A(1,2) = ONE - A(2,2) = TWO - DPAR(1) - CALL DLASET('L', IPAR(1), IPAR(2), ONE, ONE, B, LDB) - Q(1) = FOUR*DPAR(1) - 11.0D0 - Q(2) = TWO*DPAR(1) - 5.0D0 - Q(3) = TWO*DPAR(1) - TWO - IDENT = '0101' - CALL DLASET('A', IPAR(1), IPAR(1), ONE, ONE, X, LDX) - X(1,1) = TWO -C - ELSE IF (NR(2) .EQ. 6) THEN - IF (DPAR(1) .NE. ZERO) THEN - A(1,1) = DPAR(1) - A(2,2) = DPAR(1)*TWO - A(3,3) = DPAR(1)*THREE -C .. set C = V .. - TEMP = TWO/THREE - CALL DLASET('A', IPAR(3), IPAR(1), -TEMP, ONE - TEMP, - 1 C, LDC) - CALL DSYMM('L', 'L', IPAR(1), IPAR(1), ONE, C, LDC, A, LDA, - 1 ZERO, DWORK, IPAR(1)) - CALL DSYMM('R', 'L', IPAR(1), IPAR(1), ONE, C, LDC, DWORK, - 1 IPAR(1), ZERO, A, LDA) -C .. G = R ! .. - G(1) = DPAR(1) - G(4) = DPAR(1) - G(6) = DPAR(1) - Q(1) = ONE/DPAR(1) - Q(4) = ONE - Q(6) = DPAR(1) - IDENT = '1000' - CALL DLASET('A', IPAR(1), IPAR(1), ZERO, ZERO, X, LDX) - TEMP = DPAR(1)**2 - X(1,1) = TEMP + SQRT(TEMP**2 + ONE) - X(2,2) = TEMP*TWO + SQRT(FOUR*TEMP**2 + DPAR(1)) - X(3,3) = TEMP*THREE + DPAR(1)*SQRT(9.0D0*TEMP + ONE) - CALL DSYMM('L', 'L', IPAR(1), IPAR(1), ONE, C, LDC, X, LDX, - 1 ZERO, DWORK, IPAR(1)) - CALL DSYMM('R', 'L', IPAR(1), IPAR(1), ONE, C, LDC, DWORK, - 1 IPAR(1), ZERO, X, LDX) - ELSE - INFO = 2 - END IF -C - ELSE IF (NR(2) .EQ. 7) THEN - IF (DPAR(1) .NE. ZERO) THEN - A(1,2) = .400D0 - A(2,3) = .345D0 - A(3,2) = -.524D0/DPAR(1) - A(3,3) = -.465D0/DPAR(1) - A(3,4) = .262D0/DPAR(1) - A(4,4) = -ONE/DPAR(1) - B(4,1) = ONE/DPAR(1) - C(1,1) = ONE - C(2,3) = ONE - IDENT = '0011' - ELSE - INFO = 2 - END IF -C - ELSE IF (NR(2) .EQ. 8) THEN - A(1,1) = -DPAR(1) - A(2,1) = -ONE - A(1,2) = ONE - A(2,2) = -DPAR(1) - A(3,3) = DPAR(1) - A(4,3) = -ONE - A(3,4) = ONE - A(4,4) = DPAR(1) - CALL DLASET('L', IPAR(1), IPAR(2), ONE, ONE, B, LDB) - CALL DLASET('U', IPAR(3), IPAR(1), ONE, ONE, C, LDC) - IDENT = '0011' -C - ELSE IF (NR(2) .EQ. 9) THEN - IF (IPAR(3) .EQ. 10) THEN -C .. read LQR CARE ... - WRITE (CHPAR(1:12), '(A,I1,A,I1,A)') 'BB01', NR(1), '0', - 1 NR(2), '1.dat' - OPEN(1, IOSTAT = IOS, STATUS = 'OLD', FILE = CHPAR(1:12)) - IF (IOS .NE. 0) THEN - INFO = 1 - ELSE - DO 36 I = 1, 27, 2 - READ (1, FMT = *, IOSTAT = IOS) - 1 ((A(I+J,I+K), K = 0, 1), J = 0, 1) - IF (IOS .NE. 0) INFO = 1 - 36 CONTINUE - DO 37 I = 30, 44, 2 - READ (1, FMT = *, IOSTAT = IOS) - 1 ((A(I+J,I+K), K = 0, 1), J = 0, 1) - IF (IOS .NE. 0) INFO = 1 - 37 CONTINUE - DO 38 I = 1, IPAR(1) - READ (1, FMT = *, IOSTAT = IOS) - 1 (A(I,J), J = 46, IPAR(1)) - IF (IOS .NE. 0) INFO = 1 - 38 CONTINUE - A(29,29) = -.5301D1 - B(48,1) = .8D06 - B(51,2) = .8D06 - G(1) = .3647D03 - G(3) = .1459D02 - DO 39 I = 1,6 - READ (1, FMT = *, IOSTAT = IOS) - 1 (C(I,J), J = 1,45) - IF (IOS .NE. 0) INFO = 1 - 39 CONTINUE - C(7,47) = ONE - C(8,46) = ONE - C(9,50) = ONE - C(10,49) = ONE - Q(11) = .376D-13 - Q(20) = .120D-12 - Q(41) = .245D-11 - END IF - ELSE -C .. read Kalman filter CARE .. - WRITE (CHPAR(1:12), '(A,I1,A,I1,A)') 'BB01', NR(1), '0', - 1 NR(2), '2.dat' - OPEN(1, IOSTAT = IOS, STATUS = 'OLD', FILE = CHPAR(1:12)) - IF (IOS .NE. 0) THEN - INFO = 1 - ELSE - DO 40 I = 1, 27, 2 - READ (1, FMT = *, IOSTAT = IOS) - 1 ((A(I+K,I+J), K = 0, 1), J = 0, 1) - IF (IOS .NE. 0) INFO = 1 - 40 CONTINUE - DO 41 I = 30, 44, 2 - READ (1, FMT = *, IOSTAT = IOS) - 1 ((A(I+K,I+J), K = 0, 1), J = 0, 1) - IF (IOS .NE. 0) INFO = 1 - 41 CONTINUE - DO 42 I = 1, IPAR(1) - READ (1, FMT = *, IOSTAT = IOS) - 1 (A(J,I), J = 46, IPAR(1)) - IF (IOS .NE. 0) INFO = 1 - 42 CONTINUE - A(29,29) = -.5301D1 - DO 43 J = 1, IPAR(2) - READ (1, FMT = *, IOSTAT = IOS) - 1 (B(I,J), I = 1, IPAR(1)) - IF (IOS .NE. 0) INFO = 1 - 43 CONTINUE - G(1) = .685D-5 - G(3) = .373D3 - C(1,52) = .3713 - C(1,53) = .1245D1 - C(2,48) = .8D6 - C(2,54) = ONE - C(3,51) = .8D6 - C(3,55) = ONE - Q(1) = .28224D5 - Q(4) = .2742D-4 - Q(6) = .6854D-3 - END IF - END IF - CLOSE(1) - IDENT = '0000' - END IF -C - ELSE IF (NR(1) .EQ. 3) THEN - IF (NR(2) .EQ. 1) THEN - DO 45 I = 1, IPAR(1) - IF (MOD(I,2) .EQ. 1) THEN - A(I,I) = -ONE - B(I,(I+1)/2) = ONE - ELSE - A(I,I-1) = ONE - A(I,I+1) = -ONE - C(I/2,I) = ONE - END IF - 45 CONTINUE - ISYMM = 1 - DO 50 I = IPAR(3), 1, -1 - Q(ISYMM) = 10.0D0 - ISYMM = ISYMM + I - 50 CONTINUE - IDENT = '0001' -C - ELSE IF (NR(2) .EQ. 2) THEN - DO 60 I = 1, IPAR(1) - A(I,I) = -TWO - IF (I .LT. IPAR(1)) THEN - A(I,I+1) = ONE - A(I+1,I) = ONE - END IF - 60 CONTINUE - A(1,IPAR(1)) = ONE - A(IPAR(1),1) = ONE - IDENT = '1111' - TEMP = TWO * PI / DBLE(IPAR(1)) - DO 70 I = 1, IPAR(1) - DWORK(I) = COS(TEMP*DBLE(I-1)) - DWORK(IPAR(1)+I) = -TWO + TWO*DWORK(I) + - 1 SQRT(5.0D0 + FOUR*DWORK(I)*(DWORK(I) - TWO)) - 70 CONTINUE - DO 90 J = 1, IPAR(1) - DO 80 I = 1, IPAR(1) - DWORK(2*IPAR(1)+I) = COS(TEMP*DBLE(I-1)*DBLE(J-1)) - 80 CONTINUE - X(J,1) = DDOT(IPAR(1), DWORK(IPAR(1)+1), 1, - 1 DWORK(2*IPAR(1)+1), 1)/DBLE(IPAR(1)) - 90 CONTINUE -C .. set up circulant solution matrix .. - DO 100 I = 2, IPAR(1) - CALL DCOPY(IPAR(1)-I+1, X(1,1), 1, X(I,I), 1) - CALL DCOPY(I-1, X(IPAR(1)-I+2,1), 1, X(1,I), 1) - 100 CONTINUE - END IF -C - ELSE IF (NR(1) .EQ. 4) THEN - IF (NR(2) .EQ. 1) THEN -C .. set up remaining parameter .. - IF (.NOT. LSAME(DEF,'N')) THEN - DPAR(1) = ONE - DPAR(2) = ONE - END IF - CALL DLASET('A', IPAR(1)-1, IPAR(1)-1, ZERO, ONE, A(1,2), LDA) - B(IPAR(1),1) = ONE - C(1,1) = ONE - Q(1) = DPAR(1) - G(1) = DPAR(2) - IDENT = '0000' -C - ELSE IF (NR(2) .EQ. 2) THEN -C .. set up remaining parameters .. - APPIND = DBLE(IPAR(1) + 1) - IF (.NOT. LSAME(DEF,'N')) THEN - DPAR(1) = PARDEF(NR(1), NR(2)) - DPAR(2) = ONE - DPAR(3) = ONE - DPAR(4) = .2D0 - DPAR(5) = .3D0 - DPAR(6) = .2D0 - DPAR(7) = .3D0 - END IF -C .. set up stiffness matrix .. - TEMP = -DPAR(1)*APPIND - CALL DLASET('A', IPAR(1), IPAR(1), ZERO, TWO*TEMP, A, LDA) - DO 110 I = 1, IPAR(1) - 1 - A(I+1,I) = -TEMP - A(I,I+1) = -TEMP - 110 CONTINUE -C .. set up Gramian, stored by diagonals .. - TEMP = ONE/(6.0D0*APPIND) - CALL DLASET('L', IPAR(1), 1, FOUR*TEMP, FOUR*TEMP, DWORK, - 1 IPAR(1)) - CALL DLASET('L', IPAR(1)-1, 1, TEMP, TEMP, DWORK(IPAR(1)+1), - 1 IPAR(1)) - CALL DPTTRF(IPAR(1), DWORK(1), DWORK(IPAR(1)+1), INFO) -C .. A = (inverse of Gramian) * (stiffness matrix) .. - CALL DPTTRS(IPAR(1), IPAR(1), DWORK(1), DWORK(IPAR(1)+1), - 1 A, LDA, INFO) -C .. compute B, C .. - DO 120 I = 1, IPAR(1) - B1 = MAX(DBLE(I-1)/APPIND, DPAR(4)) - B2 = MIN(DBLE(I+1)/APPIND, DPAR(5)) - C1 = MAX(DBLE(I-1)/APPIND, DPAR(6)) - C2 = MIN(DBLE(I+1)/APPIND, DPAR(7)) - IF (B1 .GE. B2) THEN - B(I,1) = ZERO - ELSE - B(I,1) = B2 - B1 - TEMP = MIN(B2, DBLE(I)/APPIND) - IF (B1 .LT. TEMP) THEN - B(I,1) = B(I,1) + APPIND*(TEMP**2 - B1**2)/TWO - B(I,1) = B(I,1) + DBLE(I)*(B1 - TEMP) - END IF - TEMP = MAX(B1, DBLE(I)/APPIND) - IF (TEMP .LT. B2) THEN - B(I,1) = B(I,1) - APPIND*(B2**2 - TEMP**2)/TWO - B(I,1) = B(I,1) - DBLE(I)*(TEMP - B2) - END IF - END IF - IF (C1 .GE. C2) THEN - C(1,I) = ZERO - ELSE - C(1,I) = C2 - C1 - TEMP = MIN(C2, DBLE(I)/APPIND) - IF (C1 .LT. TEMP) THEN - C(1,I) = C(1,I) + APPIND*(TEMP**2 - C1**2)/TWO - C(1,I) = C(1,I) + DBLE(I)*(C1 - TEMP) - END IF - TEMP = MAX(C1, DBLE(I)/APPIND) - IF (TEMP .LT. C2) THEN - C(1,I) = C(1,I) - APPIND*(C2**2 - TEMP**2)/TWO - C(1,I) = C(1,I) - DBLE(I)*(TEMP - C2) - END IF - END IF - 120 CONTINUE - CALL DSCAL(IPAR(1), DPAR(2), B(1,1), 1) - CALL DSCAL(IPAR(1), DPAR(3), C(1,1), LDC) - CALL DPTTRS(IPAR(1), 1, DWORK(1), DWORK(IPAR(1)+1), B, LDB, - 1 INFO) - IDENT = '0011' -C - ELSE IF (NR(2) .EQ. 3) THEN -C .. set up remaining parameters .. - IF (.NOT. LSAME(DEF,'N')) THEN - DPAR(1) = PARDEF(NR(1),NR(2)) - DPAR(2) = FOUR - DPAR(3) = ONE - END IF - IF (DPAR(1) . NE. 0) THEN - CALL DLASET('A', L, L, ZERO, ONE, A(1,L+1), LDA) - TEMP = DPAR(3) / DPAR(1) - A(L+1,1) = -TEMP - A(L+1,2) = TEMP - A(IPAR(1),L-1) = TEMP - A(IPAR(1),L) = -TEMP - TTEMP = TWO*TEMP - DO 130 I = 2, L-1 - A(L+I,I) = -TTEMP - A(L+I,I+1) = TEMP - A(L+I,I-1) = TEMP - 130 CONTINUE - CALL DLASET('A', L, L, ZERO, -DPAR(2)/DPAR(1), A(L+1,L+1), - 1 LDA) - B(L+1,1) = ONE / DPAR(1) - B(IPAR(1),IPAR(2)) = -ONE / DPAR(1) - IDENT = '0111' - ELSE - INFO = 2 - END IF -C - ELSE IF (NR(2) .EQ. 4) THEN - IF (.NOT. LSAME(DEF,'N')) WRITE (CHPAR(1:11), '(A,I1,A,I1,A)') - 1 'BB01', NR(1), '0', NR(2), '.dat' - OPEN(1, IOSTAT = IOS, STATUS = 'OLD', FILE = CHPAR(1:11)) - IF (IOS .NE. 0) THEN - INFO = 1 - ELSE - READ (1, FMT = *, IOSTAT = IOS) (DWORK(I), I = 1, 4*L-2) - IF (IOS .NE. 0) INFO = 1 - END IF - CLOSE(1) - IF (INFO .EQ. 0) THEN - CALL DLASET('A', L-1, L-1, ZERO, ONE, A(L+1,2), LDA) - POS = 2*L + 1 - A(1,2) = - DWORK(POS) / DWORK(1) - DO 140 I = 2, L - TEMP = DWORK(POS) / DWORK(I-1) - TTEMP = DWORK(POS) / DWORK(I) - IF (I .GT. 2) A(I-1,I) = TEMP - A(I,I) = -(TEMP + TTEMP) - IF (I .LT. L) A(I+1,I) = TTEMP - POS = POS + 1 - 140 CONTINUE - POS = L - TEMP = DWORK(POS+1) / DWORK(1) - A(1,1) = -TEMP - DO 160 I = 2, L - TTEMP = TEMP - TEMP = DWORK(POS+I) / DWORK(I) - SUM = TTEMP - TEMP - A(I,1) = -SUM - A(I,I) = A(I,I) - TEMP - DO 150 J = 2, I-2 - A(I,J) = SUM - 150 CONTINUE - IF (I .GT. 2) A(I,I-1) = A(I,I-1) + SUM - 160 CONTINUE - POS = 3*L - A(1,L+1) = -DWORK(3*L)/DWORK(1) - DO 170 I = 2, L - TEMP = DWORK(POS) / DWORK(I-1) - TTEMP = DWORK(POS) / DWORK(I) - IF (I .GT. 2) A(I-1,L+I-1) = TEMP - A(I,L+I-1) = -(TEMP + TTEMP) - IF (I .LT. L) A(I+1,L+I-1) = TTEMP - POS = POS + 1 - 170 CONTINUE - B(1,1) = ONE/DWORK(1) - DO 180 I = 1, L - TEMP = ONE/DWORK(I) - IF (I .GT. 1) B(I,I) = -TEMP - IF (I .LT. L) B(I+1,I) = TEMP - 180 CONTINUE - C(1,1) = ONE - Q(1) = ONE - POS = 2*L - 1 - ISYMM = L + 1 - DO 190 I = 2, L - TEMP = DWORK(POS+I) - TTEMP = DWORK(POS+L+I-1) - C(I,I) = TEMP - C(I,L+I-1) = TTEMP - Q(ISYMM) = ONE / (TEMP*TEMP + TTEMP*TTEMP) - ISYMM = ISYMM + L - I + 1 - 190 CONTINUE - IDENT = '0001' - END IF - END IF - END IF -C - IF (INFO .NE. 0) GOTO 2001 -C .. set up data in required format .. -C - IF (BPAR(1)) THEN -C .. G is to be returned in product form .. - GDIMM = IPAR(1) - IF (IDENT(4:4) .EQ. '0') THEN -C .. invert R using Cholesky factorization, store in G .. - CALL DPPTRF('L', IPAR(2), G, INFO) - IF (INFO .EQ. 0) THEN - CALL DPPTRI('L', IPAR(2), G, INFO) - IF (IDENT(1:1) .EQ. '0') THEN -C .. B is not identity matrix .. - DO 200 I = 1, IPAR(1) - CALL DSPMV('L', IPAR(2), ONE, G, B(I,1), LDB, ZERO, - 1 DWORK((I-1)*IPAR(1)+1), 1) - 200 CONTINUE - CALL DGEMV('T', IPAR(2), IPAR(1), ONE, DWORK, IPAR(1), - 1 B(1,1), LDB, ZERO, G, 1) - ISYMM = IPAR(1) + 1 - DO 210 I = 2, IPAR(1) - CALL DGEMV('T', IPAR(2), IPAR(1), ONE, DWORK, IPAR(1), - 1 B(I,1), LDB, ZERO, B(1,1), LDB) - CALL DCOPY(IPAR(1) - I + 1, B(1,I), LDB, G(ISYMM), 1) - ISYMM = ISYMM + (IPAR(1) - I + 1) - 210 CONTINUE - END IF - ELSE - IF (INFO .GT. 0) THEN - INFO = 3 - GOTO 2001 - END IF - END IF - ELSE -C .. R = identity .. - IF (IDENT(1:1) .EQ. '0') THEN -C .. B is not identity matrix .. - IF (IPAR(2) .EQ. 1) THEN - CALL DLASET('L', NSYMM, 1, ZERO, ZERO, G, 1) - CALL DSPR('L', IPAR(1), ONE, B, 1, G) - ELSE - CALL DSYRK('L', 'N', IPAR(1), IPAR(2), ONE, - 1 B, LDB, ZERO, DWORK, IPAR(1)) - CALL MA02DD('Pack', 'Lower', IPAR(1), DWORK, IPAR(1), G) - END IF - ELSE -C .. B = R = identity .. - ISYMM = 1 - DO 220 I = IPAR(1), 1, -1 - G(ISYMM) = ONE - ISYMM = ISYMM + I - 220 CONTINUE - END IF - END IF - ELSE - GDIMM = IPAR(2) - IF (IDENT(1:1) .EQ. '1') - 1 CALL DLASET('A', IPAR(1), IPAR(2), ZERO, ONE, B, LDB) - IF (IDENT(4:4) .EQ. '1') THEN - ISYMM = 1 - DO 230 I = IPAR(2), 1, -1 - G(ISYMM) = ONE - ISYMM = ISYMM + I - 230 CONTINUE - END IF - END IF -C - IF (BPAR(4)) THEN -C .. Q is to be returned in product form .. - QDIMM = IPAR(1) - IF (IDENT(3:3) .EQ. '0') THEN - IF (IDENT(2:2) .EQ. '0') THEN -C .. C is not identity matrix .. - DO 240 I = 1, IPAR(1) - CALL DSPMV('L', IPAR(3), ONE, Q, C(1,I), 1, ZERO, - 1 DWORK((I-1)*IPAR(1)+1), 1) - 240 CONTINUE -C .. use Q(1:IPAR(1)) as workspace and compute the first column -C of Q in the end .. - ISYMM = IPAR(1) + 1 - DO 250 I = 2, IPAR(1) - CALL DGEMV('T', IPAR(3), IPAR(1), ONE, DWORK, IPAR(1), - 1 C(1,I), 1, ZERO, Q(1), 1) - CALL DCOPY(IPAR(1) - I + 1, Q(I), 1, Q(ISYMM), 1) - ISYMM = ISYMM + (IPAR(1) - I + 1) - 250 CONTINUE - CALL DGEMV('T', IPAR(3), IPAR(1), ONE, DWORK, IPAR(1), - 1 C(1,1), 1, ZERO, Q, 1) - END IF - ELSE -C .. Q = identity .. - IF (IDENT(2:2) .EQ. '0') THEN -C .. C is not identity matrix .. - IF (IPAR(3) .EQ. 1) THEN - CALL DLASET('L', NSYMM, 1, ZERO, ZERO, Q, 1) - CALL DSPR('L', IPAR(1), ONE, C, LDC, Q) - ELSE - CALL DSYRK('L', 'T', IPAR(1), IPAR(3), ONE, C, LDC, - 1 ZERO, DWORK, IPAR(1)) - CALL MA02DD('Pack', 'Lower', IPAR(1), DWORK, IPAR(1), Q) - END IF - ELSE -C .. C = Q = identity .. - ISYMM = 1 - DO 260 I = IPAR(1), 1, -1 - Q(ISYMM) = ONE - ISYMM = ISYMM + I - 260 CONTINUE - END IF - END IF - ELSE - QDIMM = IPAR(3) - IF (IDENT(2:2) .EQ. '1') - 1 CALL DLASET('A', IPAR(3), IPAR(1), ZERO, ONE, C, LDC) - IF (IDENT(3:3) .EQ. '1') THEN - ISYMM = 1 - DO 270 I = IPAR(3), 1, -1 - Q(ISYMM) = ONE - ISYMM = ISYMM + I - 270 CONTINUE - END IF - END IF -C -C .. unpack symmetric matrices if desired .. - IF (BPAR(2)) THEN - ISYMM = (GDIMM * (GDIMM + 1)) / 2 - CALL DCOPY(ISYMM, G, 1, DWORK, 1) - CALL MA02DD('Unpack', 'Lower', GDIMM, G, LDG, DWORK) - CALL MA02ED('Lower', GDIMM, G, LDG) - ELSE IF (BPAR(3)) THEN - CALL MA02DD('Unpack', 'Lower', GDIMM, DWORK, GDIMM, G) - CALL MA02ED('Lower', GDIMM, DWORK, GDIMM) - CALL MA02DD('Pack', 'Upper', GDIMM, DWORK, GDIMM, G) - END IF - IF (BPAR(5)) THEN - ISYMM = (QDIMM * (QDIMM + 1)) / 2 - CALL DCOPY(ISYMM, Q, 1, DWORK, 1) - CALL MA02DD('Unpack', 'Lower', QDIMM, Q, LDQ, DWORK) - CALL MA02ED('Lower', QDIMM, Q, LDQ) - ELSE IF (BPAR(6)) THEN - CALL MA02DD('Unpack', 'Lower', QDIMM, DWORK, QDIMM, Q) - CALL MA02ED('Lower', QDIMM, DWORK, QDIMM) - CALL MA02DD('Pack', 'Upper', QDIMM, DWORK, QDIMM, Q) - END IF -C -C ...set VEC... - VEC(1) = .TRUE. - VEC(2) = .TRUE. - VEC(3) = .TRUE. - VEC(4) = .TRUE. - VEC(5) = .NOT. BPAR(1) - VEC(6) = .NOT. BPAR(4) - VEC(7) = .TRUE. - VEC(8) = .TRUE. - IF (NR(1) .EQ. 1) THEN - IF ((NR(2) .EQ. 1) .OR. (NR(2) .EQ. 2)) VEC(9) = .TRUE. - ELSE IF (NR(1) .EQ. 2) THEN - IF ((NR(2) .EQ. 1) .OR. ((NR(2) .GE. 3) .AND. (NR(2) .LE. 6))) - 1 VEC(9) = .TRUE. - ELSE IF (NR(1) .EQ. 3) THEN - IF (NR(2) .EQ. 2) VEC(9) = .TRUE. - END IF - CHPAR = NOTES(NR(1),NR(2)) - N = IPAR(1) - M = IPAR(2) - P = IPAR(3) - 2001 CONTINUE - RETURN -C *** Last line of BB01AD *** - END diff --git a/mex/sources/libslicot/BB02AD.f b/mex/sources/libslicot/BB02AD.f deleted file mode 100644 index b9edfa346..000000000 --- a/mex/sources/libslicot/BB02AD.f +++ /dev/null @@ -1,1017 +0,0 @@ - SUBROUTINE BB02AD(DEF, NR, DPAR, IPAR, BPAR, CHPAR, VEC, N, M, P, - 1 A, LDA, B, LDB, C, LDC, Q, LDQ, R, LDR, S, LDS, - 2 X, LDX, DWORK, LDWORK, INFO) -C -C SLICOT RELEASE 5.0. -C -C Copyright (c) 2002-2009 NICONET e.V. -C -C This program is free software: you can redistribute it and/or -C modify it under the terms of the GNU General Public License as -C published by the Free Software Foundation, either version 2 of -C the License, or (at your option) any later version. -C -C This program is distributed in the hope that it will be useful, -C but WITHOUT ANY WARRANTY; without even the implied warranty of -C MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the -C GNU General Public License for more details. -C -C You should have received a copy of the GNU General Public License -C along with this program. If not, see -C . -C -C PURPOSE -C -C To generate the benchmark examples for the numerical solution of -C discrete-time algebraic Riccati equations (DAREs) of the form -C -C T T T -1 T T -C 0 = A X A - X - (A X B + S) (R + B X B) (B X A + S ) + Q -C -C as presented in [1]. Here, A,Q,X are real N-by-N matrices, B,S are -C N-by-M, and R is M-by-M. The matrices Q and R are symmetric and Q -C may be given in factored form -C -C T -C (I) Q = C Q0 C . -C -C Here, C is P-by-N and Q0 is P-by-P. If R is nonsingular and S = 0, -C the DARE can be rewritten equivalently as -C -C T -1 -C 0 = X - A X (I_n + G X) A - Q, -C -C where I_n is the N-by-N identity matrix and -C -C -1 T -C (II) G = B R B . -C -C ARGUMENTS -C -C Mode Parameters -C -C DEF CHARACTER -C This parameter specifies if the default parameters are -C to be used or not. -C = 'N' or 'n' : The parameters given in the input vectors -C xPAR (x = 'D', 'I', 'B', 'CH') are used. -C = 'D' or 'd' : The default parameters for the example -C are used. -C This parameter is not meaningful if NR(1) = 1. -C -C Input/Output Parameters -C -C NR (input) INTEGER array, dimension (2) -C This array determines the example for which DAREX returns -C data. NR(1) is the group of examples. -C NR(1) = 1 : parameter-free problems of fixed size. -C NR(1) = 2 : parameter-dependent problems of fixed size. -C NR(1) = 3 : parameter-free problems of scalable size. -C NR(1) = 4 : parameter-dependent problems of scalable size. -C NR(2) is the number of the example in group NR(1). -C Let NEXi be the number of examples in group i. Currently, -C NEX1 = 13, NEX2 = 5, NEX3 = 0, NEX4 = 1. -C 1 <= NR(1) <= 4; -C 0 <= NR(2) <= NEXi, where i = NR(1). -C -C DPAR (input/output) DOUBLE PRECISION array, dimension (4) -C Double precision parameter vector. For explanation of the -C parameters see [1]. -C DPAR(1) defines the parameter 'epsilon' for -C examples NR = 2.2,2.3,2.4, the parameter 'tau' -C for NR = 2.5, and the 1-by-1 matrix R for NR = 2.1,4.1. -C For Example 2.5, DPAR(2) - DPAR(4) define in -C consecutive order 'D', 'K', and 'r'. -C NOTE that DPAR is overwritten with default values -C if DEF = 'D' or 'd'. -C -C IPAR (input/output) INTEGER array, dimension (3) -C On input, IPAR(1) determines the actual state dimension, -C i.e., the order of the matrix A as follows: -C NR(1) = 1, NR(1) = 2 : IPAR(1) is ignored. -C NR = NR(1).NR(2) = 4.1 : IPAR(1) determines the order of -C the output matrix A. -C NOTE that IPAR(1) is overwritten for Examples 1.1-2.3. For -C the other examples, IPAR(1) is overwritten if the default -C parameters are to be used. -C On output, IPAR(1) contains the order of the matrix A. -C -C On input, IPAR(2) is the number of colums in the matrix B -C and the order of the matrix R (in control problems, the -C number of inputs of the system). Currently, IPAR(2) is -C fixed for all examples and thus is not referenced on -C input. -C On output, IPAR(2) is the number of columns of the -C matrix B from (I). -C -C On input, IPAR(3) is the number of rows in the matrix C -C (in control problems, the number of outputs of the -C system). Currently, IPAR(3) is fixed for all examples -C and thus is not referenced on input. -C On output, IPAR(3) is the number of rows of the matrix C -C from (I). -C -C NOTE that IPAR(2) and IPAR(3) are overwritten and -C IPAR(2) <= IPAR(1) and IPAR(3) <= IPAR(1) for all -C examples. -C -C BPAR (input) LOGICAL array, dimension (7) -C This array defines the form of the output of the examples -C and the storage mode of the matrices Q, G or R. -C BPAR(1) = .TRUE. : Q is returned. -C BPAR(1) = .FALSE. : Q is returned in factored form, i.e., -C Q0 and C from (I) are returned. -C BPAR(2) = .TRUE. : The matrix returned in array Q (i.e., -C Q if BPAR(1) = .TRUE. and Q0 if -C BPAR(1) = .FALSE.) is stored as full -C matrix. -C BPAR(2) = .FALSE. : The matrix returned in array Q is -C provided in packed storage mode. -C BPAR(3) = .TRUE. : If BPAR(2) = .FALSE., the matrix -C returned in array Q is stored in upper -C packed mode, i.e., the upper triangle -C of a symmetric n-by-n matrix is stored -C by columns, e.g., the matrix entry -C Q(i,j) is stored in the array entry -C Q(i+j*(j-1)/2) for i <= j. -C Otherwise, this entry is ignored. -C BPAR(3) = .FALSE. : If BPAR(2) = .FALSE., the matrix -C returned in array Q is stored in lower -C packed mode, i.e., the lower triangle -C of a symmetric n-by-n matrix is stored -C by columns, e.g., the matrix entry -C Q(i,j) is stored in the array entry -C Q(i+(2*n-j)*(j-1)/2) for j <= i. -C Otherwise, this entry is ignored. -C BPAR(4) = .TRUE. : The product G in (II) is returned. -C BPAR(4) = .FALSE. : G is returned in factored form, i.e., -C B and R from (II) are returned. -C BPAR(5) = .TRUE. : The matrix returned in array R (i.e., -C G if BPAR(4) = .TRUE. and R if -C BPAR(4) = .FALSE.) is stored as full -C matrix. -C BPAR(5) = .FALSE. : The matrix returned in array R is -C provided in packed storage mode. -C BPAR(6) = .TRUE. : If BPAR(5) = .FALSE., the matrix -C returned in array R is stored in upper -C packed mode (see above). -C Otherwise, this entry is ignored. -C BPAR(6) = .FALSE. : If BPAR(5) = .FALSE., the matrix -C returned in array R is stored in lower -C packed mode (see above). -C Otherwise, this entry is ignored. -C BPAR(7) = .TRUE. : The coefficient matrix S of the DARE -C is returned in array S. -C BPAR(7) = .FALSE. : The coefficient matrix S of the DARE -C is not returned. -C NOTE that there are no default values for BPAR. If all -C entries are declared to be .TRUE., then matrices Q, G or R -C are returned in conventional storage mode, i.e., as -C N-by-N or M-by-M arrays where the array element Z(I,J) -C contains the matrix entry Z_{i,j}. -C -C CHPAR (output) CHARACTER*255 -C On output, this string contains short information about -C the chosen example. -C -C VEC (output) LOGICAL array, dimension (10) -C Flag vector which displays the availability of the output -C data: -C VEC(j), j=1,2,3, refer to N, M, and P, respectively, and -C are always .TRUE. -C VEC(4) refers to A and is always .TRUE. -C VEC(5) is .TRUE. if BPAR(4) = .FALSE., i.e., the factors B -C and R from (II) are returned. -C VEC(6) is .TRUE. if BPAR(1) = .FALSE., i.e., the factors C -C and Q0 from (I) are returned. -C VEC(7) refers to Q and is always .TRUE. -C VEC(8) refers to R and is always .TRUE. -C VEC(9) is .TRUE. if BPAR(7) = .TRUE., i.e., the matrix S -C is returned. -C VEC(10) refers to X and is .TRUE. if the exact solution -C matrix is available. -C NOTE that VEC(i) = .FALSE. for i = 1 to 10 if on exit -C INFO .NE. 0. -C -C N (output) INTEGER -C The order of the matrices A, X, G if BPAR(4) = .TRUE., and -C Q if BPAR(1) = .TRUE. -C -C M (output) INTEGER -C The number of columns in the matrix B (or the dimension of -C the control input space of the underlying dynamical -C system). -C -C P (output) INTEGER -C The number of rows in the matrix C (or the dimension of -C the output space of the underlying dynamical system). -C -C A (output) DOUBLE PRECISION array, dimension (LDA,N) -C The leading N-by-N part of this array contains the -C coefficient matrix A of the DARE. -C -C LDA INTEGER -C The leading dimension of array A. LDA >= N. -C -C B (output) DOUBLE PRECISION array, dimension (LDB,M) -C If (BPAR(4) = .FALSE.), then the leading N-by-M part -C of this array contains the coefficient matrix B of -C the DARE. Otherwise, B is used as workspace. -C -C LDB INTEGER -C The leading dimension of array B. LDB >= N. -C -C C (output) DOUBLE PRECISION array, dimension (LDC,N) -C If (BPAR(1) = .FALSE.), then the leading P-by-N part -C of this array contains the matrix C of the factored -C form (I) of Q. Otherwise, C is used as workspace. -C -C LDC INTEGER -C The leading dimension of array C. LDC >= P. -C -C Q (output) DOUBLE PRECISION array, dimension (NQ) -C If (BPAR(1) = .TRUE.) and (BPAR(2) = .TRUE.), then -C NQ = LDQ*N. -C IF (BPAR(1) = .TRUE.) and (BPAR(2) = .FALSE.), then -C NQ = N*(N+1)/2. -C If (BPAR(1) = .FALSE.) and (BPAR(2) = .TRUE.), then -C NQ = LDQ*P. -C IF (BPAR(1) = .FALSE.) and (BPAR(2) = .FALSE.), then -C NQ = P*(P+1)/2. -C The symmetric matrix contained in array Q is stored -C according to BPAR(2) and BPAR(3). -C -C LDQ INTEGER -C If conventional storage mode is used for Q, i.e., -C BPAR(2) = .TRUE., then Q is stored like a 2-dimensional -C array with leading dimension LDQ. If packed symmetric -C storage mode is used, then LDQ is irrelevant. -C LDQ >= N if BPAR(1) = .TRUE.; -C LDQ >= P if BPAR(1) = .FALSE.. -C -C R (output) DOUBLE PRECISION array, dimension (MR) -C If (BPAR(4) = .TRUE.) and (BPAR(5) = .TRUE.), then -C MR = LDR*N. -C IF (BPAR(4) = .TRUE.) and (BPAR(5) = .FALSE.), then -C MR = N*(N+1)/2. -C If (BPAR(4) = .FALSE.) and (BPAR(5) = .TRUE.), then -C MR = LDR*M. -C IF (BPAR(4) = .FALSE.) and (BPAR(5) = .FALSE.), then -C MR = M*(M+1)/2. -C The symmetric matrix contained in array R is stored -C according to BPAR(5) and BPAR(6). -C -C LDR INTEGER -C If conventional storage mode is used for R, i.e., -C BPAR(5) = .TRUE., then R is stored like a 2-dimensional -C array with leading dimension LDR. If packed symmetric -C storage mode is used, then LDR is irrelevant. -C LDR >= N if BPAR(4) = .TRUE.; -C LDR >= M if BPAR(4) = .FALSE.. -C -C S (output) DOUBLE PRECISION array, dimension (LDS,M) -C If (BPAR(7) = .TRUE.), then the leading N-by-M part of -C this array contains the coefficient matrix S of the DARE. -C -C LDS INTEGER -C The leading dimension of array S. LDS >= 1, and -C LDS >= N if BPAR(7) = .TRUE.. -C -C X (output) DOUBLE PRECISION array, dimension (LDX,NX) -C If an exact solution is available (NR = 1.1,1.3,1.4,2.1, -C 2.3,2.4,2.5,4.1), then NX = N and the leading N-by-N part -C of this array contains the solution matrix X. -C Otherwise, X is not referenced. -C -C LDX INTEGER -C The leading dimension of array X. LDX >= 1, and -C LDX >= N if an exact solution is available. -C -C Workspace -C -C DWORK DOUBLE PRECISION array, dimension (LDWORK) -C -C LDWORK INTEGER -C The length of the array DWORK. LDWORK >= N*N. -C -C Error Indicator -C -C INFO INTEGER -C = 0 : successful exit; -C < 0 : if INFO = -i, the i-th argument had an illegal -C value; -C = 1 : data file could not be opened or had wrong format; -C = 2 : division by zero; -C = 3 : G can not be computed as in (II) due to a singular R -C matrix. This error can only occur if -C BPAR(4) = .TRUE.. -C -C REFERENCES -C -C [1] Abels, J. and Benner, P. -C DAREX - A Collection of Benchmark Examples for Discrete-Time -C Algebraic Riccati Equations (Version 2.0). -C SLICOT Working Note 1999-16, November 1999. Available from -C http://www.win.tue.nl/niconet/NIC2/reports.html. -C -C This is an updated and extended version of -C -C [2] Benner, P., Laub, A.J., and Mehrmann, V. -C A Collection of Benchmark Examples for the Numerical Solution -C of Algebraic Riccati Equations II: Discrete-Time Case. -C Technical Report SPC 95_23, Fak. f. Mathematik, -C TU Chemnitz-Zwickau (Germany), December 1995. -C -C FURTHER COMMENTS -C -C Some benchmark examples read data from the data files provided -C with the collection. -C -C CONTRIBUTOR -C -C Peter Benner (Universitaet Bremen), November 25, 1999. -C -C For questions concerning the collection or for the submission of -C test examples, please send e-mail to benner@math.uni-bremen.de. -C -C REVISIONS -C -C 1999, December 23 (V. Sima). -C -C KEYWORDS -C -C Discrete-time algebraic Riccati equation. -C -C ****************************************************************** -C -C .. Parameters .. -C . # of examples available , # of examples with fixed size. . - INTEGER NEX1, NEX2, NEX3, NEX4, NMAX - PARAMETER ( NEX1 = 13, NEX2 = 5, NEX3 = 0, NEX4 = 1 ) - PARAMETER ( NMAX = 13 ) - DOUBLE PRECISION ZERO, ONE, TWO, THREE, FOUR, FIVE - PARAMETER ( ZERO = 0.0D0, ONE = 1.0D0, TWO = 2.0D0, - 1 THREE = 3.0D0, FOUR = 4.0D0, FIVE = 5.0D0 ) -C -C .. Scalar Arguments .. - INTEGER INFO, LDA, LDB, LDC, LDQ, LDR, LDS, LDWORK, LDX, - $ M, N, P - CHARACTER DEF -C -C .. Array Arguments .. - DOUBLE PRECISION A(LDA,*), B(LDB,*), C(LDC,*), DPAR(*), DWORK(*), - 1 Q(*), R(*), S(LDS,*), X(LDX,*) - INTEGER IPAR(3), NR(2) - CHARACTER CHPAR*255 - LOGICAL BPAR(7), VEC(10) -C -C .. Local Scalars .. - INTEGER I, IOS, ISYMM, J, MSYMM, NSYMM, PSYMM, QDIMM, - 1 RDIMM - DOUBLE PRECISION ALPHA, BETA, TEMP -C -C ..Local Arrays .. - INTEGER MDEF(2,NMAX), NDEF(4,NMAX), NEX(4), PDEF(2,NMAX) - CHARACTER IDENT*4 - CHARACTER*255 NOTES(4,NMAX) -C -C .. External Functions .. -C . LAPACK . - LOGICAL LSAME - EXTERNAL LSAME -C -C .. External Subroutines .. -C . BLAS . - EXTERNAL DCOPY, DGEMV, DSPMV, DSPR, DSYMM, DSYRK -C . LAPACK . - EXTERNAL DLASET, DPPTRF, DPPTRI, DRSCL, XERBLA -C . SLICOT . - EXTERNAL MA02DD, MA02ED -C -C .. Intrinsic Functions .. - INTRINSIC SQRT -C -C .. Data Statements .. -C . default values for dimensions . - DATA NEX /NEX1, NEX2, NEX3, NEX4/ - DATA (NDEF(1,I), I = 1, NEX1) /2, 2, 2, 3, 4, 4, 4, 5, 6, 9, - 1 11, 13, 26/ - DATA (NDEF(2,I), I = 1, NEX2) /2, 2, 2, 3, 4/ - DATA (NDEF(4,I), I = 1, NEX4) /100/ - DATA (MDEF(1,I), I = 1, NEX1) /1, 2, 1, 2, 2, 2, 4, 2, 2, 3, - 1 2, 2, 6/ - DATA (MDEF(2,I), I = 1, NEX2) /1, 2, 1, 3, 1/ - DATA (PDEF(1,I), I = 1, NEX1) /1, 2, 2, 3, 4, 4, 4, 5, 2, 2, - 1 4, 4, 12/ - DATA (PDEF(2,I), I = 1, NEX2) /2, 2, 2, 3, 1/ -C . comments on examples . - DATA (NOTES(1,I), I = 1, 10) / - 1'Van Dooren 1981, Ex. II: singular R matrix', 'Ionescu/Weiss 1992 - 2: singular R matrix, nonzero S matrix', 'Jonckheere 1981: (A,B) co - 3ntrollable, no solution X <= 0', 'Sun 1998: R singular, Q non-defi - 4nite', 'Ackerson/Fu 1970 : satellite control problem', 'Litkouhi 1 - 5983 : system with slow and fast modes', 'Lu/Lin 1993, Ex. 4.3', 'G - 6ajic/Shen 1993, Section 2.7.4: chemical plant', 'Davison/Wang 1974 - 7: nonzero S matrix', 'Patnaik et al. 1980: tubular ammonia reactor - 8'/ - DATA (NOTES(1,I), I = 11, NEX1) / - 1'Sima 1996, Sec. 1.2.2: paper machine model error integrators', 'S - 2ima 1996, Ex. 2.6: paper machine model with with disturbances', 'P - 3ower plant model, Katayama et al., 1985'/ - DATA (NOTES(2,I), I = 1, NEX2) / - 1'Laub 1979, Ex. 2: uncontrollable-unobservable data', 'Laub 1979, - 2Ex. 3: increasingly ill-conditioned R-matrix', 'increasingly bad s - 3caled system as eps -> oo','Petkov et. al. 1989 : increasingly bad - 4 scaling as eps -> oo', 'Pappas et al. 1980: process control of pa - 5per machine'/ - DATA (NOTES(4,I), I = 1, NEX4) /'Pappas et al. 1980, Ex. 3'/ -C -C .. Executable Statements .. -C - INFO = 0 - DO 1 I = 1, 10 - VEC(I) = .FALSE. - 1 CONTINUE -C - IF (NR(1) .GE. 3) THEN - IF (LSAME(DEF, 'D')) IPAR(1) = NDEF(NR(1),NR(2)) - IPAR(2) = 1 - IPAR(3) = IPAR(1) - ELSE - IPAR(1) = NDEF(NR(1),NR(2)) - IPAR(2) = MDEF(NR(1),NR(2)) - IPAR(3) = PDEF(NR(1),NR(2)) - END IF -C - IF ((NR(1) .GE. 2) .AND. .NOT. ((LSAME(DEF,'D')) .OR. - $ (LSAME(DEF,'N')))) THEN - INFO = -1 - ELSE IF ((NR(1) .LT. 1) .OR. (NR(1) .GT. 4) .OR. (NR(2) .LT. 0) - 1 .OR. (NR(2) .GT. NEX(NR(1)))) THEN - INFO = -2 - ELSE IF (IPAR(1) .LT. 1) THEN - INFO = -4 - ELSE IF (IPAR(1) .GT. LDA) THEN - INFO = -12 - ELSE IF (IPAR(1) .GT. LDB) THEN - INFO = -14 - ELSE IF (IPAR(3) .GT. LDC) THEN - INFO = -16 - ELSE IF (BPAR(2) .AND. (((.NOT. BPAR(1)) .AND. - 1 (IPAR(3) .GT. LDQ)) .OR. (BPAR(1) .AND. - 2 (IPAR(1) .GT. LDQ)))) THEN - INFO = -18 - ELSE IF (BPAR(5) .AND. ((BPAR(4) .AND. (IPAR(1) .GT. LDR)) .OR. - 1 ((.NOT. BPAR(4)) .AND. (IPAR(2) .GT. LDR)))) THEN - INFO = -20 - ELSE IF (LDS .LT. 1 .OR. (BPAR(7) .AND. (IPAR(1) .GT. LDS))) THEN - INFO = -22 - ELSE IF (LDX .LT. 1) THEN - INFO = -24 - ELSE IF (((NR(1) .EQ. 1) .AND. ((NR(2) .EQ. 1) .OR. - 1 (NR(2) .EQ. 3) .OR. (NR(2) .EQ. 4))) .OR. - 2 ((NR(1) .EQ. 2) .AND. ((NR(2). EQ. 1) .OR. - 3 (NR(2) .GE. 3))) .OR. (NR(1) .EQ. 4)) THEN -C .. solution X available .. - IF (IPAR(1) .GT. LDX) THEN - INFO = -24 - ELSE - CALL DLASET('A', IPAR(1), IPAR(1), ZERO, ZERO, X, LDX) - END IF - ELSE IF (LDWORK .LT. N*N) THEN - INFO = -26 - END IF - IF (INFO .NE. 0) THEN - CALL XERBLA( 'BB02AD', -INFO ) - RETURN - END IF -C - NSYMM = (IPAR(1)*(IPAR(1)+1))/2 - MSYMM = (IPAR(2)*(IPAR(2)+1))/2 - PSYMM = (IPAR(3)*(IPAR(3)+1))/2 -C - CALL DLASET('A', IPAR(1), IPAR(1), ZERO, ZERO, A, LDA) - CALL DLASET('A', IPAR(1), IPAR(2), ZERO, ZERO, B, LDB) - CALL DLASET('A', IPAR(3), IPAR(1), ZERO, ZERO, C, LDC) - CALL DLASET('L', PSYMM, 1, ZERO, ZERO, Q, 1) - CALL DLASET('L', MSYMM, 1, ZERO, ZERO, R, 1) - IF (BPAR(7)) CALL DLASET('A', IPAR(1), IPAR(2), ZERO, ZERO, - 1 S, LDS) -C - IF(NR(1) .EQ. 1) THEN -C - IF (NR(2) .EQ. 1) THEN - A(1,1) = TWO - A(2,1) = ONE - A(1,2) = -ONE - B(1,1) = ONE - Q(1) = ONE - C(1,2) = ONE - R(1) = ZERO - CALL DLASET('A', IPAR(1), IPAR(1), ZERO, ONE, X, LDX) - IDENT = '0000' -C - ELSE IF (NR(2) .EQ. 2) THEN - A(1,2) = ONE - A(2,2) = -ONE - B(1,1) = ONE - B(2,1) = TWO - B(2,2) = ONE - R(1) = 9.0D0 - R(2) = THREE - R(3) = ONE - CALL DLASET('A', PSYMM, 1, -FOUR, -FOUR, Q, PSYMM) - Q(3) = 7.0D0 - CALL DRSCL(MSYMM, 11.0D0, Q, 1) - IF (BPAR(7)) THEN - S(1,1) = THREE - S(2,1) = -ONE - S(1,2) = ONE - S(2,2) = 7.0D0 - END IF - IDENT = '0100' -C - ELSE IF (NR(2) .EQ. 3) THEN - A(1,2) = ONE - B(2,1) = ONE - Q(1) = ONE - Q(2) = TWO - Q(3) = FOUR - X(1,1) = ONE - X(2,1) = TWO - X(1,2) = TWO - X(2,2) = TWO + SQRT(FIVE) - IDENT = '0101' -C - ELSE IF (NR(2) .EQ. 4) THEN - A(1,2) = .1000D+00 - A(2,3) = .0100D+00 - B(1,1) = ONE - B(3,2) = ONE - R(3) = ONE - Q(1) = .1D+06 - Q(4) = .1D+04 - Q(6) = -.1D+02 - X(1,1) = .1D+06 - X(2,2) = .1D+04 - IDENT = '0100' -C - ELSE IF (((NR(2) .GE. 5) .AND. (NR(2) .LE. 8)) .OR. - 1 (NR(2) .EQ. 10) .OR. (NR(2) .EQ. 11) .OR. - 2 (NR(2) .EQ. 13)) THEN - IF (NR(2) .LT. 10) THEN - WRITE (CHPAR(1:11), '(A,I1,A,I1,A)') - 1 'BB02', NR(1), '0', NR(2), '.dat' - OPEN(1, IOSTAT = IOS, STATUS = 'OLD', FILE = CHPAR(1:11)) - ELSE - WRITE (CHPAR(1:11), '(A,I1,I2,A)') - 1 'BB02', NR(1), NR(2), '.dat' - OPEN(1, IOSTAT = IOS, STATUS = 'OLD', FILE = CHPAR(1:11)) - END IF - IF (IOS .NE. 0) THEN - INFO = 1 - ELSE - IF (.NOT. (NR(2) .EQ. 13)) THEN - DO 10 I = 1, IPAR(1) - READ (1, FMT = *, IOSTAT = IOS) (A(I,J), J = 1, IPAR(1)) - IF (IOS .NE. 0) INFO = 1 - 10 CONTINUE - DO 20 I = 1, IPAR(1) - READ (1, FMT = *, IOSTAT = IOS) (B(I,J), J = 1, IPAR(2)) - IF (IOS .NE. 0) INFO = 1 - 20 CONTINUE - END IF - IF (NR(2) .EQ. 5) THEN - Q(1) = .187D1 - Q(4) = -.244D0 - Q(5) = .744D0 - Q(6) = .205D0 - Q(8) = .589D0 - Q(10) = .1048D1 - ELSE IF (NR(2) .EQ. 6) THEN - Q(1) = .1D-1 - Q(5) = .1D-1 - Q(8) = .1D-1 - Q(10) = .1D-1 - ELSE IF (NR(2) .EQ. 7) THEN - CALL DLASET('U', IPAR(3), IPAR(1), ONE, ONE, C, LDC) - C(1,3) = TWO - C(1,4) = FOUR - C(2,4) = TWO - Q(1) = TWO - Q(2) = -ONE - Q(5) = TWO - Q(6) = -ONE - Q(8) = TWO - ELSE IF (NR(2) .EQ. 10) THEN - C(1,1) = ONE - C(2,5) = ONE - Q(1) = 50.0D0 - Q(3) = 50.0D0 - ELSE IF (NR(2) .EQ. 11) THEN - A(10,10) = ONE - A(11,11) = ONE - C(1,6) = 15.0D0 - C(2,7) = 7.0D0 - C(2,8) = -.5357D+01 - C(2,9) = -.3943D+01 - C(3,10) = ONE - C(4,11) = ONE - Q(1) = 0.5D0 - Q(5) = 5.0D0 - Q(8) = 0.5D0 - Q(10) = 5.0D0 - R(1) = 400.0D0 - R(3) = 700.0D0 - IDENT = '0000' -C - ELSE IF (NR(2) .EQ. 13) THEN - DO 24 I = 1, IPAR(1)-6 - READ (1, FMT = *, IOSTAT = IOS) - 1 (A(I,J), J = 1, IPAR(1)-6) - IF (IOS .NE. 0) INFO = 1 - 24 CONTINUE - DO 25 I = 1, IPAR(1)-6 - READ (1, FMT = *, IOSTAT = IOS) - 1 (B(I,J), J = 1, IPAR(2)) - IF (IOS .NE. 0) INFO = 1 - 25 CONTINUE - DO 26 I = 1, IPAR(2) - READ (1, FMT = *, IOSTAT = IOS) - 1 (C(I,J), J = 1, IPAR(1)-6) - IF (IOS .NE. 0) INFO = 1 - 26 CONTINUE - DO 27 I = 1, 6 - A(20+I,20+I) = ONE - C(6+I,20+I) = ONE - 27 CONTINUE - J = 58 - DO 28 I = 7, 12 - READ (1, FMT = *, IOSTAT = IOS) Q(J) - IF (IOS .NE. 0) INFO = 1 - J = J + (13 - I) - 28 CONTINUE - J = 1 - DO 29 I = 1, 6 - READ (1, FMT = *, IOSTAT = IOS) R(J) - IF (IOS .NE. 0) INFO = 1 - J = J + (7 - I) - 29 CONTINUE - DO 31 I = 1, 6 - DO 30 J = 1, 20 - A(I+20,J) = -C(I,J) - 30 CONTINUE - 31 CONTINUE - IDENT = '0000' - END IF - END IF - CLOSE(1) - IF ((NR(2) .EQ. 5) .OR. (NR(2) .EQ. 6)) THEN - IDENT = '0101' - ELSE IF ((NR(2) .EQ. 7) .OR. (NR(2) .EQ. 10)) THEN - IDENT = '0001' - ELSE IF (NR(2) .EQ. 8) THEN - IDENT = '0111' - END IF -C - ELSE IF (NR(2). EQ. 9) THEN - A(1,2) = ONE - A(2,3) = ONE - A(4,5) = ONE - A(5,6) = ONE - B(3,1) = ONE - B(6,2) = ONE - C(1,1) = ONE - C(1,2) = ONE - C(2,4) = ONE - C(2,5) = -ONE - R(1) = THREE - R(3) = ONE - IF (BPAR(7)) THEN - S(1,1) = ONE - S(2,1) = ONE - S(4,1) = ONE - S(5,1) = -ONE - END IF - IDENT = '0010' - ELSE IF (NR(2) .EQ. 12) THEN - DO 32 I = 1, 10 - A(I,I+1) = ONE - 32 CONTINUE - A(6,7) = ZERO - A(8,9) = ZERO - A(12,12) = ONE - A(13,13) = ONE - A(12,1) = -.3318D+01 - A(13,1) = -.15484D+01 - A(6,6) = .7788D+00 - A(8,7) = -.4724D+00 - A(13,7) = .3981D+00 - A(8,8) = .13746D+01 - A(13,8) = .5113D+00 - A(13,9) = .57865D+01 - A(11,11) = .8071D+00 - B(6,1) = ONE - B(8,2) = ONE - C(1,1) = .3318D+01 - C(2,1) = .15484D+01 - C(2,7) = -.3981D+00 - C(2,8) = -.5113D+00 - C(2,9) = -.57865D+01 - C(3,12) = ONE - C(4,13) = ONE - Q(1) = 0.5D0 - Q(5) = 5.0D0 - Q(8) = 0.5D0 - Q(10) = 5.0D0 - R(1) = 400.0D0 - R(3) = 700.0D0 - IDENT = '0000' - END IF -C - ELSE IF (NR(1) .EQ. 2) THEN - IF (NR(2) .EQ. 1) THEN - IF (LSAME(DEF, 'D')) DPAR(1) = .1D+07 - A(1,1) = FOUR - A(2,1) = -.45D1 - A(1,2) = THREE - A(2,2) = -.35D1 - CALL DLASET('A', IPAR(1), IPAR(2), -ONE, ONE, B, LDB) - R(1) = DPAR(1) - Q(1) = 9.0D0 - Q(2) = 6.0D0 - Q(3) = FOUR - TEMP = (ONE + SQRT(ONE+FOUR*DPAR(1))) / TWO - X(1,1) = TEMP*Q(1) - X(2,1) = TEMP*Q(2) - X(1,2) = X(2,1) - X(2,2) = TEMP*Q(3) - IDENT = '0100' -C - ELSE IF (NR(2) .EQ. 2) THEN - IF (LSAME(DEF, 'D')) DPAR(1) = .1D+07 - IF (DPAR(1) .EQ. ZERO) THEN - INFO = 2 - ELSE - A(1,1) = .9512D0 - A(2,2) = .9048D0 - CALL DLASET('A', 1, IPAR(2), .4877D1, .4877D1, B, LDB) - B(2,1) = -.11895D1 - B(2,2) = .3569D1 - R(1) = ONE / (THREE*DPAR(1)) - R(3) = THREE*DPAR(1) - Q(1) = .5D-2 - Q(3) = .2D-1 - IDENT = '0100' - END IF -C - ELSE IF (NR(2) .EQ. 3) THEN - IF (LSAME(DEF,'D')) DPAR(1) = .1D7 - A(1,2) = DPAR(1) - B(2,1) = ONE - X(1,1) = ONE - X(2,2) = ONE + DPAR(1)*DPAR(1) - IDENT = '0111' -C - ELSE IF (NR(2) .EQ. 4) THEN - IF (LSAME(DEF,'D')) DPAR(1) = .1D7 - A(2,2) = ONE - A(3,3) = THREE - R(1) = DPAR(1) - R(4) = DPAR(1) - R(6) = DPAR(1) -C .. set C = V .. - TEMP = TWO/THREE - CALL DLASET('A', IPAR(3), IPAR(1), -TEMP, ONE - TEMP, C, LDC) -C .. and compute A <- C' A C - CALL DSYMM('L', 'L', IPAR(1), IPAR(1), ONE, C, LDC, A, LDA, - 1 ZERO, DWORK, IPAR(1)) - CALL DSYMM('R', 'L', IPAR(1), IPAR(1), ONE, C, LDC, DWORK, - 1 IPAR(1), ZERO, A, LDA) - Q(1) = DPAR(1) - Q(4) = DPAR(1) - Q(6) = DPAR(1) - X(1,1) = DPAR(1) - X(2,2) = DPAR(1) * (ONE + SQRT(FIVE)) / TWO - X(3,3) = DPAR(1) * (9.0D0 + SQRT(85.0D0)) / TWO - CALL DSYMM('L', 'L', IPAR(1), IPAR(1), ONE, C, LDC, X, LDX, - 1 ZERO, DWORK, IPAR(1)) - CALL DSYMM('R', 'L', IPAR(1), IPAR(1), ONE, C, LDC, DWORK, - 1 IPAR(1), ZERO, X, LDX) - IDENT = '1000' -C - ELSE IF (NR(2) .EQ. 5) THEN - IF (LSAME(DEF, 'D')) THEN - DPAR(4) = .25D0 - DPAR(3) = ONE - DPAR(2) = ONE - DPAR(1) = .1D9 - END IF - IF (DPAR(1) .EQ. ZERO) THEN - INFO = 2 - ELSE - TEMP = DPAR(2) / DPAR(1) - BETA = DPAR(3) * TEMP - ALPHA = ONE - TEMP - A(1,1) = ALPHA - CALL DLASET('A', IPAR(1)-1, IPAR(1)-1, ZERO, ONE, A(2,1), - 1 LDA) - B(1,1) = BETA - C(1,4) = ONE - R(1) = DPAR(4) - IF (BETA .EQ. ZERO) THEN - INFO = 2 - ELSE - CALL DLASET('A', IPAR(1), IPAR(1), ZERO, ONE, X, LDX) - BETA = BETA * BETA - TEMP = DPAR(4) * (ALPHA + ONE) * (ALPHA - ONE) + BETA - X(1,1) = (TEMP + SQRT(TEMP*TEMP + FOUR*BETA*DPAR(4))) - X(1,1) = X(1,1) / TWO / BETA - END IF - IDENT = '0010' - END IF - END IF -C - ELSE IF (NR(1) .EQ. 4) THEN - IF (NR(2) .EQ. 1) THEN - IF (LSAME(DEF,'D')) DPAR(1) = ONE - CALL DLASET('A', IPAR(1)-1, IPAR(1)-1, ZERO, ONE, A(1,2), LDA) - B(IPAR(1),1) = ONE - R(1) = DPAR(1) - DO 40 I = 1, IPAR(1) - X(I,I) = DBLE(I) - 40 CONTINUE - IDENT = '0110' - END IF - END IF -C - IF (INFO .NE. 0) GOTO 2001 -C .. set up data in required format .. -C - IF (BPAR(4)) THEN -C .. G is to be returned in product form .. - RDIMM = IPAR(1) - IF (IDENT(4:4) .EQ. '0') THEN -C .. invert R using Cholesky factorization, .. - CALL DPPTRF('L', IPAR(2), R, INFO) - IF (INFO .EQ. 0) THEN - CALL DPPTRI('L', IPAR(2), R, INFO) - IF (IDENT(1:1) .EQ. '0') THEN -C .. B is not identity matrix .. - DO 100 I = 1, IPAR(1) - CALL DSPMV('L', IPAR(2), ONE, R, B(I,1), LDB, ZERO, - 1 DWORK((I-1)*IPAR(1)+1), 1) - 100 CONTINUE - CALL DGEMV('T', IPAR(2), IPAR(1), ONE, DWORK, IPAR(1), - 1 B(1,1), LDB, ZERO, R, 1) - ISYMM = IPAR(1) + 1 - DO 110 I = 2, IPAR(1) - CALL DGEMV('T', IPAR(2), IPAR(1), ONE, DWORK, IPAR(1), - 1 B(I,1), LDB, ZERO, B(1,1), LDB) - CALL DCOPY(IPAR(1) - I + 1, B(1,I), LDB, R(ISYMM), 1) - ISYMM = ISYMM + (IPAR(1) - I + 1) - 110 CONTINUE - END IF - ELSE - IF (INFO .GT. 0) THEN - INFO = 3 - GOTO 2001 - END IF - END IF - ELSE -C .. R = identity .. - IF (IDENT(1:1) .EQ. '0') THEN -C .. B not identity matrix .. - IF (IPAR(2) .EQ. 1) THEN - CALL DLASET('L', NSYMM, 1, ZERO, ZERO, R, 1) - CALL DSPR('L', IPAR(1), ONE, B, 1, R) - ELSE - CALL DSYRK('L', 'N', IPAR(1), IPAR(2), ONE, B, LDB, ZERO, - 1 DWORK, IPAR(1)) - CALL MA02DD('Pack', 'Lower', IPAR(1), DWORK, IPAR(1), R) - END IF - ELSE -C .. B = R = identity .. - ISYMM = 1 - DO 120 I = IPAR(1), 1, -1 - R(ISYMM) = ONE - ISYMM = ISYMM + I - 120 CONTINUE - END IF - END IF - ELSE - RDIMM = IPAR(2) - IF (IDENT(1:1) .EQ. '1') - 1 CALL DLASET('A', IPAR(1), IPAR(2), ZERO, ONE, B, LDB) - IF (IDENT(4:4) .EQ. '1') THEN - ISYMM = 1 - DO 130 I = IPAR(2), 1, -1 - R(ISYMM) = ONE - ISYMM = ISYMM + I - 130 CONTINUE - END IF - END IF -C - IF (BPAR(1)) THEN -C .. Q is to be returned in product form .. - QDIMM = IPAR(1) - IF (IDENT(3:3) .EQ. '0') THEN - IF (IDENT(2:2) .EQ. '0') THEN -C .. C is not identity matrix .. - DO 140 I = 1, IPAR(1) - CALL DSPMV('L', IPAR(3), ONE, Q, C(1,I), 1, ZERO, - 1 DWORK((I-1)*IPAR(1)+1), 1) - 140 CONTINUE -C .. use Q(1:IPAR(1)) as workspace and compute the first column -C of Q at the end .. - ISYMM = IPAR(1) + 1 - DO 150 I = 2, IPAR(1) - CALL DGEMV('T', IPAR(3), IPAR(1), ONE, DWORK, IPAR(1), - 1 C(1,I), 1, ZERO, Q(1), 1) - CALL DCOPY(IPAR(1) - I + 1, Q(I), 1, Q(ISYMM), 1) - ISYMM = ISYMM + (IPAR(1) - I + 1) - 150 CONTINUE - CALL DGEMV('T', IPAR(3), IPAR(1), ONE, DWORK, IPAR(1), - 1 C(1,1), 1, ZERO, Q, 1) - END IF - ELSE -C .. Q = identity .. - IF (IDENT(2:2) .EQ. '0') THEN -C .. C is not identity matrix .. - IF (IPAR(3) .EQ. 1) THEN - CALL DLASET('L', NSYMM, 1, ZERO, ZERO, Q, 1) - CALL DSPR('L', IPAR(1), ONE, C, LDC, Q) - ELSE - CALL DSYRK('L', 'T', IPAR(1), IPAR(3), ONE, C, LDC, ZERO, - 1 DWORK, IPAR(1)) - CALL MA02DD('Pack', 'Lower', IPAR(1), DWORK, IPAR(1), Q) - END IF - ELSE -C .. C = Q = identity .. - ISYMM = 1 - DO 160 I = IPAR(1), 1, -1 - Q(ISYMM) = ONE - ISYMM = ISYMM + I - 160 CONTINUE - END IF - END IF - ELSE - QDIMM = IPAR(3) - IF (IDENT(2:2) .EQ. '1') - 1 CALL DLASET('A', IPAR(3), IPAR(1), ZERO, ONE, C, LDC) - IF (IDENT(3:3) .EQ. '1') THEN - ISYMM = 1 - DO 170 I = IPAR(3), 1, -1 - Q(ISYMM) = ONE - ISYMM = ISYMM + I - 170 CONTINUE - END IF - END IF -C -C .. unpack symmetric matrices if required .. - IF (BPAR(2)) THEN - ISYMM = (QDIMM * (QDIMM + 1)) / 2 - CALL DCOPY(ISYMM, Q, 1, DWORK, 1) - CALL MA02DD('Unpack', 'Lower', QDIMM, Q, LDQ, DWORK) - CALL MA02ED('Lower', QDIMM, Q, LDQ) - ELSE IF (BPAR(3)) THEN - CALL MA02DD('Unpack', 'Lower', QDIMM, DWORK, QDIMM, Q) - CALL MA02ED('Lower', QDIMM, DWORK, QDIMM) - CALL MA02DD('Pack', 'Upper', QDIMM, DWORK, QDIMM, Q) - END IF - IF (BPAR(5)) THEN - ISYMM = (RDIMM * (RDIMM + 1)) / 2 - CALL DCOPY(ISYMM, R, 1, DWORK, 1) - CALL MA02DD('Unpack', 'Lower', RDIMM, R, LDR, DWORK) - CALL MA02ED('Lower', RDIMM, R, LDR) - ELSE IF (BPAR(6)) THEN - CALL MA02DD('Unpack', 'Lower', RDIMM, DWORK, RDIMM, R) - CALL MA02ED('Lower', RDIMM, DWORK, RDIMM) - CALL MA02DD('Pack', 'Upper', RDIMM, DWORK, RDIMM, R) - END IF -C -C ...set VEC... - VEC(1) = .TRUE. - VEC(2) = .TRUE. - VEC(3) = .TRUE. - VEC(4) = .TRUE. - VEC(5) = .NOT. BPAR(4) - VEC(6) = .NOT. BPAR(1) - VEC(7) = .TRUE. - VEC(8) = .TRUE. - VEC(9) = BPAR(7) - IF (((NR(1) .EQ. 1) .AND. ((NR(2) .EQ. 1) .OR. - 1 (NR(2) .EQ. 3) .OR. (NR(2) .EQ. 4))) .OR. - 2 ((NR(1) .EQ. 2) .AND. ((NR(2). EQ. 1) .OR. - 3 (NR(2) .GE. 3))) .OR. (NR(1) .EQ. 4)) THEN - VEC(10) = .TRUE. - END IF - CHPAR = NOTES(NR(1),NR(2)) - N = IPAR(1) - M = IPAR(2) - P = IPAR(3) -C - 2001 CONTINUE - RETURN -C *** Last line of BB02AD *** - END diff --git a/mex/sources/libslicot/BB03AD.f b/mex/sources/libslicot/BB03AD.f deleted file mode 100644 index d19c19105..000000000 --- a/mex/sources/libslicot/BB03AD.f +++ /dev/null @@ -1,490 +0,0 @@ - SUBROUTINE BB03AD(DEF, NR, DPAR, IPAR, VEC, N, M, E, LDE, A, LDA, - 1 Y, LDY, B, LDB, X, LDX, U, LDU, NOTE, DWORK, - 2 LDWORK, INFO) -C -C SLICOT RELEASE 5.0. -C -C Copyright (c) 2002-2009 NICONET e.V. -C -C This program is free software: you can redistribute it and/or -C modify it under the terms of the GNU General Public License as -C published by the Free Software Foundation, either version 2 of -C the License, or (at your option) any later version. -C -C This program is distributed in the hope that it will be useful, -C but WITHOUT ANY WARRANTY; without even the implied warranty of -C MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the -C GNU General Public License for more details. -C -C You should have received a copy of the GNU General Public License -C along with this program. If not, see -C . -C -C PURPOSE -C -C To generate benchmark examples of (generalized) continuous-time -C Lyapunov equations -C -C T T -C A X E + E X A = Y . -C -C In some examples, the right hand side has the form -C -C T -C Y = - B B -C -C and the solution can be represented as a product of Cholesky -C factors -C -C T -C X = U U . -C -C E, A, Y, X, and U are real N-by-N matrices, and B is M-by-N. Note -C that E can be the identity matrix. For some examples, B, X, or U -C are not provided. -C -C This routine is an implementation of the benchmark library -C CTLEX (Version 1.0) described in [1]. -C -C ARGUMENTS -C -C Mode Parameters -C -C DEF CHARACTER*1 -C Specifies the kind of values used as parameters when -C generating parameter-dependent and scalable examples -C (i.e., examples with NR(1) = 2, 3, or 4): -C DEF = 'D' or 'd': Default values are used. -C DEF = 'N' or 'n': Values set in DPAR and IPAR are used. -C This parameter is not referenced if NR(1) = 1. -C Note that the scaling parameter of examples with -C NR(1) = 3 or 4 is considered as a regular parameter in -C this context. -C -C Input/Output Parameters -C -C NR (input) INTEGER array, dimension 2 -C Specifies the index of the desired example according -C to [1]. -C NR(1) defines the group: -C 1 : parameter-free problems of fixed size -C 2 : parameter-dependent problems of fixed size -C 3 : parameter-free problems of scalable size -C 4 : parameter-dependent problems of scalable size -C NR(2) defines the number of the benchmark example -C within a certain group according to [1]. -C -C DPAR (input/output) DOUBLE PRECISION array, dimension 2 -C On entry, if DEF = 'N' or 'n' and the desired example -C depends on real parameters, then the array DPAR must -C contain the values for these parameters. -C For an explanation of the parameters see [1]. -C For Example 4.1, DPAR(1) and DPAR(2) define 'r' and 's', -C respectively. -C For Example 4.2, DPAR(1) and DPAR(2) define 'lambda' and -C 's', respectively. -C For Examples 4.3 and 4.4, DPAR(1) defines the parameter -C 't'. -C On exit, if DEF = 'D' or 'd' and the desired example -C depends on real parameters, then the array DPAR is -C overwritten by the default values given in [1]. -C -C IPAR (input/output) INTEGER array of DIMENSION at least 1 -C On entry, if DEF = 'N' or 'n' and the desired example -C depends on integer parameters, then the array IPAR must -C contain the values for these parameters. -C For an explanation of the parameters see [1]. -C For Examples 4.1, 4.2, and 4.3, IPAR(1) defines 'n'. -C For Example 4.4, IPAR(1) defines 'q'. -C On exit, if DEF = 'D' or 'd' and the desired example -C depends on integer parameters, then the array IPAR is -C overwritten by the default values given in [1]. -C -C VEC (output) LOGICAL array, dimension 8 -C Flag vector which displays the availability of the output -C data: -C VEC(1) and VEC(2) refer to N and M, respectively, and are -C always .TRUE. -C VEC(3) is .TRUE. iff E is NOT the identity matrix. -C VEC(4) and VEC(5) refer to A and Y, respectively, and are -C always .TRUE. -C VEC(6) is .TRUE. iff B is provided. -C VEC(7) is .TRUE. iff the solution matrix X is provided. -C VEC(8) is .TRUE. iff the Cholesky factor U is provided. -C -C N (output) INTEGER -C The actual state dimension, i.e., the order of the -C matrices E and A. -C -C M (output) INTEGER -C The number of rows in the matrix B. If B is not provided -C for the desired example, M = 0 is returned. -C -C E (output) DOUBLE PRECISION array, dimension (LDE,N) -C The leading N-by-N part of this array contains the -C matrix E. -C NOTE that this array is overwritten (by the identity -C matrix), if VEC(3) = .FALSE. -C -C LDE INTEGER -C The leading dimension of array E. LDE >= N. -C -C A (output) DOUBLE PRECISION array, dimension (LDA,N) -C The leading N-by-N part of this array contains the -C matrix A. -C -C LDA INTEGER -C The leading dimension of array A. LDA >= N. -C -C Y (output) DOUBLE PRECISION array, dimension (LDY,N) -C The leading N-by-N part of this array contains the -C matrix Y. -C -C LDY INTEGER -C The leading dimension of array Y. LDY >= N. -C -C B (output) DOUBLE PRECISION array, dimension (LDB,N) -C The leading M-by-N part of this array contains the -C matrix B. -C -C LDB INTEGER -C The leading dimension of array B. LDB >= M. -C -C X (output) DOUBLE PRECISION array, dimension (LDX,N) -C The leading N-by-N part of this array contains the -C matrix X. -C -C LDX INTEGER -C The leading dimension of array X. LDX >= N. -C -C U (output) DOUBLE PRECISION array, dimension (LDU,N) -C The leading N-by-N part of this array contains the -C matrix U. -C -C LDU INTEGER -C The leading dimension of array U. LDU >= N. -C -C NOTE (output) CHARACTER*70 -C String containing short information about the chosen -C example. -C -C Workspace -C -C DWORK DOUBLE PRECISION array, dimension (LDWORK) -C -C LDWORK INTEGER -C The length of the array DWORK. -C For Examples 4.1 and 4.2., LDWORK >= 2*IPAR(1) is -C required. -C For the other examples, no workspace is needed, i.e., -C LDWORK >= 1. -C -C Error Indicator -C -C INFO INTEGER -C = 0: successful exit; -C < 0: if INFO = -i, the i-th argument had an illegal -C value; in particular, INFO = -3 or -4 indicates -C that at least one of the parameters in DPAR or -C IPAR, respectively, has an illegal value. -C -C REFERENCES -C -C [1] D. Kressner, V. Mehrmann, and T. Penzl. -C CTLEX - a Collection of Benchmark Examples for Continuous- -C Time Lyapunov Equations. -C SLICOT Working Note 1999-6, 1999. -C -C NUMERICAL ASPECTS -C -C None -C -C CONTRIBUTOR -C -C D. Kressner, V. Mehrmann, and T. Penzl (TU Chemnitz) -C -C For questions concerning the collection or for the submission of -C test examples, please contact Volker Mehrmann -C (Email: volker.mehrmann@mathematik.tu-chemnitz.de). -C -C REVISIONS -C -C June 1999, V. Sima. -C -C KEYWORDS -C -C continuous-time Lyapunov equations -C -C ******************************************************************** -C -C .. Parameters .. - DOUBLE PRECISION ZERO, ONE, TWO, THREE, FOUR - PARAMETER (ZERO = .0D0, ONE = .1D1, TWO = .2D1, - 1 THREE = .3D1, FOUR = .4D1) -C .. Scalar Arguments .. - CHARACTER DEF - CHARACTER*70 NOTE - INTEGER INFO, LDA, LDB, LDE, LDU, LDWORK, LDX, LDY, M, N -C .. Array Arguments .. - LOGICAL VEC(8) - INTEGER IPAR(*), NR(*) - DOUBLE PRECISION A(LDA,*), B(LDB,*), DPAR(*), DWORK(LDWORK), - 1 E(LDE,*), U(LDU,*), X(LDX,*), Y(LDY,*) -C .. Local Scalars .. - INTEGER I, J, K - DOUBLE PRECISION TEMP, TTM1, TTP1, TWOBYN -C .. Local Arrays .. - LOGICAL VECDEF(8) -C .. External Functions .. -C . BLAS . - DOUBLE PRECISION DDOT - EXTERNAL DDOT -C . LAPACK . - LOGICAL LSAME - EXTERNAL LSAME -C .. External Subroutines .. -C . BLAS . - EXTERNAL DGEMV, DGER, DAXPY -C . LAPACK . - EXTERNAL DLASET -C .. Intrinsic Functions .. - INTRINSIC DBLE, MIN, MOD -C .. Data Statements .. -C . default values for availabilities . - DATA VECDEF /.TRUE., .TRUE., .FALSE., .TRUE., - 1 .TRUE., .FALSE., .FALSE., .FALSE./ -C -C .. Executable Statements .. -C - INFO = 0 - DO 10 I = 1, 8 - VEC(I) = VECDEF(I) - 10 CONTINUE -C - IF (NR(1) .EQ. 4) THEN - IF (.NOT. (LSAME(DEF,'D') .OR. LSAME(DEF,'N'))) THEN - INFO = -1 - RETURN - END IF -C - IF (NR(2) .EQ. 1) THEN - NOTE = 'CTLEX: Example 4.1' - IF (LSAME(DEF,'D')) THEN - IPAR(1) = 10 - DPAR(1) = .15D1 - DPAR(2) = .15D1 - END IF - IF ((DPAR(1) .LE. ONE) .OR. (DPAR(2) .LE. ONE)) INFO = -3 - IF (IPAR(1) .LT. 2) INFO = -4 - N = IPAR(1) - M = 1 - IF (LDE .LT. N) INFO = -9 - IF (LDA .LT. N) INFO = -11 - IF (LDY .LT. N) INFO = -13 - IF (LDB .LT. M) INFO = -15 - IF (LDX .LT. N) INFO = -17 - IF (LDWORK .LT. N*2) INFO = -22 - IF (INFO .NE. 0) RETURN -C - VEC(6) = .TRUE. - VEC(7) = .TRUE. - TWOBYN = TWO / DBLE( N ) - CALL DLASET('A', N, N, ZERO, ONE, E, LDE) - CALL DLASET('A', N, N, ZERO, ZERO, A, LDA) - CALL DLASET('A', N, N, ZERO, ZERO, Y, LDY) - CALL DLASET('A', M, N, ZERO, ZERO, B, LDB) - CALL DLASET('A', N, N, ZERO, ZERO, X, LDX) - DO 30 J = 1, N - TEMP = DPAR(1) ** (J-1) - A(J,J) = -TEMP - DWORK(J) = ONE - DO 20 I = 1, N - X(I,J) = DBLE( I*J ) / (TEMP + DPAR(1)**(I-1)) - 20 CONTINUE - 30 CONTINUE -C H1 * A - CALL DGEMV('T', N,N, ONE, A, LDA, DWORK,1, ZERO, DWORK(N+1),1) - CALL DGER(N, N, -TWOBYN, DWORK, 1, DWORK(N+1), 1, A, LDA) -C A * H1 - CALL DGEMV('N', N,N, ONE, A, LDA, DWORK,1, ZERO, DWORK(N+1),1) - CALL DGER(N, N, -TWOBYN, DWORK(N+1), 1, DWORK, 1, A, LDA) -C H1 * X - CALL DGEMV('T', N,N, ONE, X, LDX, DWORK,1, ZERO, DWORK(N+1),1) - CALL DGER(N, N, -TWOBYN, DWORK, 1, DWORK(N+1), 1, X, LDX) -C X * H1 - CALL DGEMV('N', N,N, ONE, X, LDX, DWORK,1, ZERO, DWORK(N+1),1) - CALL DGER(N, N, -TWOBYN, DWORK(N+1), 1, DWORK, 1, X, LDX) -C S A INV(S), INV(S) X INV(S), B INV(S) - DO 50 J = 1, N - B(1,J) = DBLE( J-N-1 ) / (DPAR(2)**(J-1)) - DO 40 I = 1, N - X(I,J) = X(I,J) / (DPAR(2)**(I+J-2)) - A(I,J) = A(I,J) * (DPAR(2)**(I-J)) - 40 CONTINUE - DWORK(J) = ONE - TWO * MOD(J,2) - 50 CONTINUE -C H2 * A - CALL DGEMV('T', N,N, ONE, A, LDA, DWORK,1, ZERO, DWORK(N+1),1) - CALL DGER(N, N, -TWOBYN, DWORK, 1, DWORK(N+1), 1, A, LDA) -C A * H2 - CALL DGEMV('N', N,N, ONE, A, LDA, DWORK,1, ZERO, DWORK(N+1),1) - CALL DGER(N, N, -TWOBYN, DWORK(N+1), 1, DWORK, 1, A, LDA) -C H2 * X - CALL DGEMV('T', N,N, ONE, X, LDX, DWORK,1, ZERO, DWORK(N+1),1) - CALL DGER(N, N, -TWOBYN, DWORK, 1, DWORK(N+1), 1, X, LDX) -C X * H2 - CALL DGEMV('N', N,N, ONE, X, LDX, DWORK,1, ZERO, DWORK(N+1),1) - CALL DGER(N, N, -TWOBYN, DWORK(N+1), 1, DWORK, 1, X, LDX) -C B * H2 - CALL DAXPY(N, -TWOBYN * DDOT(N, B, LDB, DWORK, 1), DWORK, 1, - 1 B, LDB) -C Y = -B' * B - CALL DGER(N ,N, -ONE, B, LDB, B, LDB, Y, LDY) -C - ELSE IF (NR(2) .EQ. 2) THEN - NOTE = 'CTLEX: Example 4.2' - IF (LSAME(DEF,'D')) THEN - IPAR(1) = 10 - DPAR(1) = -.5D0 - DPAR(2) = .15D1 - END IF - IF ((DPAR(1) .GE. ZERO) .OR. (DPAR(2) .LE. ONE)) INFO = -3 - IF (IPAR(1) .LT. 2) INFO = -4 - N = IPAR(1) - M = 1 - IF (LDE .LT. N) INFO = -9 - IF (LDA .LT. N) INFO = -11 - IF (LDY .LT. N) INFO = -13 - IF (LDB .LT. M) INFO = -15 - IF (LDWORK .LT. N*2) INFO = -22 - IF (INFO .NE. 0) RETURN -C - VEC(6) = .TRUE. - TWOBYN = TWO / DBLE( N ) - CALL DLASET('A', N, N, ZERO, ONE, E, LDE) - CALL DLASET('A', N, N, ZERO, DPAR(1), A, LDA) - CALL DLASET('A', N, N, ZERO, ZERO, Y, LDY) - CALL DLASET('A', M, N, -TWOBYN, ONE - TWOBYN, B, LDB) - DO 60 I = 1, N-1 - DWORK(I) = ONE - A(I,I+1) = ONE - 60 CONTINUE - DWORK(N) = ONE -C H1 * A - CALL DGEMV('T', N,N, ONE, A, LDA, DWORK,1, ZERO, DWORK(N+1),1) - CALL DGER(N, N, -TWOBYN, DWORK, 1, DWORK(N+1), 1, A, LDA) -C A * H1 - CALL DGEMV('N', N,N, ONE, A, LDA, DWORK,1, ZERO, DWORK(N+1),1) - CALL DGER(N, N, -TWOBYN, DWORK(N+1), 1, DWORK, 1, A, LDA) -C S A INV(S), B INV(S) - DO 80 J = 1, N - B(1,J) = B(1,J) / (DPAR(2)**(J-1)) - DO 70 I = 1, N - A(I,J) = A(I,J) * (DPAR(2)**(I-J)) - 70 CONTINUE - DWORK(J) = ONE - TWO * MOD(J,2) - 80 CONTINUE -C H2 * A - CALL DGEMV('T', N,N, ONE, A, LDA, DWORK,1, ZERO, DWORK(N+1),1) - CALL DGER(N, N, -TWOBYN, DWORK, 1, DWORK(N+1), 1, A, LDA) -C A * H2 - CALL DGEMV('N', N,N, ONE, A, LDA, DWORK,1, ZERO, DWORK(N+1),1) - CALL DGER(N, N, -TWOBYN, DWORK(N+1), 1, DWORK, 1, A, LDA) -C B * H2 - CALL DAXPY(N, -TWOBYN * DDOT(N, B, LDB, DWORK, 1), DWORK, 1, - 1 B, LDB) -C Y = -B' * B - CALL DGER(N ,N, -ONE, B, LDB, B, LDB, Y, LDY) -C - ELSE IF (NR(2) .EQ. 3) THEN - NOTE = 'CTLEX: Example 4.3' - IF (LSAME(DEF,'D')) THEN - IPAR(1) = 10 - DPAR(1) = .1D2 - END IF - IF (DPAR(1) .LT. ZERO) INFO = -3 - IF (IPAR(1) .LT. 2) INFO = -4 - N = IPAR(1) - M = 0 - IF (LDE .LT. N) INFO = -9 - IF (LDA .LT. N) INFO = -11 - IF (LDY .LT. N) INFO = -13 - IF (LDX .LT. N) INFO = -17 - IF (INFO .NE. 0) RETURN -C - VEC(3) = .TRUE. - VEC(7) = .TRUE. - TEMP = TWO ** (-DPAR(1)) - CALL DLASET('U', N, N, ZERO, ZERO, E, LDE) - CALL DLASET('L', N, N, TEMP, ONE, E, LDE) - CALL DLASET('L', N, N, ZERO, ZERO, A, LDA) - CALL DLASET('U', N, N, ONE, ZERO, A, LDA) - CALL DLASET('A', N, N, ONE, ONE, X, LDX) - DO 90 I = 1, N - A(I,I) = DBLE( I - 1 ) + TEMP - 90 CONTINUE - Y(1,1) = TWO * TEMP + TWO * DBLE( N-1 ) * TEMP**2 - TTP1 = TWO * DBLE( N+1 ) * TEMP + TWO - TEMP**2 - TTM1 = TWO * DBLE( N-1 ) * TEMP + TWO - TEMP**2 - DO 100 I = 2, N - Y(I,1) = Y(1,1) + DBLE( I-1 ) * TTM1 - 100 CONTINUE - DO 120 J = 2, N - DO 110 I = 1, N - Y(I,J) = Y(I,1) + DBLE( J-1 ) * (TTP1 - FOUR * I * TEMP) - 110 CONTINUE - 120 CONTINUE -C - ELSE IF (NR(2) .EQ. 4) THEN - NOTE = 'CTLEX: Example 4.4' - IF (LSAME(DEF,'D')) THEN - IPAR(1) = 10 - DPAR(1) = .15D1 - END IF - IF (DPAR(1) .LT. ONE) INFO = -3 - IF (IPAR(1) .LT. 1) INFO = -4 - N = IPAR(1) * 3 - M = 1 - IF (LDE .LT. N) INFO = -9 - IF (LDA .LT. N) INFO = -11 - IF (LDY .LT. N) INFO = -13 - IF (LDB .LT. M) INFO = -15 - IF (INFO .NE. 0) RETURN -C - VEC(3) = .TRUE. - VEC(6) = .TRUE. - CALL DLASET('A', N, N, ZERO, ZERO, E, LDE) - CALL DLASET('A', N, N, ZERO, ZERO, A, LDA) - DO 150 I = 1, IPAR(1) - TEMP = -DPAR(1)**I - DO 140 J = 1, I - 1 - DO 130 K = 0, 2 - A(N - I*3+3, J*3-K) = TEMP - A(N - I*3+2, J*3-K) = TWO * TEMP - 130 CONTINUE - 140 CONTINUE - A(N - I*3+3, I*3-2) = TEMP - A(N - I*3+2, I*3-2) = TWO * TEMP - A(N - I*3+2, I*3-1) = TWO * TEMP - A(N - I*3+2, I*3 ) = TEMP - A(N - I*3+1, I*3 ) = TEMP - 150 CONTINUE - DO 170 J = 1, N - IF (J .GT. 1) CALL DAXPY(N, ONE, A(J-1,1), LDA, A(J,1), LDA) - B(1, J) = DBLE( J ) - DO 160 I = 1, N - E(I,N-J+1) = DBLE( MIN( I, J ) ) - Y(I,J) = -DBLE( I*J ) - 160 CONTINUE - 170 CONTINUE -C - ELSE - INFO = -2 - END IF - ELSE - INFO = -2 - END IF -C - RETURN -C *** Last Line of BB03AD *** - END diff --git a/mex/sources/libslicot/BB04AD.f b/mex/sources/libslicot/BB04AD.f deleted file mode 100644 index a017a8808..000000000 --- a/mex/sources/libslicot/BB04AD.f +++ /dev/null @@ -1,476 +0,0 @@ - SUBROUTINE BB04AD(DEF, NR, DPAR, IPAR, VEC, N, M, E, LDE, A, LDA, - 1 Y, LDY, B, LDB, X, LDX, U, LDU, NOTE, DWORK, - 2 LDWORK, INFO) -C -C SLICOT RELEASE 5.0. -C -C Copyright (c) 2002-2009 NICONET e.V. -C -C This program is free software: you can redistribute it and/or -C modify it under the terms of the GNU General Public License as -C published by the Free Software Foundation, either version 2 of -C the License, or (at your option) any later version. -C -C This program is distributed in the hope that it will be useful, -C but WITHOUT ANY WARRANTY; without even the implied warranty of -C MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the -C GNU General Public License for more details. -C -C You should have received a copy of the GNU General Public License -C along with this program. If not, see -C . -C -C PURPOSE -C -C To generate benchmark examples of (generalized) discrete-time -C Lyapunov equations -C -C T T -C A X A - E X E = Y . -C -C In some examples, the right hand side has the form -C -C T -C Y = - B B -C -C and the solution can be represented as a product of Cholesky -C factors -C -C T -C X = U U . -C -C E, A, Y, X, and U are real N-by-N matrices, and B is M-by-N. Note -C that E can be the identity matrix. For some examples, B, X, or U -C are not provided. -C -C This routine is an implementation of the benchmark library -C DTLEX (Version 1.0) described in [1]. -C -C ARGUMENTS -C -C Mode Parameters -C -C DEF CHARACTER*1 -C Specifies the kind of values used as parameters when -C generating parameter-dependent and scalable examples -C (i.e., examples with NR(1) = 2, 3, or 4): -C DEF = 'D' or 'd': Default values are used. -C DEF = 'N' or 'n': Values set in DPAR and IPAR are used. -C This parameter is not referenced if NR(1) = 1. -C Note that the scaling parameter of examples with -C NR(1) = 3 or 4 is considered as a regular parameter in -C this context. -C -C Input/Output Parameters -C -C NR (input) INTEGER array, dimension 2 -C Specifies the index of the desired example according -C to [1]. -C NR(1) defines the group: -C 1 : parameter-free problems of fixed size -C 2 : parameter-dependent problems of fixed size -C 3 : parameter-free problems of scalable size -C 4 : parameter-dependent problems of scalable size -C NR(2) defines the number of the benchmark example -C within a certain group according to [1]. -C -C DPAR (input/output) DOUBLE PRECISION array, dimension 2 -C On entry, if DEF = 'N' or 'n' and the desired example -C depends on real parameters, then the array DPAR must -C contain the values for these parameters. -C For an explanation of the parameters see [1]. -C For Example 4.1, DPAR(1) and DPAR(2) define 'r' and 's', -C respectively. -C For Example 4.2, DPAR(1) and DPAR(2) define 'lambda' and -C 's', respectively. -C For Examples 4.3 and 4.4, DPAR(1) defines the parameter -C 't'. -C On exit, if DEF = 'D' or 'd' and the desired example -C depends on real parameters, then the array DPAR is -C overwritten by the default values given in [1]. -C -C IPAR (input/output) INTEGER array of DIMENSION at least 1 -C On entry, if DEF = 'N' or 'n' and the desired example -C depends on integer parameters, then the array IPAR must -C contain the values for these parameters. -C For an explanation of the parameters see [1]. -C For Examples 4.1, 4.2, and 4.3, IPAR(1) defines 'n'. -C For Example 4.4, IPAR(1) defines 'q'. -C On exit, if DEF = 'D' or 'd' and the desired example -C depends on integer parameters, then the array IPAR is -C overwritten by the default values given in [1]. -C -C VEC (output) LOGICAL array, dimension 8 -C Flag vector which displays the availability of the output -C data: -C VEC(1) and VEC(2) refer to N and M, respectively, and are -C always .TRUE. -C VEC(3) is .TRUE. iff E is NOT the identity matrix. -C VEC(4) and VEC(5) refer to A and Y, respectively, and are -C always .TRUE. -C VEC(6) is .TRUE. iff B is provided. -C VEC(7) is .TRUE. iff the solution matrix X is provided. -C VEC(8) is .TRUE. iff the Cholesky factor U is provided. -C -C N (output) INTEGER -C The actual state dimension, i.e., the order of the -C matrices E and A. -C -C M (output) INTEGER -C The number of rows in the matrix B. If B is not provided -C for the desired example, M = 0 is returned. -C -C E (output) DOUBLE PRECISION array, dimension (LDE,N) -C The leading N-by-N part of this array contains the -C matrix E. -C NOTE that this array is overwritten (by the identity -C matrix), if VEC(3) = .FALSE. -C -C LDE INTEGER -C The leading dimension of array E. LDE >= N. -C -C A (output) DOUBLE PRECISION array, dimension (LDA,N) -C The leading N-by-N part of this array contains the -C matrix A. -C -C LDA INTEGER -C The leading dimension of array A. LDA >= N. -C -C Y (output) DOUBLE PRECISION array, dimension (LDY,N) -C The leading N-by-N part of this array contains the -C matrix Y. -C -C LDY INTEGER -C The leading dimension of array Y. LDY >= N. -C -C B (output) DOUBLE PRECISION array, dimension (LDB,N) -C The leading M-by-N part of this array contains the -C matrix B. -C -C LDB INTEGER -C The leading dimension of array B. LDB >= M. -C -C X (output) DOUBLE PRECISION array, dimension (LDX,N) -C The leading N-by-N part of this array contains the -C matrix X. -C -C LDX INTEGER -C The leading dimension of array X. LDX >= N. -C -C U (output) DOUBLE PRECISION array, dimension (LDU,N) -C The leading N-by-N part of this array contains the -C matrix U. -C -C LDU INTEGER -C The leading dimension of array U. LDU >= N. -C -C NOTE (output) CHARACTER*70 -C String containing short information about the chosen -C example. -C -C Workspace -C -C DWORK DOUBLE PRECISION array, dimension (LDWORK) -C -C LDWORK INTEGER -C The length of the array DWORK. -C For Examples 4.1 and 4.2., LDWORK >= 2*IPAR(1) is -C required. -C For the other examples, no workspace is needed, i.e., -C LDWORK >= 1. -C -C Error Indicator -C -C INFO INTEGER -C = 0: successful exit; -C < 0: if INFO = -i, the i-th argument had an illegal -C value; in particular, INFO = -3 or -4 indicates -C that at least one of the parameters in DPAR or -C IPAR, respectively, has an illegal value. -C -C REFERENCES -C -C [1] D. Kressner, V. Mehrmann, and T. Penzl. -C DTLEX - a Collection of Benchmark Examples for Discrete- -C Time Lyapunov Equations. -C SLICOT Working Note 1999-7, 1999. -C -C NUMERICAL ASPECTS -C -C None -C -C CONTRIBUTOR -C -C D. Kressner, V. Mehrmann, and T. Penzl (TU Chemnitz) -C -C For questions concerning the collection or for the submission of -C test examples, please contact Volker Mehrmann -C (Email: volker.mehrmann@mathematik.tu-chemnitz.de). -C -C REVISIONS -C -C June 1999, V. Sima. -C -C KEYWORDS -C -C discrete-time Lyapunov equations -C -C ******************************************************************** -C -C .. Parameters .. - DOUBLE PRECISION ZERO, ONE, TWO, THREE, FOUR - PARAMETER (ZERO = .0D0, ONE = .1D1, TWO = .2D1, - 1 THREE = .3D1, FOUR = .4D1) -C .. Scalar Arguments .. - CHARACTER DEF - CHARACTER*70 NOTE - INTEGER INFO, LDA, LDB, LDE, LDU, LDWORK, LDX, LDY, M, N -C .. Array Arguments .. - LOGICAL VEC(8) - INTEGER IPAR(*), NR(*) - DOUBLE PRECISION A(LDA,*), B(LDB,*), DPAR(*), DWORK(LDWORK), - 1 E(LDE,*), U(LDU,*), X(LDX,*), Y(LDY,*) -C .. Local Scalars .. - INTEGER I, J, K - DOUBLE PRECISION TEMP, TTEMP, TWOBYN -C .. Local Arrays .. - LOGICAL VECDEF(8) -C .. External Functions .. -C . BLAS . - DOUBLE PRECISION DDOT - EXTERNAL DDOT -C . LAPACK . - LOGICAL LSAME - EXTERNAL LSAME -C .. External Subroutines .. -C . BLAS . - EXTERNAL DGEMV, DGER, DAXPY -C . LAPACK . - EXTERNAL DLASET -C .. Intrinsic Functions .. - INTRINSIC DBLE, MIN, MOD, SQRT -C .. Data Statements .. -C . default values for availabilities . - DATA VECDEF /.TRUE., .TRUE., .FALSE., .TRUE., - 1 .TRUE., .FALSE., .FALSE., .FALSE./ -C -C .. Executable Statements .. -C - INFO = 0 - DO 10 I = 1, 8 - VEC(I) = VECDEF(I) - 10 CONTINUE -C - IF (NR(1) .EQ. 4) THEN - IF (.NOT. (LSAME(DEF,'D') .OR. LSAME(DEF,'N'))) THEN - INFO = -1 - RETURN - END IF -C - IF (NR(2) .EQ. 1) THEN - NOTE = 'DTLEX: Example 4.1' - IF (LSAME(DEF,'D')) THEN - IPAR(1) = 10 - DPAR(1) = .15D1 - DPAR(2) = .15D1 - END IF - IF ((DPAR(1) .LE. ONE) .OR. (DPAR(2) .LE. ONE)) INFO = -3 - IF (IPAR(1) .LT. 2) INFO = -4 - N = IPAR(1) - M = 1 - IF (LDE .LT. N) INFO = -9 - IF (LDA .LT. N) INFO = -11 - IF (LDY .LT. N) INFO = -13 - IF (LDB .LT. M) INFO = -15 - IF (LDX .LT. N) INFO = -17 - IF (LDWORK .LT. N*2) INFO = -22 - IF (INFO .NE. 0) RETURN -C - VEC(6) = .TRUE. - VEC(7) = .TRUE. - TWOBYN = TWO / DBLE( N ) - CALL DLASET('A', N, N, ZERO, ONE, E, LDE) - CALL DLASET('A', N, N, ZERO, ZERO, A, LDA) - CALL DLASET('A', N, N, ZERO, ZERO, Y, LDY) - CALL DLASET('A', M, N, -TWOBYN, ONE - TWOBYN, B, LDB) - CALL DLASET('A', N, N, ZERO, ZERO, X, LDX) - DO 20 I = 1, N - TEMP = DPAR(1) ** (I-1) - A(I,I) = (TEMP-ONE) / (TEMP+ONE) - DWORK(I) = ONE - 20 CONTINUE -C H1 * A - CALL DGEMV('T', N,N, ONE, A, LDA, DWORK,1, ZERO, DWORK(N+1),1) - CALL DGER(N, N, -TWOBYN, DWORK, 1, DWORK(N+1), 1, A, LDA) -C A * H1 - CALL DGEMV('N', N,N, ONE, A, LDA, DWORK,1, ZERO, DWORK(N+1),1) - CALL DGER(N, N, -TWOBYN, DWORK(N+1), 1, DWORK, 1, A, LDA) -C S A INV(S), B INV(S) - DO 40 J = 1, N - B(1,J) = B(1,J) / (DPAR(2)**(J-1)) - DO 30 I = 1, N - A(I,J) = A(I,J) * (DPAR(2)**(I-J)) - 30 CONTINUE - DWORK(J) = ONE - TWO * MOD(J,2) - 40 CONTINUE -C H2 * A - CALL DGEMV('T', N,N, ONE, A, LDA, DWORK,1, ZERO, DWORK(N+1),1) - CALL DGER(N, N, -TWOBYN, DWORK, 1, DWORK(N+1), 1, A, LDA) -C A * H2 - CALL DGEMV('N', N,N, ONE, A, LDA, DWORK,1, ZERO, DWORK(N+1),1) - CALL DGER(N, N, -TWOBYN, DWORK(N+1), 1, DWORK, 1, A, LDA) -C B * H2 - CALL DAXPY(N, -TWOBYN * DDOT(N, B, LDB, DWORK, 1), DWORK, 1, - 1 B, LDB) -C Y = -B' * B - CALL DGER(N ,N, -ONE, B, LDB, B, LDB, Y, LDY) -C X = -Y - DO 50 J = 1, N - CALL DAXPY(N, -ONE, Y(1,J), 1, X(1,J), 1) - 50 CONTINUE -C - ELSE IF (NR(2) .EQ. 2) THEN - NOTE = 'DTLEX: Example 4.2' - IF (LSAME(DEF,'D')) THEN - IPAR(1) = 10 - DPAR(1) = -.5D0 - DPAR(2) = .15D1 - END IF - IF ((DPAR(1) .LE. -ONE) .OR. (DPAR(1) .GE. ONE) .OR. - 1 (DPAR(2) .LE. ONE)) INFO = -3 - IF (IPAR(1) .LT. 2) INFO = -4 - N = IPAR(1) - M = 1 - IF (LDE .LT. N) INFO = -9 - IF (LDA .LT. N) INFO = -11 - IF (LDY .LT. N) INFO = -13 - IF (LDB .LT. M) INFO = -15 - IF (LDWORK .LT. N*2) INFO = -22 - IF (INFO .NE. 0) RETURN -C - VEC(6) = .TRUE. - TWOBYN = TWO / DBLE( N ) - CALL DLASET('A', N, N, ZERO, ONE, E, LDE) - CALL DLASET('A', N, N, ZERO, DPAR(1), A, LDA) - CALL DLASET('A', N, N, ZERO, ZERO, Y, LDY) - CALL DLASET('A', M, N, -TWOBYN, ONE - TWOBYN, B, LDB) - DO 60 I = 1, N-1 - DWORK(I) = ONE - A(I,I+1) = ONE - 60 CONTINUE - DWORK(N) = ONE -C H1 * A - CALL DGEMV('T', N,N, ONE, A, LDA, DWORK,1, ZERO, DWORK(N+1),1) - CALL DGER(N, N, -TWOBYN, DWORK, 1, DWORK(N+1), 1, A, LDA) -C A * H1 - CALL DGEMV('N', N,N, ONE, A, LDA, DWORK,1, ZERO, DWORK(N+1),1) - CALL DGER(N, N, -TWOBYN, DWORK(N+1), 1, DWORK, 1, A, LDA) -C S A INV(S), B INV(S) - DO 80 J = 1, N - B(1,J) = B(1,J) / (DPAR(2)**(J-1)) - DO 70 I = 1, N - A(I,J) = A(I,J) * (DPAR(2)**(I-J)) - 70 CONTINUE - DWORK(J) = ONE - TWO * MOD(J,2) - 80 CONTINUE -C H2 * A - CALL DGEMV('T', N,N, ONE, A, LDA, DWORK,1, ZERO, DWORK(N+1),1) - CALL DGER(N, N, -TWOBYN, DWORK, 1, DWORK(N+1), 1, A, LDA) -C A * H2 - CALL DGEMV('N', N,N, ONE, A, LDA, DWORK,1, ZERO, DWORK(N+1),1) - CALL DGER(N, N, -TWOBYN, DWORK(N+1), 1, DWORK, 1, A, LDA) -C B * H2 - CALL DAXPY(N, -TWOBYN * DDOT(N, B, LDB, DWORK, 1), DWORK, 1, - 1 B, LDB) -C Y = -B' * B - CALL DGER(N ,N, -ONE, B, LDB, B, LDB, Y, LDY) -C - ELSE IF (NR(2) .EQ. 3) THEN - NOTE = 'DTLEX: Example 4.3' - IF (LSAME(DEF,'D')) THEN - IPAR(1) = 10 - DPAR(1) = .1D2 - END IF - IF (DPAR(1) .LT. ZERO) INFO = -3 - IF (IPAR(1) .LT. 2) INFO = -4 - N = IPAR(1) - M = 0 - IF (LDE .LT. N) INFO = -9 - IF (LDA .LT. N) INFO = -11 - IF (LDY .LT. N) INFO = -13 - IF (LDX .LT. N) INFO = -17 - IF (INFO .NE. 0) RETURN -C - VEC(3) = .TRUE. - VEC(7) = .TRUE. - TEMP = TWO ** (-DPAR(1)) - CALL DLASET('U', N, N, ZERO, ZERO, E, LDE) - CALL DLASET('L', N, N, TEMP, ONE, E, LDE) - CALL DLASET('L', N, N, ZERO, ZERO, A, LDA) - CALL DLASET('U', N, N, ONE, ZERO, A, LDA) - CALL DLASET('A', N, N, ONE, ONE, X, LDX) - DO 90 I = 1, N - A(I,I) = DBLE( I ) + TEMP - 90 CONTINUE - DO 110 J = 1, N - DO 100 I = 1, N - Y(I,J) = TEMP * TEMP * DBLE( 1 - (N-I) * (N-J) ) + - 1 TEMP * DBLE( 3 * (I+J) - 2 * (N+1) ) + - 2 FOUR*DBLE( I*J ) - TWO * DBLE( I+J ) - 100 CONTINUE - 110 CONTINUE -C - ELSE IF (NR(2) .EQ. 4) THEN - NOTE = 'DTLEX: Example 4.4' - IF (LSAME(DEF,'D')) THEN - IPAR(1) = 10 - DPAR(1) = .15D1 - END IF - IF (DPAR(1) .LT. ONE) INFO = -3 - IF (IPAR(1) .LT. 1) INFO = -4 - N = IPAR(1) * 3 - M = 1 - IF (LDE .LT. N) INFO = -9 - IF (LDA .LT. N) INFO = -11 - IF (LDY .LT. N) INFO = -13 - IF (LDB .LT. M) INFO = -15 - IF (INFO .NE. 0) RETURN -C - VEC(3) = .TRUE. - VEC(6) = .TRUE. - CALL DLASET('A', N, N, ZERO, ZERO, E, LDE) - CALL DLASET('A', N, N, ZERO, ZERO, A, LDA) - DO 140 I = 1, IPAR(1) - TTEMP = ONE - ONE / (DPAR(1)**I) - TEMP = - TTEMP / SQRT( TWO ) - DO 130 J = 1, I - 1 - DO 120 K = 0, 2 - A(N - I*3+3, J*3-K) = TTEMP - A(N - I*3+2, J*3-K) = TWO * TEMP - 120 CONTINUE - 130 CONTINUE - A(N - I*3+3, I*3-2) = TTEMP - A(N - I*3+2, I*3-2) = TWO * TEMP - A(N - I*3+2, I*3-1) = TWO * TEMP - A(N - I*3+2, I*3 ) = TEMP - A(N - I*3+1, I*3 ) = TEMP - 140 CONTINUE - DO 160 J = 1, N - IF (J .GT. 1) CALL DAXPY(N, ONE, A(J-1,1), LDA, A(J,1), LDA) - B(1, J) = DBLE( J ) - DO 150 I = 1, N - E(I,N-J+1) = DBLE( MIN(I,J) ) - Y(I,J) = -DBLE( I*J ) - 150 CONTINUE - 160 CONTINUE -C - ELSE - INFO = -2 - END IF - ELSE - INFO = -2 - END IF -C - RETURN -C *** Last Line of BB04AD *** - END diff --git a/mex/sources/libslicot/BD01AD.f b/mex/sources/libslicot/BD01AD.f deleted file mode 100644 index 9cc34c065..000000000 --- a/mex/sources/libslicot/BD01AD.f +++ /dev/null @@ -1,1017 +0,0 @@ - SUBROUTINE BD01AD( DEF, NR, DPAR, IPAR, VEC, N, M, P, E, LDE, A, - 1 LDA, B, LDB, C, LDC, D, LDD, NOTE, DWORK, - 2 LDWORK, INFO ) -C -C SLICOT RELEASE 5.0. -C -C Copyright (c) 2002-2009 NICONET e.V. -C -C This program is free software: you can redistribute it and/or -C modify it under the terms of the GNU General Public License as -C published by the Free Software Foundation, either version 2 of -C the License, or (at your option) any later version. -C -C This program is distributed in the hope that it will be useful, -C but WITHOUT ANY WARRANTY; without even the implied warranty of -C MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the -C GNU General Public License for more details. -C -C You should have received a copy of the GNU General Public License -C along with this program. If not, see -C . -C -C PURPOSE -C -C To generate benchmark examples for time-invariant, -C continuous-time dynamical systems -C -C . -C E x(t) = A x(t) + B u(t) -C -C y(t) = C x(t) + D u(t) -C -C E, A are real N-by-N matrices, B is N-by-M, C is P-by-N, and -C D is P-by-M. In many examples, E is the identity matrix and D is -C the zero matrix. -C -C This routine is an implementation of the benchmark library -C CTDSX (Version 1.0) described in [1]. -C -C ARGUMENTS -C -C Mode Parameters -C -C DEF CHARACTER*1 -C Specifies the kind of values used as parameters when -C generating parameter-dependent and scalable examples -C (i.e., examples with NR(1) = 2, 3, or 4): -C = 'D': Default values defined in [1] are used; -C = 'N': Values set in DPAR and IPAR are used. -C This parameter is not referenced if NR(1) = 1. -C Note that the scaling parameter of examples with -C NR(1) = 3 or 4 is considered as a regular parameter in -C this context. -C -C Input/Output Parameters -C -C NR (input) INTEGER array, dimension (2) -C Specifies the index of the desired example according -C to [1]. -C NR(1) defines the group: -C 1 : parameter-free problems of fixed size -C 2 : parameter-dependent problems of fixed size -C 3 : parameter-free problems of scalable size -C 4 : parameter-dependent problems of scalable size -C NR(2) defines the number of the benchmark example -C within a certain group according to [1]. -C -C DPAR (input/output) DOUBLE PRECISION array, dimension (7) -C On entry, if DEF = 'N' and the desired example depends on -C real parameters, then the array DPAR must contain the -C values for these parameters. -C For an explanation of the parameters see [1]. -C For Examples 2.1 and 2.2, DPAR(1) defines the parameter -C 'epsilon'. -C For Example 2.4, DPAR(1), ..., DPAR(7) define 'b', 'mu', -C 'r', 'r_c', 'k_l', 'sigma', 'a', respectively. -C For Example 2.7, DPAR(1) and DPAR(2) define 'mu' and 'nu', -C respectively. -C For Example 4.1, DPAR(1), ..., DPAR(7) define 'a', 'b', -C 'c', 'beta_1', 'beta_2', 'gamma_1', 'gamma_2', -C respectively. -C For Example 4.2, DPAR(1), ..., DPAR(3) define 'mu', -C 'delta', 'kappa', respectively. -C On exit, if DEF = 'D' and the desired example depends on -C real parameters, then the array DPAR is overwritten by the -C default values given in [1]. -C -C IPAR (input/output) INTEGER array, dimension (1) -C On entry, if DEF = 'N' and the desired example depends on -C integer parameters, then the array IPAR must contain the -C values for these parameters. -C For an explanation of the parameters see [1]. -C For Examples 2.3, 2.5, and 2.6, IPAR(1) defines the -C parameter 's'. -C For Example 3.1, IPAR(1) defines 'q'. -C For Examples 3.2 and 3.3, IPAR(1) defines 'n'. -C For Example 3.4, IPAR(1) defines 'l'. -C For Example 4.1, IPAR(1) defines 'n'. -C For Example 4.2, IPAR(1) defines 'l'. -C On exit, if DEF = 'D' and the desired example depends on -C integer parameters, then the array IPAR is overwritten by -C the default values given in [1]. -C -C VEC (output) LOGICAL array, dimension (8) -C Flag vector which displays the availabilty of the output -C data: -C VEC(1), ..., VEC(3) refer to N, M, and P, respectively, -C and are always .TRUE.. -C VEC(4) is .TRUE. iff E is NOT the identity matrix. -C VEC(5), ..., VEC(7) refer to A, B, and C, respectively, -C and are always .TRUE.. -C VEC(8) is .TRUE. iff D is NOT the zero matrix. -C -C N (output) INTEGER -C The actual state dimension, i.e., the order of the -C matrices E and A. -C -C M (output) INTEGER -C The number of columns in the matrices B and D. -C -C P (output) INTEGER -C The number of rows in the matrices C and D. -C -C E (output) DOUBLE PRECISION array, dimension (LDE,N) -C The leading N-by-N part of this array contains the -C matrix E. -C NOTE that this array is overwritten (by the identity -C matrix), if VEC(4) = .FALSE.. -C -C LDE INTEGER -C The leading dimension of array E. LDE >= N. -C -C A (output) DOUBLE PRECISION array, dimension (LDA,N) -C The leading N-by-N part of this array contains the -C matrix A. -C -C LDA INTEGER -C The leading dimension of array A. LDA >= N. -C -C B (output) DOUBLE PRECISION array, dimension (LDB,M) -C The leading N-by-M part of this array contains the -C matrix B. -C -C LDB INTEGER -C The leading dimension of array B. LDB >= N. -C -C C (output) DOUBLE PRECISION array, dimension (LDC,N) -C The leading P-by-N part of this array contains the -C matrix C. -C -C LDC INTEGER -C The leading dimension of array C. LDC >= P. -C -C D (output) DOUBLE PRECISION array, dimension (LDD,M) -C The leading P-by-M part of this array contains the -C matrix D. -C NOTE that this array is overwritten (by the zero -C matrix), if VEC(8) = .FALSE.. -C -C LDD INTEGER -C The leading dimension of array D. LDD >= P. -C -C NOTE (output) CHARACTER*70 -C String containing short information about the chosen -C example. -C -C Workspace -C -C DWORK DOUBLE PRECISION array, dimension (LDWORK) -C -C LDWORK INTEGER -C The length of the array DWORK. -C For Example 3.4, LDWORK >= 4*IPAR(1) is required. -C For the other examples, no workspace is needed, i.e., -C LDWORK >= 1. -C -C Error Indicator -C -C INFO INTEGER -C = 0: successful exit; -C < 0: if INFO = -i, the i-th argument had an illegal -C value; in particular, INFO = -3 or -4 indicates -C that at least one of the parameters in DPAR or -C IPAR, respectively, has an illegal value; -C = 1: data file can not be opened or has wrong format. -C -C -C REFERENCES -C -C [1] Kressner, D., Mehrmann, V. and Penzl, T. -C CTDSX - a Collection of Benchmark Examples for State-Space -C Realizations of Continuous-Time Dynamical Systems. -C SLICOT Working Note 1998-9. 1998. -C -C NUMERICAL ASPECTS -C -C None -C -C CONTRIBUTOR -C -C D. Kressner, V. Mehrmann, and T. Penzl (TU Chemnitz) -C -C For questions concerning the collection or for the submission of -C test examples, please contact Volker Mehrmann -C (Email: volker.mehrmann@mathematik.tu-chemnitz.de). -C -C REVISIONS -C -C June 1999, V. Sima. -C -C KEYWORDS -C -C continuous-time dynamical systems -C -C ****************************************************************** -C -C .. Parameters .. - DOUBLE PRECISION ZERO, ONE, TWO, THREE, FOUR, PI - PARAMETER ( ZERO = 0.0D0, ONE = 1.0D0, TWO = 2.0D0, - 1 THREE = 3.0D0, FOUR = 4.0D0, - 2 PI = .3141592653589793D1 ) -C .. Scalar Arguments .. - CHARACTER DEF - CHARACTER*70 NOTE - INTEGER INFO, LDA, LDB, LDC, LDD, LDE, LDWORK, M, N, P -C .. Array Arguments .. - LOGICAL VEC(8) - INTEGER IPAR(*), NR(*) - DOUBLE PRECISION A(LDA,*), B(LDB,*), C(LDC,*), D(LDD,*), DPAR(*), - 1 DWORK(*), E(LDE,*) -C .. Local Scalars .. - CHARACTER*12 DATAF - INTEGER I, J, L, STATUS - DOUBLE PRECISION APPIND, B1, B2, C1, C2, TEMP, TTEMP -C .. Local Arrays .. - LOGICAL VECDEF(8) -C .. External Functions .. -C . LAPACK . - LOGICAL LSAME - EXTERNAL LSAME -C .. External Subroutines .. -C . BLAS . - EXTERNAL DSCAL -C . LAPACK . - EXTERNAL DLASET -C .. Intrinsic Functions .. - INTRINSIC MAX, MIN, MOD -C .. Data Statements .. -C . default values for availabities . - DATA VECDEF /.TRUE., .TRUE., .TRUE., .FALSE., - 1 .TRUE., .TRUE., .TRUE., .FALSE./ -C -C .. Executable Statements .. -C - INFO = 0 - DO 10 I = 1, 8 - VEC(I) = VECDEF(I) -10 CONTINUE -C - IF (NR(1) .EQ. 1) THEN -C - IF (NR(2) .EQ. 1) THEN - NOTE = 'Laub 1979, Ex.1' - N = 2 - M = 1 - P = 2 - IF (LDE .LT. N) INFO = -10 - IF (LDA .LT. N) INFO = -12 - IF (LDB .LT. N) INFO = -14 - IF (LDC .LT. P) INFO = -16 - IF (LDD .LT. P) INFO = -18 - IF (INFO .NE. 0) RETURN -C - CALL DLASET('A', N, N, ZERO, ONE, E, LDE) - CALL DLASET('A', N, N, ZERO, ZERO, A, LDA) - A(1,2) = ONE - B(1,1) = ZERO - B(2,1) = ONE - CALL DLASET('A', P, N, ZERO, ONE, C, LDC) - CALL DLASET('A', P, M, ZERO, ZERO, D, LDD) -C - ELSE IF (NR(2) .EQ. 2) THEN - NOTE = 'Laub 1979, Ex.2: uncontrollable-unobservable data' - N = 2 - M = 1 - P = 1 - IF (LDE .LT. N) INFO = -10 - IF (LDA .LT. N) INFO = -12 - IF (LDB .LT. N) INFO = -14 - IF (LDC .LT. P) INFO = -16 - IF (LDD .LT. P) INFO = -18 - IF (INFO .NE. 0) RETURN -C - CALL DLASET('A', N, N, ZERO, ONE, E, LDE) - A(1,1) = FOUR - A(2,1) = -.45D1 - A(1,2) = .3D1 - A(2,2) = -.35D1 - B(1,1) = ONE - B(2,1) = -ONE - C(1,1) = THREE - C(1,2) = TWO - CALL DLASET('A', P, M, ZERO, ZERO, D, LDD) -C - ELSE IF (NR(2) .EQ. 3) THEN - NOTE = 'Beale/Shafai 1989: model of L-1011 aircraft' - N = 4 - M = 2 - P = 4 - IF (LDE .LT. N) INFO = -10 - IF (LDA .LT. N) INFO = -12 - IF (LDB .LT. N) INFO = -14 - IF (LDC .LT. P) INFO = -16 - IF (LDD .LT. P) INFO = -18 - IF (INFO .NE. 0) RETURN -C - CALL DLASET('A', N, N, ZERO, ONE, E, LDE) - CALL DLASET('A', P, N, ZERO, ONE, C, LDC) - CALL DLASET('A', P, M, ZERO, ZERO, D, LDD) -C - ELSE IF (NR(2) .EQ. 4) THEN - NOTE = 'Bhattacharyya et al. 1983: binary distillation column' - N = 8 - M = 2 - P = 8 - IF (LDE .LT. N) INFO = -10 - IF (LDA .LT. N) INFO = -12 - IF (LDB .LT. N) INFO = -14 - IF (LDC .LT. P) INFO = -16 - IF (LDD .LT. P) INFO = -18 - IF (INFO .NE. 0) RETURN -C - CALL DLASET('A', N, N, ZERO, ONE, E, LDE) - CALL DLASET('A', P, N, ZERO, ONE, C, LDC) - CALL DLASET('A', P, M, ZERO, ZERO, D, LDD) -C - ELSE IF (NR(2) .EQ. 5) THEN - NOTE = 'Patnaik et al. 1980: tubular ammonia reactor' - N = 9 - M = 3 - P = 9 - IF (LDE .LT. N) INFO = -10 - IF (LDA .LT. N) INFO = -12 - IF (LDB .LT. N) INFO = -14 - IF (LDC .LT. P) INFO = -16 - IF (LDD .LT. P) INFO = -18 - IF (INFO .NE. 0) RETURN -C - CALL DLASET('A', N, N, ZERO, ONE, E, LDE) - CALL DLASET('A', P, N, ZERO, ONE, C, LDC) - CALL DLASET('A', P, M, ZERO, ZERO, D, LDD) -C - ELSE IF (NR(2) .EQ. 6) THEN - NOTE = 'Davison/Gesing 1978: J-100 jet engine' - N = 30 - M = 3 - P = 5 - IF (LDE .LT. N) INFO = -10 - IF (LDA .LT. N) INFO = -12 - IF (LDB .LT. N) INFO = -14 - IF (LDC .LT. P) INFO = -16 - IF (LDD .LT. P) INFO = -18 - IF (INFO .NE. 0) RETURN -C - CALL DLASET('A', N, N, ZERO, ONE, E, LDE) - CALL DLASET('A', P, M, ZERO, ZERO, D, LDD) -C - ELSE IF (NR(2) .EQ. 7) THEN - NOTE = 'Davison 1967: binary distillation column' - N = 11 - M = 3 - P = 3 - IF (LDE .LT. N) INFO = -10 - IF (LDA .LT. N) INFO = -12 - IF (LDB .LT. N) INFO = -14 - IF (LDC .LT. P) INFO = -16 - IF (LDD .LT. P) INFO = -18 - IF (INFO .NE. 0) RETURN -C - CALL DLASET('A', N, N, ZERO, ONE, E, LDE) - CALL DLASET('A', P, N, ZERO, ZERO, C, LDC) - C(2,1) = ONE - C(1,10) = ONE - C(3,11) = ONE - CALL DLASET('A', P, M, ZERO, ZERO, D, LDD) - - ELSE IF (NR(2) .EQ. 8) THEN - NOTE = 'Chien/Ergin/Ling/Lee 1958: drum boiler' - N = 9 - M = 3 - P = 2 - IF (LDE .LT. N) INFO = -10 - IF (LDA .LT. N) INFO = -12 - IF (LDB .LT. N) INFO = -14 - IF (LDC .LT. P) INFO = -16 - IF (LDD .LT. P) INFO = -18 - IF (INFO .NE. 0) RETURN -C - CALL DLASET('A', N, N, ZERO, ONE, E, LDE) - CALL DLASET('A', P, N, ZERO, ZERO, C, LDC) - C(1,6) = ONE - C(2,9) = ONE - CALL DLASET('A', P, M, ZERO, ZERO, D, LDD) -C - ELSE IF (NR(2) .EQ. 9) THEN - NOTE = 'Ly, Gangsaas 1981: B-767 airplane' - N = 55 - M = 2 - P = 2 - IF (LDE .LT. N) INFO = -10 - IF (LDA .LT. N) INFO = -12 - IF (LDB .LT. N) INFO = -14 - IF (LDC .LT. P) INFO = -16 - IF (LDD .LT. P) INFO = -18 - IF (INFO .NE. 0) RETURN -C - CALL DLASET('A', N, N, ZERO, ONE, E, LDE) - CALL DLASET('A', P, M, ZERO, ZERO, D, LDD) -C - ELSE IF (NR(2) .EQ. 10) THEN - NOTE = 'control surface servo for an underwater vehicle' - N = 8 - M = 2 - P = 1 - IF (LDE .LT. N) INFO = -10 - IF (LDA .LT. N) INFO = -12 - IF (LDB .LT. N) INFO = -14 - IF (LDC .LT. P) INFO = -16 - IF (LDD .LT. P) INFO = -18 - IF (INFO .NE. 0) RETURN -C - CALL DLASET('A', N, N, ZERO, ONE, E, LDE) - CALL DLASET('A', P, N, ZERO, ZERO, C, LDC) - C(1,7) = ONE - CALL DLASET('A', P, M, ZERO, ZERO, D, LDD) - ELSE - INFO = -2 - END IF -C - IF ((NR(2) .GE. 3) .AND. (NR(2) .LE. 10)) THEN -C .. loading data files - WRITE (DATAF(1:11), '(A,I2.2,A)') 'BD011', NR(2), '.dat' - OPEN(1, IOSTAT = STATUS, STATUS = 'OLD', FILE = DATAF(1:11)) - IF (STATUS .NE. 0) THEN - INFO = 1 - ELSE - DO 110 I = 1, N - READ (1, FMT = *, IOSTAT = STATUS) (A(I,J), J = 1, N) - IF (STATUS .NE. 0) INFO = 1 -110 CONTINUE - DO 120 I = 1, N - READ (1, FMT = *, IOSTAT = STATUS) (B(I,J), J = 1, M) - IF (STATUS .NE. 0) INFO = 1 -120 CONTINUE - IF ((NR(2) .EQ. 6) .OR. (NR(2) .EQ. 9)) THEN - DO 130 I = 1, P - READ (1, FMT = *, IOSTAT = STATUS) (C(I,J), J = 1, N) - IF (STATUS .NE. 0) INFO = 1 -130 CONTINUE - END IF - END IF - CLOSE(1) - END IF -C - ELSE IF (NR(1) .EQ. 2) THEN - IF (.NOT. (LSAME(DEF,'D') .OR. LSAME(DEF,'N'))) THEN - INFO = -1 - RETURN - END IF -C - IF (NR(2) .EQ. 1) THEN - NOTE = 'Chow/Kokotovic 1976: magnetic tape control system' - IF (LSAME(DEF,'D')) DPAR(1) = 1D-6 - IF (DPAR(1) .EQ. ZERO) INFO = -3 - N = 4 - M = 1 - P = 2 - IF (LDE .LT. N) INFO = -10 - IF (LDA .LT. N) INFO = -12 - IF (LDB .LT. N) INFO = -14 - IF (LDC .LT. P) INFO = -16 - IF (LDD .LT. P) INFO = -18 - IF (INFO .NE. 0) RETURN -C - CALL DLASET('A', N, N, ZERO, ONE, E, LDE) - CALL DLASET('A', N, N, ZERO, ZERO, A, LDA) - A(1,2) = .400D0 - A(2,3) = .345D0 - A(3,2) = -.524D0/DPAR(1) - A(3,3) = -.465D0/DPAR(1) - A(3,4) = .262D0/DPAR(1) - A(4,4) = -ONE/DPAR(1) - CALL DLASET('A', N, M, ZERO, ZERO, B, LDB) - B(4,1) = ONE/DPAR(1) - CALL DLASET('A', P, N, ZERO, ZERO, C, LDC) - C(1,1) = ONE - C(2,3) = ONE - CALL DLASET('A', P, M, ZERO, ZERO, D, LDD) -C - ELSE IF (NR(2) .EQ. 2) THEN - NOTE = 'Arnold/Laub 1984' - IF (LSAME(DEF,'D')) DPAR(1) = 1D-6 - N = 4 - M = 1 - P = 1 - IF (LDE .LT. N) INFO = -10 - IF (LDA .LT. N) INFO = -12 - IF (LDB .LT. N) INFO = -14 - IF (LDC .LT. P) INFO = -16 - IF (LDD .LT. P) INFO = -18 - IF (INFO .NE. 0) RETURN -C - CALL DLASET('A', N, N, ZERO, ONE, E, LDE) - CALL DLASET('A', N, N, ZERO, DPAR(1), A, LDA) - A(1,1) = -DPAR(1) - A(2,1) = -ONE - A(1,2) = ONE - A(2,2) = -DPAR(1) - A(4,3) = -ONE - A(3,4) = ONE - CALL DLASET('A', N, M, ONE, ONE, B, LDB) - CALL DLASET('A', P, N, ONE, ONE, C, LDC) - D(1,1) = ZERO -C - ELSE IF (NR(2) .EQ. 3) THEN - NOTE = 'Vertical acceleration of a rigid guided missile' - IF (LSAME(DEF,'D')) IPAR(1) = 1 - IF ((IPAR(1) .LT. 1) .OR. (IPAR(1) .GT. 10)) INFO = -4 - N = 3 - M = 1 - P = 1 - IF (LDE .LT. N) INFO = -10 - IF (LDA .LT. N) INFO = -12 - IF (LDB .LT. N) INFO = -14 - IF (LDC .LT. P) INFO = -16 - IF (LDD .LT. P) INFO = -18 - IF (INFO .NE. 0) RETURN -C - CALL DLASET('A', N, N, ZERO, ONE, E, LDE) - CALL DLASET('A', N, N, ZERO, ZERO, A, LDA) - A(2,1) = ONE - A(3,3) = -.19D3 - CALL DLASET('A', N, M, ZERO, ZERO, B, LDB) - B(3,1) = .19D3 - D(1,1) = ZERO - OPEN(1, IOSTAT = STATUS, STATUS = 'OLD', FILE = 'BD01203.dat') - IF (STATUS .NE. 0) THEN - INFO = 1 - ELSE - DO 210 I = 1, IPAR(1) - READ (1, FMT = *, IOSTAT = STATUS) (A(1,J), J = 1, N) - IF (STATUS .NE. 0) INFO = 1 - READ (1, FMT = *, IOSTAT = STATUS) (A(2,J), J = 2, N) - IF (STATUS .NE. 0) INFO = 1 - READ (1, FMT = *, IOSTAT = STATUS) (C(1,J), J = 1, N) - IF (STATUS .NE. 0) INFO = 1 -210 CONTINUE - END IF - CLOSE(1) -C - ELSE IF (NR(2) .EQ. 4) THEN - NOTE = 'Senning 1980: hydraulic positioning system' - IF (LSAME(DEF,'D')) THEN - DPAR(1) = .14D5 - DPAR(2) = .1287D0 - DPAR(3) = .15D0 - DPAR(4) = .1D-1 - DPAR(5) = .2D-2 - DPAR(6) = .24D0 - DPAR(7) = .1075D2 - END IF - IF (((DPAR(1) .LE. .9D4) .OR. (DPAR(1) .GE. .16D5)) .OR. - 1 ((DPAR(2) .LE. .5D-1) .OR. (DPAR(2) .GE. .3D0)) .OR. - 2 ((DPAR(3) .LE. .5D-1) .OR. (DPAR(3) .GE. .5D1)) .OR. - 3 ((DPAR(4) .LE. ZERO) .OR. (DPAR(4) .GE. .5D-1)) .OR. - 4 ((DPAR(5) .LE. .103D-3) .OR. (DPAR(5) .GE. .35D-2)) .OR. - 5 ((DPAR(6) .LE. .1D-2) .OR. (DPAR(6) .GE. .15D2)) .OR. - 6 ((DPAR(7) .LE. .105D2) .OR. (DPAR(7) .GE. .111D2))) THEN - INFO = -3 - END IF - N = 3 - M = 1 - P = 1 - IF (LDE .LT. N) INFO = -10 - IF (LDA .LT. N) INFO = -12 - IF (LDB .LT. N) INFO = -14 - IF (LDC .LT. P) INFO = -16 - IF (LDD .LT. P) INFO = -18 - IF (INFO .NE. 0) RETURN -C - CALL DLASET('A', N, N, ZERO, ONE, E, LDE) - CALL DLASET('A', N, N, ZERO, ZERO, A, LDA) - A(1,2) = ONE - A(2,2) = -(DPAR(3) + FOUR*DPAR(4)/PI) / DPAR(2) - A(2,3) = DPAR(7) / DPAR(2) - A(3,2) = -FOUR * DPAR(7) * DPAR(1) / .874D3 - A(3,3) = -FOUR * DPAR(1) * (DPAR(6) + DPAR(5)) / .874D3 - CALL DLASET('A', N, M, ZERO, ZERO, B, LDB) - B(3,1) = -FOUR * DPAR(1) / .874D3 - CALL DLASET('A', P, N, ZERO, ONE, C, LDC) - D(1,1) = 0 -C - ELSE IF (NR(2) .EQ. 5) THEN - NOTE = 'Kwakernaak/Westdyk 1985: cascade of inverted pendula' - IF (LSAME(DEF,'D')) IPAR(1) = 1 - IF ((IPAR(1) .LT. 1) .OR. (IPAR(1) .GT. 7)) INFO = -4 - IF (IPAR(1) .LE. 6) THEN - M = IPAR(1) - ELSE - M = 10 - END IF - N = 2 * M - P = M - IF (LDE .LT. N) INFO = -10 - IF (LDA .LT. N) INFO = -12 - IF (LDB .LT. N) INFO = -14 - IF (LDC .LT. P) INFO = -16 - IF (LDD .LT. P) INFO = -18 - IF (INFO .NE. 0) RETURN -C - CALL DLASET('A', N, N, ZERO, ONE, E, LDE) - WRITE (DATAF(1:12), '(A,I1,A)') 'BD01205', IPAR(1), '.dat' - OPEN(1, IOSTAT = STATUS, STATUS = 'OLD', FILE = DATAF(1:12)) - IF (STATUS .NE. 0) THEN - INFO = 1 - ELSE - DO 220 I = 1, N - READ (1, FMT = *, IOSTAT = STATUS) (A(I,J), J = 1, N) - IF (STATUS .NE. 0) INFO = 1 -220 CONTINUE - DO 230 I = 1, N - READ (1, FMT = *, IOSTAT = STATUS) (B(I,J), J = 1, M) - IF (STATUS .NE. 0) INFO = 1 -230 CONTINUE - DO 240 I = 1, P - READ (1, FMT = *, IOSTAT = STATUS) (C(I,J), J = 1, N) - IF (STATUS .NE. 0) INFO = 1 -240 CONTINUE - END IF - CLOSE(1) - CALL DLASET('A', P, M, ZERO, ZERO, D, LDD) -C - ELSE IF (NR(2) .EQ. 6) THEN - NOTE = 'Kallstrom/Astrom 1981: regulation of a ship heading' - IF (LSAME(DEF,'D')) IPAR(1) = 1 - IF ((IPAR(1) .LT. 1) .OR. (IPAR(1) .GT. 5)) INFO = -4 - N = 3 - M = 1 - P = 1 - IF (LDE .LT. N) INFO = -10 - IF (LDA .LT. N) INFO = -12 - IF (LDB .LT. N) INFO = -14 - IF (LDC .LT. P) INFO = -16 - IF (LDD .LT. P) INFO = -18 - IF (INFO .NE. 0) RETURN -C - CALL DLASET('A', N, N, ZERO, ONE, E, LDE) - CALL DLASET('A', N, N, ZERO, ZERO, A, LDA) - A(3,2) = ONE - B(3,1) = ZERO - CALL DLASET('A', P, N, ZERO, ZERO, C, LDC) - C(1,3) = ONE - D(1,1) = ZERO - OPEN(1, IOSTAT = STATUS, STATUS = 'OLD', FILE = 'BD01206.dat') - IF (STATUS .NE. 0) THEN - INFO = 1 - ELSE - DO 250 I = 1, IPAR(1) - READ (1, FMT = *, IOSTAT = STATUS) (A(1,J), J = 1, 2) - IF (STATUS .NE. 0) INFO = 1 - READ (1, FMT = *, IOSTAT = STATUS) (A(2,J), J = 1, 2) - IF (STATUS .NE. 0) INFO = 1 - READ (1, FMT = *, IOSTAT = STATUS) (B(J,1), J = 1, 2) - IF (STATUS .NE. 0) INFO = 1 -250 CONTINUE - END IF - CLOSE(1) -C - ELSE IF (NR(2) .EQ. 7) THEN - NOTE = 'Ackermann 1989: track-guided bus' - IF (LSAME(DEF,'D')) THEN - DPAR(1) = .15D2 - DPAR(2) = .1D2 - END IF - IF ((DPAR(1) .LT. .995D1) .OR. (DPAR(1) .GT. .16D2)) INFO = -3 - IF ((DPAR(1) .LT. .1D1) .OR. (DPAR(1) .GT. .2D2)) INFO = -3 - N = 5 - M = 1 - P = 1 - IF (LDE .LT. N) INFO = -10 - IF (LDA .LT. N) INFO = -12 - IF (LDB .LT. N) INFO = -14 - IF (LDC .LT. P) INFO = -16 - IF (LDD .LT. P) INFO = -18 - IF (INFO .NE. 0) RETURN -C - CALL DLASET('A', N, N, ZERO, ONE, E, LDE) - CALL DLASET('A', N, N, ZERO, ZERO, A, LDA) - A(1,1) = -.668D3 / (DPAR(1)*DPAR(2)) - A(1,2) = -ONE + .1804D3 / (DPAR(1)*DPAR(2)**2) - A(2,1) = .1804D3 / (.1086D2*DPAR(1)) - A(2,2) = -.44175452D4 / (.1086D2*DPAR(1)*DPAR(2)) - A(1,5) = 198 / (DPAR(1)*DPAR(2)) - A(2,5) = .72666D3 / (.1086D2*DPAR(1)) - A(3,1) = DPAR(2) - A(3,4) = DPAR(2) - A(4,2) = ONE - CALL DLASET('A', N, M, ZERO, ZERO, B, LDB) - B(5,1) = ONE - CALL DLASET('A', P, N, ZERO, ZERO, C, LDC) - C(1,3) = ONE - C(1,4) = .612D1 - D(1,1) = 0 -C - ELSE - INFO = -2 - END IF -C - ELSE IF (NR(1) .EQ. 3) THEN - IF (.NOT. (LSAME(DEF,'D') .OR. LSAME(DEF,'N'))) THEN - INFO = -1 - RETURN - END IF -C - IF (NR(2) .EQ. 1) THEN - NOTE = 'Laub 1979, Ex.4: string of high speed vehicles' - IF (LSAME(DEF,'D')) IPAR(1) = 20 - IF (IPAR(1) .LT. 2) INFO = -4 - N = 2*IPAR(1) - 1 - M = IPAR(1) - P = IPAR(1) - 1 - IF (LDE .LT. N) INFO = -10 - IF (LDA .LT. N) INFO = -12 - IF (LDB .LT. N) INFO = -14 - IF (LDC .LT. P) INFO = -16 - IF (LDD .LT. P) INFO = -18 - IF (INFO .NE. 0) RETURN -C - CALL DLASET('A', N, N, ZERO, ONE, E, LDE) - CALL DLASET('A', N, N, ZERO, ZERO, A, LDA) - CALL DLASET('A', N, M, ZERO, ZERO, B, LDB) - CALL DLASET('A', P, N, ZERO, ZERO, C, LDC) - DO 310 I = 1, N - IF (MOD(I,2) .EQ. 1) THEN - A(I,I) = -ONE - B(I,(I+1)/2) = ONE - ELSE - A(I,I-1) = ONE - A(I,I+1) = -ONE - C(I/2,I) = ONE - END IF -310 CONTINUE - CALL DLASET('A', P, M, ZERO, ZERO, D, LDD) -C - ELSE IF (NR(2) .EQ. 2) THEN - NOTE = 'Hodel et al. 1996: heat flow in a thin rod' - IF (LSAME(DEF,'D')) IPAR(1) = 100 - IF (IPAR(1) .LT. 1) INFO = -4 - N = IPAR(1) - M = 1 - P = N - IF (LDE .LT. N) INFO = -10 - IF (LDA .LT. N) INFO = -12 - IF (LDB .LT. N) INFO = -14 - IF (LDC .LT. P) INFO = -16 - IF (LDD .LT. P) INFO = -18 - IF (INFO .NE. 0) RETURN -C - TEMP = DBLE(N + 1) - CALL DLASET('A', N, N, ZERO, ONE, E, LDE) - CALL DLASET('A', N, N, ZERO, -TWO * TEMP, A, LDA) - A(1,1) = -TEMP - DO 320 I = 1, N - 1 - A(I,I+1) = TEMP - A(I+1,I) = TEMP -320 CONTINUE - CALL DLASET('A', N, M, ZERO, ZERO, B, LDB) - B(N,1) = TEMP - CALL DLASET('A', P, N, ZERO, ONE, C, LDC) - CALL DLASET('A', P, M, ZERO, ZERO, D, LDD) -C - ELSE IF (NR(2) .EQ. 3) THEN - NOTE = 'Laub 1979, Ex.6' - IF (LSAME(DEF,'D')) IPAR(1) = 21 - IF (IPAR(1) .LT. 1) INFO = -4 - N = IPAR(1) - M = 1 - P = 1 - IF (LDE .LT. N) INFO = -10 - IF (LDA .LT. N) INFO = -12 - IF (LDB .LT. N) INFO = -14 - IF (LDC .LT. P) INFO = -16 - IF (LDD .LT. P) INFO = -18 - IF (INFO .NE. 0) RETURN -C - CALL DLASET('A', N, N, ZERO, ONE, E, LDE) - CALL DLASET('A', N, N, ZERO, ZERO, A, LDA) - CALL DLASET('A', N-1, N-1, ZERO, ONE, A(1,2), LDA) - CALL DLASET('A', N, M, ZERO, ZERO, B, LDB) - B(N,1) = ONE - CALL DLASET('A', P, N, ZERO, ZERO, C, LDC) - C(1,1) = ONE - CALL DLASET('A', P, M, ZERO, ZERO, D, LDD) -C - ELSE IF (NR(2) .EQ. 4) THEN - NOTE = 'Lang/Penzl 1994: rotating axle' - IF (LSAME(DEF,'D')) IPAR(1) = 211 - IF ((IPAR(1) .LT. 1) .OR. (IPAR(1) .GT. 211)) INFO = -4 - N = 2*IPAR(1) - 1 - M = IPAR(1) - P = IPAR(1) - IF (LDE .LT. N) INFO = -10 - IF (LDA .LT. N) INFO = -12 - IF (LDB .LT. N) INFO = -14 - IF (LDC .LT. P) INFO = -16 - IF (LDD .LT. P) INFO = -18 - IF (LDWORK .LT. M*4) INFO = -21 - IF (INFO .NE. 0) RETURN -C - OPEN(1, IOSTAT = STATUS, STATUS = 'OLD', FILE = 'BD01304.dat') - IF (STATUS .NE. 0) THEN - INFO = 1 - ELSE - DO 330 I = 1, M*4 - READ (1, FMT = *, IOSTAT = STATUS) DWORK(I) - IF (STATUS .NE. 0) INFO = 1 -330 CONTINUE - END IF - CLOSE(1) - IF (INFO .NE. 0) RETURN - CALL DLASET('A', N, N, ZERO, ONE, E, LDE) - E(1,1) = DWORK(1) - DO 340 I = 2, M - E(I,I-1) = DWORK((I-2) * 4 + 1) - E(I,I) = -DWORK((I-1) * 4 + 1) -340 CONTINUE - E(M,M) = -E(M,M) - DO 350 I = M-1, 1, -1 - DO 345 J = I, M - IF (I .EQ. 1) THEN - E(J,I) = E(J,I) - E(J,I+1) - ELSE - E(J,I) = E(J,I+1) - E(J,I) - END IF -345 CONTINUE -350 CONTINUE - CALL DLASET('A', N, N, ZERO, ZERO, A, LDA) - DO 360 I = 2, M - A(I-1,I) = DWORK((I-2) * 4 + 3) - A(I,I) = -TWO * DWORK((I-2) * 4 + 3) - DWORK((I-1) * 4 + 2) - A(I,1) = DWORK((I-1) * 4 + 2) - DWORK((I-2) * 4 + 2) - A(I-1,M+I-1) = DWORK((I-1) * 4) - A(I,M+I-1) = -TWO * DWORK((I-1) * 4) - IF (I .LT. M) THEN - A(I+1,I) = DWORK((I-2) * 4 + 3) - DO 355 J = I+1, M - A(J,I) = A(J,I) + DWORK((J-2) * 4 + 2) - 1 - DWORK((J-1) * 4 + 2) -355 CONTINUE - A(I+1,M+I-1) = DWORK((I-1) * 4) - END IF -360 CONTINUE - A(1,1) = -DWORK(2) - A(1,2) = -DWORK(3) - A(1,M+1) = -A(1,M+1) - CALL DLASET('A', M-1, M-1, ZERO, ONE, A(M+1,2), LDA) - CALL DLASET('A', N, M, ZERO, ZERO, B, LDB) - CALL DLASET('A', P, N, ZERO, ZERO, C, LDC) - DO 370 I = 2, M - B(I,I) = -ONE - B(I,I-1) = ONE - C(I,I) = DWORK((I-2) * 4 + 3) - C(I,M+I-1) = DWORK((I-1) * 4) -370 CONTINUE - B(1,1) = ONE - C(1,1) = ONE - CALL DLASET('A', P, M, ZERO, ZERO, D, LDD) -C - ELSE - INFO = -2 - END IF -C - ELSE IF (NR(1) .EQ. 4) THEN - IF (.NOT. (LSAME(DEF,'D') .OR. LSAME(DEF,'N'))) THEN - INFO = -1 - RETURN - END IF -C - IF (NR(2) .EQ. 1) THEN - NOTE = 'Rosen/Wang 1995: control of 1-dim. heat flow' - IF (LSAME(DEF,'D')) THEN - IPAR(1) = 100 - DPAR(1) = .1D-1 - DPAR(2) = ONE - DPAR(3) = ONE - DPAR(4) = .2D0 - DPAR(5) = .3D0 - DPAR(6) = .2D0 - DPAR(7) = .3D0 - END IF - IF (IPAR(1) .LT. 2) INFO = -4 - N = IPAR(1) - M = 1 - P = 1 - IF (LDE .LT. N) INFO = -10 - IF (LDA .LT. N) INFO = -12 - IF (LDB .LT. N) INFO = -14 - IF (LDC .LT. P) INFO = -16 - IF (LDD .LT. P) INFO = -18 - IF (INFO .NE. 0) RETURN -C - VEC(4) = .TRUE. - APPIND = DBLE(N + 1) - TTEMP = -DPAR(1) * APPIND - TEMP = 1 / (.6D1 * APPIND) - CALL DLASET('A', N, N, ZERO, FOUR*TEMP, E, LDE) - CALL DLASET('A', N, N, ZERO, TWO*TTEMP, A, LDA) - DO 410 I = 1, N - 1 - A(I+1,I) = -TTEMP - A(I,I+1) = -TTEMP - E(I+1,I) = TEMP - E(I,I+1) = TEMP -410 CONTINUE - DO 420 I = 1, N - B1 = MAX(DBLE(I-1)/APPIND, DPAR(4)) - B2 = MIN(DBLE(I+1)/APPIND, DPAR(5)) - C1 = MAX(DBLE(I-1)/APPIND, DPAR(6)) - C2 = MIN(DBLE(I+1)/APPIND, DPAR(7)) - IF (B1 .GE. B2) THEN - B(I,1) = ZERO - ELSE - B(I,1) = B2 - B1 - TEMP = MIN(B2, DBLE(I)/APPIND) - IF (B1 .LT. TEMP) THEN - B(I,1) = B(I,1) + APPIND*(TEMP**2 - B1**2)/TWO - B(I,1) = B(I,1) + DBLE(I)*(B1 - TEMP) - END IF - TEMP = MAX(B1, DBLE(I)/APPIND) - IF (TEMP .LT. B2) THEN - B(I,1) = B(I,1) - APPIND*(B2**2 - TEMP**2)/TWO - B(I,1) = B(I,1) - DBLE(I)*(TEMP - B2) - END IF - END IF - IF (C1 .GE. C2) THEN - C(1,I) = ZERO - ELSE - C(1,I) = C2 - C1 - TEMP = MIN(C2, DBLE(I)/APPIND) - IF (C1 .LT. TEMP) THEN - C(1,I) = C(1,I) + APPIND*(TEMP**2 - C1**2)/TWO - C(1,I) = C(1,I) + DBLE(I)*(C1 - TEMP) - END IF - TEMP = MAX(C1, DBLE(I)/APPIND) - IF (TEMP .LT. C2) THEN - C(1,I) = C(1,I) - APPIND*(C2**2 - TEMP**2)/TWO - C(1,I) = C(1,I) - DBLE(I)*(TEMP - C2) - END IF - END IF -420 CONTINUE - CALL DSCAL(N, DPAR(2), B(1,1), 1) - CALL DSCAL(N, DPAR(3), C(1,1), LDC) - CALL DLASET('A', P, M, ZERO, ZERO, D, LDD) -C - ELSE IF (NR(2) .EQ. 2) THEN - NOTE = 'Hench et al. 1995: coupled springs, dashpots, masses' - IF (LSAME(DEF,'D')) THEN - IPAR(1) = 30 - DPAR(1) = FOUR - DPAR(2) = FOUR - DPAR(3) = ONE - END IF - IF (IPAR(1) .LT. 2) INFO = -4 - L = IPAR(1) - N = 2*L - M = 2 - P = 2*L - IF (LDE .LT. N) INFO = -10 - IF (LDA .LT. N) INFO = -12 - IF (LDB .LT. N) INFO = -14 - IF (LDC .LT. P) INFO = -16 - IF (LDD .LT. P) INFO = -18 - IF (INFO .NE. 0) RETURN -C - VEC(4) = .TRUE. - CALL DLASET('A', N, N, ZERO, DPAR(1), E, LDE) - CALL DLASET('A', N, N, ZERO, ZERO, A, LDA) - TEMP = -TWO * DPAR(3) - DO 430 I = 1, L - E(I,I) = ONE - A(I,I+L) = ONE - A(I+L,I+L) = -DPAR(2) - IF (I .LT. L) THEN - A(I+L,I+1) = DPAR(3) - A(I+L+1,I) = DPAR(3) - IF (I .GT. 1) THEN - A(I+L,I) = TEMP - END IF - END IF - 430 CONTINUE - A(L+1,1) = -DPAR(3) - A(N,L) = -DPAR(3) - CALL DLASET('A', N, M, ZERO, ZERO, B, LDB) - B(L+1,1) = ONE - B(N,2) = -ONE - CALL DLASET('A', P, N, ZERO, ONE, C, LDC) - CALL DLASET('A', P, M, ZERO, ZERO, D, LDD) -C - ELSE - INFO = -2 - END IF - ELSE - INFO = -2 - END IF -C - RETURN -C *** Last Line of BD01AD *** - END diff --git a/mex/sources/libslicot/BD02AD.f b/mex/sources/libslicot/BD02AD.f deleted file mode 100644 index ebe6f4a70..000000000 --- a/mex/sources/libslicot/BD02AD.f +++ /dev/null @@ -1,601 +0,0 @@ - SUBROUTINE BD02AD( DEF, NR, DPAR, IPAR, VEC, N, M, P, E, LDE, A, - 1 LDA, B, LDB, C, LDC, D, LDD, NOTE, DWORK, - 2 LDWORK, INFO ) -C -C SLICOT RELEASE 5.0. -C -C Copyright (c) 2002-2009 NICONET e.V. -C -C This program is free software: you can redistribute it and/or -C modify it under the terms of the GNU General Public License as -C published by the Free Software Foundation, either version 2 of -C the License, or (at your option) any later version. -C -C This program is distributed in the hope that it will be useful, -C but WITHOUT ANY WARRANTY; without even the implied warranty of -C MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the -C GNU General Public License for more details. -C -C You should have received a copy of the GNU General Public License -C along with this program. If not, see -C . -C -C PURPOSE -C -C To generate benchmark examples for time-invariant, -C discrete-time dynamical systems -C -C E x_k+1 = A x_k + B u_k -C -C y_k = C x_k + D u_k -C -C E, A are real N-by-N matrices, B is N-by-M, C is P-by-N, and -C D is P-by-M. In many examples, E is the identity matrix and D is -C the zero matrix. -C -C This routine is an implementation of the benchmark library -C DTDSX (Version 1.0) described in [1]. -C -C ARGUMENTS -C -C Mode Parameters -C -C DEF CHARACTER*1 -C Specifies the kind of values used as parameters when -C generating parameter-dependent and scalable examples -C (i.e., examples with NR(1) = 2, 3, or 4): -C = 'D': Default values defined in [1] are used; -C = 'N': Values set in DPAR and IPAR are used. -C This parameter is not referenced if NR(1) = 1. -C Note that the scaling parameter of examples with -C NR(1) = 3 or 4 is considered as a regular parameter in -C this context. -C -C Input/Output Parameters -C -C NR (input) INTEGER array, dimension (2) -C Specifies the index of the desired example according -C to [1]. -C NR(1) defines the group: -C 1 : parameter-free problems of fixed size -C 2 : parameter-dependent problems of fixed size -C 3 : parameter-free problems of scalable size -C 4 : parameter-dependent problems of scalable size -C NR(2) defines the number of the benchmark example -C within a certain group according to [1]. -C -C DPAR (input/output) DOUBLE PRECISION array, dimension (7) -C On entry, if DEF = 'N' and the desired example depends on -C real parameters, then the array DPAR must contain the -C values for these parameters. -C For an explanation of the parameters see [1]. -C For Example 2.1, DPAR(1), ..., DPAR(3) define the -C parameters 'tau', 'delta', 'K', respectively. -C On exit, if DEF = 'D' and the desired example depends on -C real parameters, then the array DPAR is overwritten by the -C default values given in [1]. -C -C IPAR (input/output) INTEGER array, dimension (1) -C On entry, if DEF = 'N' and the desired example depends on -C integer parameters, then the array IPAR must contain the -C values for these parameters. -C For an explanation of the parameters see [1]. -C For Example 3.1, IPAR(1) defines the parameter 'n'. -C On exit, if DEF = 'D' and the desired example depends on -C integer parameters, then the array IPAR is overwritten by -C the default values given in [1]. -C -C VEC (output) LOGICAL array, dimension (8) -C Flag vector which displays the availabilty of the output -C data: -C VEC(1), ..., VEC(3) refer to N, M, and P, respectively, -C and are always .TRUE.. -C VEC(4) is .TRUE. iff E is NOT the identity matrix. -C VEC(5), ..., VEC(7) refer to A, B, and C, respectively, -C and are always .TRUE.. -C VEC(8) is .TRUE. iff D is NOT the zero matrix. -C -C N (output) INTEGER -C The actual state dimension, i.e., the order of the -C matrices E and A. -C -C M (output) INTEGER -C The number of columns in the matrices B and D. -C -C P (output) INTEGER -C The number of rows in the matrices C and D. -C -C E (output) DOUBLE PRECISION array, dimension (LDE,N) -C The leading N-by-N part of this array contains the -C matrix E. -C NOTE that this array is overwritten (by the identity -C matrix), if VEC(4) = .FALSE.. -C -C LDE INTEGER -C The leading dimension of array E. LDE >= N. -C -C A (output) DOUBLE PRECISION array, dimension (LDA,N) -C The leading N-by-N part of this array contains the -C matrix A. -C -C LDA INTEGER -C The leading dimension of array A. LDA >= N. -C -C B (output) DOUBLE PRECISION array, dimension (LDB,M) -C The leading N-by-M part of this array contains the -C matrix B. -C -C LDB INTEGER -C The leading dimension of array B. LDB >= N. -C -C C (output) DOUBLE PRECISION array, dimension (LDC,N) -C The leading P-by-N part of this array contains the -C matrix C. -C -C LDC INTEGER -C The leading dimension of array C. LDC >= P. -C -C D (output) DOUBLE PRECISION array, dimension (LDD,M) -C The leading P-by-M part of this array contains the -C matrix D. -C NOTE that this array is overwritten (by the zero -C matrix), if VEC(8) = .FALSE.. -C -C LDD INTEGER -C The leading dimension of array D. LDD >= P. -C -C NOTE (output) CHARACTER*70 -C String containing short information about the chosen -C example. -C -C Workspace -C -C DWORK DOUBLE PRECISION array, dimension (LDWORK) -C NOTE that DWORK is not used in the current version -C of BD02AD. -C -C LDWORK INTEGER -C LDWORK >= 1. -C -C Error Indicator -C -C INFO INTEGER -C = 0: successful exit; -C < 0: if INFO = -i, the i-th argument had an illegal -C value; in particular, INFO = -3 or -4 indicates -C that at least one of the parameters in DPAR or -C IPAR, respectively, has an illegal value; -C = 1: data file can not be opened or has wrong format. -C -C REFERENCES -C -C [1] Kressner, D., Mehrmann, V. and Penzl, T. -C DTDSX - a Collection of Benchmark Examples for State-Space -C Realizations of Discrete-Time Dynamical Systems. -C SLICOT Working Note 1998-10. 1998. -C -C NUMERICAL ASPECTS -C -C None -C -C CONTRIBUTOR -C -C D. Kressner, V. Mehrmann, and T. Penzl (TU Chemnitz) -C -C For questions concerning the collection or for the submission of -C test examples, please contact Volker Mehrmann -C (Email: volker.mehrmann@mathematik.tu-chemnitz.de). -C -C REVISIONS -C -C June 1999, V. Sima. -C -C KEYWORDS -C -C discrete-time dynamical systems -C -C ****************************************************************** -C -C .. Parameters .. - DOUBLE PRECISION ZERO, ONE, TWO, THREE, FOUR, PI - PARAMETER ( ZERO = 0.0D0, ONE = 1.0D0, TWO = 2.0D0, - 1 THREE = 3.0D0, FOUR = 4.0D0, - 2 PI = .3141592653589793D1 ) -C .. Scalar Arguments .. - CHARACTER DEF - CHARACTER*70 NOTE - INTEGER INFO, LDA, LDB, LDC, LDD, LDE, LDWORK, M, N, P -C .. Array Arguments .. - LOGICAL VEC(8) - INTEGER IPAR(*), NR(*) - DOUBLE PRECISION A(LDA,*), B(LDB,*), C(LDC,*), D(LDD,*), DPAR(*), - 1 DWORK(*), E(LDE,*) -C .. Local Scalars .. - CHARACTER*12 DATAF - INTEGER I, J, STATUS - DOUBLE PRECISION TEMP -C .. Local Arrays .. - LOGICAL VECDEF(8) -C .. External Functions .. -C . LAPACK . - LOGICAL LSAME - EXTERNAL LSAME -C .. External Subroutines .. -C . LAPACK . - EXTERNAL DLASET -C .. Data Statements .. -C . default values for availabities . - DATA VECDEF /.TRUE., .TRUE., .TRUE., .FALSE., - 1 .TRUE., .TRUE., .TRUE., .FALSE./ -C -C .. Executable Statements .. -C - INFO = 0 - DO 10 I = 1, 8 - VEC(I) = VECDEF(I) -10 CONTINUE -C - IF (NR(1) .EQ. 1) THEN -C - IF (NR(2) .EQ. 1) THEN - NOTE = 'Laub 1979, Ex. 2: uncontrollable-unobservable data' - N = 2 - M = 1 - P = 1 - IF (LDE .LT. N) INFO = -10 - IF (LDA .LT. N) INFO = -12 - IF (LDB .LT. N) INFO = -14 - IF (LDC .LT. P) INFO = -16 - IF (LDD .LT. P) INFO = -18 - IF (INFO .NE. 0) RETURN -C - CALL DLASET('A', N, N, ZERO, ONE, E, LDE) - A(1,1) = FOUR - A(2,1) = -.45D1 - A(1,2) = THREE - A(2,2) = -.35D1 - CALL DLASET('A', N, M, -ONE, ONE, B, LDB) - C(1,1) = 3.0D0 - C(1,2) = 2.0D0 - CALL DLASET('A', P, M, ZERO, ZERO, D, LDD) -C - ELSE IF (NR(2) .EQ. 2) THEN - NOTE = 'Laub 1979, Ex. 3' - N = 2 - M = 2 - P = 2 - IF (LDE .LT. N) INFO = -10 - IF (LDA .LT. N) INFO = -12 - IF (LDB .LT. N) INFO = -14 - IF (LDC .LT. P) INFO = -16 - IF (LDD .LT. P) INFO = -18 - IF (INFO .NE. 0) RETURN -C - CALL DLASET('A', N, N, ZERO, ONE, E, LDE) - CALL DLASET('A', N, N, ZERO, ZERO, A, LDA) - A(1,1) = .9512D0 - A(2,2) = .9048D0 - B(1,1) = .4877D1 - B(1,2) = .4877D1 - B(2,1) = -.11895D1 - B(2,2) = .3569D1 - CALL DLASET('A', P, N, ZERO, ONE, C, LDC) - CALL DLASET('A', P, M, ZERO, ZERO, D, LDD) -C - ELSE IF (NR(2) .EQ. 3) THEN - NOTE = 'Van Dooren 1981, Ex. II' - N = 2 - M = 1 - P = 1 - IF (LDE .LT. N) INFO = -10 - IF (LDA .LT. N) INFO = -12 - IF (LDB .LT. N) INFO = -14 - IF (LDC .LT. P) INFO = -16 - IF (LDD .LT. P) INFO = -18 - IF (INFO .NE. 0) RETURN -C - CALL DLASET('A', N, N, ZERO, ONE, E, LDE) - A(1,1) = TWO - A(2,1) = ONE - A(1,2) = -ONE - A(2,2) = ZERO - CALL DLASET('A', N, M, ZERO, ONE, B, LDB) - CALL DLASET('A', P, N, ONE, ZERO, C, LDC) - D(1,1) = ZERO -C - ELSE IF (NR(2) .EQ. 4) THEN - NOTE = 'Ionescu/Weiss 1992' - N = 2 - M = 2 - P = 2 - IF (LDE .LT. N) INFO = -10 - IF (LDA .LT. N) INFO = -12 - IF (LDB .LT. N) INFO = -14 - IF (LDC .LT. P) INFO = -16 - IF (LDD .LT. P) INFO = -18 - IF (INFO .NE. 0) RETURN -C - CALL DLASET('A', N, N, ZERO, ONE, E, LDE) - CALL DLASET('A', N, N, ZERO, ZERO, A, LDA) - A(1,2) = ONE - A(2,2) = -ONE - CALL DLASET('A', N, M, ZERO, ONE, B, LDB) - B(2,1) = TWO - CALL DLASET('A', P, N, ZERO, ONE, C, LDC) - CALL DLASET('A', P, M, ZERO, ZERO, D, LDD) -C - ELSE IF (NR(2) .EQ. 5) THEN - NOTE = 'Jonckheere 1981' - N = 2 - M = 1 - P = 2 - IF (LDE .LT. N) INFO = -10 - IF (LDA .LT. N) INFO = -12 - IF (LDB .LT. N) INFO = -14 - IF (LDC .LT. P) INFO = -16 - IF (LDD .LT. P) INFO = -18 - IF (INFO .NE. 0) RETURN -C - CALL DLASET('A', N, N, ZERO, ONE, E, LDE) - CALL DLASET('A', N, N, ZERO, ZERO, A, LDA) - A(1,2) = ONE - CALL DLASET('A', N, M, ONE, ZERO, B, LDB) - CALL DLASET('A', P, N, ZERO, ONE, C, LDC) - CALL DLASET('A', P, M, ZERO, ZERO, D, LDD) -C - ELSE IF (NR(2) .EQ. 6) THEN - NOTE = 'Ackerson/Fu 1970: satellite control problem' - N = 4 - M = 2 - P = 4 - IF (LDE .LT. N) INFO = -10 - IF (LDA .LT. N) INFO = -12 - IF (LDB .LT. N) INFO = -14 - IF (LDC .LT. P) INFO = -16 - IF (LDD .LT. P) INFO = -18 - IF (INFO .NE. 0) RETURN -C - CALL DLASET('A', N, N, ZERO, ONE, E, LDE) - CALL DLASET('A', P, N, ZERO, ONE, C, LDC) - CALL DLASET('A', P, M, ZERO, ZERO, D, LDD) -C - ELSE IF (NR(2) .EQ. 7) THEN - NOTE = 'Litkouhi 1983: system with slow and fast modes' - N = 4 - M = 2 - P = 4 - IF (LDE .LT. N) INFO = -10 - IF (LDA .LT. N) INFO = -12 - IF (LDB .LT. N) INFO = -14 - IF (LDC .LT. P) INFO = -16 - IF (LDD .LT. P) INFO = -18 - IF (INFO .NE. 0) RETURN -C - CALL DLASET('A', N, N, ZERO, ONE, E, LDE) - CALL DLASET('A', P, N, ZERO, ONE, C, LDC) - CALL DLASET('A', P, M, ZERO, ZERO, D, LDD) -C - ELSE IF (NR(2) .EQ. 8) THEN - NOTE = 'Lu/Lin 1993, Ex. 4.3' - N = 4 - M = 4 - P = 4 - IF (LDE .LT. N) INFO = -10 - IF (LDA .LT. N) INFO = -12 - IF (LDB .LT. N) INFO = -14 - IF (LDC .LT. P) INFO = -16 - IF (LDD .LT. P) INFO = -18 - IF (INFO .NE. 0) RETURN -C - CALL DLASET('A', N, N, ZERO, ONE, E, LDE) - CALL DLASET('U', P, N, ONE, ONE, C, LDC) - C(1,3) = TWO - C(1,4) = FOUR - C(2,4) = TWO - CALL DLASET('A', P, M, ZERO, ZERO, D, LDD) -C - ELSE IF (NR(2) .EQ. 9) THEN - NOTE = 'Gajic/Shen 1993, Section 2.7.4: chemical plant' - N = 5 - M = 2 - P = 5 - IF (LDE .LT. N) INFO = -10 - IF (LDA .LT. N) INFO = -12 - IF (LDB .LT. N) INFO = -14 - IF (LDC .LT. P) INFO = -16 - IF (LDD .LT. P) INFO = -18 - IF (INFO .NE. 0) RETURN -C - CALL DLASET('A', N, N, ZERO, ONE, E, LDE) - CALL DLASET('A', P, N, ZERO, ONE, C, LDC) - CALL DLASET('A', P, M, ZERO, ZERO, D, LDD) -C - ELSE IF (NR(2) .EQ. 10) THEN - NOTE = 'Davison/Wang 1974' - N = 6 - M = 2 - P = 2 - IF (LDE .LT. N) INFO = -10 - IF (LDA .LT. N) INFO = -12 - IF (LDB .LT. N) INFO = -14 - IF (LDC .LT. P) INFO = -16 - IF (LDD .LT. P) INFO = -18 - IF (INFO .NE. 0) RETURN - VEC(8) = .TRUE. -C - CALL DLASET('A', N, N, ZERO, ONE, E, LDE) - CALL DLASET('A', N, N, ZERO, ZERO, A, LDA) - A(1,2) = ONE - A(2,3) = ONE - A(4,5) = ONE - A(5,6) = ONE - CALL DLASET('A', N, M, ZERO, ZERO, B, LDB) - B(3,1) = ONE - B(6,2) = ONE - CALL DLASET('A', P, N, ZERO, ZERO, C, LDC) - C(1,1) = ONE - C(1,2) = ONE - C(2,4) = ONE - C(2,5) = -ONE - CALL DLASET('A', P, M, ZERO, ZERO, D, LDD) - D(1,1) = ONE - D(2,1) = ONE -C - ELSE IF (NR(2) .EQ. 11) THEN - NOTE = 'Patnaik et al. 1980: tubular ammonia reactor' - N = 9 - M = 3 - P = 2 - IF (LDE .LT. N) INFO = -10 - IF (LDA .LT. N) INFO = -12 - IF (LDB .LT. N) INFO = -14 - IF (LDC .LT. P) INFO = -16 - IF (LDD .LT. P) INFO = -18 - IF (INFO .NE. 0) RETURN -C - CALL DLASET('A', N, N, ZERO, ONE, E, LDE) - CALL DLASET('A', P, N, ZERO, ZERO, C, LDC) - C(1,1) = ONE - C(2,5) = ONE - CALL DLASET('A', P, M, ZERO, ZERO, D, LDD) -C - ELSE IF (NR(2) .EQ. 12) THEN - NOTE = 'Smith 1969: two-stand cold rolling mill' - N = 10 - M = 3 - P = 5 - IF (LDE .LT. N) INFO = -10 - IF (LDA .LT. N) INFO = -12 - IF (LDB .LT. N) INFO = -14 - IF (LDC .LT. P) INFO = -16 - IF (LDD .LT. P) INFO = -18 - IF (INFO .NE. 0) RETURN - VEC(8) = .TRUE. -C - CALL DLASET('A', N, N, ZERO, ONE, E, LDE) - CALL DLASET('A', N, N, ZERO, ZERO, A, LDA) - CALL DLASET('A', N, N, ZERO, ONE, A(2,1), LDA) - A(1,10) = .112D0 - CALL DLASET('A', N, M, ZERO, ZERO, B, LDB) - B(1,1) = .276D1 - B(1,2) = -.135D1 - B(1,3) = -.46D0 - CALL DLASET('A', P, N, ZERO, ZERO, C, LDC) - C(1,1) = ONE - C(2,10) = .894D0 - C(3,10) = -.1693D2 - C(4,10) = .7D-1 - C(5,10) = .398D0 - OPEN(1, IOSTAT = STATUS, STATUS = 'OLD', FILE = 'BD02112.dat') - IF (STATUS .NE. 0) THEN - INFO = 1 - ELSE - DO 110 I = 1, P - READ (1, FMT = *, IOSTAT = STATUS) (D(I,J), J = 1, M) - IF (STATUS .NE. 0) INFO = 1 -110 CONTINUE - END IF - CLOSE(1) -C - ELSE - INFO = -2 - END IF -C - IF (((NR(2) .GE. 6) .AND. (NR(2) .LE. 9)) .OR. - 1 (NR(2) .EQ. 11)) THEN -C .. loading data files - WRITE (DATAF(1:11), '(A,I2.2,A)') 'BD021', NR(2), '.dat' - OPEN(1, IOSTAT = STATUS, STATUS = 'OLD', FILE = DATAF(1:11)) - IF (STATUS .NE. 0) THEN - INFO = 1 - ELSE - DO 120 I = 1, N - READ (1, FMT = *, IOSTAT = STATUS) (A(I,J), J = 1, N) - IF (STATUS .NE. 0) INFO = 1 -120 CONTINUE - DO 130 I = 1, N - READ (1, FMT = *, IOSTAT = STATUS) (B(I,J), J = 1, M) - IF (STATUS .NE. 0) INFO = 1 -130 CONTINUE - END IF - CLOSE(1) - END IF -C - ELSE IF (NR(1) .EQ. 2) THEN - IF (.NOT. (LSAME(DEF,'D') .OR. LSAME(DEF,'N'))) THEN - INFO = -1 - RETURN - END IF -C - IF (NR(2) .EQ. 1) THEN - NOTE = 'Pappas et al. 1980: process control of paper machine' - IF (LSAME(DEF,'D')) THEN - DPAR(1) = .1D9 - DPAR(2) = ONE - DPAR(3) = ONE - END IF - IF (DPAR(1) .EQ. ZERO) INFO = -3 - N = 4 - M = 1 - P = 1 - IF (LDE .LT. N) INFO = -10 - IF (LDA .LT. N) INFO = -12 - IF (LDB .LT. N) INFO = -14 - IF (LDC .LT. P) INFO = -16 - IF (LDD .LT. P) INFO = -18 - IF (INFO .NE. 0) RETURN -C - TEMP = DPAR(2) / DPAR(1) - CALL DLASET('A', N, N, ZERO, ONE, E, LDE) - CALL DLASET('A', N, N, ZERO, ZERO, A, LDA) - CALL DLASET('A', N-1, N-1, ZERO, ONE, A(2,1), LDA) - A(1,1) = ONE - TEMP - CALL DLASET('A', N, M, ZERO, ZERO, B, LDB) - B(1,1) = DPAR(3) * TEMP - CALL DLASET('A', P, N, ZERO, ZERO, C, LDC) - C(1,4) = ONE - CALL DLASET('A', P, M, ZERO, ZERO, D, LDD) -C - ELSE - INFO = -2 - END IF -C - ELSE IF (NR(1) .EQ. 3) THEN - IF (.NOT. (LSAME(DEF,'D') .OR. LSAME(DEF,'N'))) THEN - INFO = -1 - RETURN - END IF -C - IF (NR(2) .EQ. 1) THEN - NOTE = 'Pappas et al. 1980, Ex. 3' - IF (LSAME(DEF,'D')) IPAR(1) = 100 - IF (IPAR(1) .LT. 2) INFO = -4 - N = IPAR(1) - M = 1 - P = N - IF (LDE .LT. N) INFO = -10 - IF (LDA .LT. N) INFO = -12 - IF (LDB .LT. N) INFO = -14 - IF (LDC .LT. P) INFO = -16 - IF (LDD .LT. P) INFO = -18 - IF (INFO .NE. 0) RETURN -C - CALL DLASET('A', N, N, ZERO, ONE, E, LDE) - CALL DLASET('A', N, N, ZERO, ZERO, A, LDA) - CALL DLASET('A', N-1, N-1, ZERO, ONE, A(1,2), LDA) - CALL DLASET('A', N, M, ZERO, ZERO, B, LDB) - B(N,1) = ONE - CALL DLASET('A', P, N, ZERO, ONE, C, LDC) - CALL DLASET('A', P, M, ZERO, ZERO, D, LDD) -C - ELSE - INFO = -2 - END IF -C - ELSE - INFO = -2 - END IF -C - RETURN -C *** Last Line of BD02AD *** - END diff --git a/mex/sources/libslicot/DE01OD.f b/mex/sources/libslicot/DE01OD.f deleted file mode 100644 index b2b0a608a..000000000 --- a/mex/sources/libslicot/DE01OD.f +++ /dev/null @@ -1,203 +0,0 @@ - SUBROUTINE DE01OD( CONV, N, A, B, INFO ) -C -C SLICOT RELEASE 5.0. -C -C Copyright (c) 2002-2009 NICONET e.V. -C -C This program is free software: you can redistribute it and/or -C modify it under the terms of the GNU General Public License as -C published by the Free Software Foundation, either version 2 of -C the License, or (at your option) any later version. -C -C This program is distributed in the hope that it will be useful, -C but WITHOUT ANY WARRANTY; without even the implied warranty of -C MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the -C GNU General Public License for more details. -C -C You should have received a copy of the GNU General Public License -C along with this program. If not, see -C . -C -C PURPOSE -C -C To compute the convolution or deconvolution of two real signals -C A and B. -C -C ARGUMENTS -C -C Mode Parameters -C -C CONV CHARACTER*1 -C Indicates whether convolution or deconvolution is to be -C performed as follows: -C = 'C': Convolution; -C = 'D': Deconvolution. -C -C Input/Output Parameters -C -C N (input) INTEGER -C The number of samples. N must be a power of 2. N >= 2. -C -C A (input/output) DOUBLE PRECISION array, dimension (N) -C On entry, this array must contain the first signal. -C On exit, this array contains the convolution (if -C CONV = 'C') or deconvolution (if CONV = 'D') of the two -C signals. -C -C B (input) DOUBLE PRECISION array, dimension (N) -C On entry, this array must contain the second signal. -C NOTE that this array is overwritten. -C -C Error Indicator -C -C INFO INTEGER -C = 0: successful exit; -C < 0: if INFO = -i, the i-th argument had an illegal -C value. -C -C METHOD -C -C This routine computes the convolution or deconvolution of two real -C signals A and B using an FFT algorithm (SLICOT Library routine -C DG01MD). -C -C REFERENCES -C -C [1] Rabiner, L.R. and Rader, C.M. -C Digital Signal Processing. -C IEEE Press, 1972. -C -C NUMERICAL ASPECTS -C -C The algorithm requires 0( N*log(N) ) operations. -C -C CONTRIBUTOR -C -C Release 3.0: V. Sima, Katholieke Univ. Leuven, Belgium, Feb. 1997. -C Supersedes Release 2.0 routine DE01CD by R. Dekeyser, State -C University of Gent, Belgium. -C -C REVISIONS -C -C - -C -C KEYWORDS -C -C Convolution, deconvolution, digital signal processing, fast -C Fourier transform, real signals. -C -C ****************************************************************** -C -C .. Parameters .. - DOUBLE PRECISION ZERO, HALF, ONE - PARAMETER ( ZERO = 0.0D0, HALF=0.5D0, ONE = 1.0D0 ) -C .. Scalar Arguments .. - CHARACTER CONV - INTEGER INFO, N -C .. Array Arguments .. - DOUBLE PRECISION A(*), B(*) -C .. Local Scalars .. - LOGICAL LCONV - INTEGER J, KJ, ND2P1 - DOUBLE PRECISION AC, AS, AST, BC, BS, CI, CR -C .. External Functions .. - LOGICAL LSAME - EXTERNAL LSAME -C .. External Subroutines .. - EXTERNAL DG01MD, DLADIV, DSCAL, XERBLA -C .. Intrinsic Functions .. - INTRINSIC ABS, DBLE, MAX, MOD -C .. Executable Statements .. -C - INFO = 0 - LCONV = LSAME( CONV, 'C' ) -C -C Test the input scalar arguments. -C - IF( .NOT.LCONV .AND. .NOT.LSAME( CONV, 'D' ) ) THEN - INFO = -1 - ELSE - J = 0 - IF( N.GE.2 ) THEN - J = N -C WHILE ( MOD( J, 2 ).EQ.0 ) DO - 10 CONTINUE - IF ( MOD( J, 2 ).EQ.0 ) THEN - J = J/2 - GO TO 10 - END IF -C END WHILE 10 - END IF - IF ( J.NE.1 ) INFO = -2 - END IF -C - IF ( INFO.NE.0 ) THEN -C -C Error return. -C - CALL XERBLA( 'DE01OD', -INFO ) - RETURN - END IF -C -C Fourier transform. -C - CALL DG01MD( 'Direct', N, A, B, INFO ) -C - IF ( LCONV ) THEN - AST = A(1)*B(1) - ELSE - IF ( B(1).EQ.ZERO ) THEN - AST = ZERO - ELSE - AST = A(1)/B(1) - END IF - END IF -C - ND2P1 = N/2 + 1 - J = ND2P1 -C - DO 20 KJ = ND2P1, N -C -C Components of the transform of function A. -C - AC = HALF*( A(J) + A(KJ) ) - AS = HALF*( B(J) - B(KJ) ) -C -C Components of the transform of function B. -C - BC = HALF*( B(KJ) + B(J) ) - BS = HALF*( A(KJ) - A(J) ) -C -C Deconvolution by complex division if CONV = 'D'; -C Convolution by complex multiplication if CONV = 'C'. -C - IF ( LCONV ) THEN - CR = AC*BC - AS*BS - CI = AS*BC + AC*BS - ELSE - IF ( MAX( ABS( BC ), ABS( BS ) ).EQ.ZERO ) THEN - CR = ZERO - CI = ZERO - ELSE - CALL DLADIV( AC, AS, BC, BS, CR, CI ) - END IF - END IF -C - A(J) = CR - B(J) = CI - A(KJ) = CR - B(KJ) = -CI - J = J - 1 - 20 CONTINUE - A(1) = AST - B(1) = ZERO -C -C Inverse Fourier transform. -C - CALL DG01MD( 'Inverse', N, A, B, INFO ) -C - CALL DSCAL( N, ONE/DBLE( N ), A, 1 ) -C - RETURN -C *** Last line of DE01OD *** - END diff --git a/mex/sources/libslicot/DE01PD.f b/mex/sources/libslicot/DE01PD.f deleted file mode 100644 index 0358e8036..000000000 --- a/mex/sources/libslicot/DE01PD.f +++ /dev/null @@ -1,236 +0,0 @@ - SUBROUTINE DE01PD( CONV, WGHT, N, A, B, W, INFO ) -C -C SLICOT RELEASE 5.0. -C -C Copyright (c) 2002-2009 NICONET e.V. -C -C This program is free software: you can redistribute it and/or -C modify it under the terms of the GNU General Public License as -C published by the Free Software Foundation, either version 2 of -C the License, or (at your option) any later version. -C -C This program is distributed in the hope that it will be useful, -C but WITHOUT ANY WARRANTY; without even the implied warranty of -C MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the -C GNU General Public License for more details. -C -C You should have received a copy of the GNU General Public License -C along with this program. If not, see -C . -C -C PURPOSE -C -C To compute the convolution or deconvolution of two real signals -C A and B using the Hartley transform. -C -C ARGUMENTS -C -C Mode Parameters -C -C CONV CHARACTER*1 -C Indicates whether convolution or deconvolution is to be -C performed as follows: -C = 'C': Convolution; -C = 'D': Deconvolution. -C -C WGHT CHARACTER*1 -C Indicates whether the precomputed weights are available -C or not, as follows: -C = 'A': available; -C = 'N': not available. -C Note that if N > 1 and WGHT = 'N' on entry, then WGHT is -C set to 'A' on exit. -C -C Input/Output Parameters -C -C N (input) INTEGER -C The number of samples. N must be a power of 2. N >= 0. -C -C A (input/output) DOUBLE PRECISION array, dimension (N) -C On entry, this array must contain the first signal. -C On exit, this array contains the convolution (if -C CONV = 'C') or deconvolution (if CONV = 'D') of the two -C signals. -C -C B (input) DOUBLE PRECISION array, dimension (N) -C On entry, this array must contain the second signal. -C NOTE that this array is overwritten. -C -C W (input/output) DOUBLE PRECISION array, -C dimension (N - LOG2(N)) -C On entry with WGHT = 'A', this array must contain the long -C weight vector computed by a previous call of this routine -C or of the SLICOT Library routine DG01OD.f, with the same -C value of N. If WGHT = 'N', the contents of this array on -C entry is ignored. -C On exit, this array contains the long weight vector. -C -C Error Indicator -C -C INFO INTEGER -C = 0: successful exit; -C < 0: if INFO = -i, the i-th argument had an illegal -C value. -C -C METHOD -C -C This routine computes the convolution or deconvolution of two -C real signals A and B using three scrambled Hartley transforms -C (SLICOT Library routine DG01OD). -C -C REFERENCES -C -C [1] Van Loan, Charles. -C Computational frameworks for the fast Fourier transform. -C SIAM, 1992. -C -C NUMERICAL ASPECTS -C -C The algorithm requires O(N log(N)) floating point operations. -C -C CONTRIBUTOR -C -C D. Kressner, Technical Univ. Berlin, Germany, April 2001. -C -C REVISIONS -C -C V. Sima, Research Institute for Informatics, Bucharest, Apr. 2000. -C -C KEYWORDS -C -C Convolution, deconvolution, digital signal processing, -C fast Hartley transform, real signals. -C -C ****************************************************************** -C -C .. Parameters .. - DOUBLE PRECISION HALF, ONE, TWO - PARAMETER ( HALF = 0.5D0, ONE = 1.0D0, TWO = 2.0D0 ) -C .. Scalar Arguments .. - CHARACTER CONV, WGHT - INTEGER INFO, N -C .. Array Arguments .. - DOUBLE PRECISION A(*), B(*), W(*) -C .. Local Scalars .. - LOGICAL LCONV, LWGHT - INTEGER J, L, LEN, M, P1, R1 - DOUBLE PRECISION T1, T2, T3 -C .. External Functions .. - LOGICAL LSAME - EXTERNAL LSAME -C .. External Subroutines .. - EXTERNAL DG01OD, DLADIV, DSCAL, XERBLA -C .. Intrinsic Functions .. - INTRINSIC DBLE, MOD -C .. Executable Statements .. -C - INFO = 0 - LCONV = LSAME( CONV, 'C' ) - LWGHT = LSAME( WGHT, 'A' ) -C -C Test the input scalar arguments. -C - IF( .NOT.LCONV .AND. .NOT.LSAME( CONV, 'D' ) ) THEN - INFO = -1 - ELSE IF( .NOT.LWGHT .AND. .NOT.LSAME( WGHT, 'N' ) ) THEN - INFO = -2 - ELSE - M = 0 - J = 0 - IF( N.GE.1 ) THEN - J = N -C WHILE ( MOD( J, 2 ).EQ.0 ) DO - 10 CONTINUE - IF ( MOD( J, 2 ).EQ.0 ) THEN - J = J/2 - M = M + 1 - GO TO 10 - END IF -C END WHILE 10 - IF ( J.NE.1 ) INFO = -3 - ELSE IF ( N.LT.0 ) THEN - INFO = -3 - END IF - END IF -C - IF ( INFO.NE.0 ) THEN -C -C Error return. -C - CALL XERBLA( 'DE01PD', -INFO ) - RETURN - END IF -C -C Quick return if possible. -C - IF ( N.LE.0 ) THEN - RETURN - ELSE IF ( N.EQ.1 ) THEN - IF ( LCONV ) THEN - A(1) = A(1)*B(1) - ELSE - A(1) = A(1)/B(1) - END IF - RETURN - END IF -C -C Scrambled Hartley transforms of A and B. -C - CALL DG01OD( 'OutputScrambled', WGHT, N, A, W, INFO ) - CALL DG01OD( 'OutputScrambled', WGHT, N, B, W, INFO ) -C -C Something similar to a Hadamard product/quotient. -C - LEN = 1 - IF( LCONV ) THEN - A(1) = TWO*A(1)*B(1) - A(2) = TWO*A(2)*B(2) -C - DO 30 L = 1, M - 1 - LEN = 2*LEN - R1 = 2*LEN -C - DO 20 P1 = LEN + 1, LEN + LEN/2 - T1 = B(P1) + B(R1) - T2 = B(P1) - B(R1) - T3 = T2*A(P1) - A(P1) = T1*A(P1) + T2*A(R1) - A(R1) = T1*A(R1) - T3 - R1 = R1 - 1 - 20 CONTINUE -C - 30 CONTINUE -C - ELSE -C - A(1) = HALF*A(1)/B(1) - A(2) = HALF*A(2)/B(2) -C - DO 50 L = 1, M - 1 - LEN = 2*LEN - R1 = 2*LEN -C - DO 40 P1 = LEN + 1, LEN + LEN/2 - CALL DLADIV( A(P1), A(R1), B(P1)+B(R1), B(R1)-B(P1), T1, - $ T2 ) - A(P1) = T1 - A(R1) = T2 - R1 = R1 - 1 - 40 CONTINUE -C - 50 CONTINUE -C - END IF -C -C Transposed Hartley transform of A. -C - CALL DG01OD( 'InputScrambled', WGHT, N, A, W, INFO ) - IF ( LCONV ) THEN - CALL DSCAL( N, HALF/DBLE( N ), A, 1 ) - ELSE - CALL DSCAL( N, TWO/DBLE( N ), A, 1 ) - END IF -C - RETURN -C *** Last line of DE01PD *** - END diff --git a/mex/sources/libslicot/DF01MD.f b/mex/sources/libslicot/DF01MD.f deleted file mode 100644 index 1dafa4b97..000000000 --- a/mex/sources/libslicot/DF01MD.f +++ /dev/null @@ -1,299 +0,0 @@ - SUBROUTINE DF01MD( SICO, N, DT, A, DWORK, INFO ) -C -C SLICOT RELEASE 5.0. -C -C Copyright (c) 2002-2009 NICONET e.V. -C -C This program is free software: you can redistribute it and/or -C modify it under the terms of the GNU General Public License as -C published by the Free Software Foundation, either version 2 of -C the License, or (at your option) any later version. -C -C This program is distributed in the hope that it will be useful, -C but WITHOUT ANY WARRANTY; without even the implied warranty of -C MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the -C GNU General Public License for more details. -C -C You should have received a copy of the GNU General Public License -C along with this program. If not, see -C . -C -C PURPOSE -C -C To compute the sine transform or cosine transform of a real -C signal. -C -C ARGUMENTS -C -C Mode Parameters -C -C SICO CHARACTER*1 -C Indicates whether the sine transform or cosine transform -C is to be computed as follows: -C = 'S': The sine transform is computed; -C = 'C': The cosine transform is computed. -C -C Input/Output Parameters -C -C N (input) INTEGER -C The number of samples. N must be a power of 2 plus 1. -C N >= 5. -C -C DT (input) DOUBLE PRECISION -C The sampling time of the signal. -C -C A (input/output) DOUBLE PRECISION array, dimension (N) -C On entry, this array must contain the signal to be -C processed. -C On exit, this array contains either the sine transform, if -C SICO = 'S', or the cosine transform, if SICO = 'C', of the -C given signal. -C -C Workspace -C -C DWORK DOUBLE PRECISION array, dimension (N+1) -C -C Error Indicator -C -C INFO INTEGER -C = 0: successful exit; -C < 0: if INFO = -i, the i-th argument had an illegal -C value. -C -C METHOD -C -C Let A(1), A(2),..., A(N) be a real signal of N samples. -C -C If SICO = 'S', the routine computes the sine transform of A as -C follows. First, transform A(i), i = 1,2,...,N, into the complex -C signal B(i), i = 1,2,...,(N+1)/2, where -C -C B(1) = -2*A(2), -C B(i) = {A(2i-2) - A(2i)} - j*A(2i-1) for i = 2,3,...,(N-1)/2, -C B((N+1)/2) = 2*A(N-1) and j**2 = -1. -C -C Next, perform a discrete inverse Fourier transform on B(i) by -C calling SLICOT Library Routine DG01ND, to give the complex signal -C Z(i), i = 1,2,...,(N-1)/2, from which the real signal C(i) may be -C obtained as follows: -C -C C(2i-1) = Re(Z(i)), C(2i) = Im(Z(i)) for i = 1,2,...,(N-1)/2. -C -C Finally, compute the sine transform coefficients S ,S ,...,S -C 1 2 N -C given by -C -C S = 0, -C 1 -C { [C(k) + C(N+1-k)] } -C S = DT*{[C(k) - C(N+1-k)] - -----------------------}, -C k { [2*sin(pi*(k-1)/(N-1))]} -C -C for k = 2,3,...,N-1, and -C -C S = 0. -C N -C -C If SICO = 'C', the routine computes the cosine transform of A as -C follows. First, transform A(i), i = 1,2,...,N, into the complex -C signal B(i), i = 1,2,...,(N+1)/2, where -C -C B(1) = 2*A(1), -C B(i) = 2*A(2i-1) + 2*j*{[A(2i-2) - A(2i)]} -C for i = 2,3,...,(N-1)/2 and B((N+1)/2) = 2*A(N). -C -C Next, perform a discrete inverse Fourier transform on B(i) by -C calling SLICOT Library Routine DG01ND, to give the complex signal -C Z(i), i = 1,2,...,(N-1)/2, from which the real signal D(i) may be -C obtained as follows: -C -C D(2i-1) = Re(Z(i)), D(2i) = Im(Z(i)) for i = 1,2,...,(N-1)/2. -C -C Finally, compute the cosine transform coefficients S ,S ,...,S -C 1 2 N -C given by -C -C S = 2*DT*[D(1) + A0], -C 1 -C { [D(k) - D(N+1-k)] } -C S = DT*{[D(k) + D(N+1-k)] - -----------------------}, -C k { [2*sin(pi*(k-1)/(N-1))]} -C -C -C for k = 2,3,...,N-1, and -C -C S = 2*DT*[D(1) - A0], -C N -C (N-1)/2 -C where A0 = 2*SUM A(2i). -C i=1 -C -C REFERENCES -C -C [1] Rabiner, L.R. and Rader, C.M. -C Digital Signal Processing. -C IEEE Press, 1972. -C -C [2] Oppenheim, A.V. and Schafer, R.W. -C Discrete-Time Signal Processing. -C Prentice-Hall Signal Processing Series, 1989. -C -C NUMERICAL ASPECTS -C -C The algorithm requires 0( N*log(N) ) operations. -C -C CONTRIBUTORS -C -C Release 3.0: V. Sima, Katholieke Univ. Leuven, Belgium, Feb. 1997. -C Supersedes Release 2.0 routine DF01AD by F. Dumortier, and -C R.M.C. Dekeyser, State University of Gent, Belgium. -C -C REVISIONS -C -C V. Sima, Jan. 2003. -C -C KEYWORDS -C -C Digital signal processing, fast Fourier transform, complex -C signals. -C -C ****************************************************************** -C -C .. Parameters .. - DOUBLE PRECISION ZERO, ONE, TWO, FOUR - PARAMETER ( ZERO = 0.0D0, ONE = 1.0D0, TWO = 2.0D0, - $ FOUR = 4.0D0 ) -C .. Scalar Arguments .. - CHARACTER SICO - INTEGER INFO, N - DOUBLE PRECISION DT -C .. Array Arguments .. - DOUBLE PRECISION A(*), DWORK(*) -C .. Local Scalars .. - LOGICAL LSICO, LSIG - INTEGER I, I2, IND1, IND2, M, MD2 - DOUBLE PRECISION A0, PIBYM, W1, W2, W3 -C .. External Functions .. - LOGICAL LSAME - EXTERNAL LSAME -C .. External Subroutines .. - EXTERNAL DG01ND, XERBLA -C .. Intrinsic Functions .. - INTRINSIC ATAN, DBLE, MOD, SIN -C .. Executable Statements .. -C - INFO = 0 - LSICO = LSAME( SICO, 'S' ) -C -C Test the input scalar arguments. -C - IF( .NOT.LSICO .AND. .NOT.LSAME( SICO, 'C' ) ) THEN - INFO = -1 - ELSE - M = 0 - IF( N.GT.4 ) THEN - M = N - 1 -C WHILE ( MOD( M, 2 ).EQ.0 ) DO - 10 CONTINUE - IF ( MOD( M, 2 ).EQ.0 ) THEN - M = M/2 - GO TO 10 - END IF -C END WHILE 10 - END IF - IF ( M.NE.1 ) INFO = -2 - END IF -C - IF ( INFO.NE.0 ) THEN -C -C Error return. -C - CALL XERBLA( 'DF01MD', -INFO ) - RETURN - END IF -C -C Initialisation. -C - M = N - 1 - MD2 = ( N + 1 )/2 - PIBYM = FOUR*ATAN( ONE )/DBLE( M ) - I2 = 1 - DWORK(MD2+1) = ZERO - DWORK(2*MD2) = ZERO -C - IF ( LSICO ) THEN -C -C Sine transform. -C - LSIG = .TRUE. - DWORK(1) = -TWO*A(2) - DWORK(MD2) = TWO*A(M) -C - DO 20 I = 4, M, 2 - I2 = I2 + 1 - DWORK(I2) = A(I-2) - A(I) - DWORK(MD2+I2) = -A(I-1) - 20 CONTINUE -C - ELSE -C -C Cosine transform. -C - LSIG = .FALSE. - DWORK(1) = TWO*A(1) - DWORK(MD2) = TWO*A(N) - A0 = A(2) -C - DO 30 I = 4, M, 2 - I2 = I2 + 1 - DWORK(I2) = TWO*A(I-1) - DWORK(MD2+I2) = TWO*( A(I-2) - A(I) ) - A0 = A0 + A(I) - 30 CONTINUE -C - A0 = TWO*A0 - END IF -C -C Inverse Fourier transform. -C - CALL DG01ND( 'Inverse', MD2-1, DWORK(1), DWORK(MD2+1), INFO ) -C -C Sine or cosine coefficients. -C - IF ( LSICO ) THEN - A(1) = ZERO - A(N) = ZERO - ELSE - A(1) = TWO*DT*( DWORK(1) + A0 ) - A(N) = TWO*DT*( DWORK(1) - A0 ) - END IF -C - IND1 = MD2 + 1 - IND2 = N -C - DO 40 I = 1, M - 1, 2 - W1 = DWORK(IND1) - W2 = DWORK(IND2) - IF ( LSIG ) W2 = -W2 - W3 = TWO*SIN( PIBYM*DBLE( I ) ) - A(I+1) = DT*( W1 + W2 - ( W1 - W2 )/W3 ) - IND1 = IND1 + 1 - IND2 = IND2 - 1 - 40 CONTINUE -C - IND1 = 2 - IND2 = MD2 - 1 -C - DO 50 I = 2, M - 2, 2 - W1 = DWORK(IND1) - W2 = DWORK(IND2) - IF ( LSIG ) W2 = -W2 - W3 = TWO*SIN( PIBYM*DBLE( I ) ) - A(I+1) = DT*( W1 + W2 - ( W1 - W2 )/W3 ) - IND1 = IND1 + 1 - IND2 = IND2 - 1 - 50 CONTINUE -C - RETURN -C *** Last line of DF01MD *** - END diff --git a/mex/sources/libslicot/DG01MD.f b/mex/sources/libslicot/DG01MD.f deleted file mode 100644 index ac91ab314..000000000 --- a/mex/sources/libslicot/DG01MD.f +++ /dev/null @@ -1,235 +0,0 @@ - SUBROUTINE DG01MD( INDI, N, XR, XI, INFO ) -C -C SLICOT RELEASE 5.0. -C -C Copyright (c) 2002-2009 NICONET e.V. -C -C This program is free software: you can redistribute it and/or -C modify it under the terms of the GNU General Public License as -C published by the Free Software Foundation, either version 2 of -C the License, or (at your option) any later version. -C -C This program is distributed in the hope that it will be useful, -C but WITHOUT ANY WARRANTY; without even the implied warranty of -C MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the -C GNU General Public License for more details. -C -C You should have received a copy of the GNU General Public License -C along with this program. If not, see -C . -C -C PURPOSE -C -C To compute the discrete Fourier transform, or inverse transform, -C of a complex signal. -C -C ARGUMENTS -C -C Mode Parameters -C -C INDI CHARACTER*1 -C Indicates whether a Fourier transform or inverse Fourier -C transform is to be performed as follows: -C = 'D': (Direct) Fourier transform; -C = 'I': Inverse Fourier transform. -C -C Input/Output Parameters -C -C N (input) INTEGER -C The number of complex samples. N must be a power of 2. -C N >= 2. -C -C XR (input/output) DOUBLE PRECISION array, dimension (N) -C On entry, this array must contain the real part of either -C the complex signal z if INDI = 'D', or f(z) if INDI = 'I'. -C On exit, this array contains either the real part of the -C computed Fourier transform f(z) if INDI = 'D', or the -C inverse Fourier transform z of f(z) if INDI = 'I'. -C -C XI (input/output) DOUBLE PRECISION array, dimension (N) -C On entry, this array must contain the imaginary part of -C either z if INDI = 'D', or f(z) if INDI = 'I'. -C On exit, this array contains either the imaginary part of -C f(z) if INDI = 'D', or z if INDI = 'I'. -C -C Error Indicator -C -C INFO INTEGER -C = 0: successful exit; -C < 0: if INFO = -i, the i-th argument had an illegal -C value. -C -C METHOD -C -C If INDI = 'D', then the routine performs a discrete Fourier -C transform on the complex signal Z(i), i = 1,2,...,N. If the result -C is denoted by FZ(k), k = 1,2,...,N, then the relationship between -C Z and FZ is given by the formula: -C -C N ((k-1)*(i-1)) -C FZ(k) = SUM ( Z(i) * V ), -C i=1 -C 2 -C where V = exp( -2*pi*j/N ) and j = -1. -C -C If INDI = 'I', then the routine performs an inverse discrete -C Fourier transform on the complex signal FZ(k), k = 1,2,...,N. If -C the result is denoted by Z(i), i = 1,2,...,N, then the -C relationship between Z and FZ is given by the formula: -C -C N ((k-1)*(i-1)) -C Z(i) = SUM ( FZ(k) * W ), -C k=1 -C -C where W = exp( 2*pi*j/N ). -C -C Note that a discrete Fourier transform, followed by an inverse -C discrete Fourier transform, will result in a signal which is a -C factor N larger than the original input signal. -C -C REFERENCES -C -C [1] Rabiner, L.R. and Rader, C.M. -C Digital Signal Processing. -C IEEE Press, 1972. -C -C NUMERICAL ASPECTS -C -C The algorithm requires 0( N*log(N) ) operations. -C -C CONTRIBUTOR -C -C Release 3.0: V. Sima, Katholieke Univ. Leuven, Belgium, Feb. 1997. -C Supersedes Release 2.0 routine DG01AD by R. Dekeyser, State -C University of Gent, Belgium. -C -C REVISIONS -C -C - -C -C KEYWORDS -C -C Complex signals, digital signal processing, fast Fourier -C transform. -C -C ****************************************************************** -C -C .. Parameters .. - DOUBLE PRECISION ZERO, HALF, ONE, TWO, EIGHT - PARAMETER ( ZERO = 0.0D0, HALF = 0.5D0, ONE = 1.0D0, - $ TWO = 2.0D0, EIGHT = 8.0D0 ) -C .. Scalar Arguments .. - CHARACTER INDI - INTEGER INFO, N -C .. Array Arguments .. - DOUBLE PRECISION XI(*), XR(*) -C .. Local Scalars .. - LOGICAL LINDI - INTEGER I, J, K, L, M - DOUBLE PRECISION PI2, TI, TR, WHELP, WI, WR, WSTPI, WSTPR -C .. External Functions .. - LOGICAL LSAME - EXTERNAL LSAME -C .. External Subroutines .. - EXTERNAL XERBLA -C .. Intrinsic Functions .. - INTRINSIC ATAN, DBLE, MOD, SIN -C .. Executable Statements .. -C - INFO = 0 - LINDI = LSAME( INDI, 'D' ) -C -C Test the input scalar arguments. -C - IF( .NOT.LINDI .AND. .NOT.LSAME( INDI, 'I' ) ) THEN - INFO = -1 - ELSE - J = 0 - IF( N.GE.2 ) THEN - J = N -C WHILE ( MOD( J, 2 ).EQ.0 ) DO - 10 CONTINUE - IF ( MOD( J, 2 ).EQ.0 ) THEN - J = J/2 - GO TO 10 - END IF -C END WHILE 10 - END IF - IF ( J.NE.1 ) INFO = -2 - END IF -C - IF ( INFO.NE.0 ) THEN -C -C Error return. -C - CALL XERBLA( 'DG01MD', -INFO ) - RETURN - END IF -C -C Inplace shuffling of data. -C - J = 1 -C - DO 30 I = 1, N - IF ( J.GT.I ) THEN - TR = XR(I) - TI = XI(I) - XR(I) = XR(J) - XI(I) = XI(J) - XR(J) = TR - XI(J) = TI - END IF - K = N/2 -C REPEAT - 20 IF ( J.GT.K ) THEN - J = J - K - K = K/2 - IF ( K.GE.2 ) GO TO 20 - END IF -C UNTIL ( K.LT.2 ) - J = J + K - 30 CONTINUE -C -C Transform by decimation in time. -C - PI2 = EIGHT*ATAN( ONE ) - IF ( LINDI ) PI2 = -PI2 -C - I = 1 -C -C WHILE ( I.LT.N ) DO -C - 40 IF ( I.LT.N ) THEN - L = 2*I - WHELP = PI2/DBLE( L ) - WSTPI = SIN( WHELP ) - WHELP = SIN( HALF*WHELP ) - WSTPR = -TWO*WHELP*WHELP - WR = ONE - WI = ZERO -C - DO 60 J = 1, I -C - DO 50 K = J, N, L - M = K + I - TR = WR*XR(M) - WI*XI(M) - TI = WR*XI(M) + WI*XR(M) - XR(M) = XR(K) - TR - XI(M) = XI(K) - TI - XR(K) = XR(K) + TR - XI(K) = XI(K) + TI - 50 CONTINUE -C - WHELP = WR - WR = WR + WR*WSTPR - WI*WSTPI - WI = WI + WHELP*WSTPI + WI*WSTPR - 60 CONTINUE -C - I = L - GO TO 40 -C END WHILE 40 - END IF -C - RETURN -C *** Last line of DG01MD *** - END diff --git a/mex/sources/libslicot/DG01ND.f b/mex/sources/libslicot/DG01ND.f deleted file mode 100644 index 0a97d0ea5..000000000 --- a/mex/sources/libslicot/DG01ND.f +++ /dev/null @@ -1,247 +0,0 @@ - SUBROUTINE DG01ND( INDI, N, XR, XI, INFO ) -C -C SLICOT RELEASE 5.0. -C -C Copyright (c) 2002-2009 NICONET e.V. -C -C This program is free software: you can redistribute it and/or -C modify it under the terms of the GNU General Public License as -C published by the Free Software Foundation, either version 2 of -C the License, or (at your option) any later version. -C -C This program is distributed in the hope that it will be useful, -C but WITHOUT ANY WARRANTY; without even the implied warranty of -C MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the -C GNU General Public License for more details. -C -C You should have received a copy of the GNU General Public License -C along with this program. If not, see -C . -C -C PURPOSE -C -C To compute the discrete Fourier transform, or inverse Fourier -C transform, of a real signal. -C -C ARGUMENTS -C -C Mode Parameters -C -C INDI CHARACTER*1 -C Indicates whether a Fourier transform or inverse Fourier -C transform is to be performed as follows: -C = 'D': (Direct) Fourier transform; -C = 'I': Inverse Fourier transform. -C -C Input/Output Parameters -C -C N (input) INTEGER -C Half the number of real samples. N must be a power of 2. -C N >= 2. -C -C XR (input/output) DOUBLE PRECISION array, dimension (N+1) -C On entry with INDI = 'D', the first N elements of this -C array must contain the odd part of the input signal; for -C example, XR(I) = A(2*I-1) for I = 1,2,...,N. -C On entry with INDI = 'I', the first N+1 elements of this -C array must contain the the real part of the input discrete -C Fourier transform (computed, for instance, by a previous -C call of the routine). -C On exit with INDI = 'D', the first N+1 elements of this -C array contain the real part of the output signal, that is -C of the computed discrete Fourier transform. -C On exit with INDI = 'I', the first N elements of this -C array contain the odd part of the output signal, that is -C of the computed inverse discrete Fourier transform. -C -C XI (input/output) DOUBLE PRECISION array, dimension (N+1) -C On entry with INDI = 'D', the first N elements of this -C array must contain the even part of the input signal; for -C example, XI(I) = A(2*I) for I = 1,2,...,N. -C On entry with INDI = 'I', the first N+1 elements of this -C array must contain the the imaginary part of the input -C discrete Fourier transform (computed, for instance, by a -C previous call of the routine). -C On exit with INDI = 'D', the first N+1 elements of this -C array contain the imaginary part of the output signal, -C that is of the computed discrete Fourier transform. -C On exit with INDI = 'I', the first N elements of this -C array contain the even part of the output signal, that is -C of the computed inverse discrete Fourier transform. -C -C Error Indicator -C -C INFO INTEGER -C = 0: successful exit; -C < 0: if INFO = -i, the i-th argument had an illegal -C value. -C -C METHOD -C -C Let A(1),....,A(2*N) be a real signal of 2*N samples. Then the -C first N+1 samples of the discrete Fourier transform of this signal -C are given by the formula: -C -C 2*N ((m-1)*(i-1)) -C FA(m) = SUM ( A(i) * W ), -C i=1 -C 2 -C where m = 1,2,...,N+1, W = exp(-pi*j/N) and j = -1. -C -C This transform can be computed as follows. First, transform A(i), -C i = 1,2,...,2*N, into the complex signal Z(i) = (X(i),Y(i)), -C i = 1,2,...,N. That is, X(i) = A(2*i-1) and Y(i) = A(2*i). Next, -C perform a discrete Fourier transform on Z(i) by calling SLICOT -C Library routine DG01MD. This gives a new complex signal FZ(k), -C such that -C -C N ((k-1)*(i-1)) -C FZ(k) = SUM ( Z(i) * V ), -C i=1 -C -C where k = 1,2,...,N, V = exp(-2*pi*j/N). Using the values of -C FZ(k), the components of the discrete Fourier transform FA can be -C computed by simple linear relations, implemented in the DG01NY -C subroutine. -C -C Finally, let -C -C XR(k) = Re(FZ(k)), XI(k) = Im(FZ(k)), k = 1,2,...,N, -C -C be the contents of the arrays XR and XI on entry to DG01NY with -C INDI = 'D', then on exit XR and XI contain the real and imaginary -C parts of the Fourier transform of the original real signal A. -C That is, -C -C XR(m) = Re(FA(m)), XI(m) = Im(FA(m)), -C -C where m = 1,2,...,N+1. -C -C If INDI = 'I', then the routine evaluates the inverse Fourier -C transform of a complex signal which may itself be the discrete -C Fourier transform of a real signal. -C -C Let FA(m), m = 1,2,...,2*N, denote the full discrete Fourier -C transform of a real signal A(i), i=1,2,...,2*N. The relationship -C between FA and A is given by the formula: -C -C 2*N ((m-1)*(i-1)) -C A(i) = SUM ( FA(m) * W ), -C m=1 -C -C where W = exp(pi*j/N). -C -C Let -C -C XR(m) = Re(FA(m)) and XI(m) = Im(FA(m)) for m = 1,2,...,N+1, -C -C be the contents of the arrays XR and XI on entry to the routine -C DG01NY with INDI = 'I', then on exit the first N samples of the -C complex signal FZ are returned in XR and XI such that -C -C XR(k) = Re(FZ(k)), XI(k) = Im(FZ(k)) and k = 1,2,...,N. -C -C Next, an inverse Fourier transform is performed on FZ (e.g. by -C calling SLICOT Library routine DG01MD), to give the complex signal -C Z, whose i-th component is given by the formula: -C -C N ((k-1)*(i-1)) -C Z(i) = SUM ( FZ(k) * V ), -C k=1 -C -C where i = 1,2,...,N and V = exp(2*pi*j/N). -C -C Finally, the 2*N samples of the real signal A can then be obtained -C directly from Z. That is, -C -C A(2*i-1) = Re(Z(i)) and A(2*i) = Im(Z(i)), for i = 1,2,...N. -C -C Note that a discrete Fourier transform, followed by an inverse -C transform will result in a signal which is a factor 2*N larger -C than the original input signal. -C -C REFERENCES -C -C [1] Rabiner, L.R. and Rader, C.M. -C Digital Signal Processing. -C IEEE Press, 1972. -C -C NUMERICAL ASPECTS -C -C The algorithm requires 0( N*log(N) ) operations. -C -C CONTRIBUTORS -C -C Release 3.0: V. Sima, Katholieke Univ. Leuven, Belgium, Feb. 1997. -C Supersedes Release 2.0 routine DG01BD by R. Dekeyser, and -C F. Dumortier, State University of Gent, Belgium. -C -C REVISIONS -C -C - -C -C KEYWORDS -C -C Complex signals, digital signal processing, fast Fourier -C transform, real signals. -C -C ****************************************************************** -C -C .. Scalar Arguments .. - CHARACTER INDI - INTEGER INFO, N -C .. Array Arguments .. - DOUBLE PRECISION XI(*), XR(*) -C .. Local Scalars .. - INTEGER J - LOGICAL LINDI -C .. External Functions .. - LOGICAL LSAME - EXTERNAL LSAME -C .. External Subroutines .. - EXTERNAL DG01MD, DG01NY, XERBLA -C .. Intrinsic Functions .. - INTRINSIC MOD -C .. Executable Statements .. -C - INFO = 0 - LINDI = LSAME( INDI, 'D' ) -C -C Test the input scalar arguments. -C - IF( .NOT.LINDI .AND. .NOT.LSAME( INDI, 'I' ) ) THEN - INFO = -1 - ELSE - J = 0 - IF( N.GE.2 ) THEN - J = N -C WHILE ( MOD( J, 2 ).EQ.0 ) DO - 10 CONTINUE - IF ( MOD( J, 2 ).EQ.0 ) THEN - J = J/2 - GO TO 10 - END IF -C END WHILE 10 - END IF - IF ( J.NE.1 ) INFO = -2 - END IF -C - IF ( INFO.NE.0 ) THEN -C -C Error return. -C - CALL XERBLA( 'DG01ND', -INFO ) - RETURN - END IF -C -C Compute the Fourier transform of Z = (XR,XI). -C - IF ( .NOT.LINDI ) CALL DG01NY( INDI, N, XR, XI ) -C - CALL DG01MD( INDI, N, XR, XI, INFO ) -C - IF ( LINDI ) CALL DG01NY( INDI, N, XR, XI ) -C - RETURN -C *** Last line of DG01ND *** - END diff --git a/mex/sources/libslicot/DG01NY.f b/mex/sources/libslicot/DG01NY.f deleted file mode 100644 index 9b7929dee..000000000 --- a/mex/sources/libslicot/DG01NY.f +++ /dev/null @@ -1,94 +0,0 @@ - SUBROUTINE DG01NY( INDI, N, XR, XI ) -C -C SLICOT RELEASE 5.0. -C -C Copyright (c) 2002-2009 NICONET e.V. -C -C This program is free software: you can redistribute it and/or -C modify it under the terms of the GNU General Public License as -C published by the Free Software Foundation, either version 2 of -C the License, or (at your option) any later version. -C -C This program is distributed in the hope that it will be useful, -C but WITHOUT ANY WARRANTY; without even the implied warranty of -C MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the -C GNU General Public License for more details. -C -C You should have received a copy of the GNU General Public License -C along with this program. If not, see -C . -C -C For efficiency, no tests of the input scalar parameters are -C performed. -C -C .. Parameters .. - DOUBLE PRECISION ZERO, HALF, ONE, TWO, EIGHT - PARAMETER ( ZERO=0.0D0, HALF=0.5D0, ONE = 1.0D0, - $ TWO=2.0D0, EIGHT=8.0D0 ) -C .. Scalar Arguments .. - CHARACTER INDI - INTEGER N -C .. Array Arguments .. - DOUBLE PRECISION XI(*), XR(*) -C .. Local Scalars .. - LOGICAL LINDI - INTEGER I, J, N2 - DOUBLE PRECISION AI, AR, BI, BR, HELPI, HELPR, PI2, WHELP, WI, - $ WR, WSTPI, WSTPR -C .. External Functions .. - LOGICAL LSAME - EXTERNAL LSAME -C .. Intrinsic Functions .. - INTRINSIC ATAN, DBLE, SIN -C .. Executable Statements .. -C - LINDI = LSAME( INDI, 'D' ) -C -C Initialisation. -C - PI2 = EIGHT*ATAN( ONE ) - IF ( LINDI ) PI2 = -PI2 -C - WHELP = PI2/DBLE( 2*N ) - WSTPI = SIN( WHELP ) - WHELP = SIN( HALF*WHELP ) - WSTPR = -TWO*WHELP*WHELP - WI = ZERO -C - IF ( LINDI ) THEN - WR = ONE - XR(N+1) = XR(1) - XI(N+1) = XI(1) - ELSE - WR = -ONE - END IF -C -C Recursion. -C - N2 = N/2 + 1 - DO 10 I = 1, N2 - J = N + 2 - I - AR = XR(I) + XR(J) - AI = XI(I) - XI(J) - BR = XI(I) + XI(J) - BI = XR(J) - XR(I) - IF ( LINDI ) THEN - AR = HALF*AR - AI = HALF*AI - BR = HALF*BR - BI = HALF*BI - END IF - HELPR = WR*BR - WI*BI - HELPI = WR*BI + WI*BR - XR(I) = AR + HELPR - XI(I) = AI + HELPI - XR(J) = AR - HELPR - XI(J) = HELPI - AI - WHELP = WR - WR = WR + WR*WSTPR - WI*WSTPI - WI = WI + WI*WSTPR + WHELP*WSTPI - 10 CONTINUE -C - RETURN -C *** Last line of DG01NY *** - END diff --git a/mex/sources/libslicot/DG01OD.f b/mex/sources/libslicot/DG01OD.f deleted file mode 100644 index ded9d479f..000000000 --- a/mex/sources/libslicot/DG01OD.f +++ /dev/null @@ -1,357 +0,0 @@ - SUBROUTINE DG01OD( SCR, WGHT, N, A, W, INFO ) -C -C SLICOT RELEASE 5.0. -C -C Copyright (c) 2002-2009 NICONET e.V. -C -C This program is free software: you can redistribute it and/or -C modify it under the terms of the GNU General Public License as -C published by the Free Software Foundation, either version 2 of -C the License, or (at your option) any later version. -C -C This program is distributed in the hope that it will be useful, -C but WITHOUT ANY WARRANTY; without even the implied warranty of -C MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the -C GNU General Public License for more details. -C -C You should have received a copy of the GNU General Public License -C along with this program. If not, see -C . -C -C PURPOSE -C -C To compute the (scrambled) discrete Hartley transform of -C a real signal. -C -C ARGUMENTS -C -C Mode Parameters -C -C SCR CHARACTER*1 -C Indicates whether the signal is scrambled on input or -C on output as follows: -C = 'N': the signal is not scrambled at all; -C = 'I': the input signal is bit-reversed; -C = 'O': the output transform is bit-reversed. -C -C WGHT CHARACTER*1 -C Indicates whether the precomputed weights are available -C or not, as follows: -C = 'A': available; -C = 'N': not available. -C Note that if N > 1 and WGHT = 'N' on entry, then WGHT is -C set to 'A' on exit. -C -C Input/Output Parameters -C -C N (input) INTEGER -C Number of real samples. N must be a power of 2. -C N >= 0. -C -C A (input/output) DOUBLE PRECISION array, dimension (N) -C On entry with SCR = 'N' or SCR = 'O', this array must -C contain the input signal. -C On entry with SCR = 'I', this array must contain the -C bit-reversed input signal. -C On exit with SCR = 'N' or SCR = 'I', this array contains -C the Hartley transform of the input signal. -C On exit with SCR = 'O', this array contains the -C bit-reversed Hartley transform. -C -C W (input/output) DOUBLE PRECISION array, -C dimension (N - LOG2(N)) -C On entry with WGHT = 'A', this array must contain the long -C weight vector computed by a previous call of this routine -C with the same value of N. If WGHT = 'N', the contents of -C this array on entry is ignored. -C On exit, this array contains the long weight vector. -C -C Error Indicator -C -C INFO INTEGER -C = 0: successful exit; -C < 0: if INFO = -i, the i-th argument had an illegal -C value. -C -C METHOD -C -C This routine uses a Hartley butterfly algorithm as described -C in [1]. -C -C REFERENCES -C -C [1] Van Loan, Charles. -C Computational frameworks for the fast Fourier transform. -C SIAM, 1992. -C -C NUMERICAL ASPECTS -C -C The algorithm is backward stable and requires O(N log(N)) -C floating point operations. -C -C CONTRIBUTOR -C -C D. Kressner, Technical Univ. Berlin, Germany, April 2001. -C -C REVISIONS -C -C V. Sima, Research Institute for Informatics, Bucharest, Apr. 2000. -C -C KEYWORDS -C -C Digital signal processing, fast Hartley transform, real signals. -C -C ****************************************************************** -C -C .. Parameters .. - DOUBLE PRECISION ONE, TWO, FOUR - PARAMETER ( ONE = 1.0D0, TWO = 2.0D0, FOUR = 4.0D0 ) -C .. Scalar Arguments .. - CHARACTER SCR, WGHT - INTEGER INFO, N -C .. Array Arguments .. - DOUBLE PRECISION A(*), W(*) -C .. Local Scalars .. - INTEGER I, J, L, LEN, M, P1, P2, Q1, Q2, R1, R2, S1, S2, - $ WPOS - LOGICAL LFWD, LSCR, LWGHT - DOUBLE PRECISION CF, SF, T1, T2, TH -C .. External Functions .. - LOGICAL LSAME - EXTERNAL LSAME -C .. External Subroutines .. - EXTERNAL XERBLA -C .. Intrinsic Functions .. - INTRINSIC ATAN, COS, DBLE, MOD, SIN -C .. Executable Statements .. -C - INFO = 0 - LFWD = LSAME( SCR, 'N' ) .OR. LSAME( SCR, 'I' ) - LSCR = LSAME( SCR, 'I' ) .OR. LSAME( SCR, 'O' ) - LWGHT = LSAME( WGHT, 'A' ) -C -C Test the input scalar arguments. -C - IF( .NOT.( LFWD .OR. LSCR ) ) THEN - INFO = -1 - ELSE IF( .NOT.LWGHT .AND. .NOT.LSAME( WGHT, 'N' ) ) THEN - INFO = -2 - ELSE - M = 0 - J = 0 - IF( N.GE.1 ) THEN - J = N -C WHILE ( MOD( J, 2 ).EQ.0 ) DO - 10 CONTINUE - IF ( MOD( J, 2 ).EQ.0 ) THEN - J = J/2 - M = M + 1 - GO TO 10 - END IF -C END WHILE 10 - IF ( J.NE.1 ) INFO = -3 - ELSE IF ( N.LT.0 ) THEN - INFO = -3 - END IF - END IF -C - IF ( INFO.NE.0 ) THEN -C -C Error return. -C - CALL XERBLA( 'DG01OD', -INFO ) - RETURN - END IF -C -C Quick return if possible. -C - IF ( N.LE.1 ) - $ RETURN -C - IF ( .NOT. LWGHT ) THEN -C -C Compute the long weight vector via subvector scaling. -C - R1 = 1 - LEN = 1 - TH = FOUR*ATAN( ONE ) / DBLE( N ) -C - DO 30 L = 1, M - 2 - LEN = 2*LEN - TH = TWO*TH - CF = COS(TH) - SF = SIN(TH) - W(R1) = CF - W(R1+1) = SF - R1 = R1 + 2 -C - DO 20 I = 1, LEN - 2, 2 - W(R1) = CF*W(I) - SF*W(I+1) - W(R1+1) = SF*W(I) + CF*W(I+1) - R1 = R1 + 2 - 20 CONTINUE -C - 30 CONTINUE -C - P1 = 3 - Q1 = R1 - 2 -C - DO 50 L = M - 2, 1, -1 -C - DO 40 I = P1, Q1, 4 - W(R1) = W(I) - W(R1+1) = W(I+1) - R1 = R1 + 2 - 40 CONTINUE -C - P1 = Q1 + 4 - Q1 = R1 - 2 - 50 CONTINUE -C - WGHT = 'A' -C - END IF -C - IF ( LFWD .AND. .NOT.LSCR ) THEN -C -C Inplace shuffling of data. -C - J = 1 -C - DO 70 I = 1, N - IF ( J.GT.I ) THEN - T1 = A(I) - A(I) = A(J) - A(J) = T1 - END IF - L = N/2 -C REPEAT - 60 IF ( J.GT.L ) THEN - J = J - L - L = L/2 - IF ( L.GE.2 ) GO TO 60 - END IF -C UNTIL ( L.LT.2 ) - J = J + L - 70 CONTINUE -C - END IF -C - IF ( LFWD ) THEN -C -C Compute Hartley transform with butterfly operators. -C - DO 110 J = 2, N, 2 - T1 = A(J) - A(J) = A(J-1) - T1 - A(J-1) = A(J-1) + T1 - 110 CONTINUE -C - LEN = 1 - WPOS = N - 2*M + 1 -C - DO 140 L = 1, M - 1 - LEN = 2*LEN - P2 = 1 - Q2 = LEN + 1 - R2 = LEN / 2 + 1 - S2 = R2 + Q2 - 1 -C - DO 130 I = 0, N/( 2*LEN ) - 1 - T1 = A(Q2) - A(Q2) = A(P2) - T1 - A(P2) = A(P2) + T1 - T1 = A(S2) - A(S2) = A(R2) - T1 - A(R2) = A(R2) + T1 -C - P1 = P2 + 1 - Q1 = P1 + LEN - R1 = Q1 - 2 - S1 = R1 + LEN -C - DO 120 J = WPOS, WPOS + LEN - 3, 2 - CF = W(J) - SF = W(J+1) - T1 = CF*A(Q1) + SF*A(S1) - T2 = -CF*A(S1) + SF*A(Q1) - A(Q1) = A(P1) - T1 - A(P1) = A(P1) + T1 - A(S1) = A(R1) - T2 - A(R1) = A(R1) + T2 - P1 = P1 + 1 - Q1 = Q1 + 1 - R1 = R1 - 1 - S1 = S1 - 1 - 120 CONTINUE -C - P2 = P2 + 2*LEN - Q2 = Q2 + 2*LEN - R2 = R2 + 2*LEN - S2 = S2 + 2*LEN - 130 CONTINUE -C - WPOS = WPOS - 2*LEN + 2 - 140 CONTINUE -C - ELSE -C -C Compute Hartley transform with transposed butterfly operators. -C - WPOS = 1 - LEN = N -C - DO 230 L = M - 1, 1, -1 - LEN = LEN / 2 - P2 = 1 - Q2 = LEN + 1 - R2 = LEN / 2 + 1 - S2 = R2 + Q2 - 1 -C - DO 220 I = 0, N/( 2*LEN ) - 1 - T1 = A(Q2) - A(Q2) = A(P2) - T1 - A(P2) = A(P2) + T1 - T1 = A(S2) - A(S2) = A(R2) - T1 - A(R2) = A(R2) + T1 -C - P1 = P2 + 1 - Q1 = P1 + LEN - R1 = Q1 - 2 - S1 = R1 + LEN -C - DO 210 J = WPOS, WPOS + LEN - 3, 2 - CF = W(J) - SF = W(J+1) - T1 = A(P1) - A(Q1) - T2 = A(R1) - A(S1) - A(P1) = A(P1) + A(Q1) - A(R1) = A(R1) + A(S1) - A(Q1) = CF*T1 + SF*T2 - A(S1) = -CF*T2 + SF*T1 - P1 = P1 + 1 - Q1 = Q1 + 1 - R1 = R1 - 1 - S1 = S1 - 1 - 210 CONTINUE -C - P2 = P2 + 2*LEN - Q2 = Q2 + 2*LEN - R2 = R2 + 2*LEN - S2 = S2 + 2*LEN - 220 CONTINUE -C - WPOS = WPOS + LEN - 2 - 230 CONTINUE -C - DO 240 J = 2, N, 2 - T1 = A(J) - A(J) = A(J-1) - T1 - A(J-1) = A(J-1) + T1 - 240 CONTINUE -C - END IF - RETURN -C *** Last line of DG01OD *** - END diff --git a/mex/sources/libslicot/DK01MD.f b/mex/sources/libslicot/DK01MD.f deleted file mode 100644 index 3ae298675..000000000 --- a/mex/sources/libslicot/DK01MD.f +++ /dev/null @@ -1,183 +0,0 @@ - SUBROUTINE DK01MD( TYPE, N, A, INFO ) -C -C SLICOT RELEASE 5.0. -C -C Copyright (c) 2002-2009 NICONET e.V. -C -C This program is free software: you can redistribute it and/or -C modify it under the terms of the GNU General Public License as -C published by the Free Software Foundation, either version 2 of -C the License, or (at your option) any later version. -C -C This program is distributed in the hope that it will be useful, -C but WITHOUT ANY WARRANTY; without even the implied warranty of -C MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the -C GNU General Public License for more details. -C -C You should have received a copy of the GNU General Public License -C along with this program. If not, see -C . -C -C PURPOSE -C -C To apply an anti-aliasing window to a real signal. -C -C ARGUMENTS -C -C Mode Parameters -C -C TYPE CHARACTER*1 -C Indicates the type of window to be applied to the signal -C as follows: -C = 'M': Hamming window; -C = 'N': Hann window; -C = 'Q': Quadratic window. -C -C Input/Output Parameters -C -C N (input) INTEGER -C The number of samples. N >= 1. -C -C A (input/output) DOUBLE PRECISION array, dimension (N) -C On entry, this array must contain the signal to be -C processed. -C On exit, this array contains the windowing function. -C -C Error Indicator -C -C INFO INTEGER -C = 0: successful exit; -C < 0: if INFO = -i, the i-th argument had an illegal -C value. -C -C METHOD -C -C If TYPE = 'M', then a Hamming window is applied to A(1),...,A(N), -C which yields -C _ -C A(i) = (0.54 + 0.46*cos(pi*(i-1)/(N-1)))*A(i), i = 1,2,...,N. -C -C If TYPE = 'N', then a Hann window is applied to A(1),...,A(N), -C which yields -C _ -C A(i) = 0.5*(1 + cos(pi*(i-1)/(N-1)))*A(i), i = 1,2,...,N. -C -C If TYPE = 'Q', then a quadratic window is applied to A(1),..., -C A(N), which yields -C _ -C A(i) = (1 - 2*((i-1)/(N-1))**2)*(1 - (i-1)/(N-1))*A(i), -C i = 1,2,...,(N-1)/2+1; -C _ -C A(i) = 2*(1 - ((i-1)/(N-1))**3)*A(i), i = (N-1)/2+2,...,N. -C -C REFERENCES -C -C [1] Rabiner, L.R. and Rader, C.M. -C Digital Signal Processing. -C IEEE Press, 1972. -C -C NUMERICAL ASPECTS -C -C The algorithm requires 0( N ) operations. -C -C CONTRIBUTOR -C -C Release 3.0: V. Sima, Katholieke Univ. Leuven, Belgium, Feb. 1997. -C Supersedes Release 2.0 routine DK01AD by R. Dekeyser, State -C University of Gent, Belgium. -C -C REVISIONS -C -C - -C -C KEYWORDS -C -C Digital signal processing, Hamming window, Hann window, real -C signals, windowing. -C -C ****************************************************************** -C -C .. Parameters .. - DOUBLE PRECISION PT46, HALF, PT54, ONE, TWO, FOUR - PARAMETER ( PT46=0.46D0, HALF=0.5D0, PT54=0.54D0, - $ ONE = 1.0D0, TWO=2.0D0, FOUR=4.0D0 ) -C .. Scalar Arguments .. - CHARACTER TYPE - INTEGER INFO, N -C .. Array Arguments .. - DOUBLE PRECISION A(*) -C .. Local Scalars .. - LOGICAL MTYPE, MNTYPE, NTYPE - INTEGER I, N1 - DOUBLE PRECISION BUF, FN, TEMP -C .. External Functions .. - LOGICAL LSAME - EXTERNAL LSAME -C .. External Subroutines .. - EXTERNAL XERBLA -C .. Intrinsic Functions .. - INTRINSIC ATAN, COS, DBLE -C .. Executable Statements .. -C - INFO = 0 - MTYPE = LSAME( TYPE, 'M' ) - NTYPE = LSAME( TYPE, 'N' ) - MNTYPE = MTYPE.OR.NTYPE -C -C Test the input scalar arguments. -C - IF( .NOT.MNTYPE .AND. .NOT.LSAME( TYPE, 'Q' ) ) - $ THEN - INFO = -1 - ELSE IF( N.LE.0 ) THEN - INFO = -2 - END IF -C - IF ( INFO.NE.0 ) THEN -C -C Error return. -C - CALL XERBLA( 'DK01MD', -INFO ) - RETURN - END IF -C - FN = DBLE( N-1 ) - IF( MNTYPE ) TEMP = FOUR*ATAN( ONE )/FN -C - IF ( MTYPE ) THEN -C -C Hamming window. -C - DO 10 I = 1, N - A(I) = A(I)*( PT54 + PT46*COS( TEMP*DBLE( I-1 ) ) ) - 10 CONTINUE -C - ELSE IF ( NTYPE ) THEN -C -C Hann window. -C - DO 20 I = 1, N - A(I) = A(I)*HALF*( ONE + COS( TEMP*DBLE( I-1 ) ) ) - 20 CONTINUE -C - ELSE -C -C Quadratic window. -C - N1 = ( N-1 )/2 + 1 -C - DO 30 I = 1, N - BUF = DBLE( I-1 )/FN - TEMP = BUF**2 - IF ( I.LE.N1 ) THEN - A(I) = A(I)*( ONE - TWO*TEMP )*( ONE - BUF ) - ELSE - A(I) = A(I)*TWO*( ONE - BUF*TEMP ) - END IF - 30 CONTINUE -C - END IF -C - RETURN -C *** Last line of DK01MD *** - END diff --git a/mex/sources/libslicot/FB01QD.f b/mex/sources/libslicot/FB01QD.f deleted file mode 100644 index 4bcc391f9..000000000 --- a/mex/sources/libslicot/FB01QD.f +++ /dev/null @@ -1,464 +0,0 @@ - SUBROUTINE FB01QD( JOBK, MULTBQ, N, M, P, S, LDS, A, LDA, B, - $ LDB, Q, LDQ, C, LDC, R, LDR, K, LDK, TOL, - $ IWORK, DWORK, LDWORK, INFO ) -C -C SLICOT RELEASE 5.0. -C -C Copyright (c) 2002-2009 NICONET e.V. -C -C This program is free software: you can redistribute it and/or -C modify it under the terms of the GNU General Public License as -C published by the Free Software Foundation, either version 2 of -C the License, or (at your option) any later version. -C -C This program is distributed in the hope that it will be useful, -C but WITHOUT ANY WARRANTY; without even the implied warranty of -C MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the -C GNU General Public License for more details. -C -C You should have received a copy of the GNU General Public License -C along with this program. If not, see -C . -C -C PURPOSE -C -C To calculate a combined measurement and time update of one -C iteration of the time-varying Kalman filter. This update is given -C for the square root covariance filter, using dense matrices. -C -C ARGUMENTS -C -C Mode Parameters -C -C JOBK CHARACTER*1 -C Indicates whether the user wishes to compute the Kalman -C filter gain matrix K as follows: -C i -C = 'K': K is computed and stored in array K; -C i -C = 'N': K is not required. -C i -C -C MULTBQ CHARACTER*1 1/2 -C Indicates how matrices B and Q are to be passed to -C i i -C the routine as follows: -C = 'P': Array Q is not used and the array B must contain -C 1/2 -C the product B Q ; -C i i -C = 'N': Arrays B and Q must contain the matrices as -C described below. -C -C Input/Output Parameters -C -C N (input) INTEGER -C The actual state dimension, i.e., the order of the -C matrices S and A . N >= 0. -C i-1 i -C -C M (input) INTEGER -C The actual input dimension, i.e., the order of the matrix -C 1/2 -C Q . M >= 0. -C i -C -C P (input) INTEGER -C The actual output dimension, i.e., the order of the matrix -C 1/2 -C R . P >= 0. -C i -C -C S (input/output) DOUBLE PRECISION array, dimension (LDS,N) -C On entry, the leading N-by-N lower triangular part of this -C array must contain S , the square root (left Cholesky -C i-1 -C factor) of the state covariance matrix at instant (i-1). -C On exit, the leading N-by-N lower triangular part of this -C array contains S , the square root (left Cholesky factor) -C i -C of the state covariance matrix at instant i. -C The strict upper triangular part of this array is not -C referenced. -C -C LDS INTEGER -C The leading dimension of array S. LDS >= MAX(1,N). -C -C A (input) DOUBLE PRECISION array, dimension (LDA,N) -C The leading N-by-N part of this array must contain A , -C i -C the state transition matrix of the discrete system at -C instant i. -C -C LDA INTEGER -C The leading dimension of array A. LDA >= MAX(1,N). -C -C B (input) DOUBLE PRECISION array, dimension (LDB,M) -C The leading N-by-M part of this array must contain B , -C 1/2 i -C the input weight matrix (or the product B Q if -C i i -C MULTBQ = 'P') of the discrete system at instant i. -C -C LDB INTEGER -C The leading dimension of array B. LDB >= MAX(1,N). -C -C Q (input) DOUBLE PRECISION array, dimension (LDQ,*) -C If MULTBQ = 'N', then the leading M-by-M lower triangular -C 1/2 -C part of this array must contain Q , the square root -C i -C (left Cholesky factor) of the input (process) noise -C covariance matrix at instant i. -C The strict upper triangular part of this array is not -C referenced. -C If MULTBQ = 'P', Q is not referenced and can be supplied -C as a dummy array (i.e., set parameter LDQ = 1 and declare -C this array to be Q(1,1) in the calling program). -C -C LDQ INTEGER -C The leading dimension of array Q. -C LDQ >= MAX(1,M) if MULTBQ = 'N'; -C LDQ >= 1 if MULTBQ = 'P'. -C -C C (input) DOUBLE PRECISION array, dimension (LDC,N) -C The leading P-by-N part of this array must contain C , the -C i -C output weight matrix of the discrete system at instant i. -C -C LDC INTEGER -C The leading dimension of array C. LDC >= MAX(1,P). -C -C R (input/output) DOUBLE PRECISION array, dimension (LDR,P) -C On entry, the leading P-by-P lower triangular part of this -C 1/2 -C array must contain R , the square root (left Cholesky -C i -C factor) of the output (measurement) noise covariance -C matrix at instant i. -C On exit, the leading P-by-P lower triangular part of this -C 1/2 -C array contains (RINOV ) , the square root (left Cholesky -C i -C factor) of the covariance matrix of the innovations at -C instant i. -C The strict upper triangular part of this array is not -C referenced. -C -C LDR INTEGER -C The leading dimension of array R. LDR >= MAX(1,P). -C -C K (output) DOUBLE PRECISION array, dimension (LDK,P) -C If JOBK = 'K', and INFO = 0, then the leading N-by-P part -C of this array contains K , the Kalman filter gain matrix -C i -C at instant i. -C If JOBK = 'N', or JOBK = 'K' and INFO = 1, then the -C leading N-by-P part of this array contains AK , a matrix -C i -C related to the Kalman filter gain matrix at instant i (see -C -1/2 -C METHOD). Specifically, AK = A P C'(RINOV') . -C i i i|i-1 i i -C -C LDK INTEGER -C The leading dimension of array K. LDK >= MAX(1,N). -C -C Tolerances -C -C TOL DOUBLE PRECISION -C If JOBK = 'K', then TOL is used to test for near -C 1/2 -C singularity of the matrix (RINOV ) . If the user sets -C i -C TOL > 0, then the given value of TOL is used as a -C lower bound for the reciprocal condition number of that -C matrix; a matrix whose estimated condition number is less -C than 1/TOL is considered to be nonsingular. If the user -C sets TOL <= 0, then an implicitly computed, default -C tolerance, defined by TOLDEF = P*P*EPS, is used instead, -C where EPS is the machine precision (see LAPACK Library -C routine DLAMCH). -C Otherwise, TOL is not referenced. -C -C Workspace -C -C IWORK INTEGER array, dimension (LIWORK), -C where LIWORK = P if JOBK = 'K', -C and LIWORK = 1 otherwise. -C -C DWORK DOUBLE PRECISION array, dimension (LDWORK) -C On exit, if INFO = 0, DWORK(1) returns the optimal value -C of LDWORK. If INFO = 0 and JOBK = 'K', DWORK(2) returns -C an estimate of the reciprocal of the condition number -C 1/2 -C (in the 1-norm) of (RINOV ) . -C i -C -C LDWORK The length of the array DWORK. -C LDWORK >= MAX(1,N*(P+N)+2*P,N*(N+M+2)), if JOBK = 'N'; -C LDWORK >= MAX(2,N*(P+N)+2*P,N*(N+M+2),3*P), if JOBK = 'K'. -C For optimum performance LDWORK should be larger. -C -C Error Indicator -C -C INFO INTEGER -C = 0: successful exit; -C < 0: if INFO = -i, the i-th argument had an illegal -C value; -C 1/2 -C = 1: if JOBK = 'K' and the matrix (RINOV ) is singular, -C i 1/2 -C i.e., the condition number estimate of (RINOV ) -C i -C (in the 1-norm) exceeds 1/TOL. The matrices S, AK , -C 1/2 i -C and (RINOV ) have been computed. -C i -C -C METHOD -C -C The routine performs one recursion of the square root covariance -C filter algorithm, summarized as follows: -C -C | 1/2 | | 1/2 | -C | R C x S 0 | | (RINOV ) 0 0 | -C | i i i-1 | | i | -C | 1/2 | T = | | -C | 0 A x S B x Q | | AK S 0 | -C | i i-1 i i | | i i | -C -C (Pre-array) (Post-array) -C -C where T is an orthogonal transformation triangularizing the -C pre-array. -C -C The state covariance matrix P is factorized as -C i|i-1 -C P = S S' -C i|i-1 i i -C -C and one combined time and measurement update for the state X -C i|i-1 -C is given by -C -C X = A X + K (Y - C X ), -C i+1|i i i|i-1 i i i i|i-1 -C -C -1/2 -C where K = AK (RINOV ) is the Kalman filter gain matrix and Y -C i i i i -C is the observed output of the system. -C -C The triangularization is done entirely via Householder -C transformations exploiting the zero pattern of the pre-array. -C -C REFERENCES -C -C [1] Anderson, B.D.O. and Moore, J.B. -C Optimal Filtering. -C Prentice Hall, Englewood Cliffs, New Jersey, 1979. -C -C [2] Verhaegen, M.H.G. and Van Dooren, P. -C Numerical Aspects of Different Kalman Filter Implementations. -C IEEE Trans. Auto. Contr., AC-31, pp. 907-917, Oct. 1986. -C -C [3] Vanbegin, M., Van Dooren, P., and Verhaegen, M.H.G. -C Algorithm 675: FORTRAN Subroutines for Computing the Square -C Root Covariance Filter and Square Root Information Filter in -C Dense or Hessenberg Forms. -C ACM Trans. Math. Software, 15, pp. 243-256, 1989. -C -C NUMERICAL ASPECTS -C -C The algorithm requires -C -C 3 2 2 2 -C (7/6)N + N x (5/2 x P + M) + N x (1/2 x M + P ) -C -C operations and is backward stable (see [2]). -C -C CONTRIBUTORS -C -C Release 3.0: V. Sima, Katholieke Univ. Leuven, Belgium, Feb. 1997. -C Supersedes Release 2.0 routine FB01ED by M. Vanbegin, -C P. Van Dooren, and M.H.G. Verhaegen. -C -C REVISIONS -C -C February 20, 1998, November 20, 2003. -C -C KEYWORDS -C -C Kalman filtering, optimal filtering, orthogonal transformation, -C recursive estimation, square-root covariance filtering, -C square-root filtering. -C -C ****************************************************************** -C -C .. Parameters .. - DOUBLE PRECISION ZERO, ONE, TWO - PARAMETER ( ZERO = 0.0D0, ONE = 1.0D0, TWO = 2.0D0 ) -C .. Scalar Arguments .. - CHARACTER JOBK, MULTBQ - INTEGER INFO, LDA, LDB, LDC, LDK, LDQ, LDR, LDS, LDWORK, - $ M, N, P - DOUBLE PRECISION TOL -C .. Array Arguments .. - INTEGER IWORK(*) - DOUBLE PRECISION A(LDA,*), B(LDB,*), C(LDC,*), DWORK(*), - $ K(LDK,*), Q(LDQ,*), R(LDR,*), S(LDS,*) -C .. Local Scalars .. - LOGICAL LJOBK, LMULTB - INTEGER I12, ITAU, JWORK, N1, PN, WRKOPT - DOUBLE PRECISION RCOND -C .. External Functions .. - LOGICAL LSAME - EXTERNAL LSAME -C .. External Subroutines .. - EXTERNAL DGELQF, DLACPY, DTRMM, MB02OD, MB04LD, XERBLA -C .. Intrinsic Functions .. - INTRINSIC INT, MAX -C .. Executable Statements .. -C - PN = P + N - N1 = MAX( 1, N ) - INFO = 0 - LJOBK = LSAME( JOBK, 'K' ) - LMULTB = LSAME( MULTBQ, 'P' ) -C -C Test the input scalar arguments. -C - IF( .NOT.LJOBK .AND. .NOT.LSAME( JOBK, 'N' ) ) THEN - INFO = -1 - ELSE IF( .NOT.LMULTB .AND. .NOT.LSAME( MULTBQ, 'N' ) ) THEN - INFO = -2 - ELSE IF( N.LT.0 ) THEN - INFO = -3 - ELSE IF( M.LT.0 ) THEN - INFO = -4 - ELSE IF( P.LT.0 ) THEN - INFO = -5 - ELSE IF( LDS.LT.N1 ) THEN - INFO = -7 - ELSE IF( LDA.LT.N1 ) THEN - INFO = -9 - ELSE IF( LDB.LT.N1 ) THEN - INFO = -11 - ELSE IF( LDQ.LT.1 .OR. ( .NOT.LMULTB .AND. LDQ.LT.M ) ) THEN - INFO = -13 - ELSE IF( LDC.LT.MAX( 1, P ) ) THEN - INFO = -15 - ELSE IF( LDR.LT.MAX( 1, P ) ) THEN - INFO = -17 - ELSE IF( LDK.LT.N1 ) THEN - INFO = -19 - ELSE IF( ( LJOBK .AND. LDWORK.LT.MAX( 2, PN*N + 2*P, - $ N*(N + M + 2), 3*P ) ) .OR. - $ ( .NOT.LJOBK .AND. LDWORK.LT.MAX( 1, PN*N + 2*P, - $ N*(N + M + 2) ) ) ) THEN - INFO = -23 - END IF -C - IF ( INFO.NE.0 ) THEN -C -C Error return. -C - CALL XERBLA( 'FB01QD', -INFO ) - RETURN - END IF -C -C Quick return if possible. -C - IF ( N.EQ.0 ) THEN - IF ( LJOBK ) THEN - DWORK(1) = TWO - DWORK(2) = ONE - ELSE - DWORK(1) = ONE - END IF - RETURN - END IF -C -C Construction of the needed part of the pre-array in DWORK. -C To save workspace, only the blocks (1,2), (2,2), and (2,3) will be -C constructed as shown below. -C -C Storing A x S and C x S in the (1,1) and (2,1) blocks of DWORK, -C respectively. -C Workspace: need (N+P)*N. -C -C (Note: Comments in the code beginning "Workspace:" describe the -C minimal amount of real workspace needed at that point in the -C code, as well as the preferred amount for good performance. -C NB refers to the optimal block size for the immediately -C following subroutine, as returned by ILAENV.) -C - CALL DLACPY( 'Full', N, N, A, LDA, DWORK, PN ) - CALL DLACPY( 'Full', P, N, C, LDC, DWORK(N+1), PN ) - CALL DTRMM( 'Right', 'Lower', 'No transpose', 'Non-unit', PN, N, - $ ONE, S, LDS, DWORK, PN ) -C -C Triangularization (2 steps). -C -C Step 1: annihilate the matrix C x S. -C Workspace: need (N+P)*N + 2*P. -C - ITAU = PN*N + 1 - JWORK = ITAU + P -C - CALL MB04LD( 'Full', P, N, N, R, LDR, DWORK(N+1), PN, DWORK, PN, - $ K, LDK, DWORK(ITAU), DWORK(JWORK) ) - WRKOPT = PN*N + 2*P -C -C Now, the workspace for C x S is no longer needed. -C Adjust the leading dimension of DWORK, to save space for the -C following computations. -C - CALL DLACPY( 'Full', N, N, DWORK, PN, DWORK, N ) - I12 = N*N + 1 -C -C Storing B x Q in the (1,2) block of DWORK. -C Workspace: need N*(N+M). -C - CALL DLACPY( 'Full', N, M, B, LDB, DWORK(I12), N ) - IF ( .NOT.LMULTB ) - $ CALL DTRMM( 'Right', 'Lower', 'No transpose', 'Non-unit', N, M, - $ ONE, Q, LDQ, DWORK(I12), N ) - WRKOPT = MAX( WRKOPT, N*( N + M ) ) -C -C Step 2: LQ triangularization of the matrix [ A x S B x Q ], where -C A x S was modified at Step 1. -C Workspace: need N*(N+M+2); prefer N*(N+M+1)+N*NB. -C - ITAU = N*( N + M ) + 1 - JWORK = ITAU + N -C - CALL DGELQF( N, N+M, DWORK, N, DWORK(ITAU), DWORK(JWORK), - $ LDWORK-JWORK+1, INFO ) - WRKOPT = MAX( WRKOPT, INT( DWORK(JWORK) )+JWORK-1 ) -C -C Output S and K (if needed) and set the optimal workspace -C dimension (and the reciprocal of the condition number estimate). -C - CALL DLACPY( 'Lower', N, N, DWORK, N, S, LDS ) -C - IF ( LJOBK ) THEN -C -C Compute K. -C Workspace: need 3*P. -C - CALL MB02OD( 'Right', 'Lower', 'No transpose', 'Non-unit', - $ '1-norm', N, P, ONE, R, LDR, K, LDK, RCOND, TOL, - $ IWORK, DWORK, INFO ) - IF ( INFO.EQ.0 ) THEN - WRKOPT = MAX( WRKOPT, 3*P ) - DWORK(2) = RCOND - END IF - END IF -C - DWORK(1) = WRKOPT -C - RETURN -C *** Last line of FB01QD *** - END diff --git a/mex/sources/libslicot/FB01RD.f b/mex/sources/libslicot/FB01RD.f deleted file mode 100644 index 721cb2ae7..000000000 --- a/mex/sources/libslicot/FB01RD.f +++ /dev/null @@ -1,535 +0,0 @@ - SUBROUTINE FB01RD( JOBK, MULTBQ, N, M, P, S, LDS, A, LDA, B, - $ LDB, Q, LDQ, C, LDC, R, LDR, K, LDK, TOL, - $ IWORK, DWORK, LDWORK, INFO ) -C -C SLICOT RELEASE 5.0. -C -C Copyright (c) 2002-2009 NICONET e.V. -C -C This program is free software: you can redistribute it and/or -C modify it under the terms of the GNU General Public License as -C published by the Free Software Foundation, either version 2 of -C the License, or (at your option) any later version. -C -C This program is distributed in the hope that it will be useful, -C but WITHOUT ANY WARRANTY; without even the implied warranty of -C MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the -C GNU General Public License for more details. -C -C You should have received a copy of the GNU General Public License -C along with this program. If not, see -C . -C -C PURPOSE -C -C To calculate a combined measurement and time update of one -C iteration of the time-invariant Kalman filter. This update is -C given for the square root covariance filter, using the condensed -C observer Hessenberg form. -C -C ARGUMENTS -C -C Mode Parameters -C -C JOBK CHARACTER*1 -C Indicates whether the user wishes to compute the Kalman -C filter gain matrix K as follows: -C i -C = 'K': K is computed and stored in array K; -C i -C = 'N': K is not required. -C i -C -C MULTBQ CHARACTER*1 1/2 -C Indicates how matrices B and Q are to be passed to -C i i -C the routine as follows: -C = 'P': Array Q is not used and the array B must contain -C 1/2 -C the product B Q ; -C i i -C = 'N': Arrays B and Q must contain the matrices as -C described below. -C -C Input/Output Parameters -C -C N (input) INTEGER -C The actual state dimension, i.e., the order of the -C matrices S and A. N >= 0. -C i-1 -C -C M (input) INTEGER -C The actual input dimension, i.e., the order of the matrix -C 1/2 -C Q . M >= 0. -C i -C -C P (input) INTEGER -C The actual output dimension, i.e., the order of the matrix -C 1/2 -C R . P >= 0. -C i -C -C S (input/output) DOUBLE PRECISION array, dimension (LDS,N) -C On entry, the leading N-by-N lower triangular part of this -C array must contain S , the square root (left Cholesky -C i-1 -C factor) of the state covariance matrix at instant (i-1). -C On exit, the leading N-by-N lower triangular part of this -C array contains S , the square root (left Cholesky factor) -C i -C of the state covariance matrix at instant i. -C The strict upper triangular part of this array is not -C referenced. -C -C LDS INTEGER -C The leading dimension of array S. LDS >= MAX(1,N). -C -C A (input) DOUBLE PRECISION array, dimension (LDA,N) -C The leading N-by-N part of this array must contain A, -C the state transition matrix of the discrete system in -C lower observer Hessenberg form (e.g., as produced by -C SLICOT Library Routine TB01ND). -C -C LDA INTEGER -C The leading dimension of array A. LDA >= MAX(1,N). -C -C B (input) DOUBLE PRECISION array, dimension (LDB,M) -C The leading N-by-M part of this array must contain B , -C 1/2 i -C the input weight matrix (or the product B Q if -C i i -C MULTBQ = 'P') of the discrete system at instant i. -C -C LDB INTEGER -C The leading dimension of array B. LDB >= MAX(1,N). -C -C Q (input) DOUBLE PRECISION array, dimension (LDQ,*) -C If MULTBQ = 'N', then the leading M-by-M lower triangular -C 1/2 -C part of this array must contain Q , the square root -C i -C (left Cholesky factor) of the input (process) noise -C covariance matrix at instant i. -C The strict upper triangular part of this array is not -C referenced. -C Otherwise, Q is not referenced and can be supplied as a -C dummy array (i.e., set parameter LDQ = 1 and declare this -C array to be Q(1,1) in the calling program). -C -C LDQ INTEGER -C The leading dimension of array Q. -C LDQ >= MAX(1,M) if MULTBQ = 'N'; -C LDQ >= 1 if MULTBQ = 'P'. -C -C C (input) DOUBLE PRECISION array, dimension (LDC,N) -C The leading P-by-N part of this array must contain C, -C the output weight matrix of the discrete system in lower -C observer Hessenberg form (e.g., as produced by SLICOT -C Library routine TB01ND). -C -C LDC INTEGER -C The leading dimension of array C. LDC >= MAX(1,P). -C -C R (input/output) DOUBLE PRECISION array, dimension (LDR,P) -C On entry, the leading P-by-P lower triangular part of this -C 1/2 -C array must contain R , the square root (left Cholesky -C i -C factor) of the output (measurement) noise covariance -C matrix at instant i. -C On exit, the leading P-by-P lower triangular part of this -C 1/2 -C array contains (RINOV ) , the square root (left Cholesky -C i -C factor) of the covariance matrix of the innovations at -C instant i. -C The strict upper triangular part of this array is not -C referenced. -C -C LDR INTEGER -C The leading dimension of array R. LDR >= MAX(1,P). -C -C K (output) DOUBLE PRECISION array, dimension (LDK,P) -C If JOBK = 'K', and INFO = 0, then the leading N-by-P part -C of this array contains K , the Kalman filter gain matrix -C i -C at instant i. -C If JOBK = 'N', or JOBK = 'K' and INFO = 1, then the -C leading N-by-P part of this array contains AK , a matrix -C i -C related to the Kalman filter gain matrix at instant i (see -C -1/2 -C METHOD). Specifically, AK = A P C'(RINOV') . -C i i|i-1 i -C -C LDK INTEGER -C The leading dimension of array K. LDK >= MAX(1,N). -C -C Tolerances -C -C TOL DOUBLE PRECISION -C If JOBK = 'K', then TOL is used to test for near -C 1/2 -C singularity of the matrix (RINOV ) . If the user sets -C i -C TOL > 0, then the given value of TOL is used as a -C lower bound for the reciprocal condition number of that -C matrix; a matrix whose estimated condition number is less -C than 1/TOL is considered to be nonsingular. If the user -C sets TOL <= 0, then an implicitly computed, default -C tolerance, defined by TOLDEF = P*P*EPS, is used instead, -C where EPS is the machine precision (see LAPACK Library -C routine DLAMCH). -C Otherwise, TOL is not referenced. -C -C Workspace -C -C IWORK INTEGER array, dimension (LIWORK) -C where LIWORK = P if JOBK = 'K', -C and LIWORK = 1 otherwise. -C -C DWORK DOUBLE PRECISION array, dimension (LDWORK) -C On exit, if INFO = 0, DWORK(1) returns the optimal value -C of LDWORK. If INFO = 0 and JOBK = 'K', DWORK(2) returns -C an estimate of the reciprocal of the condition number -C 1/2 -C (in the 1-norm) of (RINOV ) . -C i -C -C LDWORK The length of the array DWORK. -C LDWORK >= MAX(1,N*(P+N+1),N*(P+N)+2*P,N*(N+M+2)), -C if JOBK = 'N'; -C LDWORK >= MAX(2,N*(P+N+1),N*(P+N)+2*P,N*(N+M+2),3*P), -C if JOBK = 'K'. -C For optimum performance LDWORK should be larger. -C -C Error Indicator -C -C INFO INTEGER -C = 0: successful exit; -C < 0: if INFO = -i, the i-th argument had an illegal -C value; -C 1/2 -C = 1: if JOBK = 'K' and the matrix (RINOV ) is singular, -C i 1/2 -C i.e., the condition number estimate of (RINOV ) -C i -C (in the 1-norm) exceeds 1/TOL. The matrices S, AK , -C 1/2 i -C and (RINOV ) have been computed. -C i -C -C METHOD -C -C The routine performs one recursion of the square root covariance -C filter algorithm, summarized as follows: -C -C | 1/2 | | 1/2 | -C | R 0 C x S | | (RINOV ) 0 0 | -C | i i-1 | | i | -C | 1/2 | T = | | -C | 0 B x Q A x S | | AK S 0 | -C | i i i-1 | | i i | -C -C (Pre-array) (Post-array) -C -C where T is unitary and (A,C) is in lower observer Hessenberg form. -C -C An example of the pre-array is given below (where N = 6, P = 2 -C and M = 3): -C -C |x | | x | -C |x x | | x x | -C |____|______|____________| -C | | x x x| x x x | -C | | x x x| x x x x | -C | | x x x| x x x x x | -C | | x x x| x x x x x x| -C | | x x x| x x x x x x| -C | | x x x| x x x x x x| -C -C The corresponding state covariance matrix P is then -C i|i-1 -C factorized as -C -C P = S S' -C i|i-1 i i -C -C and one combined time and measurement update for the state X -C i|i-1 -C is given by -C -C X = A X + K (Y - C X ) -C i+1|i i|i-1 i i i|i-1 -C -C -1/2 -C where K = AK (RINOV ) is the Kalman filter gain matrix and Y -C i i i i -C is the observed output of the system. -C -C The triangularization is done entirely via Householder -C transformations exploiting the zero pattern of the pre-array. -C -C REFERENCES -C -C [1] Anderson, B.D.O. and Moore, J.B. -C Optimal Filtering. -C Prentice Hall, Englewood Cliffs, New Jersey, 1979. -C -C [2] Van Dooren, P. and Verhaegen, M.H.G. -C Condensed Forms for Efficient Time-Invariant Kalman Filtering. -C SIAM J. Sci. Stat. Comp., 9. pp. 516-530, 1988. -C -C [3] Verhaegen, M.H.G. and Van Dooren, P. -C Numerical Aspects of Different Kalman Filter Implementations. -C IEEE Trans. Auto. Contr., AC-31, pp. 907-917, Oct. 1986. -C -C [4] Vanbegin, M., Van Dooren, P., and Verhaegen, M.H.G. -C Algorithm 675: FORTRAN Subroutines for Computing the Square -C Root Covariance Filter and Square Root Information Filter in -C Dense or Hessenberg Forms. -C ACM Trans. Math. Software, 15, pp. 243-256, 1989. -C -C NUMERICAL ASPECTS -C -C The algorithm requires -C -C 3 2 2 3 -C 1/6 x N + N x (3/2 x P + M) + 2 x N x P + 2/3 x P -C -C operations and is backward stable (see [3]). -C -C CONTRIBUTORS -C -C Release 3.0: V. Sima, Katholieke Univ. Leuven, Belgium, Feb. 1997. -C Supersedes Release 2.0 routine FB01FD by M. Vanbegin, -C P. Van Dooren, and M.H.G. Verhaegen. -C -C REVISIONS -C -C February 20, 1998, November 20, 2003, February 14, 2004. -C -C KEYWORDS -C -C Kalman filtering, observer Hessenberg form, optimal filtering, -C orthogonal transformation, recursive estimation, square-root -C covariance filtering, square-root filtering. -C -C ****************************************************************** -C -C .. Parameters .. - DOUBLE PRECISION ONE, TWO - PARAMETER ( ONE = 1.0D0, TWO = 2.0D0 ) -C .. Scalar Arguments .. - CHARACTER JOBK, MULTBQ - INTEGER INFO, LDA, LDB, LDC, LDK, LDQ, LDR, LDS, LDWORK, - $ M, N, P - DOUBLE PRECISION TOL -C .. Array Arguments .. - INTEGER IWORK(*) - DOUBLE PRECISION A(LDA,*), B(LDB,*), C(LDC,*), DWORK(*), - $ K(LDK,*), Q(LDQ,*), R(LDR,*), S(LDS,*) -C .. Local Scalars .. - LOGICAL LJOBK, LMULTB - INTEGER I, II, ITAU, JWORK, N1, PL, PN, WRKOPT - DOUBLE PRECISION RCOND -C .. External Functions .. - LOGICAL LSAME - EXTERNAL LSAME -C .. External Subroutines .. - EXTERNAL DCOPY, DLACPY, DTRMM, DTRMV, MB02OD, MB04JD, - $ MB04LD, XERBLA -C .. Intrinsic Functions .. - INTRINSIC INT, MAX, MIN -C .. Executable Statements .. -C - PN = P + N - N1 = MAX( 1, N ) - INFO = 0 - LJOBK = LSAME( JOBK, 'K' ) - LMULTB = LSAME( MULTBQ, 'P' ) -C -C Test the input scalar arguments. -C - IF( .NOT.LJOBK .AND. .NOT.LSAME( JOBK, 'N' ) ) THEN - INFO = -1 - ELSE IF( .NOT.LMULTB .AND. .NOT.LSAME( MULTBQ, 'N' ) ) THEN - INFO = -2 - ELSE IF( N.LT.0 ) THEN - INFO = -3 - ELSE IF( M.LT.0 ) THEN - INFO = -4 - ELSE IF( P.LT.0 ) THEN - INFO = -5 - ELSE IF( LDS.LT.N1 ) THEN - INFO = -7 - ELSE IF( LDA.LT.N1 ) THEN - INFO = -9 - ELSE IF( LDB.LT.N1 ) THEN - INFO = -11 - ELSE IF( LDQ.LT.1 .OR. ( .NOT.LMULTB .AND. LDQ.LT.M ) ) THEN - INFO = -13 - ELSE IF( LDC.LT.MAX( 1, P ) ) THEN - INFO = -15 - ELSE IF( LDR.LT.MAX( 1, P ) ) THEN - INFO = -17 - ELSE IF( LDK.LT.N1 ) THEN - INFO = -19 - ELSE IF( ( LJOBK .AND. LDWORK.LT.MAX( 2, PN*N + N, PN*N + 2*P, - $ N*(N + M + 2), 3*P ) ) .OR. - $ ( .NOT.LJOBK .AND. LDWORK.LT.MAX( 1, PN*N + N, PN*N + 2*P, - $ N*(N + M + 2) ) ) ) THEN - INFO = -23 - END IF -C - IF ( INFO.NE.0 ) THEN -C -C Error return. -C - CALL XERBLA( 'FB01RD', -INFO ) - RETURN - END IF -C -C Quick return if possible. -C - IF ( N.EQ.0 ) THEN - IF ( LJOBK ) THEN - DWORK(1) = TWO - DWORK(2) = ONE - ELSE - DWORK(1) = ONE - END IF - RETURN - END IF -C -C Construction of the needed part of the pre-array in DWORK. -C To save workspace, only the blocks (1,3), (2,2), and (2,3) will be -C constructed as shown below. -C -C Storing C x S and A x S in the (1,1) and (2,1) blocks of DWORK, -C respectively. The lower trapezoidal structure of [ C' A' ]' is -C fully exploited. Specifically, if P <= N, the following partition -C is used: -C -C [ C1 0 ] [ S1 0 ] -C [ A1 A3 ] [ S2 S3 ], -C [ A2 A4 ] -C -C where C1, S1, and A2 are P-by-P matrices, A1 and S2 are -C (N-P)-by-P, A3 and S3 are (N-P)-by-(N-P), A4 is P-by-(N-P), and -C C1, S1, A3, and S3 are lower triangular. The left hand side -C matrix above is stored in the workspace. If P > N, the partition -C is: -C -C [ C1 ] -C [ C2 ] [ S ], -C [ A ] -C -C where C1 and C2 are N-by-N and (P-N)-by-N matrices, respectively, -C and C1 and S are lower triangular. -C -C Workspace: need (P+N)*N. -C -C (Note: Comments in the code beginning "Workspace:" describe the -C minimal amount of real workspace needed at that point in the -C code, as well as the preferred amount for good performance. -C NB refers to the optimal block size for the immediately -C following subroutine, as returned by ILAENV.) -C - CALL DLACPY( 'Lower', P, MIN( N, P ), C, LDC, DWORK, PN ) - CALL DLACPY( 'Full', N, MIN( N, P ), A, LDA, DWORK(P+1), PN ) - IF ( N.GT.P ) - $ CALL DLACPY( 'Lower', N, N-P, A(1,P+1), LDA, DWORK(P*PN+P+1), - $ PN ) -C -C [ C1 0 ] -C Compute [ ] x S or C1 x S as a product of lower triangular -C [ A1 A3 ] -C matrices. -C Workspace: need (P+N+1)*N. -C - II = 1 - PL = N*PN + 1 - WRKOPT = PL + N - 1 -C - DO 10 I = 1, N - CALL DCOPY( N-I+1, S(I,I), 1, DWORK(PL), 1 ) - CALL DTRMV( 'Lower', 'No transpose', 'Non-unit', N-I+1, - $ DWORK(II), PN, DWORK(PL), 1 ) - CALL DCOPY( N-I+1, DWORK(PL), 1, DWORK(II), 1 ) - II = II + PN + 1 - 10 CONTINUE -C -C Compute [ A2 A4 ] x S. -C - CALL DTRMM( 'Right', 'Lower', 'No transpose', 'Non-unit', P, N, - $ ONE, S, LDS, DWORK(N+1), PN ) -C -C Triangularization (2 steps). -C -C Step 1: annihilate the matrix C x S (hence C1 x S1, if P <= N). -C Workspace: need (N+P)*N + 2*P. -C - ITAU = PL - JWORK = ITAU + P -C - CALL MB04LD( 'Lower', P, N, N, R, LDR, DWORK, PN, DWORK(P+1), PN, - $ K, LDK, DWORK(ITAU), DWORK(JWORK) ) - WRKOPT = MAX( WRKOPT, PN*N + 2*P ) -C -C Now, the workspace for C x S is no longer needed. -C Adjust the leading dimension of DWORK, to save space for the -C following computations, and make room for B x Q. -C - CALL DLACPY( 'Full', N, N, DWORK(P+1), PN, DWORK, N ) -C - DO 20 I = N*( N - 1 ) + 1, 1, -N - CALL DCOPY( N, DWORK(I), 1, DWORK(I+N*M), 1 ) - 20 CONTINUE -C -C Storing B x Q in the (1,1) block of DWORK. -C Workspace: need N*(M+N). -C - CALL DLACPY( 'Full', N, M, B, LDB, DWORK, N ) - IF ( .NOT.LMULTB ) - $ CALL DTRMM( 'Right', 'Lower', 'No transpose', 'Non-unit', N, M, - $ ONE, Q, LDQ, DWORK, N ) -C -C Step 2: LQ triangularization of the matrix [ B x Q A x S ], where -C A x S was modified at Step 1. -C Workspace: need N*(N+M+2); -C prefer N*(N+M+1)+(P+1)*NB, where NB is the optimal -C block size for DGELQF (called in MB04JD). -C - ITAU = N*( M + N ) + 1 - JWORK = ITAU + N -C - CALL MB04JD( N, M+N, MAX( N-P-1, 0 ), 0, DWORK, N, DWORK, N, - $ DWORK(ITAU), DWORK(JWORK), LDWORK-JWORK+1, INFO ) - WRKOPT = MAX( WRKOPT, INT( DWORK(JWORK) )+JWORK-1 ) -C -C Output S and K (if needed) and set the optimal workspace -C dimension (and the reciprocal of the condition number estimate). -C - CALL DLACPY( 'Lower', N, N, DWORK, N, S, LDS ) -C - IF ( LJOBK ) THEN -C -C Compute K. -C Workspace: need 3*P. -C - CALL MB02OD( 'Right', 'Lower', 'No transpose', 'Non-unit', - $ '1-norm', N, P, ONE, R, LDR, K, LDK, RCOND, TOL, - $ IWORK, DWORK, INFO ) - IF ( INFO.EQ.0 ) THEN - WRKOPT = MAX( WRKOPT, 3*P ) - DWORK(2) = RCOND - END IF - END IF -C - DWORK(1) = WRKOPT -C - RETURN -C *** Last line of FB01RD *** - END diff --git a/mex/sources/libslicot/FB01SD.f b/mex/sources/libslicot/FB01SD.f deleted file mode 100644 index 41783fc2e..000000000 --- a/mex/sources/libslicot/FB01SD.f +++ /dev/null @@ -1,597 +0,0 @@ - SUBROUTINE FB01SD( JOBX, MULTAB, MULTRC, N, M, P, SINV, LDSINV, - $ AINV, LDAINV, B, LDB, RINV, LDRINV, C, LDC, - $ QINV, LDQINV, X, RINVY, Z, E, TOL, IWORK, - $ DWORK, LDWORK, INFO ) -C -C SLICOT RELEASE 5.0. -C -C Copyright (c) 2002-2009 NICONET e.V. -C -C This program is free software: you can redistribute it and/or -C modify it under the terms of the GNU General Public License as -C published by the Free Software Foundation, either version 2 of -C the License, or (at your option) any later version. -C -C This program is distributed in the hope that it will be useful, -C but WITHOUT ANY WARRANTY; without even the implied warranty of -C MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the -C GNU General Public License for more details. -C -C You should have received a copy of the GNU General Public License -C along with this program. If not, see -C . -C -C PURPOSE -C -C To calculate a combined measurement and time update of one -C iteration of the time-varying Kalman filter. This update is given -C for the square root information filter, using dense matrices. -C -C ARGUMENTS -C -C Mode Parameters -C -C JOBX CHARACTER*1 -C Indicates whether X is to be computed as follows: -C i+1 -C = 'X': X is computed and stored in array X; -C i+1 -C = 'N': X is not required. -C i+1 -C -C MULTAB CHARACTER*1 -1 -C Indicates how matrices A and B are to be passed to -C i i -C the routine as follows: -1 -C = 'P': Array AINV must contain the matrix A and the -C -1 i -C array B must contain the product A B ; -C i i -C = 'N': Arrays AINV and B must contain the matrices -C as described below. -C -C MULTRC CHARACTER*1 -1/2 -C Indicates how matrices R and C are to be passed to -C i+1 i+1 -C the routine as follows: -C = 'P': Array RINV is not used and the array C must -C -1/2 -C contain the product R C ; -C i+1 i+1 -C = 'N': Arrays RINV and C must contain the matrices -C as described below. -C -C Input/Output Parameters -C -C N (input) INTEGER -C The actual state dimension, i.e., the order of the -C -1 -1 -C matrices S and A . N >= 0. -C i i -C -C M (input) INTEGER -C The actual input dimension, i.e., the order of the matrix -C -1/2 -C Q . M >= 0. -C i -C -C P (input) INTEGER -C The actual output dimension, i.e., the order of the matrix -C -1/2 -C R . P >= 0. -C i+1 -C -C SINV (input/output) DOUBLE PRECISION array, dimension -C (LDSINV,N) -C On entry, the leading N-by-N upper triangular part of this -C -1 -C array must contain S , the inverse of the square root -C i -C (right Cholesky factor) of the state covariance matrix -C P (hence the information square root) at instant i. -C i|i -C On exit, the leading N-by-N upper triangular part of this -C -1 -C array contains S , the inverse of the square root (right -C i+1 -C Cholesky factor) of the state covariance matrix P -C i+1|i+1 -C (hence the information square root) at instant i+1. -C The strict lower triangular part of this array is not -C referenced. -C -C LDSINV INTEGER -C The leading dimension of array SINV. LDSINV >= MAX(1,N). -C -C AINV (input) DOUBLE PRECISION array, dimension (LDAINV,N) -C -1 -C The leading N-by-N part of this array must contain A , -C i -C the inverse of the state transition matrix of the discrete -C system at instant i. -C -C LDAINV INTEGER -C The leading dimension of array AINV. LDAINV >= MAX(1,N). -C -C B (input) DOUBLE PRECISION array, dimension (LDB,M) -C The leading N-by-M part of this array must contain B , -C -1 i -C the input weight matrix (or the product A B if -C i i -C MULTAB = 'P') of the discrete system at instant i. -C -C LDB INTEGER -C The leading dimension of array B. LDB >= MAX(1,N). -C -C RINV (input) DOUBLE PRECISION array, dimension (LDRINV,*) -C If MULTRC = 'N', then the leading P-by-P upper triangular -C -1/2 -C part of this array must contain R , the inverse of the -C i+1 -C covariance square root (right Cholesky factor) of the -C output (measurement) noise (hence the information square -C root) at instant i+1. -C The strict lower triangular part of this array is not -C referenced. -C Otherwise, RINV is not referenced and can be supplied as a -C dummy array (i.e., set parameter LDRINV = 1 and declare -C this array to be RINV(1,1) in the calling program). -C -C LDRINV INTEGER -C The leading dimension of array RINV. -C LDRINV >= MAX(1,P) if MULTRC = 'N'; -C LDRINV >= 1 if MULTRC = 'P'. -C -C C (input) DOUBLE PRECISION array, dimension (LDC,N) -C The leading P-by-N part of this array must contain C , -C -1/2 i+1 -C the output weight matrix (or the product R C if -C i+1 i+1 -C MULTRC = 'P') of the discrete system at instant i+1. -C -C LDC INTEGER -C The leading dimension of array C. LDC >= MAX(1,P). -C -C QINV (input/output) DOUBLE PRECISION array, dimension -C (LDQINV,M) -C On entry, the leading M-by-M upper triangular part of this -C -1/2 -C array must contain Q , the inverse of the covariance -C i -C square root (right Cholesky factor) of the input (process) -C noise (hence the information square root) at instant i. -C On exit, the leading M-by-M upper triangular part of this -C -1/2 -C array contains (QINOV ) , the inverse of the covariance -C i -C square root (right Cholesky factor) of the process noise -C innovation (hence the information square root) at -C instant i. -C The strict lower triangular part of this array is not -C referenced. -C -C LDQINV INTEGER -C The leading dimension of array QINV. LDQINV >= MAX(1,M). -C -C X (input/output) DOUBLE PRECISION array, dimension (N) -C On entry, this array must contain X , the estimated -C i -C filtered state at instant i. -C On exit, if JOBX = 'X', and INFO = 0, then this array -C contains X , the estimated filtered state at -C i+1 -C instant i+1. -C On exit, if JOBX = 'N', or JOBX = 'X' and INFO = 1, then -C -1 -C this array contains S X . -C i+1 i+1 -C -C RINVY (input) DOUBLE PRECISION array, dimension (P) -C -1/2 -C This array must contain R Y , the product of the -C i+1 i+1 -C -1/2 -C upper triangular matrix R and the measured output -C i+1 -C vector Y at instant i+1. -C i+1 -C -C Z (input) DOUBLE PRECISION array, dimension (M) -C This array must contain Z , the mean value of the state -C i -C process noise at instant i. -C -C E (output) DOUBLE PRECISION array, dimension (P) -C This array contains E , the estimated error at instant -C i+1 -C i+1. -C -C Tolerances -C -C TOL DOUBLE PRECISION -C If JOBX = 'X', then TOL is used to test for near -C -1 -C singularity of the matrix S . If the user sets -C i+1 -C TOL > 0, then the given value of TOL is used as a -C lower bound for the reciprocal condition number of that -C matrix; a matrix whose estimated condition number is less -C than 1/TOL is considered to be nonsingular. If the user -C sets TOL <= 0, then an implicitly computed, default -C tolerance, defined by TOLDEF = N*N*EPS, is used instead, -C where EPS is the machine precision (see LAPACK Library -C routine DLAMCH). -C Otherwise, TOL is not referenced. -C -C Workspace -C -C IWORK INTEGER array, dimension (LIWORK) -C where LIWORK = N if JOBX = 'X', -C and LIWORK = 1 otherwise. -C -C DWORK DOUBLE PRECISION array, dimension (LDWORK) -C On exit, if INFO = 0, DWORK(1) returns the optimal value -C of LDWORK. If INFO = 0 and JOBX = 'X', DWORK(2) returns -C an estimate of the reciprocal of the condition number -C -1 -C (in the 1-norm) of S . -C i+1 -C -C LDWORK The length of the array DWORK. -C LDWORK >= MAX(1,N*(N+2*M)+3*M,(N+P)*(N+1)+2*N), -C if JOBX = 'N'; -C LDWORK >= MAX(2,N*(N+2*M)+3*M,(N+P)*(N+1)+2*N,3*N), -C if JOBX = 'X'. -C For optimum performance LDWORK should be larger. -C -C Error Indicator -C -C INFO INTEGER -C = 0: successful exit; -C < 0: if INFO = -i, the i-th argument had an illegal -C value; -1 -C = 1: if JOBX = 'X' and the matrix S is singular, -C i+1 -1 -C i.e., the condition number estimate of S (in the -C i+1 -C -1 -1/2 -C 1-norm) exceeds 1/TOL. The matrices S , Q -C i+1 i -C and E have been computed. -C -C METHOD -C -C The routine performs one recursion of the square root information -C filter algorithm, summarized as follows: -C -C | -1/2 -1/2 | | -1/2 | -C | Q 0 Q Z | | (QINOV ) * * | -C | i i i | | i | -C | | | | -C | -1 -1 -1 -1 -1 | | -1 -1 | -C T | S A B S A S X | = | 0 S S X | -C | i i i i i i i | | i+1 i+1 i+1| -C | | | | -C | -1/2 -1/2 | | | -C | 0 R C R Y | | 0 0 E | -C | i+1 i+1 i+1 i+1| | i+1 | -C -C (Pre-array) (Post-array) -C -C where T is an orthogonal transformation triangularizing the -C -1/2 -C pre-array, (QINOV ) is the inverse of the covariance square -C i -C root (right Cholesky factor) of the process noise innovation -C (hence the information square root) at instant i, and E is the -C i+1 -C estimated error at instant i+1. -C -C The inverse of the corresponding state covariance matrix P -C i+1|i+1 -C (hence the information matrix I) is then factorized as -C -C -1 -1 -1 -C I = P = (S )' S -C i+1|i+1 i+1|i+1 i+1 i+1 -C -C and one combined time and measurement update for the state is -C given by X . -C i+1 -C -C The triangularization is done entirely via Householder -C transformations exploiting the zero pattern of the pre-array. -C -C REFERENCES -C -C [1] Anderson, B.D.O. and Moore, J.B. -C Optimal Filtering. -C Prentice Hall, Englewood Cliffs, New Jersey, 1979. -C -C [2] Verhaegen, M.H.G. and Van Dooren, P. -C Numerical Aspects of Different Kalman Filter Implementations. -C IEEE Trans. Auto. Contr., AC-31, pp. 907-917, Oct. 1986. -C -C [3] Vanbegin, M., Van Dooren, P., and Verhaegen, M.H.G. -C Algorithm 675: FORTRAN Subroutines for Computing the Square -C Root Covariance Filter and Square Root Information Filter in -C Dense or Hessenberg Forms. -C ACM Trans. Math. Software, 15, pp. 243-256, 1989. -C -C NUMERICAL ASPECTS -C -C The algorithm requires approximately -C -C 3 2 2 2 -C (7/6)N + N x (7/2 x M + P) + N x (1/2 x P + M ) -C -C operations and is backward stable (see [2]). -C -C CONTRIBUTORS -C -C Release 3.0: V. Sima, Katholieke Univ. Leuven, Belgium, Feb. 1997. -C Supersedes Release 2.0 routine FB01GD by M. Vanbegin, -C P. Van Dooren, and M.H.G. Verhaegen. -C -C REVISIONS -C -C February 20, 1998, November 20, 2003, February 14, 2004. -C -C KEYWORDS -C -C Kalman filtering, optimal filtering, orthogonal transformation, -C recursive estimation, square-root filtering, square-root -C information filtering. -C -C ****************************************************************** -C -C .. Parameters .. - DOUBLE PRECISION ZERO, ONE, TWO - PARAMETER ( ZERO = 0.0D0, ONE = 1.0D0, TWO = 2.0D0 ) -C .. Scalar Arguments .. - CHARACTER JOBX, MULTAB, MULTRC - INTEGER INFO, LDAINV, LDB, LDC, LDQINV, LDRINV, LDSINV, - $ LDWORK, M, N, P - DOUBLE PRECISION TOL -C .. Array Arguments .. - INTEGER IWORK(*) - DOUBLE PRECISION AINV(LDAINV,*), B(LDB,*), C(LDC,*), DWORK(*), - $ E(*), QINV(LDQINV,*), RINV(LDRINV,*), RINVY(*), - $ SINV(LDSINV,*), X(*), Z(*) -C .. Local Scalars .. - LOGICAL LJOBX, LMULTA, LMULTR - INTEGER I, I12, I13, I21, I23, IJ, ITAU, JWORK, LDW, M1, - $ N1, NP, WRKOPT - DOUBLE PRECISION RCOND -C .. External Functions .. - LOGICAL LSAME - DOUBLE PRECISION DDOT - EXTERNAL DDOT, LSAME -C .. External Subroutines .. - EXTERNAL DAXPY, DCOPY, DGEMM, DGEQRF, DLACPY, DORMQR, - $ DTRMM, DTRMV, MB02OD, MB04KD, XERBLA -C .. Intrinsic Functions .. - INTRINSIC INT, MAX -C .. Executable Statements .. -C - NP = N + P - N1 = MAX( 1, N ) - M1 = MAX( 1, M ) - INFO = 0 - LJOBX = LSAME( JOBX, 'X' ) - LMULTA = LSAME( MULTAB, 'P' ) - LMULTR = LSAME( MULTRC, 'P' ) -C -C Test the input scalar arguments. -C - IF( .NOT.LJOBX .AND. .NOT.LSAME( JOBX, 'N' ) ) THEN - INFO = -1 - ELSE IF( .NOT.LMULTA .AND. .NOT.LSAME( MULTAB, 'N' ) ) THEN - INFO = -2 - ELSE IF( .NOT.LMULTR .AND. .NOT.LSAME( MULTRC, 'N' ) ) THEN - INFO = -3 - ELSE IF( N.LT.0 ) THEN - INFO = -4 - ELSE IF( M.LT.0 ) THEN - INFO = -5 - ELSE IF( P.LT.0 ) THEN - INFO = -6 - ELSE IF( LDSINV.LT.N1 ) THEN - INFO = -8 - ELSE IF( LDAINV.LT.N1 ) THEN - INFO = -10 - ELSE IF( LDB.LT.N1 ) THEN - INFO = -12 - ELSE IF( LDRINV.LT.1 .OR. ( .NOT.LMULTR .AND. LDRINV.LT.P ) ) THEN - INFO = -14 - ELSE IF( LDC.LT.MAX( 1, P ) ) THEN - INFO = -16 - ELSE IF( LDQINV.LT.M1 ) THEN - INFO = -18 - ELSE IF( ( LJOBX .AND. LDWORK.LT.MAX( 2, N*(N + 2*M) + 3*M, - $ NP*(N + 1) + 2*N, 3*N ) ) - $ .OR. - $ ( .NOT.LJOBX .AND. LDWORK.LT.MAX( 1, N*(N + 2*M) + 3*M, - $ NP*(N + 1) + 2*N ) ) ) THEN - INFO = -26 - END IF -C - IF ( INFO.NE.0 ) THEN -C -C Error return. -C - CALL XERBLA( 'FB01SD', -INFO ) - RETURN - END IF -C -C Quick return if possible. -C - IF ( MAX( N, P ).EQ.0 ) THEN - IF ( LJOBX ) THEN - DWORK(1) = TWO - DWORK(2) = ONE - ELSE - DWORK(1) = ONE - END IF - RETURN - END IF -C -C Construction of the needed part of the pre-array in DWORK. -C To save workspace, only the blocks (1,3), (2,1)-(2,3), (3,2), and -C (3,3) will be constructed when needed as shown below. -C -C Storing SINV x AINV and SINV x AINV x B in the (1,1) and (1,2) -C blocks of DWORK, respectively. -C The variables called Ixy define the starting positions where the -C (x,y) blocks of the pre-array are initially stored in DWORK. -C Workspace: need N*(N+M). -C -C (Note: Comments in the code beginning "Workspace:" describe the -C minimal amount of real workspace needed at that point in the -C code, as well as the preferred amount for good performance. -C NB refers to the optimal block size for the immediately -C following subroutine, as returned by ILAENV.) -C - LDW = N1 - I21 = N*N + 1 -C - CALL DLACPY( 'Full', N, N, AINV, LDAINV, DWORK, LDW ) - IF ( LMULTA ) THEN - CALL DLACPY( 'Full', N, M, B, LDB, DWORK(I21), LDW ) - ELSE - CALL DGEMM( 'No transpose', 'No transpose', N, M, N, ONE, - $ DWORK, LDW, B, LDB, ZERO, DWORK(I21), LDW ) - END IF - CALL DTRMM( 'Left', 'Upper', 'No transpose', 'Non-unit', N, N+M, - $ ONE, SINV, LDSINV, DWORK, LDW ) -C -C Storing the process noise mean value in (1,3) block of DWORK. -C Workspace: need N*(N+M) + M. -C - I13 = N*( N + M ) + 1 -C - CALL DCOPY( M, Z, 1, DWORK(I13), 1 ) - CALL DTRMV( 'Upper', 'No transpose', 'Non-unit', M, QINV, LDQINV, - $ DWORK(I13), 1 ) -C -C Computing SINV x X in X. -C - CALL DTRMV( 'Upper', 'No transpose', 'Non-unit', N, SINV, LDSINV, - $ X, 1 ) -C -C Triangularization (2 steps). -C -C Step 1: annihilate the matrix SINV x AINV x B. -C Workspace: need N*(N+2*M) + 3*M. -C - I12 = I13 + M - ITAU = I12 + M*N - JWORK = ITAU + M -C - CALL MB04KD( 'Full', M, N, N, QINV, LDQINV, DWORK(I21), LDW, - $ DWORK, LDW, DWORK(I12), M1, DWORK(ITAU), - $ DWORK(JWORK) ) - WRKOPT = MAX( 1, N*( N + 2*M ) + 3*M ) -C - IF ( N.EQ.0 ) THEN - CALL DCOPY( P, RINVY, 1, E, 1 ) - IF ( LJOBX ) - $ DWORK(2) = ONE - DWORK(1) = WRKOPT - RETURN - END IF -C -C Apply the transformations to the last column of the pre-array. -C (Only the updated (2,3) block is now needed.) -C - IJ = I21 -C - DO 10 I = 1, M - CALL DAXPY( N, -DWORK(ITAU+I-1)*( DWORK(I13+I-1) + - $ DDOT( N, DWORK(IJ), 1, X, 1 ) ), - $ DWORK(IJ), 1, X, 1 ) - IJ = IJ + N - 10 CONTINUE -C -C Now, the workspace for SINV x AINV x B, as well as for the updated -C (1,2) block of the pre-array, are no longer needed. -C Move the computed (2,3) block of the pre-array in the (1,2) block -C position of DWORK, to save space for the following computations. -C Then, adjust the implicitly defined leading dimension of DWORK, -C to make space for storing the (3,2) and (3,3) blocks of the -C pre-array. -C Workspace: need (N+P)*(N+1). -C - CALL DCOPY( N, X, 1, DWORK(I21), 1 ) - LDW = MAX( 1, NP ) -C - DO 30 I = N + 1, 1, -1 - DO 20 IJ = N, 1, -1 - DWORK(NP*(I-1)+IJ) = DWORK(N*(I-1)+IJ) - 20 CONTINUE - 30 CONTINUE -C -C Copy of RINV x C in the (2,1) block of DWORK. -C - CALL DLACPY( 'Full', P, N, C, LDC, DWORK(N+1), LDW ) - IF ( .NOT.LMULTR ) - $ CALL DTRMM( 'Left', 'Upper', 'No transpose', 'Non-unit', P, N, - $ ONE, RINV, LDRINV, DWORK(N+1), LDW ) -C -C Copy the inclusion measurement in the (2,2) block of DWORK. -C - I21 = NP*N + 1 - I23 = I21 + N - CALL DCOPY( P, RINVY, 1, DWORK(I23), 1 ) - WRKOPT = MAX( WRKOPT, NP*( N + 1 ) ) -C -C Step 2: QR factorization of the first block column of the matrix -C -C [ SINV x AINV SINV x X ] -C [ RINV x C RINV x Y ], -C -C where the first block row was modified at Step 1. -C Workspace: need (N+P)*(N+1) + 2*N; -C prefer (N+P)*(N+1) + N + N*NB. -C - ITAU = I21 + NP - JWORK = ITAU + N -C - CALL DGEQRF( NP, N, DWORK, LDW, DWORK(ITAU), DWORK(JWORK), - $ LDWORK-JWORK+1, INFO ) - WRKOPT = MAX( WRKOPT, INT( DWORK(JWORK) )+JWORK-1 ) -C -C Apply the Householder transformations to the last column. -C Workspace: need (N+P)*(N+1) + 1; prefer (N+P)*(N+1) + NB. -C - CALL DORMQR( 'Left', 'Transpose', NP, 1, N, DWORK, LDW, - $ DWORK(ITAU), DWORK(I21), LDW, DWORK(JWORK), - $ LDWORK-JWORK+1, INFO ) - WRKOPT = MAX( WRKOPT, INT( DWORK(JWORK) )+JWORK-1 ) -C -C Output SINV, X, and E and set the optimal workspace dimension -C (and the reciprocal of the condition number estimate). -C - CALL DLACPY( 'Upper', N, N, DWORK, LDW, SINV, LDSINV ) - CALL DCOPY( N, DWORK(I21), 1, X, 1 ) - CALL DCOPY( P, DWORK(I23), 1, E, 1 ) -C - IF ( LJOBX ) THEN -C -C Compute X. -C Workspace: need 3*N. -C - CALL MB02OD( 'Left', 'Upper', 'No transpose', 'Non-unit', - $ '1-norm', N, 1, ONE, SINV, LDSINV, X, N, RCOND, - $ TOL, IWORK, DWORK, INFO ) - IF ( INFO.EQ.0 ) THEN - WRKOPT = MAX( WRKOPT, 3*N ) - DWORK(2) = RCOND - END IF - END IF -C - DWORK(1) = WRKOPT -C - RETURN -C *** Last line of FB01SD *** - END diff --git a/mex/sources/libslicot/FB01TD.f b/mex/sources/libslicot/FB01TD.f deleted file mode 100644 index f248de0d9..000000000 --- a/mex/sources/libslicot/FB01TD.f +++ /dev/null @@ -1,641 +0,0 @@ - SUBROUTINE FB01TD( JOBX, MULTRC, N, M, P, SINV, LDSINV, AINV, - $ LDAINV, AINVB, LDAINB, RINV, LDRINV, C, LDC, - $ QINV, LDQINV, X, RINVY, Z, E, TOL, IWORK, - $ DWORK, LDWORK, INFO ) -C -C SLICOT RELEASE 5.0. -C -C Copyright (c) 2002-2009 NICONET e.V. -C -C This program is free software: you can redistribute it and/or -C modify it under the terms of the GNU General Public License as -C published by the Free Software Foundation, either version 2 of -C the License, or (at your option) any later version. -C -C This program is distributed in the hope that it will be useful, -C but WITHOUT ANY WARRANTY; without even the implied warranty of -C MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the -C GNU General Public License for more details. -C -C You should have received a copy of the GNU General Public License -C along with this program. If not, see -C . -C -C PURPOSE -C -C To calculate a combined measurement and time update of one -C iteration of the time-invariant Kalman filter. This update is -C given for the square root information filter, using the condensed -C controller Hessenberg form. -C -C ARGUMENTS -C -C Mode Parameters -C -C JOBX CHARACTER*1 -C Indicates whether X is to be computed as follows: -C i+1 -C = 'X': X is computed and stored in array X; -C i+1 -C = 'N': X is not required. -C i+1 -C -C MULTRC CHARACTER*1 -1/2 -C Indicates how matrices R and C are to be passed to -C i+1 i+1 -C the routine as follows: -C = 'P': Array RINV is not used and the array C must -C -1/2 -C contain the product R C ; -C i+1 i+1 -C = 'N': Arrays RINV and C must contain the matrices -C as described below. -C -C Input/Output Parameters -C -C N (input) INTEGER -C The actual state dimension, i.e., the order of the -C -1 -1 -C matrices S and A . N >= 0. -C i -C -C M (input) INTEGER -C The actual input dimension, i.e., the order of the matrix -C -1/2 -C Q . M >= 0. -C i -C -C P (input) INTEGER -C The actual output dimension, i.e., the order of the matrix -C -1/2 -C R . P >= 0. -C i+1 -C -C SINV (input/output) DOUBLE PRECISION array, dimension -C (LDSINV,N) -C On entry, the leading N-by-N upper triangular part of this -C -1 -C array must contain S , the inverse of the square root -C i -C (right Cholesky factor) of the state covariance matrix -C P (hence the information square root) at instant i. -C i|i -C On exit, the leading N-by-N upper triangular part of this -C -1 -C array contains S , the inverse of the square root (right -C i+1 -C Cholesky factor) of the state covariance matrix P -C i+1|i+1 -C (hence the information square root) at instant i+1. -C The strict lower triangular part of this array is not -C referenced. -C -C LDSINV INTEGER -C The leading dimension of array SINV. LDSINV >= MAX(1,N). -C -C AINV (input) DOUBLE PRECISION array, dimension (LDAINV,N) -C -1 -C The leading N-by-N part of this array must contain A , -C the inverse of the state transition matrix of the discrete -C system in controller Hessenberg form (e.g., as produced by -C SLICOT Library Routine TB01MD). -C -C LDAINV INTEGER -C The leading dimension of array AINV. LDAINV >= MAX(1,N). -C -C AINVB (input) DOUBLE PRECISION array, dimension (LDAINB,M) -C -1 -C The leading N-by-M part of this array must contain A B, -C -1 -C the product of A and the input weight matrix B of the -C discrete system, in upper controller Hessenberg form -C (e.g., as produced by SLICOT Library Routine TB01MD). -C -C LDAINB INTEGER -C The leading dimension of array AINVB. LDAINB >= MAX(1,N). -C -C RINV (input) DOUBLE PRECISION array, dimension (LDRINV,*) -C If MULTRC = 'N', then the leading P-by-P upper triangular -C -1/2 -C part of this array must contain R , the inverse of the -C i+1 -C covariance square root (right Cholesky factor) of the -C output (measurement) noise (hence the information square -C root) at instant i+1. -C The strict lower triangular part of this array is not -C referenced. -C Otherwise, RINV is not referenced and can be supplied as a -C dummy array (i.e., set parameter LDRINV = 1 and declare -C this array to be RINV(1,1) in the calling program). -C -C LDRINV INTEGER -C The leading dimension of array RINV. -C LDRINV >= MAX(1,P) if MULTRC = 'N'; -C LDRINV >= 1 if MULTRC = 'P'. -C -C C (input) DOUBLE PRECISION array, dimension (LDC,N) -C The leading P-by-N part of this array must contain C , -C -1/2 i+1 -C the output weight matrix (or the product R C if -C i+1 i+1 -C MULTRC = 'P') of the discrete system at instant i+1. -C -C LDC INTEGER -C The leading dimension of array C. LDC >= MAX(1,P). -C -C QINV (input/output) DOUBLE PRECISION array, dimension -C (LDQINV,M) -C On entry, the leading M-by-M upper triangular part of this -C -1/2 -C array must contain Q , the inverse of the covariance -C i -C square root (right Cholesky factor) of the input (process) -C noise (hence the information square root) at instant i. -C On exit, the leading M-by-M upper triangular part of this -C -1/2 -C array contains (QINOV ) , the inverse of the covariance -C i -C square root (right Cholesky factor) of the process noise -C innovation (hence the information square root) at -C instant i. -C The strict lower triangular part of this array is not -C referenced. -C -C LDQINV INTEGER -C The leading dimension of array QINV. LDQINV >= MAX(1,M). -C -C X (input/output) DOUBLE PRECISION array, dimension (N) -C On entry, this array must contain X , the estimated -C i -C filtered state at instant i. -C On exit, if JOBX = 'X', and INFO = 0, then this array -C contains X , the estimated filtered state at -C i+1 -C instant i+1. -C On exit, if JOBX = 'N', or JOBX = 'X' and INFO = 1, then -C -1 -C this array contains S X . -C i+1 i+1 -C -C RINVY (input) DOUBLE PRECISION array, dimension (P) -C -1/2 -C This array must contain R Y , the product of the -C i+1 i+1 -C -1/2 -C upper triangular matrix R and the measured output -C i+1 -C vector Y at instant i+1. -C i+1 -C -C Z (input) DOUBLE PRECISION array, dimension (M) -C This array must contain Z , the mean value of the state -C i -C process noise at instant i. -C -C E (output) DOUBLE PRECISION array, dimension (P) -C This array contains E , the estimated error at instant -C i+1 -C i+1. -C -C Tolerances -C -C TOL DOUBLE PRECISION -C If JOBX = 'X', then TOL is used to test for near -C -1 -C singularity of the matrix S . If the user sets -C i+1 -C TOL > 0, then the given value of TOL is used as a -C lower bound for the reciprocal condition number of that -C matrix; a matrix whose estimated condition number is less -C than 1/TOL is considered to be nonsingular. If the user -C sets TOL <= 0, then an implicitly computed, default -C tolerance, defined by TOLDEF = N*N*EPS, is used instead, -C where EPS is the machine precision (see LAPACK Library -C routine DLAMCH). -C Otherwise, TOL is not referenced. -C -C Workspace -C -C IWORK INTEGER array, dimension (LIWORK) -C where LIWORK = N if JOBX = 'X', -C and LIWORK = 1 otherwise. -C -C DWORK DOUBLE PRECISION array, dimension (LDWORK) -C On exit, if INFO = 0, DWORK(1) returns the optimal value -C of LDWORK. If INFO = 0 and JOBX = 'X', DWORK(2) returns -C an estimate of the reciprocal of the condition number -C -1 -C (in the 1-norm) of S . -C i+1 -C -C LDWORK The length of the array DWORK. -C LDWORK >= MAX(1,N*(N+2*M)+3*M,(N+P)*(N+1)+N+MAX(N-1,M+1)), -C if JOBX = 'N'; -C LDWORK >= MAX(2,N*(N+2*M)+3*M,(N+P)*(N+1)+N+MAX(N-1,M+1), -C 3*N), if JOBX = 'X'. -C For optimum performance LDWORK should be larger. -C -C Error Indicator -C -C INFO INTEGER -C = 0: successful exit; -C < 0: if INFO = -i, the i-th argument had an illegal -C value; -1 -C = 1: if JOBX = 'X' and the matrix S is singular, -C i+1 -1 -C i.e., the condition number estimate of S (in the -C i+1 -C -1 -1/2 -C 1-norm) exceeds 1/TOL. The matrices S , Q -C i+1 i -C and E have been computed. -C -C METHOD -C -C The routine performs one recursion of the square root information -C filter algorithm, summarized as follows: -C -C | -1/2 -1/2 | | -1/2 | -C | Q 0 Q Z | | (QINOV ) * * | -C | i i i | | i | -C | | | | -C | -1/2 -1/2 | | -1 -1 | -C T | 0 R C R Y | = | 0 S S X | -C | i+1 i+1 i+1 i+1| | i+1 i+1 i+1| -C | | | | -C | -1 -1 -1 -1 -1 | | | -C | S A B S A S X | | 0 0 E | -C | i i i i | | i+1 | -C -C (Pre-array) (Post-array) -C -C where T is an orthogonal transformation triangularizing the -C -1/2 -C pre-array, (QINOV ) is the inverse of the covariance square -C i -C root (right Cholesky factor) of the process noise innovation -C -1 -1 -C (hence the information square root) at instant i and (A ,A B) is -C in upper controller Hessenberg form. -C -C An example of the pre-array is given below (where N = 6, M = 2, -C and P = 3): -C -C |x x | | x| -C | x | | x| -C _______________________ -C | | x x x x x x | x| -C | | x x x x x x | x| -C | | x x x x x x | x| -C _______________________ -C |x x | x x x x x x | x| -C | x | x x x x x x | x| -C | | x x x x x x | x| -C | | x x x x x | x| -C | | x x x x | x| -C | | x x x | x| -C -C The inverse of the corresponding state covariance matrix P -C i+1|i+1 -C (hence the information matrix I) is then factorized as -C -C -1 -1 -1 -C I = P = (S )' S -C i+1|i+1 i+1|i+1 i+1 i+1 -C -C and one combined time and measurement update for the state is -C given by X . -C i+1 -C -C The triangularization is done entirely via Householder -C transformations exploiting the zero pattern of the pre-array. -C -C REFERENCES -C -C [1] Anderson, B.D.O. and Moore, J.B. -C Optimal Filtering. -C Prentice Hall, Englewood Cliffs, New Jersey, 1979. -C -C [2] Van Dooren, P. and Verhaegen, M.H.G. -C Condensed Forms for Efficient Time-Invariant Kalman Filtering. -C SIAM J. Sci. Stat. Comp., 9. pp. 516-530, 1988. -C -C [3] Verhaegen, M.H.G. and Van Dooren, P. -C Numerical Aspects of Different Kalman Filter Implementations. -C IEEE Trans. Auto. Contr., AC-31, pp. 907-917, Oct. 1986. -C -C [4] Vanbegin, M., Van Dooren, P., and Verhaegen, M.H.G. -C Algorithm 675: FORTRAN Subroutines for Computing the Square -C Root Covariance Filter and Square Root Information Filter in -C Dense or Hessenberg Forms. -C ACM Trans. Math. Software, 15, pp. 243-256, 1989. -C -C NUMERICAL ASPECTS -C -C The algorithm requires approximately -C -C 3 2 2 3 -C (1/6)N + N x (3/2 x M + P) + 2 x N x M + 2/3 x M -C -C operations and is backward stable (see [3]). -C -C CONTRIBUTORS -C -C Release 3.0: V. Sima, Katholieke Univ. Leuven, Belgium, Feb. 1997. -C Supersedes Release 2.0 routine FB01HD by M. Vanbegin, -C P. Van Dooren, and M.H.G. Verhaegen. -C -C REVISIONS -C -C February 20, 1998, November 20, 2003, February 14, 2004. -C -C KEYWORDS -C -C Controller Hessenberg form, Kalman filtering, optimal filtering, -C orthogonal transformation, recursive estimation, square-root -C filtering, square-root information filtering. -C -C ****************************************************************** -C -C .. Parameters .. - DOUBLE PRECISION ZERO, ONE, TWO - PARAMETER ( ZERO = 0.0D0, ONE = 1.0D0, TWO = 2.0D0 ) -C .. Scalar Arguments .. - CHARACTER JOBX, MULTRC - INTEGER INFO, LDAINB, LDAINV, LDC, LDQINV, LDRINV, - $ LDSINV, LDWORK, M, N, P - DOUBLE PRECISION TOL -C .. Array Arguments .. - INTEGER IWORK(*) - DOUBLE PRECISION AINV(LDAINV,*), AINVB(LDAINB,*), C(LDC,*), - $ DWORK(*), E(*), QINV(LDQINV,*), RINV(LDRINV,*), - $ RINVY(*), SINV(LDSINV,*), X(*), Z(*) -C .. Local Scalars .. - LOGICAL LJOBX, LMULTR - INTEGER I, I12, I13, I23, I32, I33, II, IJ, ITAU, JWORK, - $ LDW, M1, MP1, N1, NM, NP, WRKOPT - DOUBLE PRECISION RCOND -C .. External Functions .. - LOGICAL LSAME - DOUBLE PRECISION DDOT - EXTERNAL DDOT, LSAME -C .. External Subroutines .. - EXTERNAL DAXPY, DCOPY, DLACPY, DTRMM, DTRMV, MB02OD, - $ MB04ID, MB04KD, XERBLA -C .. Intrinsic Functions .. - INTRINSIC INT, MAX, MIN -C .. Executable Statements .. -C - NP = N + P - NM = N + M - N1 = MAX( 1, N ) - M1 = MAX( 1, M ) - MP1 = M + 1 - INFO = 0 - LJOBX = LSAME( JOBX, 'X' ) - LMULTR = LSAME( MULTRC, 'P' ) -C -C Test the input scalar arguments. -C - IF( .NOT.LJOBX .AND. .NOT.LSAME( JOBX, 'N' ) ) THEN - INFO = -1 - ELSE IF( .NOT.LMULTR .AND. .NOT.LSAME( MULTRC, 'N' ) ) THEN - INFO = -2 - ELSE IF( N.LT.0 ) THEN - INFO = -3 - ELSE IF( M.LT.0 ) THEN - INFO = -4 - ELSE IF( P.LT.0 ) THEN - INFO = -5 - ELSE IF( LDSINV.LT.N1 ) THEN - INFO = -7 - ELSE IF( LDAINV.LT.N1 ) THEN - INFO = -9 - ELSE IF( LDAINB.LT.N1 ) THEN - INFO = -11 - ELSE IF( LDRINV.LT.1 .OR. ( .NOT.LMULTR .AND. LDRINV.LT.P ) ) THEN - INFO = -13 - ELSE IF( LDC.LT.MAX( 1, P ) ) THEN - INFO = -15 - ELSE IF( LDQINV.LT.M1 ) THEN - INFO = -17 - ELSE IF( ( LJOBX .AND. LDWORK.LT.MAX( 2, N*(NM + M) + 3*M, - $ NP*(N + 1) + N + - $ MAX( N - 1, MP1 ), 3*N ) ) - $ .OR. - $ ( .NOT.LJOBX .AND. LDWORK.LT.MAX( 1, N*(NM + M) + 3*M, - $ NP*(N + 1) + N + - $ MAX( N - 1, MP1 ) ) ) ) THEN - INFO = -25 - END IF -C - IF ( INFO.NE.0 ) THEN -C -C Error return. -C - CALL XERBLA( 'FB01TD', -INFO ) - RETURN - END IF -C -C Quick return if possible. -C - IF ( MAX( N, P ).EQ.0 ) THEN - IF ( LJOBX ) THEN - DWORK(1) = TWO - DWORK(2) = ONE - ELSE - DWORK(1) = ONE - END IF - RETURN - END IF -C -C Construction of the needed part of the pre-array in DWORK. -C To save workspace, only the blocks (1,3), (3,1)-(3,3), (2,2), and -C (2,3) will be constructed when needed as shown below. -C -C Storing SINV x AINVB and SINV x AINV in the (1,1) and (1,2) -C blocks of DWORK, respectively. The upper trapezoidal structure of -C [ AINVB AINV ] is fully exploited. Specifically, if M <= N, the -C following partition is used: -C -C [ S1 S2 ] [ B1 A1 A3 ] -C [ 0 S3 ] [ 0 A2 A4 ], -C -C where B1, A3, and S1 are M-by-M matrices, A1 and S2 are -C M-by-(N-M), A2 and S3 are (N-M)-by-(N-M), A4 is (N-M)-by-M, and -C B1, S1, A2, and S3 are upper triangular. The right hand side -C matrix above is stored in the workspace. If M > N, the partition -C is [ SINV ] [ B1 B2 A ], where B1 is N-by-N, B2 is N-by-(M-N), -C and B1 and SINV are upper triangular. -C The variables called Ixy define the starting positions where the -C (x,y) blocks of the pre-array are initially stored in DWORK. -C Workspace: need N*(M+N). -C -C (Note: Comments in the code beginning "Workspace:" describe the -C minimal amount of real workspace needed at that point in the -C code, as well as the preferred amount for good performance. -C NB refers to the optimal block size for the immediately -C following subroutine, as returned by ILAENV.) -C - LDW = N1 - I32 = N*M + 1 -C - CALL DLACPY( 'Upper', N, M, AINVB, LDAINB, DWORK, LDW ) - CALL DLACPY( 'Full', MIN( M, N ), N, AINV, LDAINV, DWORK(I32), - $ LDW ) - IF ( N.GT.M ) - $ CALL DLACPY( 'Upper', N-M, N, AINV(MP1,1), LDAINV, - $ DWORK(I32+M), LDW ) -C -C [ B1 A1 ] -C Compute SINV x [ 0 A2 ] or SINV x B1 as a product of upper -C triangular matrices. -C Workspace: need N*(M+N+1). -C - II = 1 - I13 = N*NM + 1 - WRKOPT = MAX( 1, N*NM + N ) -C - DO 10 I = 1, N - CALL DCOPY( I, DWORK(II), 1, DWORK(I13), 1 ) - CALL DTRMV( 'Upper', 'No transpose', 'Non-unit', I, SINV, - $ LDSINV, DWORK(I13), 1 ) - CALL DCOPY( I, DWORK(I13), 1, DWORK(II), 1 ) - II = II + N - 10 CONTINUE -C -C [ A3 ] -C Compute SINV x [ A4 ] or SINV x [ B2 A ]. -C - CALL DTRMM( 'Left', 'Upper', 'No transpose', 'Non-unit', N, M, - $ ONE, SINV, LDSINV, DWORK(II), LDW ) -C -C Storing the process noise mean value in (1,3) block of DWORK. -C Workspace: need N*(M+N) + M. -C - CALL DCOPY( M, Z, 1, DWORK(I13), 1 ) - CALL DTRMV( 'Upper', 'No transpose', 'Non-unit', M, QINV, LDQINV, - $ DWORK(I13), 1 ) -C -C Computing SINV x X in X. -C - CALL DTRMV( 'Upper', 'No transpose', 'Non-unit', N, SINV, LDSINV, - $ X, 1 ) -C -C Triangularization (2 steps). -C -C Step 1: annihilate the matrix SINV x AINVB. -C Workspace: need N*(N+2*M) + 3*M. -C - I12 = I13 + M - ITAU = I12 + M*N - JWORK = ITAU + M -C - CALL MB04KD( 'Upper', M, N, N, QINV, LDQINV, DWORK, LDW, - $ DWORK(I32), LDW, DWORK(I12), M1, DWORK(ITAU), - $ DWORK(JWORK) ) - WRKOPT = MAX( WRKOPT, N*( NM + M ) + 3*M ) -C - IF ( N.EQ.0 ) THEN - CALL DCOPY( P, RINVY, 1, E, 1 ) - IF ( LJOBX ) - $ DWORK(2) = ONE - DWORK(1) = WRKOPT - RETURN - END IF -C -C Apply the transformations to the last column of the pre-array. -C (Only the updated (3,3) block is now needed.) -C - IJ = 1 -C - DO 20 I = 1, M - CALL DAXPY( MIN( I, N ), -DWORK(ITAU+I-1)*( DWORK(I13+I-1) + - $ DDOT( MIN( I, N ), DWORK(IJ), 1, X, 1 ) ), - $ DWORK(IJ), 1, X, 1 ) - IJ = IJ + N - 20 CONTINUE -C -C Now, the workspace for SINV x AINVB, as well as for the updated -C (1,2) block of the pre-array, are no longer needed. -C Move the computed (3,2) and (3,3) blocks of the pre-array in the -C (1,1) and (1,2) block positions of DWORK, to save space for the -C following computations. -C Then, adjust the implicitly defined leading dimension of DWORK, -C to make space for storing the (2,2) and (2,3) blocks of the -C pre-array. -C Workspace: need (P+N)*(N+1). -C - CALL DLACPY( 'Full', MIN( M, N ), N, DWORK(I32), LDW, DWORK, LDW ) - IF ( N.GT.M ) - $ CALL DLACPY( 'Upper', N-M, N, DWORK(I32+M), LDW, DWORK(MP1), - $ LDW ) - LDW = MAX( 1, NP ) -C - DO 40 I = N, 1, -1 - DO 30 IJ = MIN( N, I+M ), 1, -1 - DWORK(NP*(I-1)+P+IJ) = DWORK(N*(I-1)+IJ) - 30 CONTINUE - 40 CONTINUE -C -C Copy of RINV x C in the (1,1) block of DWORK. -C - CALL DLACPY( 'Full', P, N, C, LDC, DWORK, LDW ) - IF ( .NOT.LMULTR ) - $ CALL DTRMM( 'Left', 'Upper', 'No transpose', 'Non-unit', P, N, - $ ONE, RINV, LDRINV, DWORK, LDW ) -C -C Copy the inclusion measurement in the (1,2) block and the updated -C X in the (2,2) block of DWORK. -C - I23 = NP*N + 1 - I33 = I23 + P - CALL DCOPY( P, RINVY, 1, DWORK(I23), 1 ) - CALL DCOPY( N, X, 1, DWORK(I33), 1 ) - WRKOPT = MAX( WRKOPT, NP*( N + 1 ) ) -C -C Step 2: QR factorization of the first block column of the matrix -C -C [ RINV x C RINV x Y ], -C [ SINV x AINV SINV x X ] -C -C where the second block row was modified at Step 1. -C Workspace: need (P+N)*(N+1) + N + MAX(N-1,M+1); -C prefer (P+N)*(N+1) + N + (M+1)*NB, where NB is the -C optimal block size for DGEQRF called in MB04ID. -C - ITAU = I23 + NP - JWORK = ITAU + N -C - CALL MB04ID( NP, N, MAX( N-MP1, 0 ), 1, DWORK, LDW, DWORK(I23), - $ LDW, DWORK(ITAU), DWORK(JWORK), LDWORK-JWORK+1, - $ INFO ) - WRKOPT = MAX( WRKOPT, INT( DWORK(JWORK) )+JWORK-1 ) -C -C Output SINV, X, and E and set the optimal workspace dimension -C (and the reciprocal of the condition number estimate). -C - CALL DLACPY( 'Upper', N, N, DWORK, LDW, SINV, LDSINV ) - CALL DCOPY( N, DWORK(I23), 1, X, 1 ) - IF( P.GT.0 ) - $ CALL DCOPY( P, DWORK(I23+N), 1, E, 1 ) -C - IF ( LJOBX ) THEN -C -C Compute X. -C Workspace: need 3*N. -C - CALL MB02OD( 'Left', 'Upper', 'No transpose', 'Non-unit', - $ '1-norm', N, 1, ONE, SINV, LDSINV, X, N, RCOND, - $ TOL, IWORK, DWORK, INFO ) - IF ( INFO.EQ.0 ) THEN - WRKOPT = MAX( WRKOPT, 3*N ) - DWORK(2) = RCOND - END IF - END IF -C - DWORK(1) = WRKOPT -C - RETURN -C *** Last line of FB01TD*** - END diff --git a/mex/sources/libslicot/FB01VD.f b/mex/sources/libslicot/FB01VD.f deleted file mode 100644 index eabf21748..000000000 --- a/mex/sources/libslicot/FB01VD.f +++ /dev/null @@ -1,391 +0,0 @@ - SUBROUTINE FB01VD( N, M, L, P, LDP, A, LDA, B, LDB, C, LDC, Q, - $ LDQ, R, LDR, K, LDK, TOL, IWORK, DWORK, LDWORK, - $ INFO ) -C -C SLICOT RELEASE 5.0. -C -C Copyright (c) 2002-2009 NICONET e.V. -C -C This program is free software: you can redistribute it and/or -C modify it under the terms of the GNU General Public License as -C published by the Free Software Foundation, either version 2 of -C the License, or (at your option) any later version. -C -C This program is distributed in the hope that it will be useful, -C but WITHOUT ANY WARRANTY; without even the implied warranty of -C MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the -C GNU General Public License for more details. -C -C You should have received a copy of the GNU General Public License -C along with this program. If not, see -C . -C -C PURPOSE -C -C To compute one recursion of the conventional Kalman filter -C equations. This is one update of the Riccati difference equation -C and the Kalman filter gain. -C -C ARGUMENTS -C -C Input/Output Parameters -C -C N (input) INTEGER -C The actual state dimension, i.e., the order of the -C matrices P and A . N >= 0. -C i|i-1 i -C -C M (input) INTEGER -C The actual input dimension, i.e., the order of the matrix -C Q . M >= 0. -C i -C -C L (input) INTEGER -C The actual output dimension, i.e., the order of the matrix -C R . L >= 0. -C i -C -C P (input/output) DOUBLE PRECISION array, dimension (LDP,N) -C On entry, the leading N-by-N part of this array must -C contain P , the state covariance matrix at instant -C i|i-1 -C (i-1). The upper triangular part only is needed. -C On exit, if INFO = 0, the leading N-by-N part of this -C array contains P , the state covariance matrix at -C i+1|i -C instant i. The strictly lower triangular part is not set. -C Otherwise, the leading N-by-N part of this array contains -C P , its input value. -C i|i-1 -C -C LDP INTEGER -C The leading dimension of array P. LDP >= MAX(1,N). -C -C A (input) DOUBLE PRECISION array, dimension (LDA,N) -C The leading N-by-N part of this array must contain A , -C i -C the state transition matrix of the discrete system at -C instant i. -C -C LDA INTEGER -C The leading dimension of array A. LDA >= MAX(1,N). -C -C B (input) DOUBLE PRECISION array, dimension (LDB,M) -C The leading N-by-M part of this array must contain B , -C i -C the input weight matrix of the discrete system at -C instant i. -C -C LDB INTEGER -C The leading dimension of array B. LDB >= MAX(1,N). -C -C C (input) DOUBLE PRECISION array, dimension (LDC,N) -C The leading L-by-N part of this array must contain C , -C i -C the output weight matrix of the discrete system at -C instant i. -C -C LDC INTEGER -C The leading dimension of array C. LDC >= MAX(1,L). -C -C Q (input) DOUBLE PRECISION array, dimension (LDQ,M) -C The leading M-by-M part of this array must contain Q , -C i -C the input (process) noise covariance matrix at instant i. -C The diagonal elements of this array are modified by the -C routine, but are restored on exit. -C -C LDQ INTEGER -C The leading dimension of array Q. LDQ >= MAX(1,M). -C -C R (input/output) DOUBLE PRECISION array, dimension (LDR,L) -C On entry, the leading L-by-L part of this array must -C contain R , the output (measurement) noise covariance -C i -C matrix at instant i. -C On exit, if INFO = 0, or INFO = L+1, the leading L-by-L -C 1/2 -C upper triangular part of this array contains (RINOV ) , -C i -C the square root (left Cholesky factor) of the covariance -C matrix of the innovations at instant i. -C -C LDR INTEGER -C The leading dimension of array R. LDR >= MAX(1,L). -C -C K (output) DOUBLE PRECISION array, dimension (LDK,L) -C If INFO = 0, the leading N-by-L part of this array -C contains K , the Kalman filter gain matrix at instant i. -C i -C If INFO > 0, the leading N-by-L part of this array -C contains the matrix product P C'. -C i|i-1 i -C -C LDK INTEGER -C The leading dimension of array K. LDK >= MAX(1,N). -C -C Tolerances -C -C TOL DOUBLE PRECISION -C The tolerance to be used to test for near singularity of -C the matrix RINOV . If the user sets TOL > 0, then the -C i -C given value of TOL is used as a lower bound for the -C reciprocal condition number of that matrix; a matrix whose -C estimated condition number is less than 1/TOL is -C considered to be nonsingular. If the user sets TOL <= 0, -C then an implicitly computed, default tolerance, defined by -C TOLDEF = L*L*EPS, is used instead, where EPS is the -C machine precision (see LAPACK Library routine DLAMCH). -C -C Workspace -C -C IWORK INTEGER array, dimension (L) -C -C DWORK DOUBLE PRECISION array, dimension (LDWORK) -C On exit, if INFO = 0, or INFO = L+1, DWORK(1) returns an -C estimate of the reciprocal of the condition number (in the -C 1-norm) of the matrix RINOV . -C i -C -C LDWORK The length of the array DWORK. -C LDWORK >= MAX(1,L*N+3*L,N*N,N*M). -C -C Error Indicator -C -C INFO INTEGER -C = 0: successful exit; -C < 0: if INFO = -k, the k-th argument had an illegal -C value; -C = k: if INFO = k, 1 <= k <= L, the leading minor of order -C k of the matrix RINOV is not positive-definite, and -C i -C its Cholesky factorization could not be completed; -C = L+1: the matrix RINOV is singular, i.e., the condition -C i -C number estimate of RINOV (in the 1-norm) exceeds -C i -C 1/TOL. -C -C METHOD -C -C The conventional Kalman filter gain used at the i-th recursion -C step is of the form -C -C -1 -C K = P C' RINOV , -C i i|i-1 i i -C -C where RINOV = C P C' + R , and the state covariance matrix -C i i i|i-1 i i -C -C P is updated by the discrete-time difference Riccati equation -C i|i-1 -C -C P = A (P - K C P ) A' + B Q B'. -C i+1|i i i|i-1 i i i|i-1 i i i i -C -C Using these two updates, the combined time and measurement update -C of the state X is given by -C i|i-1 -C -C X = A X + A K (Y - C X ), -C i+1|i i i|i-1 i i i i i|i-1 -C -C where Y is the new observation at step i. -C i -C -C REFERENCES -C -C [1] Anderson, B.D.O. and Moore, J.B. -C Optimal Filtering, -C Prentice Hall, Englewood Cliffs, New Jersey, 1979. -C -C [2] Verhaegen, M.H.G. and Van Dooren, P. -C Numerical Aspects of Different Kalman Filter Implementations. -C IEEE Trans. Auto. Contr., AC-31, pp. 907-917, 1986. -C -C NUMERICAL ASPECTS -C -C The algorithm requires approximately -C -C 3 2 -C 3/2 x N + N x (3 x L + M/2) -C -C operations. -C -C CONTRIBUTORS -C -C Release 3.0: V. Sima, Katholieke Univ. Leuven, Belgium, Feb. 1997. -C Supersedes Release 2.0 routine FB01JD by M.H.G. Verhaegen, -C M. Vanbegin, and P. Van Dooren. -C -C REVISIONS -C -C February 20, 1998, November 20, 2003, April 20, 2004. -C -C KEYWORDS -C -C Kalman filtering, optimal filtering, recursive estimation. -C -C ****************************************************************** -C -C .. Parameters .. - DOUBLE PRECISION ZERO, ONE, TWO - PARAMETER ( ZERO = 0.0D0, ONE = 1.0D0, TWO = 2.0D0 ) -C .. Scalar Arguments .. - INTEGER INFO, L, LDA, LDB, LDC, LDK, LDP, LDQ, LDR, - $ LDWORK, M, N - DOUBLE PRECISION TOL -C .. Array Arguments .. - INTEGER IWORK(*) - DOUBLE PRECISION A(LDA,*), B(LDB,*), C(LDC,*), DWORK(*), - $ K(LDK,*), P(LDP,*), Q(LDQ,*), R(LDR,*) -C .. Local Scalars .. - INTEGER J, JWORK, LDW, N1 - DOUBLE PRECISION RCOND, RNORM, TOLDEF -C .. External Functions .. - DOUBLE PRECISION DLAMCH, DLANSY - EXTERNAL DLAMCH, DLANSY -C .. External Subroutines .. - EXTERNAL DAXPY, DCOPY, DGEMV, DLACPY, DLASET, DPOCON, - $ DPOTRF, DSCAL, DTRMM, DTRSM, MB01RD, XERBLA -C .. Intrinsic Functions .. - INTRINSIC DBLE, MAX -C .. Executable Statements .. -C -C Test the input scalar arguments. -C - INFO = 0 - N1 = MAX( 1, N ) - IF( N.LT.0 ) THEN - INFO = -1 - ELSE IF( M.LT.0 ) THEN - INFO = -2 - ELSE IF( L.LT.0 ) THEN - INFO = -3 - ELSE IF( LDP.LT.N1 ) THEN - INFO = -5 - ELSE IF( LDA.LT.N1 ) THEN - INFO = -7 - ELSE IF( LDB.LT.N1 ) THEN - INFO = -9 - ELSE IF( LDC.LT.MAX( 1, L ) ) THEN - INFO = -11 - ELSE IF( LDQ.LT.MAX( 1, M ) ) THEN - INFO = -13 - ELSE IF( LDR.LT.MAX( 1, L ) ) THEN - INFO = -15 - ELSE IF( LDK.LT.N1 ) THEN - INFO = -17 - ELSE IF( LDWORK.LT.MAX( 1, L*N + 3*L, N*N, N*M ) ) THEN - INFO = -21 - END IF -C - IF ( INFO.NE.0 ) THEN -C -C Error return. -C - CALL XERBLA( 'FB01VD', -INFO ) - RETURN - END IF -C -C Quick return if possible. -C - IF ( MAX( N, L ).EQ.0 ) THEN - DWORK(1) = ONE - RETURN - END IF -C -C Efficiently compute RINOV = CPC' + R in R and put CP in DWORK and -C PC' in K. (The content of DWORK on exit from MB01RD is used.) -C Workspace: need L*N. -C -C (Note: Comments in the code beginning "Workspace:" describe the -C minimal amount of real workspace needed at that point in the -C code.) -C - CALL MB01RD( 'Upper', 'No transpose', L, N, ONE, ONE, R, LDR, C, - $ LDC, P, LDP, DWORK, LDWORK, INFO ) - LDW = MAX( 1, L ) -C - DO 10 J = 1, L - CALL DCOPY( N, DWORK(J), LDW, K(1,J), 1 ) - 10 CONTINUE -C - CALL DLACPY( 'Full', L, N, C, LDC, DWORK, LDW ) - CALL DTRMM( 'Right', 'Upper', 'Transpose', 'Non-unit', L, N, ONE, - $ P, LDP, DWORK, LDW ) - CALL DSCAL( N, TWO, P, LDP+1 ) -C - DO 20 J = 1, L - CALL DAXPY( N, ONE, K(1,J), 1, DWORK(J), LDW ) - CALL DCOPY( N, DWORK(J), LDW, K(1,J), 1 ) - 20 CONTINUE -C -C Calculate the Cholesky decomposition U'U of the innovation -C covariance matrix RINOV, and its reciprocal condition number. -C Workspace: need L*N + 3*L. -C - JWORK = L*N + 1 - RNORM = DLANSY( '1-norm', 'Upper', L, R, LDR, DWORK(JWORK) ) -C - TOLDEF = TOL - IF ( TOLDEF.LE.ZERO ) - $ TOLDEF = DBLE( L*L )*DLAMCH( 'Epsilon' ) - CALL DPOTRF( 'Upper', L, R, LDR, INFO ) - IF ( INFO.NE.0 ) - $ RETURN -C - CALL DPOCON( 'Upper', L, R, LDR, RNORM, RCOND, DWORK(JWORK), - $ IWORK, INFO ) -C - IF ( RCOND.LT.TOLDEF ) THEN -C -C Error return: RINOV is numerically singular. -C - INFO = L+1 - DWORK(1) = RCOND - RETURN - END IF -C - IF ( L.GT.1 ) - $ CALL DLASET( 'Lower', L-1, L-1, ZERO, ZERO, R(2,1),LDR ) -C -1 -C Calculate the Kalman filter gain matrix K = PC'RINOV . -C Workspace: need L*N. -C - CALL DTRSM( 'Right', 'Upper', 'No transpose', 'Non-unit', N, L, - $ ONE, R, LDR, K, LDK ) - CALL DTRSM( 'Right', 'Upper', 'Transpose', 'Non-unit', N, L, - $ ONE, R, LDR, K, LDK ) -C -C First part of the Riccati equation update: compute A(P-KCP)A'. -C The upper triangular part of the symmetric matrix P-KCP is formed. -C Workspace: need max(L*N,N*N). -C - JWORK = 1 -C - DO 30 J = 1, N - CALL DGEMV( 'No transpose', J, L, -ONE, K, LDK, DWORK(JWORK), - $ 1, ONE, P(1,J), 1 ) - JWORK = JWORK + L - 30 CONTINUE -C - CALL MB01RD( 'Upper', 'No transpose', N, N, ZERO, ONE, P, LDP, A, - $ LDA, P, LDP, DWORK, LDWORK, INFO ) -C -C Second part of the Riccati equation update: add BQB'. -C Workspace: need N*M. -C - CALL MB01RD( 'Upper', 'No transpose', N, M, ONE, ONE, P, LDP, B, - $ LDB, Q, LDQ, DWORK, LDWORK, INFO ) - CALL DSCAL( M, TWO, Q, LDQ+1 ) -C -C Set the reciprocal of the condition number estimate. -C - DWORK(1) = RCOND -C - RETURN -C *** Last line of FB01VD *** - END diff --git a/mex/sources/libslicot/FD01AD.f b/mex/sources/libslicot/FD01AD.f deleted file mode 100644 index 79fef1b65..000000000 --- a/mex/sources/libslicot/FD01AD.f +++ /dev/null @@ -1,367 +0,0 @@ - SUBROUTINE FD01AD( JP, L, LAMBDA, XIN, YIN, EFOR, XF, EPSBCK, - $ CTETA, STETA, YQ, EPOS, EOUT, SALPH, IWARN, - $ INFO ) -C -C SLICOT RELEASE 5.0. -C -C Copyright (c) 2002-2009 NICONET e.V. -C -C This program is free software: you can redistribute it and/or -C modify it under the terms of the GNU General Public License as -C published by the Free Software Foundation, either version 2 of -C the License, or (at your option) any later version. -C -C This program is distributed in the hope that it will be useful, -C but WITHOUT ANY WARRANTY; without even the implied warranty of -C MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the -C GNU General Public License for more details. -C -C You should have received a copy of the GNU General Public License -C along with this program. If not, see -C . -C -C PURPOSE -C -C To solve the least-squares filtering problem recursively in time. -C Each subroutine call implements one time update of the solution. -C The algorithm uses a fast QR-decomposition based approach. -C -C ARGUMENTS -C -C Mode Parameters -C -C JP CHARACTER*1 -C Indicates whether the user wishes to apply both prediction -C and filtering parts, as follows: -C = 'B': Both prediction and filtering parts are to be -C applied; -C = 'P': Only the prediction section is to be applied. -C -C Input/Output Parameters -C -C L (input) INTEGER -C The length of the impulse response of the equivalent -C transversal filter model. L >= 1. -C -C LAMBDA (input) DOUBLE PRECISION -C Square root of the forgetting factor. -C For tracking capabilities and exponentially stable error -C propagation, LAMBDA < 1.0 (strict inequality) should -C be used. 0.0 < LAMBDA <= 1.0. -C -C XIN (input) DOUBLE PRECISION -C The input sample at instant n. -C (The situation just before and just after the call of -C the routine are denoted by instant (n-1) and instant n, -C respectively.) -C -C YIN (input) DOUBLE PRECISION -C If JP = 'B', then YIN must contain the reference sample -C at instant n. -C Otherwise, YIN is not referenced. -C -C EFOR (input/output) DOUBLE PRECISION -C On entry, this parameter must contain the square root of -C exponentially weighted forward prediction error energy -C at instant (n-1). EFOR >= 0.0. -C On exit, this parameter contains the square root of the -C exponentially weighted forward prediction error energy -C at instant n. -C -C XF (input/output) DOUBLE PRECISION array, dimension (L) -C On entry, this array must contain the transformed forward -C prediction variables at instant (n-1). -C On exit, this array contains the transformed forward -C prediction variables at instant n. -C -C EPSBCK (input/output) DOUBLE PRECISION array, dimension (L+1) -C On entry, the leading L elements of this array must -C contain the normalized a posteriori backward prediction -C error residuals of orders zero through L-1, respectively, -C at instant (n-1), and EPSBCK(L+1) must contain the -C square-root of the so-called "conversion factor" at -C instant (n-1). -C On exit, this array contains the normalized a posteriori -C backward prediction error residuals, plus the square root -C of the conversion factor at instant n. -C -C CTETA (input/output) DOUBLE PRECISION array, dimension (L) -C On entry, this array must contain the cosines of the -C rotation angles used in time updates, at instant (n-1). -C On exit, this array contains the cosines of the rotation -C angles at instant n. -C -C STETA (input/output) DOUBLE PRECISION array, dimension (L) -C On entry, this array must contain the sines of the -C rotation angles used in time updates, at instant (n-1). -C On exit, this array contains the sines of the rotation -C angles at instant n. -C -C YQ (input/output) DOUBLE PRECISION array, dimension (L) -C On entry, if JP = 'B', then this array must contain the -C orthogonally transformed reference vector at instant -C (n-1). These elements are also the tap multipliers of an -C equivalent normalized lattice least-squares filter. -C Otherwise, YQ is not referenced and can be supplied as -C a dummy array (i.e., declare this array to be YQ(1) in -C the calling program). -C On exit, if JP = 'B', then this array contains the -C orthogonally transformed reference vector at instant n. -C -C EPOS (output) DOUBLE PRECISION -C The a posteriori forward prediction error residual. -C -C EOUT (output) DOUBLE PRECISION -C If JP = 'B', then EOUT contains the a posteriori output -C error residual from the least-squares filter at instant n. -C -C SALPH (output) DOUBLE PRECISION array, dimension (L) -C The element SALPH(i), i=1,...,L, contains the opposite of -C the i-(th) reflection coefficient for the least-squares -C normalized lattice predictor (whose value is -SALPH(i)). -C -C Warning Indicator -C -C IWARN INTEGER -C = 0: no warning; -C = 1: an element to be annihilated by a rotation is less -C than the machine precision (see LAPACK Library -C routine DLAMCH). -C -C Error Indicator -C -C INFO INTEGER -C = 0: successful exit; -C < 0: if INFO = -i, the i-th argument had an illegal -C value. -C -C METHOD -C -C The output error EOUT at instant n, denoted by EOUT(n), is the -C reference sample minus a linear combination of L successive input -C samples: -C -C L-1 -C EOUT(n) = YIN(n) - SUM h_i * XIN(n-i), -C i=0 -C -C where YIN(n) and XIN(n) are the scalar samples at instant n. -C A least-squares filter uses those h_0,...,h_{L-1} which minimize -C an exponentially weighted sum of successive output errors squared: -C -C n -C SUM [LAMBDA**(2(n-k)) * EOUT(k)**2]. -C k=1 -C -C Each subroutine call performs a time update of the least-squares -C filter using a fast least-squares algorithm derived from a -C QR decomposition, as described in references [1] and [2] (the -C notation from [2] is followed in the naming of the arrays). -C The algorithm does not compute the parameters h_0,...,h_{L-1} from -C the above formula, but instead furnishes the parameters of an -C equivalent normalized least-squares lattice filter, which are -C available from the arrays SALPH (reflection coefficients) and YQ -C (tap multipliers), as well as the exponentially weighted input -C signal energy -C -C n L -C SUM [LAMBDA**(2(n-k)) * XIN(k)**2] = EFOR**2 + SUM XF(i)**2. -C k=1 i=1 -C -C For more details on reflection coefficients and tap multipliers, -C references [2] and [4] are recommended. -C -C REFERENCES -C -C [1] Proudler, I. K., McWhirter, J. G., and Shepherd, T. J. -C Fast QRD based algorithms for least-squares linear -C prediction. -C Proceedings IMA Conf. Mathematics in Signal Processing -C Warwick, UK, December 1988. -C -C [2] Regalia, P. A., and Bellanger, M. G. -C On the duality between QR methods and lattice methods in -C least-squares adaptive filtering. -C IEEE Trans. Signal Processing, SP-39, pp. 879-891, -C April 1991. -C -C [3] Regalia, P. A. -C Numerical stability properties of a QR-based fast -C least-squares algorithm. -C IEEE Trans. Signal Processing, SP-41, June 1993. -C -C [4] Lev-Ari, H., Kailath, T., and Cioffi, J. -C Least-squares adaptive lattice and transversal filters: -C A unified geometric theory. -C IEEE Trans. Information Theory, IT-30, pp. 222-236, -C March 1984. -C -C NUMERICAL ASPECTS -C -C The algorithm requires O(L) operations for each subroutine call. -C It is backward consistent for all input sequences XIN, and -C backward stable for persistently exciting input sequences, -C assuming LAMBDA < 1.0 (see [3]). -C If the condition of the signal is very poor (IWARN = 1), then the -C results are not guaranteed to be reliable. -C -C FURTHER COMMENTS -C -C 1. For tracking capabilities and exponentially stable error -C propagation, LAMBDA < 1.0 should be used. LAMBDA is typically -C chosen slightly less than 1.0 so that "past" data are -C exponentially forgotten. -C 2. Prior to the first subroutine call, the variables must be -C initialized. The following initial values are recommended: -C -C XF(i) = 0.0, i=1,...,L -C EPSBCK(i) = 0.0 i=1,...,L -C EPSBCK(L+1) = 1.0 -C CTETA(i) = 1.0 i=1,...,L -C STETA(i) = 0.0 i=1,...,L -C YQ(i) = 0.0 i=1,...,L -C -C EFOR = 0.0 (exact start) -C EFOR = "small positive constant" (soft start). -C -C Soft starts are numerically more reliable, but result in a -C biased least-squares solution during the first few iterations. -C This bias decays exponentially fast provided LAMBDA < 1.0. -C If sigma is the standard deviation of the input sequence -C XIN, then initializing EFOR = sigma*1.0E-02 usually works -C well. -C -C CONTRIBUTOR -C -C P. A. Regalia (October 1994). -C Release 4.0: V. Sima, Katholieke Univ. Leuven, Belgium, Dec. 1999. -C -C REVISIONS -C -C - -C -C KEYWORDS -C -C Kalman filtering, least-squares estimator, optimal filtering, -C orthogonal transformation, recursive estimation, QR decomposition. -C -C ****************************************************************** -C -C .. Parameters .. - DOUBLE PRECISION ONE, ZERO - PARAMETER ( ONE = 1.0D0, ZERO = 0.0D0 ) -C .. Scalar Arguments .. - CHARACTER JP - INTEGER INFO, IWARN, L - DOUBLE PRECISION EFOR, EOUT, EPOS, LAMBDA, XIN, YIN -C .. Array Arguments .. - DOUBLE PRECISION CTETA(*), EPSBCK(*), SALPH(*), STETA(*), XF(*), - $ YQ(*) -C .. Local Scalars .. - LOGICAL BOTH - INTEGER I - DOUBLE PRECISION CTEMP, EPS, FNODE, NORM, TEMP, XFI, YQI -C .. External Functions .. - LOGICAL LSAME - DOUBLE PRECISION DLAMCH, DLAPY2, DNRM2 - EXTERNAL DLAMCH, DLAPY2, DNRM2, LSAME -C .. External Subroutines .. - EXTERNAL DLARTG, XERBLA -C .. Intrinsic Functions - INTRINSIC ABS, SQRT -C .. Executable statements .. -C -C Test the input scalar arguments. -C - BOTH = LSAME( JP, 'B' ) - IWARN = 0 - INFO = 0 -C - IF( .NOT.BOTH .AND. .NOT.LSAME( JP, 'P' ) ) THEN - INFO = -1 - ELSE IF( L.LT.1 ) THEN - INFO = -2 - ELSE IF( ( LAMBDA.LE.ZERO ) .OR. ( LAMBDA.GT.ONE ) ) THEN - INFO = -3 - END IF -C - IF ( INFO.NE.0 ) THEN -C -C Error return. -C - CALL XERBLA( 'FD01AD', -INFO ) - RETURN - END IF -C -C Computation of the machine precision EPS. -C - EPS = DLAMCH( 'Epsilon' ) -C -C Forward prediction rotations. -C - FNODE = XIN -C - DO 10 I = 1, L - XFI = XF(I) * LAMBDA - XF(I) = STETA(I) * FNODE + CTETA(I) * XFI - FNODE = CTETA(I) * FNODE - STETA(I) * XFI - 10 CONTINUE -C - EPOS = FNODE * EPSBCK(L+1) -C -C Update the square root of the prediction energy. -C - EFOR = EFOR * LAMBDA - TEMP = DLAPY2( FNODE, EFOR ) - IF ( TEMP.LT.EPS ) THEN - FNODE = ZERO - IWARN = 1 - ELSE - FNODE = FNODE * EPSBCK(L+1)/TEMP - END IF - EFOR = TEMP -C -C Calculate the reflection coefficients and the backward prediction -C errors. -C - DO 20 I = L, 1, -1 - IF ( ABS( XF(I) ).LT.EPS ) - $ IWARN = 1 - CALL DLARTG( TEMP, XF(I), CTEMP, SALPH(I), NORM ) - EPSBCK(I+1) = CTEMP * EPSBCK(I) - SALPH(I) * FNODE - FNODE = CTEMP * FNODE + SALPH(I) * EPSBCK(I) - TEMP = NORM - 20 CONTINUE -C - EPSBCK(1) = FNODE -C -C Update to new rotation angles. -C - NORM = DNRM2( L, EPSBCK, 1 ) - TEMP = SQRT( ( ONE + NORM )*( ONE - NORM ) ) - EPSBCK(L+1) = TEMP -C - DO 30 I = L, 1, -1 - IF ( ABS( EPSBCK(I) ).LT.EPS ) - $ IWARN = 1 - CALL DLARTG( TEMP, EPSBCK(I), CTETA(I), STETA(I), NORM ) - TEMP = NORM - 30 CONTINUE -C -C Joint process section. -C - IF ( BOTH) THEN - FNODE = YIN -C - DO 40 I = 1, L - YQI = YQ(I) * LAMBDA - YQ(I) = STETA(I) * FNODE + CTETA(I) * YQI - FNODE = CTETA(I) * FNODE - STETA(I) * YQI - 40 CONTINUE -C - EOUT = FNODE * EPSBCK(L+1) - END IF -C - RETURN -C *** Last line of FD01AD *** - END diff --git a/mex/sources/libslicot/IB01AD.f b/mex/sources/libslicot/IB01AD.f deleted file mode 100644 index 301cdd529..000000000 --- a/mex/sources/libslicot/IB01AD.f +++ /dev/null @@ -1,686 +0,0 @@ - SUBROUTINE IB01AD( METH, ALG, JOBD, BATCH, CONCT, CTRL, NOBR, M, - $ L, NSMP, U, LDU, Y, LDY, N, R, LDR, SV, RCOND, - $ TOL, IWORK, DWORK, LDWORK, IWARN, INFO ) -C -C SLICOT RELEASE 5.0. -C -C Copyright (c) 2002-2009 NICONET e.V. -C -C This program is free software: you can redistribute it and/or -C modify it under the terms of the GNU General Public License as -C published by the Free Software Foundation, either version 2 of -C the License, or (at your option) any later version. -C -C This program is distributed in the hope that it will be useful, -C but WITHOUT ANY WARRANTY; without even the implied warranty of -C MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the -C GNU General Public License for more details. -C -C You should have received a copy of the GNU General Public License -C along with this program. If not, see -C . -C -C PURPOSE -C -C To preprocess the input-output data for estimating the matrices -C of a linear time-invariant dynamical system and to find an -C estimate of the system order. The input-output data can, -C optionally, be processed sequentially. -C -C ARGUMENTS -C -C Mode Parameters -C -C METH CHARACTER*1 -C Specifies the subspace identification method to be used, -C as follows: -C = 'M': MOESP algorithm with past inputs and outputs; -C = 'N': N4SID algorithm. -C -C ALG CHARACTER*1 -C Specifies the algorithm for computing the triangular -C factor R, as follows: -C = 'C': Cholesky algorithm applied to the correlation -C matrix of the input-output data; -C = 'F': Fast QR algorithm; -C = 'Q': QR algorithm applied to the concatenated block -C Hankel matrices. -C -C JOBD CHARACTER*1 -C Specifies whether or not the matrices B and D should later -C be computed using the MOESP approach, as follows: -C = 'M': the matrices B and D should later be computed -C using the MOESP approach; -C = 'N': the matrices B and D should not be computed using -C the MOESP approach. -C This parameter is not relevant for METH = 'N'. -C -C BATCH CHARACTER*1 -C Specifies whether or not sequential data processing is to -C be used, and, for sequential processing, whether or not -C the current data block is the first block, an intermediate -C block, or the last block, as follows: -C = 'F': the first block in sequential data processing; -C = 'I': an intermediate block in sequential data -C processing; -C = 'L': the last block in sequential data processing; -C = 'O': one block only (non-sequential data processing). -C NOTE that when 100 cycles of sequential data processing -C are completed for BATCH = 'I', a warning is -C issued, to prevent for an infinite loop. -C -C CONCT CHARACTER*1 -C Specifies whether or not the successive data blocks in -C sequential data processing belong to a single experiment, -C as follows: -C = 'C': the current data block is a continuation of the -C previous data block and/or it will be continued -C by the next data block; -C = 'N': there is no connection between the current data -C block and the previous and/or the next ones. -C This parameter is not used if BATCH = 'O'. -C -C CTRL CHARACTER*1 -C Specifies whether or not the user's confirmation of the -C system order estimate is desired, as follows: -C = 'C': user's confirmation; -C = 'N': no confirmation. -C If CTRL = 'C', a reverse communication routine, IB01OY, -C is indirectly called (by SLICOT Library routine IB01OD), -C and, after inspecting the singular values and system order -C estimate, n, the user may accept n or set a new value. -C IB01OY is not called if CTRL = 'N'. -C -C Input/Output Parameters -C -C NOBR (input) INTEGER -C The number of block rows, s, in the input and output -C block Hankel matrices to be processed. NOBR > 0. -C (In the MOESP theory, NOBR should be larger than n, -C the estimated dimension of state vector.) -C -C M (input) INTEGER -C The number of system inputs. M >= 0. -C When M = 0, no system inputs are processed. -C -C L (input) INTEGER -C The number of system outputs. L > 0. -C -C NSMP (input) INTEGER -C The number of rows of matrices U and Y (number of -C samples, t). (When sequential data processing is used, -C NSMP is the number of samples of the current data -C block.) -C NSMP >= 2*(M+L+1)*NOBR - 1, for non-sequential -C processing; -C NSMP >= 2*NOBR, for sequential processing. -C The total number of samples when calling the routine with -C BATCH = 'L' should be at least 2*(M+L+1)*NOBR - 1. -C The NSMP argument may vary from a cycle to another in -C sequential data processing, but NOBR, M, and L should -C be kept constant. For efficiency, it is advisable to use -C NSMP as large as possible. -C -C U (input) DOUBLE PRECISION array, dimension (LDU,M) -C The leading NSMP-by-M part of this array must contain the -C t-by-m input-data sequence matrix U, -C U = [u_1 u_2 ... u_m]. Column j of U contains the -C NSMP values of the j-th input component for consecutive -C time increments. -C If M = 0, this array is not referenced. -C -C LDU INTEGER -C The leading dimension of the array U. -C LDU >= NSMP, if M > 0; -C LDU >= 1, if M = 0. -C -C Y (input) DOUBLE PRECISION array, dimension (LDY,L) -C The leading NSMP-by-L part of this array must contain the -C t-by-l output-data sequence matrix Y, -C Y = [y_1 y_2 ... y_l]. Column j of Y contains the -C NSMP values of the j-th output component for consecutive -C time increments. -C -C LDY INTEGER -C The leading dimension of the array Y. LDY >= NSMP. -C -C N (output) INTEGER -C The estimated order of the system. -C If CTRL = 'C', the estimated order has been reset to a -C value specified by the user. -C -C R (output or input/output) DOUBLE PRECISION array, dimension -C ( LDR,2*(M+L)*NOBR ) -C On exit, if ALG = 'C' and BATCH = 'F' or 'I', the leading -C 2*(M+L)*NOBR-by-2*(M+L)*NOBR upper triangular part of this -C array contains the current upper triangular part of the -C correlation matrix in sequential data processing. -C If ALG = 'F' and BATCH = 'F' or 'I', the array R is not -C referenced. -C On exit, if INFO = 0, ALG = 'Q', and BATCH = 'F' or 'I', -C the leading 2*(M+L)*NOBR-by-2*(M+L)*NOBR upper triangular -C part of this array contains the current upper triangular -C factor R from the QR factorization of the concatenated -C block Hankel matrices. Denote R_ij, i,j = 1:4, the -C ij submatrix of R, partitioned by M*NOBR, M*NOBR, -C L*NOBR, and L*NOBR rows and columns. -C On exit, if INFO = 0 and BATCH = 'L' or 'O', the leading -C 2*(M+L)*NOBR-by-2*(M+L)*NOBR upper triangular part of -C this array contains the matrix S, the processed upper -C triangular factor R from the QR factorization of the -C concatenated block Hankel matrices, as required by other -C subroutines. Specifically, let S_ij, i,j = 1:4, be the -C ij submatrix of S, partitioned by M*NOBR, L*NOBR, -C M*NOBR, and L*NOBR rows and columns. The submatrix -C S_22 contains the matrix of left singular vectors needed -C subsequently. Useful information is stored in S_11 and -C in the block-column S_14 : S_44. For METH = 'M' and -C JOBD = 'M', the upper triangular part of S_31 contains -C the upper triangular factor in the QR factorization of the -C matrix R_1c = [ R_12' R_22' R_11' ]', and S_12 -C contains the corresponding leading part of the transformed -C matrix R_2c = [ R_13' R_23' R_14' ]'. For METH = 'N', -C the subarray S_41 : S_43 contains the transpose of the -C matrix contained in S_14 : S_34. -C The details of the contents of R need not be known if this -C routine is followed by SLICOT Library routine IB01BD. -C On entry, if ALG = 'C', or ALG = 'Q', and BATCH = 'I' or -C 'L', the leading 2*(M+L)*NOBR-by-2*(M+L)*NOBR upper -C triangular part of this array must contain the upper -C triangular matrix R computed at the previous call of this -C routine in sequential data processing. The array R need -C not be set on entry if ALG = 'F' or if BATCH = 'F' or 'O'. -C -C LDR INTEGER -C The leading dimension of the array R. -C LDR >= MAX( 2*(M+L)*NOBR, 3*M*NOBR ), -C for METH = 'M' and JOBD = 'M'; -C LDR >= 2*(M+L)*NOBR, for METH = 'M' and JOBD = 'N' or -C for METH = 'N'. -C -C SV (output) DOUBLE PRECISION array, dimension ( L*NOBR ) -C The singular values used to estimate the system order. -C -C Tolerances -C -C RCOND DOUBLE PRECISION -C The tolerance to be used for estimating the rank of -C matrices. If the user sets RCOND > 0, the given value -C of RCOND is used as a lower bound for the reciprocal -C condition number; an m-by-n matrix whose estimated -C condition number is less than 1/RCOND is considered to -C be of full rank. If the user sets RCOND <= 0, then an -C implicitly computed, default tolerance, defined by -C RCONDEF = m*n*EPS, is used instead, where EPS is the -C relative machine precision (see LAPACK Library routine -C DLAMCH). -C This parameter is not used for METH = 'M'. -C -C TOL DOUBLE PRECISION -C Absolute tolerance used for determining an estimate of -C the system order. If TOL >= 0, the estimate is -C indicated by the index of the last singular value greater -C than or equal to TOL. (Singular values less than TOL -C are considered as zero.) When TOL = 0, an internally -C computed default value, TOL = NOBR*EPS*SV(1), is used, -C where SV(1) is the maximal singular value, and EPS is -C the relative machine precision (see LAPACK Library routine -C DLAMCH). When TOL < 0, the estimate is indicated by the -C index of the singular value that has the largest -C logarithmic gap to its successor. -C -C Workspace -C -C IWORK INTEGER array, dimension (LIWORK) -C LIWORK >= (M+L)*NOBR, if METH = 'N'; -C LIWORK >= M+L, if METH = 'M' and ALG = 'F'; -C LIWORK >= 0, if METH = 'M' and ALG = 'C' or 'Q'. -C -C DWORK DOUBLE PRECISION array, dimension (LDWORK) -C On exit, if INFO = 0, DWORK(1) returns the optimal value -C of LDWORK, and, for METH = 'N', and BATCH = 'L' or -C 'O', DWORK(2) and DWORK(3) contain the reciprocal -C condition numbers of the triangular factors of the -C matrices U_f and r_1 [6]. -C On exit, if INFO = -23, DWORK(1) returns the minimum -C value of LDWORK. -C Let -C k = 0, if CONCT = 'N' and ALG = 'C' or 'Q'; -C k = 2*NOBR-1, if CONCT = 'C' and ALG = 'C' or 'Q'; -C k = 2*NOBR*(M+L+1), if CONCT = 'N' and ALG = 'F'; -C k = 2*NOBR*(M+L+2), if CONCT = 'C' and ALG = 'F'. -C The first (M+L)*k elements of DWORK should be preserved -C during successive calls of the routine with BATCH = 'F' -C or 'I', till the final call with BATCH = 'L'. -C -C LDWORK INTEGER -C The length of the array DWORK. -C LDWORK >= (4*NOBR-2)*(M+L), if ALG = 'C', BATCH = 'F' or -C 'I' and CONCT = 'C'; -C LDWORK >= 1, if ALG = 'C', BATCH = 'F' or 'I' and -C CONCT = 'N'; -C LDWORK >= max((4*NOBR-2)*(M+L), 5*L*NOBR), if METH = 'M', -C ALG = 'C', BATCH = 'L' and CONCT = 'C'; -C LDWORK >= max((2*M-1)*NOBR, (M+L)*NOBR, 5*L*NOBR), -C if METH = 'M', JOBD = 'M', ALG = 'C', -C BATCH = 'O', or -C (BATCH = 'L' and CONCT = 'N'); -C LDWORK >= 5*L*NOBR, if METH = 'M', JOBD = 'N', ALG = 'C', -C BATCH = 'O', or -C (BATCH = 'L' and CONCT = 'N'); -C LDWORK >= 5*(M+L)*NOBR+1, if METH = 'N', ALG = 'C', and -C BATCH = 'L' or 'O'; -C LDWORK >= (M+L)*2*NOBR*(M+L+3), if ALG = 'F', -C BATCH <> 'O' and CONCT = 'C'; -C LDWORK >= (M+L)*2*NOBR*(M+L+1), if ALG = 'F', -C BATCH = 'F', 'I' and CONCT = 'N'; -C LDWORK >= (M+L)*4*NOBR*(M+L+1)+(M+L)*2*NOBR, if ALG = 'F', -C BATCH = 'L' and CONCT = 'N', or -C BATCH = 'O'; -C LDWORK >= 4*(M+L)*NOBR, if ALG = 'Q', BATCH = 'F', and -C LDR >= NS = NSMP - 2*NOBR + 1; -C LDWORK >= max(4*(M+L)*NOBR, 5*L*NOBR), if METH = 'M', -C ALG = 'Q', BATCH = 'O', and LDR >= NS; -C LDWORK >= 5*(M+L)*NOBR+1, if METH = 'N', ALG = 'Q', -C BATCH = 'O', and LDR >= NS; -C LDWORK >= 6*(M+L)*NOBR, if ALG = 'Q', (BATCH = 'F' or 'O', -C and LDR < NS), or (BATCH = 'I' or -C 'L' and CONCT = 'N'); -C LDWORK >= 4*(NOBR+1)*(M+L)*NOBR, if ALG = 'Q', BATCH = 'I' -C or 'L' and CONCT = 'C'. -C The workspace used for ALG = 'Q' is -C LDRWRK*2*(M+L)*NOBR + 4*(M+L)*NOBR, -C where LDRWRK = LDWORK/(2*(M+L)*NOBR) - 2; recommended -C value LDRWRK = NS, assuming a large enough cache size. -C For good performance, LDWORK should be larger. -C -C Warning Indicator -C -C IWARN INTEGER -C = 0: no warning; -C = 1: the number of 100 cycles in sequential data -C processing has been exhausted without signaling -C that the last block of data was get; the cycle -C counter was reinitialized; -C = 2: a fast algorithm was requested (ALG = 'C' or 'F'), -C but it failed, and the QR algorithm was then used -C (non-sequential data processing); -C = 3: all singular values were exactly zero, hence N = 0 -C (both input and output were identically zero); -C = 4: the least squares problems with coefficient matrix -C U_f, used for computing the weighted oblique -C projection (for METH = 'N'), have a rank-deficient -C coefficient matrix; -C = 5: the least squares problem with coefficient matrix -C r_1 [6], used for computing the weighted oblique -C projection (for METH = 'N'), has a rank-deficient -C coefficient matrix. -C NOTE: the values 4 and 5 of IWARN have no significance -C for the identification problem. -C -C Error Indicator -C -C INFO INTEGER -C = 0: successful exit; -C < 0: if INFO = -i, the i-th argument had an illegal -C value; -C = 1: a fast algorithm was requested (ALG = 'C', or 'F') -C in sequential data processing, but it failed; the -C routine can be repeatedly called again using the -C standard QR algorithm; -C = 2: the singular value decomposition (SVD) algorithm did -C not converge. -C -C METHOD -C -C The procedure consists in three main steps, the first step being -C performed by one of the three algorithms included. -C -C 1.a) For non-sequential data processing using QR algorithm, a -C t x 2(m+l)s matrix H is constructed, where -C -C H = [ Uf' Up' Y' ], for METH = 'M', -C s+1,2s,t 1,s,t 1,2s,t -C -C H = [ U' Y' ], for METH = 'N', -C 1,2s,t 1,2s,t -C -C and Up , Uf , U , and Y are block Hankel -C 1,s,t s+1,2s,t 1,2s,t 1,2s,t -C matrices defined in terms of the input and output data [3]. -C A QR factorization is used to compress the data. -C The fast QR algorithm uses a QR factorization which exploits -C the block-Hankel structure. Actually, the Cholesky factor of H'*H -C is computed. -C -C 1.b) For sequential data processing using QR algorithm, the QR -C decomposition is done sequentially, by updating the upper -C triangular factor R. This is also performed internally if the -C workspace is not large enough to accommodate an entire batch. -C -C 1.c) For non-sequential or sequential data processing using -C Cholesky algorithm, the correlation matrix of input-output data is -C computed (sequentially, if requested), taking advantage of the -C block Hankel structure [7]. Then, the Cholesky factor of the -C correlation matrix is found, if possible. -C -C 2) A singular value decomposition (SVD) of a certain matrix is -C then computed, which reveals the order n of the system as the -C number of "non-zero" singular values. For the MOESP approach, this -C matrix is [ R_24' R_34' ]' := R(ms+1:(2m+l)s,(2m+l)s+1:2(m+l)s), -C where R is the upper triangular factor R constructed by SLICOT -C Library routine IB01MD. For the N4SID approach, a weighted -C oblique projection is computed from the upper triangular factor R -C and its SVD is then found. -C -C 3) The singular values are compared to the given, or default TOL, -C and the estimated order n is returned, possibly after user's -C confirmation. -C -C REFERENCES -C -C [1] Verhaegen M., and Dewilde, P. -C Subspace Model Identification. Part 1: The output-error -C state-space model identification class of algorithms. -C Int. J. Control, 56, pp. 1187-1210, 1992. -C -C [2] Verhaegen M. -C Subspace Model Identification. Part 3: Analysis of the -C ordinary output-error state-space model identification -C algorithm. -C Int. J. Control, 58, pp. 555-586, 1993. -C -C [3] Verhaegen M. -C Identification of the deterministic part of MIMO state space -C models given in innovations form from input-output data. -C Automatica, Vol.30, No.1, pp.61-74, 1994. -C -C [4] Van Overschee, P., and De Moor, B. -C N4SID: Subspace Algorithms for the Identification of -C Combined Deterministic-Stochastic Systems. -C Automatica, Vol.30, No.1, pp. 75-93, 1994. -C -C [5] Peternell, K., Scherrer, W. and Deistler, M. -C Statistical Analysis of Novel Subspace Identification Methods. -C Signal Processing, 52, pp. 161-177, 1996. -C -C [6] Sima, V. -C Subspace-based Algorithms for Multivariable System -C Identification. -C Studies in Informatics and Control, 5, pp. 335-344, 1996. -C -C [7] Sima, V. -C Cholesky or QR Factorization for Data Compression in -C Subspace-based Identification ? -C Proceedings of the Second NICONET Workshop on ``Numerical -C Control Software: SLICOT, a Useful Tool in Industry'', -C December 3, 1999, INRIA Rocquencourt, France, pp. 75-80, 1999. -C -C NUMERICAL ASPECTS -C -C The implemented method is numerically stable (when QR algorithm is -C used), reliable and efficient. The fast Cholesky or QR algorithms -C are more efficient, but the accuracy could diminish by forming the -C correlation matrix. -C The most time-consuming computational step is step 1: -C 2 -C The QR algorithm needs 0(t(2(m+l)s) ) floating point operations. -C 2 3 -C The Cholesky algorithm needs 0(2t(m+l) s)+0((2(m+l)s) ) floating -C point operations. -C 2 3 2 -C The fast QR algorithm needs 0(2t(m+l) s)+0(4(m+l) s ) floating -C point operations. -C 3 -C Step 2 of the algorithm requires 0(((m+l)s) ) floating point -C operations. -C -C FURTHER COMMENTS -C -C For ALG = 'Q', BATCH = 'O' and LDR < NS, or BATCH <> 'O', the -C calculations could be rather inefficient if only minimal workspace -C (see argument LDWORK) is provided. It is advisable to provide as -C much workspace as possible. Almost optimal efficiency can be -C obtained for LDWORK = (NS+2)*(2*(M+L)*NOBR), assuming that the -C cache size is large enough to accommodate R, U, Y, and DWORK. -C -C CONTRIBUTOR -C -C V. Sima, Katholieke Universiteit Leuven, Feb. 2000. -C -C REVISIONS -C -C August 2000, March 2005. -C -C KEYWORDS -C -C Cholesky decomposition, Hankel matrix, identification methods, -C multivariable systems, QR decomposition, singular value -C decomposition. -C -C ****************************************************************** -C -C .. Scalar Arguments .. - DOUBLE PRECISION RCOND, TOL - INTEGER INFO, IWARN, L, LDR, LDU, LDWORK, LDY, M, N, - $ NOBR, NSMP - CHARACTER ALG, BATCH, CONCT, CTRL, JOBD, METH -C .. Array Arguments .. - INTEGER IWORK(*) - DOUBLE PRECISION DWORK(*), R(LDR, *), SV(*), U(LDU, *), - $ Y(LDY, *) -C .. Local Scalars .. - INTEGER IWARNL, LMNOBR, LNOBR, MAXWRK, MINWRK, MNOBR, - $ NOBR21, NR, NS, NSMPSM - LOGICAL CHALG, CONNEC, CONTRL, FIRST, FQRALG, INTERM, - $ JOBDM, LAST, MOESP, N4SID, ONEBCH, QRALG -C .. External Functions .. - LOGICAL LSAME - EXTERNAL LSAME -C .. External Subroutines .. - EXTERNAL IB01MD, IB01ND, IB01OD, XERBLA -C .. Intrinsic Functions .. - INTRINSIC MAX -C .. Save Statement .. -C MAXWRK is used to store the optimal workspace. -C NSMPSM is used to sum up the NSMP values for BATCH <> 'O'. - SAVE MAXWRK, NSMPSM -C .. -C .. Executable Statements .. -C -C Decode the scalar input parameters. -C - MOESP = LSAME( METH, 'M' ) - N4SID = LSAME( METH, 'N' ) - FQRALG = LSAME( ALG, 'F' ) - QRALG = LSAME( ALG, 'Q' ) - CHALG = LSAME( ALG, 'C' ) - JOBDM = LSAME( JOBD, 'M' ) - ONEBCH = LSAME( BATCH, 'O' ) - FIRST = LSAME( BATCH, 'F' ) .OR. ONEBCH - INTERM = LSAME( BATCH, 'I' ) - LAST = LSAME( BATCH, 'L' ) .OR. ONEBCH - CONTRL = LSAME( CTRL, 'C' ) -C - IF( .NOT.ONEBCH ) THEN - CONNEC = LSAME( CONCT, 'C' ) - ELSE - CONNEC = .FALSE. - END IF -C - MNOBR = M*NOBR - LNOBR = L*NOBR - LMNOBR = LNOBR + MNOBR - NR = LMNOBR + LMNOBR - NOBR21 = 2*NOBR - 1 - IWARN = 0 - INFO = 0 - IF( FIRST ) THEN - MAXWRK = 1 - NSMPSM = 0 - END IF - NSMPSM = NSMPSM + NSMP -C -C Check the scalar input parameters. -C - IF( .NOT.( MOESP .OR. N4SID ) ) THEN - INFO = -1 - ELSE IF( .NOT.( FQRALG .OR. QRALG .OR. CHALG ) ) THEN - INFO = -2 - ELSE IF( MOESP .AND. .NOT.( JOBDM .OR. LSAME( JOBD, 'N' ) ) ) THEN - INFO = -3 - ELSE IF( .NOT.( FIRST .OR. INTERM .OR. LAST ) ) THEN - INFO = -4 - ELSE IF( .NOT. ONEBCH ) THEN - IF( .NOT.( CONNEC .OR. LSAME( CONCT, 'N' ) ) ) - $ INFO = -5 - END IF - IF( INFO.EQ.0 ) THEN - IF( .NOT.( CONTRL .OR. LSAME( CTRL, 'N' ) ) ) THEN - INFO = -6 - ELSE IF( NOBR.LE.0 ) THEN - INFO = -7 - ELSE IF( M.LT.0 ) THEN - INFO = -8 - ELSE IF( L.LE.0 ) THEN - INFO = -9 - ELSE IF( NSMP.LT.2*NOBR .OR. - $ ( LAST .AND. NSMPSM.LT.NR+NOBR21 ) ) THEN - INFO = -10 - ELSE IF( LDU.LT.1 .OR. ( M.GT.0 .AND. LDU.LT.NSMP ) ) THEN - INFO = -12 - ELSE IF( LDY.LT.NSMP ) THEN - INFO = -14 - ELSE IF( LDR.LT.NR .OR. ( MOESP .AND. JOBDM .AND. - $ LDR.LT.3*MNOBR ) ) THEN - INFO = -17 - ELSE -C -C Compute workspace. -C (Note: Comments in the code beginning "Workspace:" describe -C the minimal amount of workspace needed at that point in the -C code, as well as the preferred amount for good performance.) -C - NS = NSMP - NOBR21 - IF ( CHALG ) THEN - IF ( .NOT.LAST ) THEN - IF ( CONNEC ) THEN - MINWRK = 2*( NR - M - L ) - ELSE - MINWRK = 1 - END IF - ELSE IF ( MOESP ) THEN - IF ( CONNEC .AND. .NOT.ONEBCH ) THEN - MINWRK = MAX( 2*( NR - M - L ), 5*LNOBR ) - ELSE - MINWRK = 5*LNOBR - IF ( JOBDM ) - $ MINWRK = MAX( 2*MNOBR - NOBR, LMNOBR, MINWRK ) - END IF - ELSE - MINWRK = 5*LMNOBR + 1 - END IF - ELSE IF ( FQRALG ) THEN - IF ( .NOT.ONEBCH .AND. CONNEC ) THEN - MINWRK = NR*( M + L + 3 ) - ELSE IF ( FIRST .OR. INTERM ) THEN - MINWRK = NR*( M + L + 1 ) - ELSE - MINWRK = 2*NR*( M + L + 1 ) + NR - END IF - ELSE - MINWRK = 2*NR - IF ( ONEBCH .AND. LDR.GE.NS ) THEN - IF ( MOESP ) THEN - MINWRK = MAX( MINWRK, 5*LNOBR ) - ELSE - MINWRK = 5*LMNOBR + 1 - END IF - END IF - IF ( FIRST ) THEN - IF ( LDR.LT.NS ) THEN - MINWRK = MINWRK + NR - END IF - ELSE - IF ( CONNEC ) THEN - MINWRK = MINWRK*( NOBR + 1 ) - ELSE - MINWRK = MINWRK + NR - END IF - END IF - END IF -C - MAXWRK = MINWRK -C - IF( LDWORK.LT.MINWRK ) THEN - INFO = -23 - DWORK( 1 ) = MINWRK - END IF - END IF - END IF -C -C Return if there are illegal arguments. -C - IF( INFO.NE.0 ) THEN - CALL XERBLA( 'IB01AD', -INFO ) - RETURN - END IF -C -C Compress the input-output data. -C Workspace: need c*(M+L)*NOBR, where c is a constant depending -C on the algorithm and the options used -C (see SLICOT Library routine IB01MD); -C prefer larger. -C - CALL IB01MD( METH, ALG, BATCH, CONCT, NOBR, M, L, NSMP, U, LDU, Y, - $ LDY, R, LDR, IWORK, DWORK, LDWORK, IWARN, INFO ) -C - IF ( INFO.EQ.1 ) THEN -C -C Error return: A fast algorithm was requested (ALG = 'C', 'F') -C in sequential data processing, but it failed. -C - RETURN - END IF -C - MAXWRK = MAX( MAXWRK, INT( DWORK( 1 ) ) ) -C - IF ( .NOT.LAST ) THEN -C -C Return to get new data. -C - RETURN - END IF -C -C Find the singular value decomposition (SVD) giving the system -C order, and perform related preliminary calculations needed for -C computing the system matrices. -C Workspace: need max( (2*M-1)*NOBR, (M+L)*NOBR, 5*L*NOBR ), -C if METH = 'M'; -C 5*(M+L)*NOBR+1, if METH = 'N'; -C prefer larger. -C - CALL IB01ND( METH, JOBD, NOBR, M, L, R, LDR, SV, RCOND, IWORK, - $ DWORK, LDWORK, IWARNL, INFO ) - IWARN = MAX( IWARN, IWARNL ) -C - IF ( INFO.EQ.2 ) THEN -C -C Error return: the singular value decomposition (SVD) algorithm -C did not converge. -C - RETURN - END IF -C -C Estimate the system order. -C - CALL IB01OD( CTRL, NOBR, L, SV, N, TOL, IWARNL, INFO ) - IWARN = MAX( IWARN, IWARNL ) -C -C Return optimal workspace in DWORK(1). -C - DWORK( 1 ) = MAX( MAXWRK, INT( DWORK( 1 ) ) ) - RETURN -C -C *** Last line of IB01AD *** - END diff --git a/mex/sources/libslicot/IB01BD.f b/mex/sources/libslicot/IB01BD.f deleted file mode 100644 index 011e02d34..000000000 --- a/mex/sources/libslicot/IB01BD.f +++ /dev/null @@ -1,791 +0,0 @@ - SUBROUTINE IB01BD( METH, JOB, JOBCK, NOBR, N, M, L, NSMPL, R, - $ LDR, A, LDA, C, LDC, B, LDB, D, LDD, Q, LDQ, - $ RY, LDRY, S, LDS, K, LDK, TOL, IWORK, DWORK, - $ LDWORK, BWORK, IWARN, INFO ) -C -C SLICOT RELEASE 5.0. -C -C Copyright (c) 2002-2009 NICONET e.V. -C -C This program is free software: you can redistribute it and/or -C modify it under the terms of the GNU General Public License as -C published by the Free Software Foundation, either version 2 of -C the License, or (at your option) any later version. -C -C This program is distributed in the hope that it will be useful, -C but WITHOUT ANY WARRANTY; without even the implied warranty of -C MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the -C GNU General Public License for more details. -C -C You should have received a copy of the GNU General Public License -C along with this program. If not, see -C . -C -C PURPOSE -C -C To estimate the system matrices A, C, B, and D, the noise -C covariance matrices Q, Ry, and S, and the Kalman gain matrix K -C of a linear time-invariant state space model, using the -C processed triangular factor R of the concatenated block Hankel -C matrices, provided by SLICOT Library routine IB01AD. -C -C ARGUMENTS -C -C Mode Parameters -C -C METH CHARACTER*1 -C Specifies the subspace identification method to be used, -C as follows: -C = 'M': MOESP algorithm with past inputs and outputs; -C = 'N': N4SID algorithm; -C = 'C': combined method: MOESP algorithm for finding the -C matrices A and C, and N4SID algorithm for -C finding the matrices B and D. -C -C JOB CHARACTER*1 -C Specifies which matrices should be computed, as follows: -C = 'A': compute all system matrices, A, B, C, and D; -C = 'C': compute the matrices A and C only; -C = 'B': compute the matrix B only; -C = 'D': compute the matrices B and D only. -C -C JOBCK CHARACTER*1 -C Specifies whether or not the covariance matrices and the -C Kalman gain matrix are to be computed, as follows: -C = 'C': the covariance matrices only should be computed; -C = 'K': the covariance matrices and the Kalman gain -C matrix should be computed; -C = 'N': the covariance matrices and the Kalman gain matrix -C should not be computed. -C -C Input/Output Parameters -C -C NOBR (input) INTEGER -C The number of block rows, s, in the input and output -C Hankel matrices processed by other routines. NOBR > 1. -C -C N (input) INTEGER -C The order of the system. NOBR > N > 0. -C -C M (input) INTEGER -C The number of system inputs. M >= 0. -C -C L (input) INTEGER -C The number of system outputs. L > 0. -C -C NSMPL (input) INTEGER -C If JOBCK = 'C' or 'K', the total number of samples used -C for calculating the covariance matrices. -C NSMPL >= 2*(M+L)*NOBR. -C This parameter is not meaningful if JOBCK = 'N'. -C -C R (input/workspace) DOUBLE PRECISION array, dimension -C ( LDR,2*(M+L)*NOBR ) -C On entry, the leading 2*(M+L)*NOBR-by-2*(M+L)*NOBR part -C of this array must contain the relevant data for the MOESP -C or N4SID algorithms, as constructed by SLICOT Library -C routine IB01AD. Let R_ij, i,j = 1:4, be the -C ij submatrix of R (denoted S in IB01AD), partitioned -C by M*NOBR, L*NOBR, M*NOBR, and L*NOBR rows and -C columns. The submatrix R_22 contains the matrix of left -C singular vectors used. Also needed, for METH = 'N' or -C JOBCK <> 'N', are the submatrices R_11, R_14 : R_44, -C and, for METH = 'M' or 'C' and JOB <> 'C', the -C submatrices R_31 and R_12, containing the processed -C matrices R_1c and R_2c, respectively, as returned by -C SLICOT Library routine IB01AD. -C Moreover, if METH = 'N' and JOB = 'A' or 'C', the -C block-row R_41 : R_43 must contain the transpose of the -C block-column R_14 : R_34 as returned by SLICOT Library -C routine IB01AD. -C The remaining part of R is used as workspace. -C On exit, part of this array is overwritten. Specifically, -C if METH = 'M', R_22 and R_31 are overwritten if -C JOB = 'B' or 'D', and R_12, R_22, R_14 : R_34, -C and possibly R_11 are overwritten if JOBCK <> 'N'; -C if METH = 'N', all needed submatrices are overwritten. -C The details of the contents of R need not be known if -C this routine is called once just after calling the SLICOT -C Library routine IB01AD. -C -C LDR INTEGER -C The leading dimension of the array R. -C LDR >= 2*(M+L)*NOBR. -C -C A (input or output) DOUBLE PRECISION array, dimension -C (LDA,N) -C On entry, if METH = 'N' or 'C' and JOB = 'B' or 'D', -C the leading N-by-N part of this array must contain the -C system state matrix. -C If METH = 'M' or (METH = 'N' or 'C' and JOB = 'A' -C or 'C'), this array need not be set on input. -C On exit, if JOB = 'A' or 'C' and INFO = 0, the -C leading N-by-N part of this array contains the system -C state matrix. -C -C LDA INTEGER -C The leading dimension of the array A. -C LDA >= N, if JOB = 'A' or 'C', or METH = 'N' or 'C' -C and JOB = 'B' or 'D'; -C LDA >= 1, otherwise. -C -C C (input or output) DOUBLE PRECISION array, dimension -C (LDC,N) -C On entry, if METH = 'N' or 'C' and JOB = 'B' or 'D', -C the leading L-by-N part of this array must contain the -C system output matrix. -C If METH = 'M' or (METH = 'N' or 'C' and JOB = 'A' -C or 'C'), this array need not be set on input. -C On exit, if JOB = 'A' or 'C' and INFO = 0, or -C INFO = 3 (or INFO >= 0, for METH = 'M'), the leading -C L-by-N part of this array contains the system output -C matrix. -C -C LDC INTEGER -C The leading dimension of the array C. -C LDC >= L, if JOB = 'A' or 'C', or METH = 'N' or 'C' -C and JOB = 'B' or 'D'; -C LDC >= 1, otherwise. -C -C B (output) DOUBLE PRECISION array, dimension (LDB,M) -C If M > 0, JOB = 'A', 'B', or 'D' and INFO = 0, the -C leading N-by-M part of this array contains the system -C input matrix. If M = 0 or JOB = 'C', this array is -C not referenced. -C -C LDB INTEGER -C The leading dimension of the array B. -C LDB >= N, if M > 0 and JOB = 'A', 'B', or 'D'; -C LDB >= 1, if M = 0 or JOB = 'C'. -C -C D (output) DOUBLE PRECISION array, dimension (LDD,M) -C If M > 0, JOB = 'A' or 'D' and INFO = 0, the leading -C L-by-M part of this array contains the system input-output -C matrix. If M = 0 or JOB = 'C' or 'B', this array is -C not referenced. -C -C LDD INTEGER -C The leading dimension of the array D. -C LDD >= L, if M > 0 and JOB = 'A' or 'D'; -C LDD >= 1, if M = 0 or JOB = 'C' or 'B'. -C -C Q (output) DOUBLE PRECISION array, dimension (LDQ,N) -C If JOBCK = 'C' or 'K', the leading N-by-N part of this -C array contains the positive semidefinite state covariance -C matrix. If JOBCK = 'K', this matrix has been used as -C state weighting matrix for computing the Kalman gain. -C This parameter is not referenced if JOBCK = 'N'. -C -C LDQ INTEGER -C The leading dimension of the array Q. -C LDQ >= N, if JOBCK = 'C' or 'K'; -C LDQ >= 1, if JOBCK = 'N'. -C -C RY (output) DOUBLE PRECISION array, dimension (LDRY,L) -C If JOBCK = 'C' or 'K', the leading L-by-L part of this -C array contains the positive (semi)definite output -C covariance matrix. If JOBCK = 'K', this matrix has been -C used as output weighting matrix for computing the Kalman -C gain. -C This parameter is not referenced if JOBCK = 'N'. -C -C LDRY INTEGER -C The leading dimension of the array RY. -C LDRY >= L, if JOBCK = 'C' or 'K'; -C LDRY >= 1, if JOBCK = 'N'. -C -C S (output) DOUBLE PRECISION array, dimension (LDS,L) -C If JOBCK = 'C' or 'K', the leading N-by-L part of this -C array contains the state-output cross-covariance matrix. -C If JOBCK = 'K', this matrix has been used as state- -C output weighting matrix for computing the Kalman gain. -C This parameter is not referenced if JOBCK = 'N'. -C -C LDS INTEGER -C The leading dimension of the array S. -C LDS >= N, if JOBCK = 'C' or 'K'; -C LDS >= 1, if JOBCK = 'N'. -C -C K (output) DOUBLE PRECISION array, dimension ( LDK,L ) -C If JOBCK = 'K', the leading N-by-L part of this array -C contains the estimated Kalman gain matrix. -C If JOBCK = 'C' or 'N', this array is not referenced. -C -C LDK INTEGER -C The leading dimension of the array K. -C LDK >= N, if JOBCK = 'K'; -C LDK >= 1, if JOBCK = 'C' or 'N'. -C -C Tolerances -C -C TOL DOUBLE PRECISION -C The tolerance to be used for estimating the rank of -C matrices. If the user sets TOL > 0, then the given value -C of TOL is used as a lower bound for the reciprocal -C condition number; an m-by-n matrix whose estimated -C condition number is less than 1/TOL is considered to -C be of full rank. If the user sets TOL <= 0, then an -C implicitly computed, default tolerance, defined by -C TOLDEF = m*n*EPS, is used instead, where EPS is the -C relative machine precision (see LAPACK Library routine -C DLAMCH). -C -C Workspace -C -C IWORK INTEGER array, dimension (LIWORK) -C LIWORK >= max(LIW1,LIW2), where -C LIW1 = N, if METH <> 'N' and M = 0 -C or JOB = 'C' and JOBCK = 'N'; -C LIW1 = M*NOBR+N, if METH <> 'N', JOB = 'C', -C and JOBCK <> 'N'; -C LIW1 = max(L*NOBR,M*NOBR), if METH = 'M', JOB <> 'C', -C and JOBCK = 'N'; -C LIW1 = max(L*NOBR,M*NOBR+N), if METH = 'M', JOB <> 'C', -C and JOBCK = 'C' or 'K'; -C LIW1 = max(M*NOBR+N,M*(N+L)), if METH = 'N', or METH = 'C' -C and JOB <> 'C'; -C LIW2 = 0, if JOBCK <> 'K'; -C LIW2 = N*N, if JOBCK = 'K'. -C -C DWORK DOUBLE PRECISION array, dimension (LDWORK) -C On exit, if INFO = 0, DWORK(1) returns the optimal value -C of LDWORK, and DWORK(2), DWORK(3), DWORK(4), and -C DWORK(5) contain the reciprocal condition numbers of the -C triangular factors of the following matrices (defined in -C SLICOT Library routine IB01PD and in the lower level -C routines): -C GaL (GaL = Un(1:(s-1)*L,1:n)), -C R_1c (if METH = 'M' or 'C'), -C M (if JOBCK = 'C' or 'K' or METH = 'N'), and -C Q or T (see SLICOT Library routine IB01PY or IB01PX), -C respectively. -C If METH = 'N', DWORK(3) is set to one without any -C calculations. Similarly, if METH = 'M' and JOBCK = 'N', -C DWORK(4) is set to one. If M = 0 or JOB = 'C', -C DWORK(3) and DWORK(5) are set to one. -C If JOBCK = 'K' and INFO = 0, DWORK(6) to DWORK(13) -C contain information about the accuracy of the results when -C computing the Kalman gain matrix, as follows: -C DWORK(6) - reciprocal condition number of the matrix -C U11 of the Nth order system of algebraic -C equations from which the solution matrix X -C of the Riccati equation is obtained; -C DWORK(7) - reciprocal pivot growth factor for the LU -C factorization of the matrix U11; -C DWORK(8) - reciprocal condition number of the matrix -C As = A - S*inv(Ry)*C, which is inverted by -C the standard Riccati solver; -C DWORK(9) - reciprocal pivot growth factor for the LU -C factorization of the matrix As; -C DWORK(10) - reciprocal condition number of the matrix -C Ry; -C DWORK(11) - reciprocal condition number of the matrix -C Ry + C*X*C'; -C DWORK(12) - reciprocal condition number for the Riccati -C equation solution; -C DWORK(13) - forward error bound for the Riccati -C equation solution. -C On exit, if INFO = -30, DWORK(1) returns the minimum -C value of LDWORK. -C -C LDWORK INTEGER -C The length of the array DWORK. -C LDWORK >= max( LDW1,LDW2,LDW3 ), where, if METH = 'M', -C LDW1 >= max( 2*(L*NOBR-L)*N+2*N, (L*NOBR-L)*N+N*N+7*N ), -C if JOB = 'C' or JOB = 'A' and M = 0; -C LDW1 >= max( 2*(L*NOBR-L)*N+N*N+7*N, -C (L*NOBR-L)*N+N+6*M*NOBR, (L*NOBR-L)*N+N+ -C max( L+M*NOBR, L*NOBR + -C max( 3*L*NOBR+1, M ) ) ), -C if M > 0 and JOB = 'A', 'B', or 'D'; -C LDW2 >= 0, if JOBCK = 'N'; -C LDW2 >= L*NOBR*N+ -C max( (L*NOBR-L)*N+Aw+2*N+max(5*N,(2*M+L)*NOBR+L), -C 4*(M*NOBR+N)+1, M*NOBR+2*N+L ), -C if JOBCK = 'C' or 'K', -C where Aw = N+N*N, if M = 0 or JOB = 'C'; -C Aw = 0, otherwise; -C if METH = 'N', -C LDW1 >= L*NOBR*N+max( (L*NOBR-L)*N+2*N+(2*M+L)*NOBR+L, -C 2*(L*NOBR-L)*N+N*N+8*N, -C N+4*(M*NOBR+N)+1, M*NOBR+3*N+L ); -C LDW2 >= 0, if M = 0 or JOB = 'C'; -C LDW2 >= L*NOBR*N+M*NOBR*(N+L)*(M*(N+L)+1)+ -C max( (N+L)**2, 4*M*(N+L)+1 ), -C if M > 0 and JOB = 'A', 'B', or 'D'; -C and, if METH = 'C', LDW1 as -C max( LDW1 for METH = 'M', JOB = 'C', LDW1 for METH = 'N'), -C and LDW2 for METH = 'N' are used; -C LDW3 >= 0, if JOBCK <> 'K'; -C LDW3 >= max( 4*N*N+2*N*L+L*L+max( 3*L,N*L ), -C 14*N*N+12*N+5 ), if JOBCK = 'K'. -C For good performance, LDWORK should be larger. -C -C BWORK LOGICAL array, dimension (LBWORK) -C LBWORK = 2*N, if JOBCK = 'K'; -C LBWORK = 0, if JOBCK <> 'K'. -C -C Warning Indicator -C -C IWARN INTEGER -C = 0: no warning; -C = 4: a least squares problem to be solved has a -C rank-deficient coefficient matrix; -C = 5: the computed covariance matrices are too small. -C The problem seems to be a deterministic one; the -C gain matrix is set to zero. -C -C Error Indicator -C -C INFO INTEGER -C = 0: successful exit; -C < 0: if INFO = -i, the i-th argument had an illegal -C value; -C = 2: the singular value decomposition (SVD) algorithm did -C not converge; -C = 3: a singular upper triangular matrix was found; -C = 3+i: if JOBCK = 'K' and the associated Riccati -C equation could not be solved, where i = 1,...,6; -C (see the description of the parameter INFO for the -C SLICOT Library routine SB02RD for the meaning of -C the i values); -C = 10: the QR algorithm did not converge. -C -C METHOD -C -C In the MOESP approach, the matrices A and C are first -C computed from an estimated extended observability matrix [1], -C and then, the matrices B and D are obtained by solving an -C extended linear system in a least squares sense. -C In the N4SID approach, besides the estimated extended -C observability matrix, the solutions of two least squares problems -C are used to build another least squares problem, whose solution -C is needed to compute the system matrices A, C, B, and D. The -C solutions of the two least squares problems are also optionally -C used by both approaches to find the covariance matrices. -C The Kalman gain matrix is obtained by solving a discrete-time -C algebraic Riccati equation. -C -C REFERENCES -C -C [1] Verhaegen M., and Dewilde, P. -C Subspace Model Identification. Part 1: The output-error -C state-space model identification class of algorithms. -C Int. J. Control, 56, pp. 1187-1210, 1992. -C -C [2] Van Overschee, P., and De Moor, B. -C N4SID: Two Subspace Algorithms for the Identification -C of Combined Deterministic-Stochastic Systems. -C Automatica, Vol.30, No.1, pp. 75-93, 1994. -C -C [3] Van Overschee, P. -C Subspace Identification : Theory - Implementation - -C Applications. -C Ph. D. Thesis, Department of Electrical Engineering, -C Katholieke Universiteit Leuven, Belgium, Feb. 1995. -C -C [4] Sima, V. -C Subspace-based Algorithms for Multivariable System -C Identification. -C Studies in Informatics and Control, 5, pp. 335-344, 1996. -C -C NUMERICAL ASPECTS -C -C The implemented method consists in numerically stable steps. -C -C FURTHER COMMENTS -C -C The covariance matrices are computed using the N4SID approach. -C Therefore, for efficiency reasons, it is advisable to set -C METH = 'N', if the Kalman gain matrix or covariance matrices -C are needed (JOBCK = 'K', or 'C'). When JOBCK = 'N', it could -C be more efficient to use the combined method, METH = 'C'. -C Often, this combination will also provide better accuracy than -C MOESP algorithm. -C In some applications, it is useful to compute the system matrices -C using two calls to this routine, the first one with JOB = 'C', -C and the second one with JOB = 'B' or 'D'. This is slightly less -C efficient than using a single call with JOB = 'A', because some -C calculations are repeated. If METH = 'N', all the calculations -C at the first call are performed again at the second call; -C moreover, it is required to save the needed submatrices of R -C before the first call and restore them before the second call. -C If the covariance matrices and/or the Kalman gain are desired, -C JOBCK should be set to 'C' or 'K' at the second call. -C If B and D are both needed, they should be computed at once. -C -C CONTRIBUTOR -C -C V. Sima, Research Institute for Informatics, Bucharest, Dec. 1999. -C -C REVISIONS -C -C March 2000, August 2000, Sept. 2001, March 2005. -C -C KEYWORDS -C -C Identification methods; least squares solutions; multivariable -C systems; QR decomposition; singular value decomposition. -C -C ****************************************************************** -C -C .. Parameters .. - DOUBLE PRECISION ZERO, ONE - PARAMETER ( ZERO = 0.0D0, ONE = 1.0D0 ) -C .. Scalar Arguments .. - DOUBLE PRECISION TOL - INTEGER INFO, IWARN, L, LDA, LDB, LDC, LDD, LDK, LDQ, - $ LDR, LDRY, LDS, LDWORK, M, N, NOBR, NSMPL - CHARACTER JOB, JOBCK, METH -C .. Array Arguments .. - DOUBLE PRECISION A(LDA, *), B(LDB, *), C(LDC, *), D(LDD, *), - $ DWORK(*), K(LDK, *), Q(LDQ, *), R(LDR, *), - $ RY(LDRY, *), S(LDS, *) - INTEGER IWORK( * ) - LOGICAL BWORK( * ) -C .. Local Scalars .. - DOUBLE PRECISION FERR, RCOND, RCONDR, RNORM, SEP - INTEGER I, IA, IAW, IC, ID, IERR, IFACT, IG, IK, IO, - $ IQ, IR, IS, IT, IV, IWARNL, IWI, IWR, IX, - $ JWORK, LDUNN, LL, LMMNOL, LMNOBR, LNOBR, - $ MAXWRK, MINWRK, MNOBR, MNOBRN, N2, NL, NN, NPL, - $ NR - CHARACTER JOBBD, JOBCOV, JOBCV - LOGICAL COMBIN, MOESP, N4SID, WITHAL, WITHB, WITHC, - $ WITHCO, WITHD, WITHK -C .. Local Arrays .. - DOUBLE PRECISION RCND(8) - INTEGER OUFACT(2) -C .. External Functions .. - LOGICAL LSAME - EXTERNAL LSAME -C .. External Subroutines .. - EXTERNAL DLACPY, DLASET, IB01PD, MA02AD, SB02MT, SB02ND, - $ SB02RD, XERBLA -C .. Intrinsic Functions .. - INTRINSIC INT, MAX -C .. Executable Statements .. -C -C Decode the scalar input parameters. -C - MOESP = LSAME( METH, 'M' ) - N4SID = LSAME( METH, 'N' ) - COMBIN = LSAME( METH, 'C' ) - WITHAL = LSAME( JOB, 'A' ) - WITHC = LSAME( JOB, 'C' ) .OR. WITHAL - WITHD = LSAME( JOB, 'D' ) .OR. WITHAL - WITHB = LSAME( JOB, 'B' ) .OR. WITHD - WITHK = LSAME( JOBCK, 'K' ) - WITHCO = LSAME( JOBCK, 'C' ) .OR. WITHK - MNOBR = M*NOBR - LNOBR = L*NOBR - LMNOBR = LNOBR + MNOBR - MNOBRN = MNOBR + N - LDUNN = ( LNOBR - L )*N - LMMNOL = LNOBR + 2*MNOBR + L - NR = LMNOBR + LMNOBR - NPL = N + L - N2 = N + N - NN = N*N - NL = N*L - LL = L*L - MINWRK = 1 - IWARN = 0 - INFO = 0 -C -C Check the scalar input parameters. -C - IF( .NOT.( MOESP .OR. N4SID .OR. COMBIN ) ) THEN - INFO = -1 - ELSE IF( .NOT.( WITHB .OR. WITHC ) ) THEN - INFO = -2 - ELSE IF( .NOT.( WITHCO .OR. LSAME( JOBCK, 'N' ) ) ) THEN - INFO = -3 - ELSE IF( NOBR.LE.1 ) THEN - INFO = -4 - ELSE IF( N.LE.0 .OR. N.GE.NOBR ) THEN - INFO = -5 - ELSE IF( M.LT.0 ) THEN - INFO = -6 - ELSE IF( L.LE.0 ) THEN - INFO = -7 - ELSE IF( WITHCO .AND. NSMPL.LT.NR ) THEN - INFO = -8 - ELSE IF( LDR.LT.NR ) THEN - INFO = -10 - ELSE IF( LDA.LT.1 .OR. ( ( WITHC .OR. ( WITHB .AND. .NOT.MOESP ) ) - $ .AND. LDA.LT.N ) ) THEN - INFO = -12 - ELSE IF( LDC.LT.1 .OR. ( ( WITHC .OR. ( WITHB .AND. .NOT.MOESP ) ) - $ .AND. LDC.LT.L ) ) THEN - INFO = -14 - ELSE IF( LDB.LT.1 .OR. ( WITHB .AND. LDB.LT.N .AND. M.GT.0 ) ) - $ THEN - INFO = -16 - ELSE IF( LDD.LT.1 .OR. ( WITHD .AND. LDD.LT.L .AND. M.GT.0 ) ) - $ THEN - INFO = -18 - ELSE IF( LDQ.LT.1 .OR. ( WITHCO .AND. LDQ.LT.N ) ) THEN - INFO = -20 - ELSE IF( LDRY.LT.1 .OR. ( WITHCO .AND. LDRY.LT.L ) ) THEN - INFO = -22 - ELSE IF( LDS.LT.1 .OR. ( WITHCO .AND. LDS.LT.N ) ) THEN - INFO = -24 - ELSE IF( LDK.LT.1 .OR. ( WITHK .AND. LDK.LT.N ) ) THEN - INFO = -26 - ELSE -C -C Compute workspace. -C (Note: Comments in the code beginning "Workspace:" describe the -C minimal amount of workspace needed at that point in the code, -C as well as the preferred amount for good performance.) -C - IAW = 0 - MINWRK = LDUNN + 4*N - IF( .NOT.N4SID ) THEN - ID = 0 - IF( WITHC ) THEN - MINWRK = MAX( MINWRK, 2*LDUNN + N2, LDUNN + NN + 7*N ) - END IF - ELSE - ID = N - END IF -C - IF( ( M.GT.0 .AND. WITHB ) .OR. .NOT.MOESP ) THEN - MINWRK = MAX( MINWRK, 2*LDUNN + NN + ID + 7*N ) - IF ( MOESP ) - $ MINWRK = MAX( MINWRK, LDUNN + N + 6*MNOBR, LDUNN + N + - $ MAX( L + MNOBR, LNOBR + - $ MAX( 3*LNOBR + 1, M ) ) ) - ELSE - IF( .NOT.N4SID ) - $ IAW = N + NN - END IF -C - IF( .NOT.MOESP .OR. WITHCO ) THEN - MINWRK = MAX( MINWRK, LDUNN + IAW + N2 + MAX( 5*N, LMMNOL ), - $ ID + 4*MNOBRN + 1, ID + MNOBRN + NPL ) - IF( .NOT.MOESP .AND. M.GT.0 .AND. WITHB ) - $ MINWRK = MAX( MINWRK, MNOBR*NPL*( M*NPL + 1 ) + - $ MAX( NPL**2, 4*M*NPL + 1 ) ) - MINWRK = LNOBR*N + MINWRK - END IF -C - IF( WITHK ) THEN - MINWRK = MAX( MINWRK, 4*NN + 2*NL + LL + MAX( 3*L, NL ), - $ 14*NN + 12*N + 5 ) - END IF -C - IF ( LDWORK.LT.MINWRK ) THEN - INFO = -30 - DWORK( 1 ) = MINWRK - END IF - END IF -C -C Return if there are illegal arguments. -C - IF( INFO.NE.0 ) THEN - CALL XERBLA( 'IB01BD', -INFO ) - RETURN - END IF -C - IF ( .NOT.WITHK ) THEN - JOBCV = JOBCK - ELSE - JOBCV = 'C' - END IF -C - IO = 1 - IF ( .NOT.MOESP .OR. WITHCO ) THEN - JWORK = IO + LNOBR*N - ELSE - JWORK = IO - END IF - MAXWRK = MINWRK -C -C Call the computational routine for estimating system matrices. -C - IF ( .NOT.COMBIN ) THEN - CALL IB01PD( METH, JOB, JOBCV, NOBR, N, M, L, NSMPL, R, LDR, - $ A, LDA, C, LDC, B, LDB, D, LDD, Q, LDQ, RY, LDRY, - $ S, LDS, DWORK(IO), LNOBR, TOL, IWORK, - $ DWORK(JWORK), LDWORK-JWORK+1, IWARN, INFO ) -C - ELSE -C - IF ( WITHC ) THEN - IF ( WITHAL ) THEN - JOBCOV = 'N' - ELSE - JOBCOV = JOBCV - END IF - CALL IB01PD( 'MOESP', 'C and A', JOBCOV, NOBR, N, M, L, - $ NSMPL, R, LDR, A, LDA, C, LDC, B, LDB, D, LDD, - $ Q, LDQ, RY, LDRY, S, LDS, DWORK(IO), LNOBR, - $ TOL, IWORK, DWORK(JWORK), LDWORK-JWORK+1, - $ IWARNL, INFO ) - IF ( INFO.NE.0 ) - $ RETURN - IWARN = MAX( IWARN, IWARNL ) - MAXWRK = MAX( MAXWRK, INT( DWORK(JWORK) ) + JWORK - 1 ) - END IF -C - IF ( WITHB ) THEN - IF ( .NOT.WITHAL ) THEN - JOBBD = JOB - ELSE - JOBBD = 'D' - END IF - CALL IB01PD( 'N4SID', JOBBD, JOBCV, NOBR, N, M, L, NSMPL, R, - $ LDR, A, LDA, C, LDC, B, LDB, D, LDD, Q, LDQ, - $ RY, LDRY, S, LDS, DWORK(IO), LNOBR, TOL, IWORK, - $ DWORK(JWORK), LDWORK-JWORK+1, IWARNL, INFO ) - IWARN = MAX( IWARN, IWARNL ) - END IF - END IF -C - IF ( INFO.NE.0 ) - $ RETURN - MAXWRK = MAX( MAXWRK, INT( DWORK(JWORK) ) + JWORK - 1 ) -C - DO 10 I = 1, 4 - RCND(I) = DWORK(JWORK+I) - 10 CONTINUE -C - IF ( WITHK ) THEN - IF ( IWARN.EQ.5 ) THEN -C -C The problem seems to be a deterministic one. Set the Kalman -C gain to zero, set accuracy parameters and return. -C - CALL DLASET( 'Full', N, L, ZERO, ZERO, K, LDK ) -C - DO 20 I = 6, 12 - DWORK(I) = ONE - 20 CONTINUE -C - DWORK(13) = ZERO - ELSE -C -C Compute the Kalman gain matrix. -C -C Convert the optimal problem with coupling weighting terms -C to a standard problem. -C Workspace: need 4*N*N+2*N*L+L*L+max( 3*L,N*L ); -C prefer larger. -C - IX = 1 - IQ = IX + NN - IA = IQ + NN - IG = IA + NN - IC = IG + NN - IR = IC + NL - IS = IR + LL - JWORK = IS + NL -C - CALL MA02AD( 'Full', N, N, A, LDA, DWORK(IA), N ) - CALL MA02AD( 'Full', L, N, C, LDC, DWORK(IC), N ) - CALL DLACPY( 'Upper', N, N, Q, LDQ, DWORK(IQ), N ) - CALL DLACPY( 'Upper', L, L, RY, LDRY, DWORK(IR), L ) - CALL DLACPY( 'Full', N, L, S, LDS, DWORK(IS), N ) -C - CALL SB02MT( 'G needed', 'Nonzero S', 'Not factored', - $ 'Upper', N, L, DWORK(IA), N, DWORK(IC), N, - $ DWORK(IQ), N, DWORK(IR), L, DWORK(IS), N, - $ IWORK, IFACT, DWORK(IG), N, IWORK(L+1), - $ DWORK(JWORK), LDWORK-JWORK+1, IERR ) - IF ( IERR.NE.0 ) THEN - INFO = 3 - RETURN - END IF - MAXWRK = MAX( MAXWRK, INT( DWORK(JWORK) ) + JWORK - 1 ) - RCONDR = DWORK(JWORK+1) -C -C Solve the Riccati equation. -C Workspace: need 14*N*N+12*N+5; -C prefer larger. -C - IT = IC - IV = IT + NN - IWR = IV + NN - IWI = IWR + N2 - IS = IWI + N2 - JWORK = IS + N2*N2 -C - CALL SB02RD( 'All', 'Discrete', 'Direct', 'NoTranspose', - $ 'Upper', 'General scaling', 'Unstable first', - $ 'Not factored', 'Reduced', N, DWORK(IA), N, - $ DWORK(IT), N, DWORK(IV), N, DWORK(IG), N, - $ DWORK(IQ), N, DWORK(IX), N, SEP, RCOND, FERR, - $ DWORK(IWR), DWORK(IWI), DWORK(IS), N2, IWORK, - $ DWORK(JWORK), LDWORK-JWORK+1, BWORK, IERR ) -C - IF ( IERR.NE.0 .AND. IERR.LT.7 ) THEN - INFO = IERR + 3 - RETURN - END IF - MAXWRK = MAX( MAXWRK, INT( DWORK(JWORK) ) + JWORK - 1 ) -C - DO 30 I = 1, 4 - RCND(I+4) = DWORK(JWORK+I) - 30 CONTINUE -C -C Compute the gain matrix. -C Workspace: need 2*N*N+2*N*L+L*L+3*L; -C prefer larger. -C - IA = IX + NN - IC = IA + NN - IR = IC + NL - IK = IR + LL - JWORK = IK + NL -C - CALL MA02AD( 'Full', N, N, A, LDA, DWORK(IA), N ) - CALL MA02AD( 'Full', L, N, C, LDC, DWORK(IC), N ) - CALL DLACPY( 'Upper', L, L, RY, LDRY, DWORK(IR), L ) -C - CALL SB02ND( 'Discrete', 'NotFactored', 'Upper', - $ 'Nonzero S', N, L, 0, DWORK(IA), N, DWORK(IC), - $ N, DWORK(IR), L, IWORK, S, LDS, DWORK(IX), N, - $ RNORM, DWORK(IK), L, OUFACT, IWORK(L+1), - $ DWORK(JWORK), LDWORK-JWORK+1, IERR ) -C - IF ( IERR.NE.0 ) THEN - IF ( IERR.LE.L+1 ) THEN - INFO = 3 - ELSE IF ( IERR.EQ.L+2 ) THEN - INFO = 10 - END IF - RETURN - END IF - MAXWRK = MAX( MAXWRK, INT( DWORK(JWORK) ) + JWORK - 1 ) -C - CALL MA02AD( 'Full', L, N, DWORK(IK), L, K, LDK ) -C -C Set the accuracy parameters. -C - DWORK(11) = DWORK(JWORK+1) -C - DO 40 I = 6, 9 - DWORK(I) = RCND(I-1) - 40 CONTINUE -C - DWORK(10) = RCONDR - DWORK(12) = RCOND - DWORK(13) = FERR - END IF - END IF -C -C Return optimal workspace in DWORK(1) and the remaining -C reciprocal condition numbers in the next locations. -C - DWORK(1) = MAXWRK -C - DO 50 I = 2, 5 - DWORK(I) = RCND(I-1) - 50 CONTINUE -C - RETURN -C -C *** Last line of IB01BD *** - END diff --git a/mex/sources/libslicot/IB01CD.f b/mex/sources/libslicot/IB01CD.f deleted file mode 100644 index 001c6dcca..000000000 --- a/mex/sources/libslicot/IB01CD.f +++ /dev/null @@ -1,823 +0,0 @@ - SUBROUTINE IB01CD( JOBX0, COMUSE, JOB, N, M, L, NSMP, A, LDA, B, - $ LDB, C, LDC, D, LDD, U, LDU, Y, LDY, X0, V, - $ LDV, TOL, IWORK, DWORK, LDWORK, IWARN, INFO ) -C -C SLICOT RELEASE 5.0. -C -C Copyright (c) 2002-2009 NICONET e.V. -C -C This program is free software: you can redistribute it and/or -C modify it under the terms of the GNU General Public License as -C published by the Free Software Foundation, either version 2 of -C the License, or (at your option) any later version. -C -C This program is distributed in the hope that it will be useful, -C but WITHOUT ANY WARRANTY; without even the implied warranty of -C MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the -C GNU General Public License for more details. -C -C You should have received a copy of the GNU General Public License -C along with this program. If not, see -C . -C -C PURPOSE -C -C To estimate the initial state and, optionally, the system matrices -C B and D of a linear time-invariant (LTI) discrete-time system, -C given the system matrices (A,B,C,D), or (when B and D are -C estimated) only the matrix pair (A,C), and the input and output -C trajectories of the system. The model structure is : -C -C x(k+1) = Ax(k) + Bu(k), k >= 0, -C y(k) = Cx(k) + Du(k), -C -C where x(k) is the n-dimensional state vector (at time k), -C u(k) is the m-dimensional input vector, -C y(k) is the l-dimensional output vector, -C and A, B, C, and D are real matrices of appropriate dimensions. -C The input-output data can internally be processed sequentially. -C -C ARGUMENTS -C -C Mode Parameters -C -C JOBX0 CHARACTER*1 -C Specifies whether or not the initial state should be -C computed, as follows: -C = 'X': compute the initial state x(0); -C = 'N': do not compute the initial state (possibly, -C because x(0) is known to be zero). -C -C COMUSE CHARACTER*1 -C Specifies whether the system matrices B and D should be -C computed or used, as follows: -C = 'C': compute the system matrices B and D, as specified -C by JOB; -C = 'U': use the system matrices B and D, as specified by -C JOB; -C = 'N': do not compute/use the matrices B and D. -C If JOBX0 = 'N' and COMUSE <> 'N', then x(0) is set -C to zero. -C If JOBX0 = 'N' and COMUSE = 'N', then x(0) is -C neither computed nor set to zero. -C -C JOB CHARACTER*1 -C If COMUSE = 'C' or 'U', specifies which of the system -C matrices B and D should be computed or used, as follows: -C = 'B': compute/use the matrix B only (D is known to be -C zero); -C = 'D': compute/use the matrices B and D. -C The value of JOB is irrelevant if COMUSE = 'N' or if -C JOBX0 = 'N' and COMUSE = 'U'. -C The combinations of options, the data used, and the -C returned results, are given in the table below, where -C '*' denotes an irrelevant value. -C -C JOBX0 COMUSE JOB Data used Returned results -C ---------------------------------------------------------- -C X C B A,C,u,y x,B -C X C D A,C,u,y x,B,D -C N C B A,C,u,y x=0,B -C N C D A,C,u,y x=0,B,D -C ---------------------------------------------------------- -C X U B A,B,C,u,y x -C X U D A,B,C,D,u,y x -C N U * - x=0 -C ---------------------------------------------------------- -C X N * A,C,y x -C N N * - - -C ---------------------------------------------------------- -C -C For JOBX0 = 'N' and COMUSE = 'N', the routine just -C sets DWORK(1) to 2 and DWORK(2) to 1, and returns -C (see the parameter DWORK). -C -C Input/Output Parameters -C -C N (input) INTEGER -C The order of the system. N >= 0. -C -C M (input) INTEGER -C The number of system inputs. M >= 0. -C -C L (input) INTEGER -C The number of system outputs. L > 0. -C -C NSMP (input) INTEGER -C The number of rows of matrices U and Y (number of -C samples, t). -C NSMP >= 0, if JOBX0 = 'N' and COMUSE <> 'C'; -C NSMP >= N, if JOBX0 = 'X' and COMUSE <> 'C'; -C NSMP >= N*M + a + e, if COMUSE = 'C', -C where a = 0, if JOBX0 = 'N'; -C a = N, if JOBX0 = 'X'; -C e = 0, if JOBX0 = 'X' and JOB = 'B'; -C e = 1, if JOBX0 = 'N' and JOB = 'B'; -C e = M, if JOB = 'D'. -C -C A (input) DOUBLE PRECISION array, dimension (LDA,N) -C If JOBX0 = 'X' or COMUSE = 'C', the leading N-by-N -C part of this array must contain the system state matrix A. -C If N = 0, or JOBX0 = 'N' and COMUSE <> 'C', this -C array is not referenced. -C -C LDA INTEGER -C The leading dimension of the array A. -C LDA >= MAX(1,N), if JOBX0 = 'X' or COMUSE = 'C'; -C LDA >= 1, if JOBX0 = 'N' and COMUSE <> 'C'. -C -C B (input or output) DOUBLE PRECISION array, dimension -C (LDB,M) -C If JOBX0 = 'X' and COMUSE = 'U', B is an input -C parameter and, on entry, the leading N-by-M part of this -C array must contain the system input matrix B. -C If COMUSE = 'C', B is an output parameter and, on exit, -C if INFO = 0, the leading N-by-M part of this array -C contains the estimated system input matrix B. -C If min(N,M) = 0, or JOBX0 = 'N' and COMUSE = 'U', -C or COMUSE = 'N', this array is not referenced. -C -C LDB INTEGER -C The leading dimension of the array B. -C LDB >= MAX(1,N), if M > 0, COMUSE = 'U', JOBX0 = 'X', -C or M > 0, COMUSE = 'C'; -C LDB >= 1, if min(N,M) = 0, or COMUSE = 'N', -C or JOBX0 = 'N' and COMUSE = 'U'. -C -C C (input) DOUBLE PRECISION array, dimension (LDC,N) -C If JOBX0 = 'X' or COMUSE = 'C', the leading L-by-N -C part of this array must contain the system output -C matrix C. -C If N = 0, or JOBX0 = 'N' and COMUSE <> 'C', this -C array is not referenced. -C -C LDC INTEGER -C The leading dimension of the array C. -C LDC >= L, if N > 0, and JOBX0 = 'X' or COMUSE = 'C'; -C LDC >= 1, if N = 0, or JOBX0 = 'N' and COMUSE <> 'C'. -C -C D (input or output) DOUBLE PRECISION array, dimension -C (LDD,M) -C If JOBX0 = 'X', COMUSE = 'U', and JOB = 'D', D is an -C input parameter and, on entry, the leading L-by-M part of -C this array must contain the system input-output matrix D. -C If COMUSE = 'C' and JOB = 'D', D is an output -C parameter and, on exit, if INFO = 0, the leading -C L-by-M part of this array contains the estimated system -C input-output matrix D. -C If M = 0, or JOBX0 = 'N' and COMUSE = 'U', or -C COMUSE = 'N', or JOB = 'B', this array is not -C referenced. -C -C LDD INTEGER -C The leading dimension of the array D. -C LDD >= L, if M > 0, JOBX0 = 'X', COMUSE = 'U', and -C JOB = 'D', or -C if M > 0, COMUSE = 'C', and JOB = 'D'; -C LDD >= 1, if M = 0, or JOBX0 = 'N' and COMUSE = 'U', -C or COMUSE = 'N', or JOB = 'B'. -C -C U (input or input/output) DOUBLE PRECISION array, dimension -C (LDU,M) -C On entry, if COMUSE = 'C', or JOBX0 = 'X' and -C COMUSE = 'U', the leading NSMP-by-M part of this array -C must contain the t-by-m input-data sequence matrix U, -C U = [u_1 u_2 ... u_m]. Column j of U contains the -C NSMP values of the j-th input component for consecutive -C time increments. -C On exit, if COMUSE = 'C' and JOB = 'D', the leading -C NSMP-by-M part of this array contains details of the -C QR factorization of the t-by-m matrix U, possibly -C computed sequentially (see METHOD). -C If COMUSE = 'C' and JOB = 'B', or COMUSE = 'U', this -C array is unchanged on exit. -C If M = 0, or JOBX0 = 'N' and COMUSE = 'U', or -C COMUSE = 'N', this array is not referenced. -C -C LDU INTEGER -C The leading dimension of the array U. -C LDU >= MAX(1,NSMP), if M > 0 and COMUSE = 'C' or -C JOBX0 = 'X' and COMUSE = 'U; -C LDU >= 1, if M = 0, or COMUSE = 'N', or -C JOBX0 = 'N' and COMUSE = 'U'. -C -C Y (input) DOUBLE PRECISION array, dimension (LDY,L) -C On entry, if JOBX0 = 'X' or COMUSE = 'C', the leading -C NSMP-by-L part of this array must contain the t-by-l -C output-data sequence matrix Y, Y = [y_1 y_2 ... y_l]. -C Column j of Y contains the NSMP values of the j-th -C output component for consecutive time increments. -C If JOBX0 = 'N' and COMUSE <> 'C', this array is not -C referenced. -C -C LDY INTEGER -C The leading dimension of the array Y. -C LDY >= MAX(1,NSMP), if JOBX0 = 'X' or COMUSE = 'C; -C LDY >= 1, if JOBX0 = 'N' and COMUSE <> 'C'. -C -C X0 (output) DOUBLE PRECISION array, dimension (N) -C If INFO = 0 and JOBX0 = 'X', this array contains the -C estimated initial state of the system, x(0). -C If JOBX0 = 'N' and COMUSE = 'C', this array is used as -C workspace and finally it is set to zero. -C If JOBX0 = 'N' and COMUSE = 'U', then x(0) is set to -C zero without any calculations. -C If JOBX0 = 'N' and COMUSE = 'N', this array is not -C referenced. -C -C V (output) DOUBLE PRECISION array, dimension (LDV,N) -C On exit, if INFO = 0 or 2, JOBX0 = 'X' or -C COMUSE = 'C', the leading N-by-N part of this array -C contains the orthogonal matrix V of a real Schur -C factorization of the matrix A. -C If JOBX0 = 'N' and COMUSE <> 'C', this array is not -C referenced. -C -C LDV INTEGER -C The leading dimension of the array V. -C LDV >= MAX(1,N), if JOBX0 = 'X' or COMUSE = 'C; -C LDV >= 1, if JOBX0 = 'N' and COMUSE <> 'C'. -C -C Tolerances -C -C TOL DOUBLE PRECISION -C The tolerance to be used for estimating the rank of -C matrices. If the user sets TOL > 0, then the given value -C of TOL is used as a lower bound for the reciprocal -C condition number; a matrix whose estimated condition -C number is less than 1/TOL is considered to be of full -C rank. If the user sets TOL <= 0, then EPS is used -C instead, where EPS is the relative machine precision -C (see LAPACK Library routine DLAMCH). TOL <= 1. -C -C Workspace -C -C IWORK INTEGER array, dimension (LIWORK), where -C LIWORK >= 0, if JOBX0 = 'N' and COMUSE <> 'C'; -C LIWORK >= N, if JOBX0 = 'X' and COMUSE <> 'C'; -C LIWORK >= N*M + a, if COMUSE = 'C' and JOB = 'B', -C LIWORK >= max(N*M + a,M), if COMUSE = 'C' and JOB = 'D', -C with a = 0, if JOBX0 = 'N'; -C a = N, if JOBX0 = 'X'. -C -C DWORK DOUBLE PRECISION array, dimension (LDWORK) -C On exit, if INFO = 0, DWORK(1) returns the optimal value -C of LDWORK; DWORK(2) contains the reciprocal condition -C number of the triangular factor of the QR factorization of -C the matrix W2, if COMUSE = 'C', or of the matrix -C Gamma, if COMUSE = 'U' (see METHOD); if JOBX0 = 'N' -C and COMUSE <> 'C', DWORK(2) is set to one; -C if COMUSE = 'C', M > 0, and JOB = 'D', DWORK(3) -C contains the reciprocal condition number of the triangular -C factor of the QR factorization of U; denoting -C g = 2, if JOBX0 = 'X' and COMUSE <> 'C' or -C COMUSE = 'C' and M = 0 or JOB = 'B', -C g = 3, if COMUSE = 'C' and M > 0 and JOB = 'D', -C then DWORK(i), i = g+1:g+N*N, -C DWORK(j), j = g+1+N*N:g+N*N+L*N, and -C DWORK(k), k = g+1+N*N+L*N:g+N*N+L*N+N*M, -C contain the transformed system matrices At, Ct, and Bt, -C respectively, corresponding to the real Schur form of the -C given system state matrix A, i.e., -C At = V'*A*V, Bt = V'*B, Ct = C*V. -C The matrices At, Ct, Bt are not computed if JOBX0 = 'N' -C and COMUSE <> 'C'. -C On exit, if INFO = -26, DWORK(1) returns the minimum -C value of LDWORK. -C -C LDWORK INTEGER -C The length of the array DWORK. -C LDWORK >= 2, if JOBX0 = 'N' and COMUSE <> 'C', or -C if max( N, M ) = 0. -C Otherwise, -C LDWORK >= LDW1 + N*( N + M + L ) + -C max( 5*N, LDW1, min( LDW2, LDW3 ) ), -C where, if COMUSE = 'C', then -C LDW1 = 2, if M = 0 or JOB = 'B', -C LDW1 = 3, if M > 0 and JOB = 'D', -C LDWa = t*L*(r + 1) + max( N + max( d, f ), 6*r ), -C LDW2 = LDWa, if M = 0 or JOB = 'B', -C LDW2 = max( LDWa, t*L*(r + 1) + 2*M*M + 6*M ), -C if M > 0 and JOB = 'D', -C LDWb = (b + r)*(r + 1) + -C max( q*(r + 1) + N*N*M + c + max( d, f ), 6*r ), -C LDW3 = LDWb, if M = 0 or JOB = 'B', -C LDW3 = max( LDWb, (b + r)*(r + 1) + 2*M*M + 6*M ), -C if M > 0 and JOB = 'D', -C r = N*M + a, -C a = 0, if JOBX0 = 'N', -C a = N, if JOBX0 = 'X'; -C b = 0, if JOB = 'B', -C b = L*M, if JOB = 'D'; -C c = 0, if JOBX0 = 'N', -C c = L*N, if JOBX0 = 'X'; -C d = 0, if JOBX0 = 'N', -C d = 2*N*N + N, if JOBX0 = 'X'; -C f = 2*r, if JOB = 'B' or M = 0, -C f = M + max( 2*r, M ), if JOB = 'D' and M > 0; -C q = b + r*L; -C and, if JOBX0 = 'X' and COMUSE <> 'C', then -C LDW1 = 2, -C LDW2 = t*L*(N + 1) + 2*N + max( 2*N*N, 4*N ), -C LDW3 = N*(N + 1) + 2*N + max( q*(N + 1) + 2*N*N + L*N, -C 4*N ), -C q = N*L. -C For good performance, LDWORK should be larger. -C If LDWORK >= LDW2, or if COMUSE = 'C' and -C LDWORK >= t*L*(r + 1) + (b + r)*(r + 1) + N*N*M + c + -C max( d, f ), -C then standard QR factorizations of the matrices U and/or -C W2, if COMUSE = 'C', or of the matrix Gamma, if -C JOBX0 = 'X' and COMUSE <> 'C' (see METHOD), are used. -C Otherwise, the QR factorizations are computed sequentially -C by performing NCYCLE cycles, each cycle (except possibly -C the last one) processing s < t samples, where s is -C chosen by equating LDWORK to the first term of LDWb, -C if COMUSE = 'C', or of LDW3, if COMUSE <> 'C', for -C q replaced by s*L. (s is larger than or equal to the -C minimum value of NSMP.) The computational effort may -C increase and the accuracy may slightly decrease with the -C decrease of s. Recommended value is LDWORK = LDW2, -C assuming a large enough cache size, to also accommodate -C A, (B,) C, (D,) U, and Y. -C -C Warning Indicator -C -C IWARN INTEGER -C = 0: no warning; -C = 4: the least squares problem to be solved has a -C rank-deficient coefficient matrix; -C = 6: the matrix A is unstable; the estimated x(0) -C and/or B and D could be inaccurate. -C NOTE: the value 4 of IWARN has no significance for the -C identification problem. -C -C Error Indicator -C -C INFO INTEGER -C = 0: successful exit; -C < 0: if INFO = -i, the i-th argument had an illegal -C value; -C = 1: if the QR algorithm failed to compute all the -C eigenvalues of the matrix A (see LAPACK Library -C routine DGEES); the locations DWORK(i), for -C i = g+1:g+N*N, contain the partially converged -C Schur form; -C = 2: the singular value decomposition (SVD) algorithm did -C not converge. -C -C METHOD -C -C Matrix A is initially reduced to a real Schur form, A = V*At*V', -C and the given system matrices are transformed accordingly. For the -C reduced system, an extension and refinement of the method in [1,2] -C is used. Specifically, for JOBX0 = 'X', COMUSE = 'C', and -C JOB = 'D', denoting -C -C X = [ vec(D')' vec(B)' x0' ]', -C -C where vec(M) is the vector obtained by stacking the columns of -C the matrix M, then X is the least squares solution of the -C system S*X = vec(Y), with the matrix S = [ diag(U) W ], -C defined by -C -C ( U | | ... | | | ... | | ) -C ( U | 11 | ... | n1 | 12 | ... | nm | ) -C S = ( : | y | ... | y | y | ... | y | P*Gamma ), -C ( : | | ... | | | ... | | ) -C ( U | | ... | | | ... | | ) -C ij -C diag(U) having L block rows and columns. In this formula, y -C are the outputs of the system for zero initial state computed -C using the following model, for j = 1:m, and for i = 1:n, -C ij ij ij -C x (k+1) = Ax (k) + e_i u_j(k), x (0) = 0, -C -C ij ij -C y (k) = Cx (k), -C -C where e_i is the i-th n-dimensional unit vector, Gamma is -C given by -C -C ( C ) -C ( C*A ) -C Gamma = ( C*A^2 ), -C ( : ) -C ( C*A^(t-1) ) -C -C and P is a permutation matrix that groups together the rows of -C Gamma depending on the same row of C, namely -C [ c_j; c_j*A; c_j*A^2; ... c_j*A^(t-1) ], for j = 1:L. -C The first block column, diag(U), is not explicitly constructed, -C but its structure is exploited. The last block column is evaluated -C using powers of A with exponents 2^k. No interchanges are applied. -C A special QR decomposition of the matrix S is computed. Let -C U = q*[ r' 0 ]' be the QR decomposition of U, if M > 0, where -C r is M-by-M. Then, diag(q') is applied to W and vec(Y). -C The block-rows of S and vec(Y) are implicitly permuted so that -C matrix S becomes -C -C ( diag(r) W1 ) -C ( 0 W2 ), -C -C where W1 has L*M rows. Then, the QR decomposition of W2 is -C computed (sequentially, if M > 0) and used to obtain B and x0. -C The intermediate results and the QR decomposition of U are -C needed to find D. If a triangular factor is too ill conditioned, -C then singular value decomposition (SVD) is employed. SVD is not -C generally needed if the input sequence is sufficiently -C persistently exciting and NSMP is large enough. -C If the matrix W cannot be stored in the workspace (i.e., -C LDWORK < LDW2), the QR decompositions of W2 and U are -C computed sequentially. -C For JOBX0 = 'N' and COMUSE = 'C', or JOB = 'B', a simpler -C problem is solved efficiently. -C -C For JOBX0 = 'X' and COMUSE <> 'C', a simpler method is used. -C Specifically, the output y0(k) of the system for zero initial -C state is computed for k = 0, 1, ..., t-1 using the given model. -C Then the following least squares problem is solved for x(0) -C -C ( y(0) - y0(0) ) -C ( y(1) - y0(1) ) -C Gamma * x(0) = ( : ). -C ( : ) -C ( y(t-1) - y0(t-1) ) -C -C The coefficient matrix Gamma is evaluated using powers of A with -C exponents 2^k. The QR decomposition of this matrix is computed. -C If its triangular factor R is too ill conditioned, then singular -C value decomposition of R is used. -C If the coefficient matrix cannot be stored in the workspace (i.e., -C LDWORK < LDW2), the QR decomposition is computed sequentially. -C -C -C REFERENCES -C -C [1] Verhaegen M., and Varga, A. -C Some Experience with the MOESP Class of Subspace Model -C Identification Methods in Identifying the BO105 Helicopter. -C Report TR R165-94, DLR Oberpfaffenhofen, 1994. -C -C [2] Sima, V., and Varga, A. -C RASP-IDENT : Subspace Model Identification Programs. -C Deutsche Forschungsanstalt fur Luft- und Raumfahrt e. V., -C Report TR R888-94, DLR Oberpfaffenhofen, Oct. 1994. -C -C NUMERICAL ASPECTS -C -C The implemented method is numerically stable. -C -C FURTHER COMMENTS -C -C The algorithm for computing the system matrices B and D is -C less efficient than the MOESP or N4SID algorithms implemented in -C SLICOT Library routines IB01BD/IB01PD, because a large least -C squares problem has to be solved, but the accuracy is better, as -C the computed matrices B and D are fitted to the input and -C output trajectories. However, if matrix A is unstable, the -C computed matrices B and D could be inaccurate. -C -C CONTRIBUTOR -C -C V. Sima, Research Institute for Informatics, Bucharest, Apr. 2000. -C -C REVISIONS -C -C - -C -C KEYWORDS -C -C Identification methods; least squares solutions; multivariable -C systems; QR decomposition; singular value decomposition. -C -C ****************************************************************** -C -C .. Parameters .. - DOUBLE PRECISION ZERO, ONE, TWO, THREE - PARAMETER ( ZERO = 0.0D0, ONE = 1.0D0, TWO = 2.0D0, - $ THREE = 3.0D0 ) -C .. Scalar Arguments .. - DOUBLE PRECISION TOL - INTEGER INFO, IWARN, L, LDA, LDB, LDC, LDD, LDU, LDV, - $ LDWORK, LDY, M, N, NSMP - CHARACTER COMUSE, JOB, JOBX0 -C .. Array Arguments .. - DOUBLE PRECISION A(LDA, *), B(LDB, *), C(LDC, *), D(LDD, *), - $ DWORK(*), U(LDU, *), V(LDV, *), X0(*), - $ Y(LDY, *) - INTEGER IWORK(*) -C .. Local Scalars .. - DOUBLE PRECISION RCOND, RCONDU - INTEGER I, IA, IB, IC, IERR, IQ, ISIZE, ITAU, IWARNL, - $ IWI, IWR, JWORK, LDW, LDW2, LDW3, LM, LN, - $ MAXWRK, MINSMP, MINWLS, MINWRK, MTMP, N2M, - $ NCOL, NCP1, NM, NN, NSMPL - LOGICAL COMPBD, USEBD, MAXDIA, MAXDIM, WITHB, WITHD, - $ WITHX0 - CHARACTER JOBD -C .. Local Arrays .. - DOUBLE PRECISION DUM(1) -C .. External Functions .. - LOGICAL LSAME - INTEGER ILAENV - DOUBLE PRECISION DLAMCH, DLAPY2 - EXTERNAL DLAMCH, DLAPY2, ILAENV, LSAME -C .. External Subroutines .. - EXTERNAL DCOPY, DGEMM, DGEMV, DLACPY, IB01QD, IB01RD, - $ TB01WD, XERBLA -C .. Intrinsic Functions .. - INTRINSIC INT, MAX, MIN -C .. Executable Statements .. -C -C Check the input parameters. -C - WITHX0 = LSAME( JOBX0, 'X' ) - COMPBD = LSAME( COMUSE, 'C' ) - USEBD = LSAME( COMUSE, 'U' ) - WITHD = LSAME( JOB, 'D' ) - WITHB = LSAME( JOB, 'B' ) .OR. WITHD - MAXDIM = ( WITHX0 .AND. USEBD ) .OR. COMPBD - MAXDIA = WITHX0 .OR. COMPBD -C - IWARN = 0 - INFO = 0 - LDW = MAX( 1, N ) - LM = L*M - LN = L*N - NN = N*N - NM = N*M - N2M = N*NM - IF( COMPBD ) THEN - NCOL = NM - IF( WITHX0 ) - $ NCOL = NCOL + N - MINSMP = NCOL - IF( WITHD ) THEN - MINSMP = MINSMP + M - IQ = MINSMP - ELSE IF ( .NOT.WITHX0 ) THEN - IQ = MINSMP - MINSMP = MINSMP + 1 - ELSE - IQ = MINSMP - END IF - ELSE - NCOL = N - IF( WITHX0 ) THEN - MINSMP = N - ELSE - MINSMP = 0 - END IF - IQ = MINSMP - END IF -C - IF( .NOT.( WITHX0 .OR. LSAME( JOBX0, 'N' ) ) ) THEN - INFO = -1 - ELSE IF( .NOT.( COMPBD .OR. USEBD .OR. LSAME( COMUSE, 'N' ) ) ) - $ THEN - INFO = -2 - ELSE IF( .NOT.WITHB ) THEN - INFO = -3 - ELSE IF( N.LT.0 ) THEN - INFO = -4 - ELSE IF( M.LT.0 ) THEN - INFO = -5 - ELSE IF( L.LE.0 ) THEN - INFO = -6 - ELSE IF( NSMP.LT.MINSMP ) THEN - INFO = -7 - ELSE IF( LDA.LT.1 .OR. ( MAXDIA .AND. LDA.LT.LDW ) ) THEN - INFO = -9 - ELSE IF( LDB.LT.1 .OR. ( M.GT.0 .AND. MAXDIM .AND. LDB.LT.LDW ) ) - $ THEN - INFO = -11 - ELSE IF( LDC.LT.1 .OR. ( N.GT.0 .AND. MAXDIA .AND. LDC.LT.L ) ) - $ THEN - INFO = -13 - ELSE IF( LDD.LT.1 .OR. ( M.GT.0 .AND. MAXDIM .AND. WITHD .AND. - $ LDD.LT.L ) ) THEN - INFO = -15 - ELSE IF( LDU.LT.1 .OR. ( M.GT.0 .AND. MAXDIM .AND. LDU.LT.NSMP ) ) - $ THEN - INFO = -17 - ELSE IF( LDY.LT.1 .OR. ( MAXDIA .AND. LDY.LT.NSMP ) ) THEN - INFO = -19 - ELSE IF( LDV.LT.1 .OR. ( MAXDIA .AND. LDV.LT.LDW ) ) THEN - INFO = -22 - ELSE IF( TOL.GT.ONE ) THEN - INFO = -23 - END IF -C -C Compute workspace. -C (Note: Comments in the code beginning "Workspace:" describe the -C minimal amount of workspace needed at that point in the code, -C as well as the preferred amount for good performance. -C NB refers to the optimal block size for the immediately -C following subroutine, as returned by ILAENV.) -C - IF ( .NOT.MAXDIA .OR. MAX( N, M ).EQ.0 ) THEN - MINWRK = 2 - ELSE - NSMPL = NSMP*L - IQ = IQ*L - NCP1 = NCOL + 1 - ISIZE = NSMPL*NCP1 - IF ( COMPBD ) THEN - IF ( N.GT.0 .AND. WITHX0 ) THEN - IC = 2*NN + N - ELSE - IC = 0 - END IF - ELSE - IC = 2*NN - END IF - MINWLS = NCOL*NCP1 - IF ( COMPBD ) THEN - IF ( WITHD ) - $ MINWLS = MINWLS + LM*NCP1 - IF ( M.GT.0 .AND. WITHD ) THEN - IA = M + MAX( 2*NCOL, M ) - ELSE - IA = 2*NCOL - END IF - ITAU = N2M + MAX( IC, IA ) - IF ( WITHX0 ) - $ ITAU = ITAU + LN - LDW2 = ISIZE + MAX( N + MAX( IC, IA ), 6*NCOL ) - LDW3 = MINWLS + MAX( IQ*NCP1 + ITAU, 6*NCOL ) - IF ( M.GT.0 .AND. WITHD ) THEN - LDW2 = MAX( LDW2, ISIZE + 2*M*M + 6*M ) - LDW3 = MAX( LDW3, MINWLS + 2*M*M + 6*M ) - IA = 3 - ELSE - IA = 2 - END IF - ELSE - ITAU = IC + LN - LDW2 = ISIZE + 2*N + MAX( IC, 4*N ) - LDW3 = MINWLS + 2*N + MAX( IQ*NCP1 + ITAU, 4*N ) - IA = 2 - END IF - MINWRK = IA + NN + NM + LN + MAX( 5*N, IA, MIN( LDW2, LDW3 ) ) -C - IF ( INFO.EQ.0 .AND. LDWORK.GE.MINWRK ) THEN - MAXWRK = MAX( 5*N, IA ) - IF ( COMPBD ) THEN - IF ( M.GT.0 .AND. WITHD ) THEN - MAXWRK = MAX( MAXWRK, ISIZE + N + M + - $ MAX( M*ILAENV( 1, 'DGEQRF', ' ', NSMP, - $ M, -1, -1 ), - $ NCOL + NCOL*ILAENV( 1, 'DGEQRF', - $ ' ', NSMP-M, NCOL, -1, -1 ) ) ) - MAXWRK = MAX( MAXWRK, ISIZE + N + M + - $ MAX( NCP1*ILAENV( 1, 'DORMQR', 'LT', - $ NSMP, NCP1, M, -1 ), - $ NCOL + ILAENV( 1, 'DORMQR', 'LT', - $ NSMP-M, 1, NCOL, -1 ) ) ) - ELSE - MAXWRK = MAX( MAXWRK, ISIZE + N + NCOL + - $ MAX( NCOL*ILAENV( 1, 'DGEQRF', - $ ' ', NSMPL, NCOL, -1, -1 ), - $ ILAENV( 1, 'DORMQR', 'LT', - $ NSMPL, 1, NCOL, -1 ) ) ) - END IF - ELSE - MAXWRK = MAX( MAXWRK, ISIZE + 2*N + - $ MAX( N*ILAENV( 1, 'DGEQRF', ' ', - $ NSMPL, N, -1, -1 ), - $ ILAENV( 1, 'DORMQR', 'LT', - $ NSMPL, 1, N, -1 ) ) ) - END IF - MAXWRK = IA + NN + NM + LN + MAXWRK - MAXWRK = MAX( MAXWRK, MINWRK ) - END IF - END IF -C - IF ( INFO.EQ.0 .AND. LDWORK.LT.MINWRK ) THEN - INFO = -26 - DWORK(1) = MINWRK - END IF -C -C Return if there are illegal arguments. -C - IF( INFO.NE.0 ) THEN - CALL XERBLA( 'IB01CD', -INFO ) - RETURN - END IF -C -C Quick return if possible. -C - IF ( .NOT.MAXDIA .OR. MAX( N, M ).EQ.0 ) THEN - DWORK(2) = ONE - IF ( COMPBD .AND. M.GT.0 .AND. WITHD ) THEN - DWORK(1) = THREE - DWORK(3) = ONE - ELSE - DWORK(1) = TWO - END IF - IF ( N.GT.0 .AND. USEBD ) THEN - DUM(1) = ZERO - CALL DCOPY( N, DUM, 0, X0, 1 ) - END IF - RETURN - END IF -C -C Compute the Schur factorization of A and transform the other -C given system matrices accordingly. -C Workspace: need g + N*N + L*N + N*M + 5*N, where -C g = 2, if M = 0, COMUSE = 'C', or JOB = 'B', -C g = 3, if M > 0, COMUSE = 'C', and JOB = 'D', -C g = 2, if JOBX0 = 'X' and COMUSE <> 'C'; -C prefer larger. -C - IA = IA + 1 - IC = IA + NN - IB = IC + LN - CALL DLACPY( 'Full', N, N, A, LDA, DWORK(IA), LDW ) - CALL DLACPY( 'Full', L, N, C, LDC, DWORK(IC), L ) -C - IF ( USEBD ) THEN - MTMP = M - CALL DLACPY( 'Full', N, M, B, LDB, DWORK(IB), LDW ) - ELSE - MTMP = 0 - END IF - IWR = IB + NM - IWI = IWR + N - JWORK = IWI + N -C - CALL TB01WD( N, MTMP, L, DWORK(IA), LDW, DWORK(IB), LDW, - $ DWORK(IC), L, V, LDV, DWORK(IWR), DWORK(IWI), - $ DWORK(JWORK), LDWORK-JWORK+1, IERR ) - IF( IERR.GT.0 ) THEN - INFO = 1 - RETURN - END IF - MAXWRK = MAX( MAXWRK, INT( DWORK( JWORK ) ) + JWORK - 1 ) -C - DO 10 I = IWR, IWI - 1 - IF( DLAPY2( DWORK(I), DWORK(I+N) ).GE.ONE ) - $ IWARN = 6 - 10 CONTINUE -C - JWORK = IWR -C -C Estimate x(0) and/or the system matrices B and D. -C Workspace: need g + N*N + L*N + N*M + -C max( g, min( LDW2, LDW3 ) ) (see LDWORK); -C prefer larger. -C - IF ( COMPBD ) THEN - CALL IB01QD( JOBX0, JOB, N, M, L, NSMP, DWORK(IA), LDW, - $ DWORK(IC), L, U, LDU, Y, LDY, X0, DWORK(IB), LDW, - $ D, LDD, TOL, IWORK, DWORK(JWORK), LDWORK-JWORK+1, - $ IWARNL, INFO ) -C - IF( INFO.EQ.0 ) THEN - IF ( M.GT.0 .AND. WITHD ) - $ RCONDU = DWORK(JWORK+2) -C -C Compute the system input matrix B corresponding to the -C original system. -C - CALL DGEMM( 'NoTranspose', 'NoTranspose', N, M, N, ONE, - $ V, LDV, DWORK(IB), LDW, ZERO, B, LDB ) - END IF - ELSE - IF ( WITHD ) THEN - JOBD = 'N' - ELSE - JOBD = 'Z' - END IF -C - CALL IB01RD( JOBD, N, MTMP, L, NSMP, DWORK(IA), LDW, DWORK(IB), - $ LDW, DWORK(IC), L, D, LDD, U, LDU, Y, LDY, X0, - $ TOL, IWORK, DWORK(JWORK), LDWORK-JWORK+1, IWARNL, - $ INFO ) - END IF - IWARN = MAX( IWARN, IWARNL ) -C - IF( INFO.EQ.0 ) THEN - RCOND = DWORK(JWORK+1) - MAXWRK = MAX( MAXWRK, INT( DWORK(JWORK) ) + JWORK - 1 ) - IF( WITHX0 ) THEN -C -C Transform the initial state estimate to obtain the initial -C state corresponding to the original system. -C Workspace: need g + N*N + L*N + N*M + N. -C - CALL DGEMV( 'NoTranspose', N, N, ONE, V, LDV, X0, 1, ZERO, - $ DWORK(JWORK), 1 ) - CALL DCOPY( N, DWORK(JWORK), 1, X0, 1 ) - END IF -C - DWORK(1) = MAXWRK - DWORK(2) = RCOND - IF ( COMPBD .AND. M.GT.0 .AND. WITHD ) - $ DWORK(3) = RCONDU - END IF - RETURN -C -C *** End of IB01CD *** - END diff --git a/mex/sources/libslicot/IB01MD.f b/mex/sources/libslicot/IB01MD.f deleted file mode 100644 index d76b4af38..000000000 --- a/mex/sources/libslicot/IB01MD.f +++ /dev/null @@ -1,1433 +0,0 @@ - SUBROUTINE IB01MD( METH, ALG, BATCH, CONCT, NOBR, M, L, NSMP, U, - $ LDU, Y, LDY, R, LDR, IWORK, DWORK, LDWORK, - $ IWARN, INFO ) -C -C SLICOT RELEASE 5.0. -C -C Copyright (c) 2002-2009 NICONET e.V. -C -C This program is free software: you can redistribute it and/or -C modify it under the terms of the GNU General Public License as -C published by the Free Software Foundation, either version 2 of -C the License, or (at your option) any later version. -C -C This program is distributed in the hope that it will be useful, -C but WITHOUT ANY WARRANTY; without even the implied warranty of -C MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the -C GNU General Public License for more details. -C -C You should have received a copy of the GNU General Public License -C along with this program. If not, see -C . -C -C PURPOSE -C -C To construct an upper triangular factor R of the concatenated -C block Hankel matrices using input-output data. The input-output -C data can, optionally, be processed sequentially. -C -C ARGUMENTS -C -C Mode Parameters -C -C METH CHARACTER*1 -C Specifies the subspace identification method to be used, -C as follows: -C = 'M': MOESP algorithm with past inputs and outputs; -C = 'N': N4SID algorithm. -C -C ALG CHARACTER*1 -C Specifies the algorithm for computing the triangular -C factor R, as follows: -C = 'C': Cholesky algorithm applied to the correlation -C matrix of the input-output data; -C = 'F': Fast QR algorithm; -C = 'Q': QR algorithm applied to the concatenated block -C Hankel matrices. -C -C BATCH CHARACTER*1 -C Specifies whether or not sequential data processing is to -C be used, and, for sequential processing, whether or not -C the current data block is the first block, an intermediate -C block, or the last block, as follows: -C = 'F': the first block in sequential data processing; -C = 'I': an intermediate block in sequential data -C processing; -C = 'L': the last block in sequential data processing; -C = 'O': one block only (non-sequential data processing). -C NOTE that when 100 cycles of sequential data processing -C are completed for BATCH = 'I', a warning is -C issued, to prevent for an infinite loop. -C -C CONCT CHARACTER*1 -C Specifies whether or not the successive data blocks in -C sequential data processing belong to a single experiment, -C as follows: -C = 'C': the current data block is a continuation of the -C previous data block and/or it will be continued -C by the next data block; -C = 'N': there is no connection between the current data -C block and the previous and/or the next ones. -C This parameter is not used if BATCH = 'O'. -C -C Input/Output Parameters -C -C NOBR (input) INTEGER -C The number of block rows, s, in the input and output -C block Hankel matrices to be processed. NOBR > 0. -C (In the MOESP theory, NOBR should be larger than n, -C the estimated dimension of state vector.) -C -C M (input) INTEGER -C The number of system inputs. M >= 0. -C When M = 0, no system inputs are processed. -C -C L (input) INTEGER -C The number of system outputs. L > 0. -C -C NSMP (input) INTEGER -C The number of rows of matrices U and Y (number of -C samples, t). (When sequential data processing is used, -C NSMP is the number of samples of the current data -C block.) -C NSMP >= 2*(M+L+1)*NOBR - 1, for non-sequential -C processing; -C NSMP >= 2*NOBR, for sequential processing. -C The total number of samples when calling the routine with -C BATCH = 'L' should be at least 2*(M+L+1)*NOBR - 1. -C The NSMP argument may vary from a cycle to another in -C sequential data processing, but NOBR, M, and L should -C be kept constant. For efficiency, it is advisable to use -C NSMP as large as possible. -C -C U (input) DOUBLE PRECISION array, dimension (LDU,M) -C The leading NSMP-by-M part of this array must contain the -C t-by-m input-data sequence matrix U, -C U = [u_1 u_2 ... u_m]. Column j of U contains the -C NSMP values of the j-th input component for consecutive -C time increments. -C If M = 0, this array is not referenced. -C -C LDU INTEGER -C The leading dimension of the array U. -C LDU >= NSMP, if M > 0; -C LDU >= 1, if M = 0. -C -C Y (input) DOUBLE PRECISION array, dimension (LDY,L) -C The leading NSMP-by-L part of this array must contain the -C t-by-l output-data sequence matrix Y, -C Y = [y_1 y_2 ... y_l]. Column j of Y contains the -C NSMP values of the j-th output component for consecutive -C time increments. -C -C LDY INTEGER -C The leading dimension of the array Y. LDY >= NSMP. -C -C R (output or input/output) DOUBLE PRECISION array, dimension -C ( LDR,2*(M+L)*NOBR ) -C On exit, if INFO = 0 and ALG = 'Q', or (ALG = 'C' or 'F', -C and BATCH = 'L' or 'O'), the leading -C 2*(M+L)*NOBR-by-2*(M+L)*NOBR upper triangular part of -C this array contains the (current) upper triangular factor -C R from the QR factorization of the concatenated block -C Hankel matrices. The diagonal elements of R are positive -C when the Cholesky algorithm was successfully used. -C On exit, if ALG = 'C' and BATCH = 'F' or 'I', the leading -C 2*(M+L)*NOBR-by-2*(M+L)*NOBR upper triangular part of this -C array contains the current upper triangular part of the -C correlation matrix in sequential data processing. -C If ALG = 'F' and BATCH = 'F' or 'I', the array R is not -C referenced. -C On entry, if ALG = 'C', or ALG = 'Q', and BATCH = 'I' or -C 'L', the leading 2*(M+L)*NOBR-by-2*(M+L)*NOBR upper -C triangular part of this array must contain the upper -C triangular matrix R computed at the previous call of this -C routine in sequential data processing. The array R need -C not be set on entry if ALG = 'F' or if BATCH = 'F' or 'O'. -C -C LDR INTEGER -C The leading dimension of the array R. -C LDR >= 2*(M+L)*NOBR. -C -C Workspace -C -C IWORK INTEGER array, dimension (LIWORK) -C LIWORK >= M+L, if ALG = 'F'; -C LIWORK >= 0, if ALG = 'C' or 'Q'. -C -C DWORK DOUBLE PRECISION array, dimension (LDWORK) -C On exit, if INFO = 0, DWORK(1) returns the optimal -C value of LDWORK. -C On exit, if INFO = -17, DWORK(1) returns the minimum -C value of LDWORK. -C Let -C k = 0, if CONCT = 'N' and ALG = 'C' or 'Q'; -C k = 2*NOBR-1, if CONCT = 'C' and ALG = 'C' or 'Q'; -C k = 2*NOBR*(M+L+1), if CONCT = 'N' and ALG = 'F'; -C k = 2*NOBR*(M+L+2), if CONCT = 'C' and ALG = 'F'. -C The first (M+L)*k elements of DWORK should be preserved -C during successive calls of the routine with BATCH = 'F' -C or 'I', till the final call with BATCH = 'L'. -C -C LDWORK INTEGER -C The length of the array DWORK. -C LDWORK >= (4*NOBR-2)*(M+L), if ALG = 'C', BATCH <> 'O' and -C CONCT = 'C'; -C LDWORK >= 1, if ALG = 'C', BATCH = 'O' or -C CONCT = 'N'; -C LDWORK >= (M+L)*2*NOBR*(M+L+3), if ALG = 'F', -C BATCH <> 'O' and CONCT = 'C'; -C LDWORK >= (M+L)*2*NOBR*(M+L+1), if ALG = 'F', -C BATCH = 'F', 'I' and CONCT = 'N'; -C LDWORK >= (M+L)*4*NOBR*(M+L+1)+(M+L)*2*NOBR, if ALG = 'F', -C BATCH = 'L' and CONCT = 'N', or -C BATCH = 'O'; -C LDWORK >= 4*(M+L)*NOBR, if ALG = 'Q', BATCH = 'F' or 'O', -C and LDR >= NS = NSMP - 2*NOBR + 1; -C LDWORK >= 6*(M+L)*NOBR, if ALG = 'Q', BATCH = 'F' or 'O', -C and LDR < NS, or BATCH = 'I' or -C 'L' and CONCT = 'N'; -C LDWORK >= 4*(NOBR+1)*(M+L)*NOBR, if ALG = 'Q', BATCH = 'I' -C or 'L' and CONCT = 'C'. -C The workspace used for ALG = 'Q' is -C LDRWRK*2*(M+L)*NOBR + 4*(M+L)*NOBR, -C where LDRWRK = LDWORK/(2*(M+L)*NOBR) - 2; recommended -C value LDRWRK = NS, assuming a large enough cache size. -C For good performance, LDWORK should be larger. -C -C Warning Indicator -C -C IWARN INTEGER -C = 0: no warning; -C = 1: the number of 100 cycles in sequential data -C processing has been exhausted without signaling -C that the last block of data was get; the cycle -C counter was reinitialized; -C = 2: a fast algorithm was requested (ALG = 'C' or 'F'), -C but it failed, and the QR algorithm was then used -C (non-sequential data processing). -C -C Error Indicator -C -C INFO INTEGER -C = 0: successful exit; -C < 0: if INFO = -i, the i-th argument had an illegal -C value; -C = 1: a fast algorithm was requested (ALG = 'C', or 'F') -C in sequential data processing, but it failed. The -C routine can be repeatedly called again using the -C standard QR algorithm. -C -C METHOD -C -C 1) For non-sequential data processing using QR algorithm, a -C t x 2(m+l)s matrix H is constructed, where -C -C H = [ Uf' Up' Y' ], for METH = 'M', -C s+1,2s,t 1,s,t 1,2s,t -C -C H = [ U' Y' ], for METH = 'N', -C 1,2s,t 1,2s,t -C -C and Up , Uf , U , and Y are block Hankel -C 1,s,t s+1,2s,t 1,2s,t 1,2s,t -C matrices defined in terms of the input and output data [3]. -C A QR factorization is used to compress the data. -C The fast QR algorithm uses a QR factorization which exploits -C the block-Hankel structure. Actually, the Cholesky factor of H'*H -C is computed. -C -C 2) For sequential data processing using QR algorithm, the QR -C decomposition is done sequentially, by updating the upper -C triangular factor R. This is also performed internally if the -C workspace is not large enough to accommodate an entire batch. -C -C 3) For non-sequential or sequential data processing using -C Cholesky algorithm, the correlation matrix of input-output data is -C computed (sequentially, if requested), taking advantage of the -C block Hankel structure [7]. Then, the Cholesky factor of the -C correlation matrix is found, if possible. -C -C REFERENCES -C -C [1] Verhaegen M., and Dewilde, P. -C Subspace Model Identification. Part 1: The output-error -C state-space model identification class of algorithms. -C Int. J. Control, 56, pp. 1187-1210, 1992. -C -C [2] Verhaegen M. -C Subspace Model Identification. Part 3: Analysis of the -C ordinary output-error state-space model identification -C algorithm. -C Int. J. Control, 58, pp. 555-586, 1993. -C -C [3] Verhaegen M. -C Identification of the deterministic part of MIMO state space -C models given in innovations form from input-output data. -C Automatica, Vol.30, No.1, pp.61-74, 1994. -C -C [4] Van Overschee, P., and De Moor, B. -C N4SID: Subspace Algorithms for the Identification of -C Combined Deterministic-Stochastic Systems. -C Automatica, Vol.30, No.1, pp. 75-93, 1994. -C -C [5] Peternell, K., Scherrer, W. and Deistler, M. -C Statistical Analysis of Novel Subspace Identification Methods. -C Signal Processing, 52, pp. 161-177, 1996. -C -C [6] Sima, V. -C Subspace-based Algorithms for Multivariable System -C Identification. -C Studies in Informatics and Control, 5, pp. 335-344, 1996. -C -C [7] Sima, V. -C Cholesky or QR Factorization for Data Compression in -C Subspace-based Identification ? -C Proceedings of the Second NICONET Workshop on ``Numerical -C Control Software: SLICOT, a Useful Tool in Industry'', -C December 3, 1999, INRIA Rocquencourt, France, pp. 75-80, 1999. -C -C NUMERICAL ASPECTS -C -C The implemented method is numerically stable (when QR algorithm is -C used), reliable and efficient. The fast Cholesky or QR algorithms -C are more efficient, but the accuracy could diminish by forming the -C correlation matrix. -C 2 -C The QR algorithm needs 0(t(2(m+l)s) ) floating point operations. -C 2 3 -C The Cholesky algorithm needs 0(2t(m+l) s)+0((2(m+l)s) ) floating -C point operations. -C 2 3 2 -C The fast QR algorithm needs 0(2t(m+l) s)+0(4(m+l) s ) floating -C point operations. -C -C FURTHER COMMENTS -C -C For ALG = 'Q', BATCH = 'O' and LDR < NS, or BATCH <> 'O', the -C calculations could be rather inefficient if only minimal workspace -C (see argument LDWORK) is provided. It is advisable to provide as -C much workspace as possible. Almost optimal efficiency can be -C obtained for LDWORK = (NS+2)*(2*(M+L)*NOBR), assuming that the -C cache size is large enough to accommodate R, U, Y, and DWORK. -C -C CONTRIBUTOR -C -C V. Sima, Research Institute for Informatics, Bucharest, Aug. 1999. -C -C REVISIONS -C -C Feb. 2000, Aug. 2000, Feb. 2004. -C -C KEYWORDS -C -C Cholesky decomposition, Hankel matrix, identification methods, -C multivariable systems, QR decomposition. -C -C ****************************************************************** -C -C .. Parameters .. - DOUBLE PRECISION ZERO, ONE - PARAMETER ( ZERO = 0.0D0, ONE = 1.0D0 ) - INTEGER MAXCYC - PARAMETER ( MAXCYC = 100 ) -C .. Scalar Arguments .. - INTEGER INFO, IWARN, L, LDR, LDU, LDWORK, LDY, M, NOBR, - $ NSMP - CHARACTER ALG, BATCH, CONCT, METH -C .. Array Arguments .. - INTEGER IWORK(*) - DOUBLE PRECISION DWORK(*), R(LDR, *), U(LDU, *), Y(LDY, *) -C .. Local Scalars .. - DOUBLE PRECISION UPD, TEMP - INTEGER I, ICOL, ICYCLE, ID, IERR, II, INICYC, INIT, - $ INITI, INU, INY, IREV, ISHFT2, ISHFTU, ISHFTY, - $ ITAU, J, JD, JWORK, LDRWMX, LDRWRK, LLDRW, - $ LMNOBR, LNOBR, MAXWRK, MINWRK, MLDRW, MMNOBR, - $ MNOBR, NCYCLE, NICYCL, NOBR2, NOBR21, NOBRM1, - $ NR, NS, NSF, NSL, NSLAST, NSMPSM - LOGICAL CHALG, CONNEC, FIRST, FQRALG, INTERM, LAST, - $ LINR, MOESP, N4SID, ONEBCH, QRALG -C .. Local Arrays .. - DOUBLE PRECISION DUM( 1 ) -C .. External Functions .. - LOGICAL LSAME - INTEGER ILAENV - EXTERNAL ILAENV, LSAME -C .. External Subroutines .. - EXTERNAL DAXPY, DCOPY, DGEMM, DGEQRF, DGER, DLACPY, - $ DLASET, DPOTRF, DSWAP, DSYRK, IB01MY, MB04OD, - $ XERBLA -C .. Intrinsic Functions .. - INTRINSIC INT, MAX, MIN -C .. Save Statement .. -C ICYCLE is used to count the cycles for BATCH = 'I'. It is -C reinitialized at each MAXCYC cycles. -C MAXWRK is used to store the optimal workspace. -C NSMPSM is used to sum up the NSMP values for BATCH <> 'O'. - SAVE ICYCLE, MAXWRK, NSMPSM -C .. -C .. Executable Statements .. -C -C Decode the scalar input parameters. -C - MOESP = LSAME( METH, 'M' ) - N4SID = LSAME( METH, 'N' ) - FQRALG = LSAME( ALG, 'F' ) - QRALG = LSAME( ALG, 'Q' ) - CHALG = LSAME( ALG, 'C' ) - ONEBCH = LSAME( BATCH, 'O' ) - FIRST = LSAME( BATCH, 'F' ) .OR. ONEBCH - INTERM = LSAME( BATCH, 'I' ) - LAST = LSAME( BATCH, 'L' ) .OR. ONEBCH - IF( .NOT.ONEBCH ) THEN - CONNEC = LSAME( CONCT, 'C' ) - ELSE - CONNEC = .FALSE. - END IF -C - MNOBR = M*NOBR - LNOBR = L*NOBR - LMNOBR = LNOBR + MNOBR - MMNOBR = MNOBR + MNOBR - NOBRM1 = NOBR - 1 - NOBR21 = NOBR + NOBRM1 - NOBR2 = NOBR21 + 1 - IWARN = 0 - INFO = 0 - IERR = 0 - IF( FIRST ) THEN - ICYCLE = 1 - MAXWRK = 1 - NSMPSM = 0 - END IF - NSMPSM = NSMPSM + NSMP - NR = LMNOBR + LMNOBR -C -C Check the scalar input parameters. -C - IF( .NOT.( MOESP .OR. N4SID ) ) THEN - INFO = -1 - ELSE IF( .NOT.( FQRALG .OR. QRALG .OR. CHALG ) ) THEN - INFO = -2 - ELSE IF( .NOT.( FIRST .OR. INTERM .OR. LAST ) ) THEN - INFO = -3 - ELSE IF( .NOT. ONEBCH ) THEN - IF( .NOT.( CONNEC .OR. LSAME( CONCT, 'N' ) ) ) - $ INFO = -4 - END IF - IF( INFO.EQ.0 ) THEN - IF( NOBR.LE.0 ) THEN - INFO = -5 - ELSE IF( M.LT.0 ) THEN - INFO = -6 - ELSE IF( L.LE.0 ) THEN - INFO = -7 - ELSE IF( NSMP.LT.NOBR2 .OR. - $ ( LAST .AND. NSMPSM.LT.NR+NOBR21 ) ) THEN - INFO = -8 - ELSE IF( LDU.LT.1 .OR. ( M.GT.0 .AND. LDU.LT.NSMP ) ) THEN - INFO = -10 - ELSE IF( LDY.LT.NSMP ) THEN - INFO = -12 - ELSE IF( LDR.LT.NR ) THEN - INFO = -14 - ELSE -C -C Compute workspace. -C (Note: Comments in the code beginning "Workspace:" describe -C the minimal amount of workspace needed at that point in the -C code, as well as the preferred amount for good performance. -C NB refers to the optimal block size for the immediately -C following subroutine, as returned by ILAENV.) -C - NS = NSMP - NOBR21 - IF ( CHALG ) THEN - IF ( .NOT.ONEBCH .AND. CONNEC ) THEN - MINWRK = 2*( NR - M - L ) - ELSE - MINWRK = 1 - END IF - ELSE IF ( FQRALG ) THEN - IF ( .NOT.ONEBCH .AND. CONNEC ) THEN - MINWRK = NR*( M + L + 3 ) - ELSE IF ( FIRST .OR. INTERM ) THEN - MINWRK = NR*( M + L + 1 ) - ELSE - MINWRK = 2*NR*( M + L + 1 ) + NR - END IF - ELSE - MINWRK = 2*NR - MAXWRK = NR + NR*ILAENV( 1, 'DGEQRF', ' ', NS, NR, -1, - $ -1 ) - IF ( FIRST ) THEN - IF ( LDR.LT.NS ) THEN - MINWRK = MINWRK + NR - MAXWRK = NS*NR + MAXWRK - END IF - ELSE - IF ( CONNEC ) THEN - MINWRK = MINWRK*( NOBR + 1 ) - ELSE - MINWRK = MINWRK + NR - END IF - MAXWRK = NS*NR + MAXWRK - END IF - END IF - MAXWRK = MAX( MINWRK, MAXWRK ) -C - IF( LDWORK.LT.MINWRK ) THEN - INFO = -17 - DWORK( 1 ) = MINWRK - END IF - END IF - END IF -C -C Return if there are illegal arguments. -C - IF( INFO.NE.0 ) THEN - CALL XERBLA( 'IB01MD', -INFO ) - RETURN - END IF -C - IF ( CHALG ) THEN -C -C Compute the R factor from a Cholesky factorization of the -C input-output data correlation matrix. -C -C Set the parameters for constructing the correlations of the -C current block. -C - LDRWRK = 2*NOBR2 - 2 - IF( FIRST ) THEN - UPD = ZERO - ELSE - UPD = ONE - END IF -C - IF( .NOT.FIRST .AND. CONNEC ) THEN -C -C Restore the saved (M+L)*(2*NOBR-1) "connection" elements of -C U and Y into their appropriate position in sequential -C processing. The process is performed column-wise, in -C reverse order, first for Y and then for U. -C Workspace: need (4*NOBR-2)*(M+L). -C - IREV = NR - M - L - NOBR21 + 1 - ICOL = 2*( NR - M - L ) - LDRWRK + 1 -C - DO 10 J = 2, M + L - DO 5 I = NOBR21 - 1, 0, -1 - DWORK(ICOL+I) = DWORK(IREV+I) - 5 CONTINUE - IREV = IREV - NOBR21 - ICOL = ICOL - LDRWRK - 10 CONTINUE -C - IF ( M.GT.0 ) - $ CALL DLACPY( 'Full', NOBR21, M, U, LDU, DWORK(NOBR2), - $ LDRWRK ) - CALL DLACPY( 'Full', NOBR21, L, Y, LDY, - $ DWORK(LDRWRK*M+NOBR2), LDRWRK ) - END IF -C - IF ( M.GT.0 ) THEN -C -C Let Guu(i,j) = Guu0(i,j) + u_i*u_j' + u_(i+1)*u_(j+1)' + -C ... + u_(i+NS-1)*u_(j+NS-1)', -C where u_i' is the i-th row of U, j = 1 : 2s, i = 1 : j, -C NS = NSMP - 2s + 1, and Guu0(i,j) is a zero matrix for -C BATCH = 'O' or 'F', and it is the matrix Guu(i,j) computed -C till the current block for BATCH = 'I' or 'L'. The matrix -C Guu(i,j) is m-by-m, and Guu(j,j) is symmetric. The -C upper triangle of the U-U correlations, Guu, is computed -C (or updated) column-wise in the array R, that is, in the -C order Guu(1,1), Guu(1,2), Guu(2,2), ..., Guu(2s,2s). -C Only the submatrices of the first block-row are fully -C computed (or updated). The remaining ones are determined -C exploiting the block-Hankel structure, using the updating -C formula -C -C Guu(i+1,j+1) = Guu0(i+1,j+1) - Guu0(i,j) + Guu(i,j) + -C u_(i+NS)*u_(j+NS)' - u_i*u_j'. -C - IF( .NOT.FIRST ) THEN -C -C Subtract the contribution of the previous block of data -C in sequential processing. The columns must be processed -C in backward order. -C - DO 20 I = NOBR21*M, 1, -1 - CALL DAXPY( I, -ONE, R(1,I), 1, R(M+1,M+I), 1 ) - 20 CONTINUE -C - END IF -C -C Compute/update Guu(1,1). -C - IF( .NOT.FIRST .AND. CONNEC ) - $ CALL DSYRK( 'Upper', 'Transpose', M, NOBR21, ONE, DWORK, - $ LDRWRK, UPD, R, LDR ) - CALL DSYRK( 'Upper', 'Transpose', M, NS, ONE, U, LDU, UPD, - $ R, LDR ) -C - JD = 1 -C - IF( FIRST .OR. .NOT.CONNEC ) THEN -C - DO 70 J = 2, NOBR2 - JD = JD + M - ID = M + 1 -C -C Compute/update Guu(1,j). -C - CALL DGEMM( 'Transpose', 'NoTranspose', M, M, NS, ONE, - $ U, LDU, U(J,1), LDU, UPD, R(1,JD), LDR ) -C -C Compute/update Guu(2:j,j), exploiting the -C block-Hankel structure. -C - IF( FIRST ) THEN -C - DO 30 I = JD - M, JD - 1 - CALL DCOPY( I, R(1,I), 1, R(M+1,M+I), 1 ) - 30 CONTINUE -C - ELSE -C - DO 40 I = JD - M, JD - 1 - CALL DAXPY( I, ONE, R(1,I), 1, R(M+1,M+I), 1 ) - 40 CONTINUE -C - END IF -C - DO 50 I = 2, J - 1 - CALL DGER( M, M, ONE, U(NS+I-1,1), LDU, - $ U(NS+J-1,1), LDU, R(ID,JD), LDR ) - CALL DGER( M, M, -ONE, U(I-1,1), LDU, U(J-1,1), - $ LDU, R(ID,JD), LDR ) - ID = ID + M - 50 CONTINUE -C - DO 60 I = 1, M - CALL DAXPY( I, U(NS+J-1,I), U(NS+J-1,1), LDU, - $ R(JD,JD+I-1), 1 ) - CALL DAXPY( I, -U(J-1,I), U(J-1,1), LDU, - $ R(JD,JD+I-1), 1 ) - 60 CONTINUE -C - 70 CONTINUE -C - ELSE -C - DO 120 J = 2, NOBR2 - JD = JD + M - ID = M + 1 -C -C Compute/update Guu(1,j) for sequential processing -C with connected blocks. -C - CALL DGEMM( 'Transpose', 'NoTranspose', M, M, NOBR21, - $ ONE, DWORK, LDRWRK, DWORK(J), LDRWRK, UPD, - $ R(1,JD), LDR ) - CALL DGEMM( 'Transpose', 'NoTranspose', M, M, NS, ONE, - $ U, LDU, U(J,1), LDU, ONE, R(1,JD), LDR ) -C -C Compute/update Guu(2:j,j) for sequential processing -C with connected blocks, exploiting the block-Hankel -C structure. -C - IF( FIRST ) THEN -C - DO 80 I = JD - M, JD - 1 - CALL DCOPY( I, R(1,I), 1, R(M+1,M+I), 1 ) - 80 CONTINUE -C - ELSE -C - DO 90 I = JD - M, JD - 1 - CALL DAXPY( I, ONE, R(1,I), 1, R(M+1,M+I), 1 ) - 90 CONTINUE -C - END IF -C - DO 100 I = 2, J - 1 - CALL DGER( M, M, ONE, U(NS+I-1,1), LDU, - $ U(NS+J-1,1), LDU, R(ID,JD), LDR ) - CALL DGER( M, M, -ONE, DWORK(I-1), LDRWRK, - $ DWORK(J-1), LDRWRK, R(ID,JD), LDR ) - ID = ID + M - 100 CONTINUE -C - DO 110 I = 1, M - CALL DAXPY( I, U(NS+J-1,I), U(NS+J-1,1), LDU, - $ R(JD,JD+I-1), 1 ) - CALL DAXPY( I, -DWORK((I-1)*LDRWRK+J-1), - $ DWORK(J-1), LDRWRK, R(JD,JD+I-1), 1 ) - 110 CONTINUE -C - 120 CONTINUE -C - END IF -C - IF ( LAST .AND. MOESP ) THEN -C -C Interchange past and future parts for MOESP algorithm. -C (Only the upper triangular parts are interchanged, and -C the (1,2) part is transposed in-situ.) -C - TEMP = R(1,1) - R(1,1) = R(MNOBR+1,MNOBR+1) - R(MNOBR+1,MNOBR+1) = TEMP -C - DO 130 J = 2, MNOBR - CALL DSWAP( J, R(1,J), 1, R(MNOBR+1,MNOBR+J), 1 ) - CALL DSWAP( J-1, R(1,MNOBR+J), 1, R(J,MNOBR+1), LDR ) - 130 CONTINUE -C - END IF -C -C Let Guy(i,j) = Guy0(i,j) + u_i*y_j' + u_(i+1)*y_(j+1)' + -C ... + u_(i+NS-1)*y_(j+NS-1)', -C where u_i' is the i-th row of U, y_j' is the j-th row -C of Y, j = 1 : 2s, i = 1 : 2s, NS = NSMP - 2s + 1, and -C Guy0(i,j) is a zero matrix for BATCH = 'O' or 'F', and it -C is the matrix Guy(i,j) computed till the current block for -C BATCH = 'I' or 'L'. Guy(i,j) is m-by-L. The U-Y -C correlations, Guy, are computed (or updated) column-wise -C in the array R. Only the submatrices of the first block- -C column and block-row are fully computed (or updated). The -C remaining ones are determined exploiting the block-Hankel -C structure, using the updating formula -C -C Guy(i+1,j+1) = Guy0(i+1,j+1) - Guy0(i,j) + Guy(i,j) + -C u_(i+NS)*y(j+NS)' - u_i*y_j'. -C - II = MMNOBR - M - IF( .NOT.FIRST ) THEN -C -C Subtract the contribution of the previous block of data -C in sequential processing. The columns must be processed -C in backward order. -C - DO 140 I = NR - L, MMNOBR + 1, -1 - CALL DAXPY( II, -ONE, R(1,I), 1, R(M+1,L+I), 1 ) - 140 CONTINUE -C - END IF -C -C Compute/update the first block-column of Guy, Guy(i,1). -C - IF( FIRST .OR. .NOT.CONNEC ) THEN -C - DO 150 I = 1, NOBR2 - CALL DGEMM( 'Transpose', 'NoTranspose', M, L, NS, ONE, - $ U(I,1), LDU, Y, LDY, UPD, - $ R((I-1)*M+1,MMNOBR+1), LDR ) - 150 CONTINUE -C - ELSE -C - DO 160 I = 1, NOBR2 - CALL DGEMM( 'Transpose', 'NoTranspose', M, L, NOBR21, - $ ONE, DWORK(I), LDRWRK, DWORK(LDRWRK*M+1), - $ LDRWRK, UPD, R((I-1)*M+1,MMNOBR+1), LDR ) - CALL DGEMM( 'Transpose', 'NoTranspose', M, L, NS, ONE, - $ U(I,1), LDU, Y, LDY, ONE, - $ R((I-1)*M+1,MMNOBR+1), LDR ) - 160 CONTINUE -C - END IF -C - JD = MMNOBR + 1 -C - IF( FIRST .OR. .NOT.CONNEC ) THEN -C - DO 200 J = 2, NOBR2 - JD = JD + L - ID = M + 1 -C -C Compute/update Guy(1,j). -C - CALL DGEMM( 'Transpose', 'NoTranspose', M, L, NS, ONE, - $ U, LDU, Y(J,1), LDY, UPD, R(1,JD), LDR ) -C -C Compute/update Guy(2:2*s,j), exploiting the -C block-Hankel structure. -C - IF( FIRST ) THEN -C - DO 170 I = JD - L, JD - 1 - CALL DCOPY( II, R(1,I), 1, R(M+1,L+I), 1 ) - 170 CONTINUE -C - ELSE -C - DO 180 I = JD - L, JD - 1 - CALL DAXPY( II, ONE, R(1,I), 1, R(M+1,L+I), 1 ) - 180 CONTINUE -C - END IF -C - DO 190 I = 2, NOBR2 - CALL DGER( M, L, ONE, U(NS+I-1,1), LDU, - $ Y(NS+J-1,1), LDY, R(ID,JD), LDR ) - CALL DGER( M, L, -ONE, U(I-1,1), LDU, Y(J-1,1), - $ LDY, R(ID,JD), LDR ) - ID = ID + M - 190 CONTINUE -C - 200 CONTINUE -C - ELSE -C - DO 240 J = 2, NOBR2 - JD = JD + L - ID = M + 1 -C -C Compute/update Guy(1,j) for sequential processing -C with connected blocks. -C - CALL DGEMM( 'Transpose', 'NoTranspose', M, L, NOBR21, - $ ONE, DWORK, LDRWRK, DWORK(LDRWRK*M+J), - $ LDRWRK, UPD, R(1,JD), LDR ) - CALL DGEMM( 'Transpose', 'NoTranspose', M, L, NS, ONE, - $ U, LDU, Y(J,1), LDY, ONE, R(1,JD), LDR ) -C -C Compute/update Guy(2:2*s,j) for sequential -C processing with connected blocks, exploiting the -C block-Hankel structure. -C - IF( FIRST ) THEN -C - DO 210 I = JD - L, JD - 1 - CALL DCOPY( II, R(1,I), 1, R(M+1,L+I), 1 ) - 210 CONTINUE -C - ELSE -C - DO 220 I = JD - L, JD - 1 - CALL DAXPY( II, ONE, R(1,I), 1, R(M+1,L+I), 1 ) - 220 CONTINUE -C - END IF -C - DO 230 I = 2, NOBR2 - CALL DGER( M, L, ONE, U(NS+I-1,1), LDU, - $ Y(NS+J-1,1), LDY, R(ID,JD), LDR ) - CALL DGER( M, L, -ONE, DWORK(I-1), LDRWRK, - $ DWORK(LDRWRK*M+J-1), LDRWRK, R(ID,JD), - $ LDR ) - ID = ID + M - 230 CONTINUE -C - 240 CONTINUE -C - END IF -C - IF ( LAST .AND. MOESP ) THEN -C -C Interchange past and future parts of U-Y correlations -C for MOESP algorithm. -C - DO 250 J = MMNOBR + 1, NR - CALL DSWAP( MNOBR, R(1,J), 1, R(MNOBR+1,J), 1 ) - 250 CONTINUE -C - END IF - END IF -C -C Let Gyy(i,j) = Gyy0(i,j) + y_i*y_i' + y_(i+1)*y_(i+1)' + ... + -C y_(i+NS-1)*y_(i+NS-1)', -C where y_i' is the i-th row of Y, j = 1 : 2s, i = 1 : j, -C NS = NSMP - 2s + 1, and Gyy0(i,j) is a zero matrix for -C BATCH = 'O' or 'F', and it is the matrix Gyy(i,j) computed till -C the current block for BATCH = 'I' or 'L'. Gyy(i,j) is L-by-L, -C and Gyy(j,j) is symmetric. The upper triangle of the Y-Y -C correlations, Gyy, is computed (or updated) column-wise in -C the corresponding part of the array R, that is, in the order -C Gyy(1,1), Gyy(1,2), Gyy(2,2), ..., Gyy(2s,2s). Only the -C submatrices of the first block-row are fully computed (or -C updated). The remaining ones are determined exploiting the -C block-Hankel structure, using the updating formula -C -C Gyy(i+1,j+1) = Gyy0(i+1,j+1) - Gyy0(i,j) + Gyy(i,j) + -C y_(i+NS)*y_(j+NS)' - y_i*y_j'. -C - JD = MMNOBR + 1 -C - IF( .NOT.FIRST ) THEN -C -C Subtract the contribution of the previous block of data -C in sequential processing. The columns must be processed in -C backward order. -C - DO 260 I = NR - L, MMNOBR + 1, -1 - CALL DAXPY( I-MMNOBR, -ONE, R(JD,I), 1, R(JD+L,L+I), 1 ) - 260 CONTINUE -C - END IF -C -C Compute/update Gyy(1,1). -C - IF( .NOT.FIRST .AND. CONNEC ) - $ CALL DSYRK( 'Upper', 'Transpose', L, NOBR21, ONE, - $ DWORK(LDRWRK*M+1), LDRWRK, UPD, R(JD,JD), LDR ) - CALL DSYRK( 'Upper', 'Transpose', L, NS, ONE, Y, LDY, UPD, - $ R(JD,JD), LDR ) -C - IF( FIRST .OR. .NOT.CONNEC ) THEN -C - DO 310 J = 2, NOBR2 - JD = JD + L - ID = MMNOBR + L + 1 -C -C Compute/update Gyy(1,j). -C - CALL DGEMM( 'Transpose', 'NoTranspose', L, L, NS, ONE, Y, - $ LDY, Y(J,1), LDY, UPD, R(MMNOBR+1,JD), LDR ) -C -C Compute/update Gyy(2:j,j), exploiting the block-Hankel -C structure. -C - IF( FIRST ) THEN -C - DO 270 I = JD - L, JD - 1 - CALL DCOPY( I-MMNOBR, R(MMNOBR+1,I), 1, - $ R(MMNOBR+L+1,L+I), 1 ) - 270 CONTINUE -C - ELSE -C - DO 280 I = JD - L, JD - 1 - CALL DAXPY( I-MMNOBR, ONE, R(MMNOBR+1,I), 1, - $ R(MMNOBR+L+1,L+I), 1 ) - 280 CONTINUE -C - END IF -C - DO 290 I = 2, J - 1 - CALL DGER( L, L, ONE, Y(NS+I-1,1), LDY, Y(NS+J-1,1), - $ LDY, R(ID,JD), LDR ) - CALL DGER( L, L, -ONE, Y(I-1,1), LDY, Y(J-1,1), LDY, - $ R(ID,JD), LDR ) - ID = ID + L - 290 CONTINUE -C - DO 300 I = 1, L - CALL DAXPY( I, Y(NS+J-1,I), Y(NS+J-1,1), LDY, - $ R(JD,JD+I-1), 1 ) - CALL DAXPY( I, -Y(J-1,I), Y(J-1,1), LDY, R(JD,JD+I-1), - $ 1 ) - 300 CONTINUE -C - 310 CONTINUE -C - ELSE -C - DO 360 J = 2, NOBR2 - JD = JD + L - ID = MMNOBR + L + 1 -C -C Compute/update Gyy(1,j) for sequential processing with -C connected blocks. -C - CALL DGEMM( 'Transpose', 'NoTranspose', L, L, NOBR21, - $ ONE, DWORK(LDRWRK*M+1), LDRWRK, - $ DWORK(LDRWRK*M+J), LDRWRK, UPD, - $ R(MMNOBR+1,JD), LDR ) - CALL DGEMM( 'Transpose', 'NoTranspose', L, L, NS, ONE, Y, - $ LDY, Y(J,1), LDY, ONE, R(MMNOBR+1,JD), LDR ) -C -C Compute/update Gyy(2:j,j) for sequential processing -C with connected blocks, exploiting the block-Hankel -C structure. -C - IF( FIRST ) THEN -C - DO 320 I = JD - L, JD - 1 - CALL DCOPY( I-MMNOBR, R(MMNOBR+1,I), 1, - $ R(MMNOBR+L+1,L+I), 1 ) - 320 CONTINUE -C - ELSE -C - DO 330 I = JD - L, JD - 1 - CALL DAXPY( I-MMNOBR, ONE, R(MMNOBR+1,I), 1, - $ R(MMNOBR+L+1,L+I), 1 ) - 330 CONTINUE -C - END IF -C - DO 340 I = 2, J - 1 - CALL DGER( L, L, ONE, Y(NS+I-1,1), LDY, Y(NS+J-1,1), - $ LDY, R(ID,JD), LDR ) - CALL DGER( L, L, -ONE, DWORK(LDRWRK*M+I-1), LDRWRK, - $ DWORK(LDRWRK*M+J-1), LDRWRK, R(ID,JD), - $ LDR ) - ID = ID + L - 340 CONTINUE -C - DO 350 I = 1, L - CALL DAXPY( I, Y(NS+J-1,I), Y(NS+J-1,1), LDY, - $ R(JD,JD+I-1), 1 ) - CALL DAXPY( I, -DWORK(LDRWRK*(M+I-1)+J-1), - $ DWORK(LDRWRK*M+J-1), LDRWRK, R(JD,JD+I-1), - $ 1 ) - 350 CONTINUE -C - 360 CONTINUE -C - END IF -C - IF ( .NOT.LAST ) THEN - IF ( CONNEC ) THEN -C -C For sequential processing with connected data blocks, -C save the remaining ("connection") elements of U and Y -C in the first (M+L)*(2*NOBR-1) locations of DWORK. -C - IF ( M.GT.0 ) - $ CALL DLACPY( 'Full', NOBR21, M, U(NS+1,1), LDU, DWORK, - $ NOBR21 ) - CALL DLACPY( 'Full', NOBR21, L, Y(NS+1,1), LDY, - $ DWORK(MMNOBR-M+1), NOBR21 ) - END IF -C -C Return to get new data. -C - ICYCLE = ICYCLE + 1 - IF ( ICYCLE.GT.MAXCYC ) - $ IWARN = 1 - RETURN -C - ELSE -C -C Try to compute the Cholesky factor of the correlation -C matrix. -C - CALL DPOTRF( 'Upper', NR, R, LDR, IERR ) - GO TO 370 - END IF - ELSE IF ( FQRALG ) THEN -C -C Compute the R factor from a fast QR factorization of the -C input-output data correlation matrix. -C - CALL IB01MY( METH, BATCH, CONCT, NOBR, M, L, NSMP, U, LDU, - $ Y, LDY, R, LDR, IWORK, DWORK, LDWORK, IWARN, - $ IERR ) - IF( .NOT.LAST ) - $ RETURN - MAXWRK = MAX( MAXWRK, INT( DWORK(1) ) ) - END IF -C - 370 CONTINUE -C - IF( IERR.NE.0 ) THEN -C -C Error return from a fast factorization algorithm of the -C input-output data correlation matrix. -C - IF( ONEBCH ) THEN - QRALG = .TRUE. - IWARN = 2 - MINWRK = 2*NR - MAXWRK = NR + NR*ILAENV( 1, 'DGEQRF', ' ', NS, NR, -1, - $ -1 ) - IF ( LDR.LT.NS ) THEN - MINWRK = MINWRK + NR - MAXWRK = NS*NR + MAXWRK - END IF - MAXWRK = MAX( MINWRK, MAXWRK ) -C - IF( LDWORK.LT.MINWRK ) THEN - INFO = -17 -C -C Return: Not enough workspace. -C - DWORK( 1 ) = MINWRK - CALL XERBLA( 'IB01MD', -INFO ) - RETURN - END IF - ELSE - INFO = 1 - RETURN - END IF - END IF -C - IF ( QRALG ) THEN -C -C Compute the R factor from a QR factorization of the matrix H -C of concatenated block Hankel matrices. -C -C Construct the matrix H. -C -C Set the parameters for constructing the current segment of the -C Hankel matrix, taking the available memory space into account. -C INITI+1 points to the beginning rows of U and Y from which -C data are taken when NCYCLE > 1 inner cycles are needed, -C or for sequential processing with connected blocks. -C LDRWMX is the number of rows that can fit in the working space. -C LDRWRK is the actual number of rows processed in this space. -C NSLAST is the number of samples to be processed at the last -C inner cycle. -C - INITI = 0 - LDRWMX = LDWORK / NR - 2 - NCYCLE = 1 - NSLAST = NSMP - LINR = .FALSE. - IF ( FIRST ) THEN - LINR = LDR.GE.NS - LDRWRK = NS - ELSE IF ( CONNEC ) THEN - LDRWRK = NSMP - ELSE - LDRWRK = NS - END IF - INICYC = 1 -C - IF ( .NOT.LINR ) THEN - IF ( LDRWMX.LT.LDRWRK ) THEN -C -C Not enough working space for doing a single inner cycle. -C NCYCLE inner cycles are to be performed for the current -C data block using the working space. -C - NCYCLE = LDRWRK / LDRWMX - NSLAST = MOD( LDRWRK, LDRWMX ) - IF ( NSLAST.NE.0 ) THEN - NCYCLE = NCYCLE + 1 - ELSE - NSLAST = LDRWMX - END IF - LDRWRK = LDRWMX - NS = LDRWRK - IF ( FIRST ) INICYC = 2 - END IF - MLDRW = M*LDRWRK - LLDRW = L*LDRWRK - INU = MLDRW*NOBR + 1 - INY = MLDRW*NOBR2 + 1 - END IF -C -C Process the data given at the current call. -C - IF ( .NOT.FIRST .AND. CONNEC ) THEN -C -C Restore the saved (M+L)*(2*NOBR-1) "connection" elements of -C U and Y into their appropriate position in sequential -C processing. The process is performed column-wise, in -C reverse order, first for Y and then for U. -C - IREV = NR - M - L - NOBR21 + 1 - ICOL = INY + LLDRW - LDRWRK -C - DO 380 J = 1, L - DO 375 I = NOBR21 - 1, 0, -1 - DWORK(ICOL+I) = DWORK(IREV+I) - 375 CONTINUE - IREV = IREV - NOBR21 - ICOL = ICOL - LDRWRK - 380 CONTINUE -C - IF( MOESP ) THEN - ICOL = INU + MLDRW - LDRWRK - ELSE - ICOL = MLDRW - LDRWRK + 1 - END IF -C - DO 390 J = 1, M - DO 385 I = NOBR21 - 1, 0, -1 - DWORK(ICOL+I) = DWORK(IREV+I) - 385 CONTINUE - IREV = IREV - NOBR21 - ICOL = ICOL - LDRWRK - 390 CONTINUE -C - IF( MOESP ) - $ CALL DLACPY( 'Full', NOBRM1, M, DWORK(INU+NOBR), LDRWRK, - $ DWORK, LDRWRK ) - END IF -C -C Data compression using QR factorization. -C - IF ( FIRST ) THEN -C -C Non-sequential data processing or first block in -C sequential data processing: -C Use the general QR factorization algorithm. -C - IF ( LINR ) THEN -C -C Put the input-output data in the array R. -C - IF( M.GT.0 ) THEN - IF( MOESP ) THEN -C - DO 400 I = 1, NOBR - CALL DLACPY( 'Full', NS, M, U(NOBR+I,1), LDU, - $ R(1,M*(I-1)+1), LDR ) - 400 CONTINUE -C - DO 410 I = 1, NOBR - CALL DLACPY( 'Full', NS, M, U(I,1), LDU, - $ R(1,MNOBR+M*(I-1)+1), LDR ) - 410 CONTINUE -C - ELSE -C - DO 420 I = 1, NOBR2 - CALL DLACPY( 'Full', NS, M, U(I,1), LDU, - $ R(1,M*(I-1)+1), LDR ) - 420 CONTINUE -C - END IF - END IF -C - DO 430 I = 1, NOBR2 - CALL DLACPY( 'Full', NS, L, Y(I,1), LDY, - $ R(1,MMNOBR+L*(I-1)+1), LDR ) - 430 CONTINUE -C -C Workspace: need 4*(M+L)*NOBR, -C prefer 2*(M+L)*NOBR+2*(M+L)*NOBR*NB. -C - ITAU = 1 - JWORK = ITAU + NR - CALL DGEQRF( NS, NR, R, LDR, DWORK(ITAU), DWORK(JWORK), - $ LDWORK-JWORK+1, IERR ) - ELSE -C -C Put the input-output data in the array DWORK. -C - IF( M.GT.0 ) THEN - ISHFTU = 1 - IF( MOESP ) THEN - ISHFT2 = INU -C - DO 440 I = 1, NOBR - CALL DLACPY( 'Full', NS, M, U(NOBR+I,1), LDU, - $ DWORK(ISHFTU), LDRWRK ) - ISHFTU = ISHFTU + MLDRW - 440 CONTINUE -C - DO 450 I = 1, NOBR - CALL DLACPY( 'Full', NS, M, U(I,1), LDU, - $ DWORK(ISHFT2), LDRWRK ) - ISHFT2 = ISHFT2 + MLDRW - 450 CONTINUE -C - ELSE -C - DO 460 I = 1, NOBR2 - CALL DLACPY( 'Full', NS, M, U(I,1), LDU, - $ DWORK(ISHFTU), LDRWRK ) - ISHFTU = ISHFTU + MLDRW - 460 CONTINUE -C - END IF - END IF -C - ISHFTY = INY -C - DO 470 I = 1, NOBR2 - CALL DLACPY( 'Full', NS, L, Y(I,1), LDY, - $ DWORK(ISHFTY), LDRWRK ) - ISHFTY = ISHFTY + LLDRW - 470 CONTINUE -C -C Workspace: need 2*(M+L)*NOBR + 4*(M+L)*NOBR, -C prefer NS*2*(M+L)*NOBR + 2*(M+L)*NOBR -C + 2*(M+L)*NOBR*NB, -C used LDRWRK*2*(M+L)*NOBR + 4*(M+L)*NOBR, -C where NS = NSMP - 2*NOBR + 1, -C LDRWRK = min(NS, LDWORK/(2*(M+L)*NOBR)-2). -C - ITAU = LDRWRK*NR + 1 - JWORK = ITAU + NR - CALL DGEQRF( NS, NR, DWORK, LDRWRK, DWORK(ITAU), - $ DWORK(JWORK), LDWORK-JWORK+1, IERR ) - CALL DLACPY( 'Upper ', MIN(NS,NR), NR, DWORK, LDRWRK, R, - $ LDR ) - END IF -C - IF ( NS.LT.NR ) - $ CALL DLASET( 'Upper ', NR - NS, NR - NS, ZERO, ZERO, - $ R(NS+1,NS+1), LDR ) - INITI = INITI + NS - END IF -C - IF ( NCYCLE.GT.1 .OR. .NOT.FIRST ) THEN -C -C Remaining segments of the first data block or -C remaining segments/blocks in sequential data processing: -C Use a structure-exploiting QR factorization algorithm. -C - NSL = LDRWRK - IF ( .NOT.CONNEC ) NSL = NS - ITAU = LDRWRK*NR + 1 - JWORK = ITAU + NR -C - DO 560 NICYCL = INICYC, NCYCLE -C -C INIT denotes the beginning row where new data are put. -C - IF ( CONNEC .AND. NICYCL.EQ.1 ) THEN - INIT = NOBR2 - ELSE - INIT = 1 - END IF - IF ( NCYCLE.GT.1 .AND. NICYCL.EQ.NCYCLE ) THEN -C -C Last samples in the last data segment of a block. -C - NS = NSLAST - NSL = NSLAST - END IF -C -C Put the input-output data in the array DWORK. -C - NSF = NS - IF ( INIT.GT.1 .AND. NCYCLE.GT.1 ) NSF = NSF - NOBR21 - IF ( M.GT.0 ) THEN - ISHFTU = INIT -C - IF( MOESP ) THEN - ISHFT2 = INIT + INU - 1 -C - DO 480 I = 1, NOBR - CALL DLACPY( 'Full', NSF, M, U(INITI+NOBR+I,1), - $ LDU, DWORK(ISHFTU), LDRWRK ) - ISHFTU = ISHFTU + MLDRW - 480 CONTINUE -C - DO 490 I = 1, NOBR - CALL DLACPY( 'Full', NSF, M, U(INITI+I,1), LDU, - $ DWORK(ISHFT2), LDRWRK ) - ISHFT2 = ISHFT2 + MLDRW - 490 CONTINUE -C - ELSE -C - DO 500 I = 1, NOBR2 - CALL DLACPY( 'Full', NSF, M, U(INITI+I,1), LDU, - $ DWORK(ISHFTU), LDRWRK ) - ISHFTU = ISHFTU + MLDRW - 500 CONTINUE -C - END IF - END IF -C - ISHFTY = INIT + INY - 1 -C - DO 510 I = 1, NOBR2 - CALL DLACPY( 'Full', NSF, L, Y(INITI+I,1), LDY, - $ DWORK(ISHFTY), LDRWRK ) - ISHFTY = ISHFTY + LLDRW - 510 CONTINUE -C - IF ( INIT.GT.1 ) THEN -C -C Prepare the connection to the previous block of data -C in sequential processing. -C - IF( MOESP .AND. M.GT.0 ) - $ CALL DLACPY( 'Full', NOBR, M, U, LDU, DWORK(NOBR), - $ LDRWRK ) -C -C Shift the elements from the connection to the previous -C block of data in sequential processing. -C - IF ( M.GT.0 ) THEN - ISHFTU = MLDRW + 1 -C - IF( MOESP ) THEN - ISHFT2 = MLDRW + INU -C - DO 520 I = 1, NOBRM1 - CALL DLACPY( 'Full', NOBR21, M, - $ DWORK(ISHFTU-MLDRW+1), LDRWRK, - $ DWORK(ISHFTU), LDRWRK ) - ISHFTU = ISHFTU + MLDRW - 520 CONTINUE -C - DO 530 I = 1, NOBRM1 - CALL DLACPY( 'Full', NOBR21, M, - $ DWORK(ISHFT2-MLDRW+1), LDRWRK, - $ DWORK(ISHFT2), LDRWRK ) - ISHFT2 = ISHFT2 + MLDRW - 530 CONTINUE -C - ELSE -C - DO 540 I = 1, NOBR21 - CALL DLACPY( 'Full', NOBR21, M, - $ DWORK(ISHFTU-MLDRW+1), LDRWRK, - $ DWORK(ISHFTU), LDRWRK ) - ISHFTU = ISHFTU + MLDRW - 540 CONTINUE -C - END IF - END IF -C - ISHFTY = LLDRW + INY -C - DO 550 I = 1, NOBR21 - CALL DLACPY( 'Full', NOBR21, L, - $ DWORK(ISHFTY-LLDRW+1), LDRWRK, - $ DWORK(ISHFTY), LDRWRK ) - ISHFTY = ISHFTY + LLDRW - 550 CONTINUE -C - END IF -C -C Workspace: need LDRWRK*2*(M+L)*NOBR + 4*(M+L)*NOBR. -C - CALL MB04OD( 'Full', NR, 0, NSL, R, LDR, DWORK, LDRWRK, - $ DUM, NR, DUM, NR, DWORK(ITAU), DWORK(JWORK) - $ ) - INITI = INITI + NSF - 560 CONTINUE -C - END IF -C - IF ( .NOT.LAST ) THEN - IF ( CONNEC ) THEN -C -C For sequential processing with connected data blocks, -C save the remaining ("connection") elements of U and Y -C in the first (M+L)*(2*NOBR-1) locations of DWORK. -C - IF ( M.GT.0 ) - $ CALL DLACPY( 'Full', NOBR21, M, U(INITI+1,1), LDU, - $ DWORK, NOBR21 ) - CALL DLACPY( 'Full', NOBR21, L, Y(INITI+1,1), LDY, - $ DWORK(MMNOBR-M+1), NOBR21 ) - END IF -C -C Return to get new data. -C - ICYCLE = ICYCLE + 1 - IF ( ICYCLE.LE.MAXCYC ) - $ RETURN - IWARN = 1 - ICYCLE = 1 -C - END IF -C - END IF -C -C Return optimal workspace in DWORK(1). -C - DWORK( 1 ) = MAXWRK - IF ( LAST ) THEN - ICYCLE = 1 - MAXWRK = 1 - NSMPSM = 0 - END IF - RETURN -C -C *** Last line of IB01MD *** - END diff --git a/mex/sources/libslicot/IB01MY.f b/mex/sources/libslicot/IB01MY.f deleted file mode 100644 index a76f452a3..000000000 --- a/mex/sources/libslicot/IB01MY.f +++ /dev/null @@ -1,1094 +0,0 @@ - SUBROUTINE IB01MY( METH, BATCH, CONCT, NOBR, M, L, NSMP, U, LDU, - $ Y, LDY, R, LDR, IWORK, DWORK, LDWORK, IWARN, - $ INFO ) -C -C SLICOT RELEASE 5.0. -C -C Copyright (c) 2002-2009 NICONET e.V. -C -C This program is free software: you can redistribute it and/or -C modify it under the terms of the GNU General Public License as -C published by the Free Software Foundation, either version 2 of -C the License, or (at your option) any later version. -C -C This program is distributed in the hope that it will be useful, -C but WITHOUT ANY WARRANTY; without even the implied warranty of -C MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the -C GNU General Public License for more details. -C -C You should have received a copy of the GNU General Public License -C along with this program. If not, see -C . -C -C PURPOSE -C -C To construct an upper triangular factor R of the concatenated -C block Hankel matrices using input-output data, via a fast QR -C algorithm based on displacement rank. The input-output data can, -C optionally, be processed sequentially. -C -C ARGUMENTS -C -C Mode Parameters -C -C METH CHARACTER*1 -C Specifies the subspace identification method to be used, -C as follows: -C = 'M': MOESP algorithm with past inputs and outputs; -C = 'N': N4SID algorithm. -C -C BATCH CHARACTER*1 -C Specifies whether or not sequential data processing is to -C be used, and, for sequential processing, whether or not -C the current data block is the first block, an intermediate -C block, or the last block, as follows: -C = 'F': the first block in sequential data processing; -C = 'I': an intermediate block in sequential data -C processing; -C = 'L': the last block in sequential data processing; -C = 'O': one block only (non-sequential data processing). -C NOTE that when 100 cycles of sequential data processing -C are completed for BATCH = 'I', a warning is -C issued, to prevent for an infinite loop. -C -C CONCT CHARACTER*1 -C Specifies whether or not the successive data blocks in -C sequential data processing belong to a single experiment, -C as follows: -C = 'C': the current data block is a continuation of the -C previous data block and/or it will be continued -C by the next data block; -C = 'N': there is no connection between the current data -C block and the previous and/or the next ones. -C This parameter is not used if BATCH = 'O'. -C -C Input/Output Parameters -C -C NOBR (input) INTEGER -C The number of block rows, s, in the input and output -C block Hankel matrices to be processed. NOBR > 0. -C (In the MOESP theory, NOBR should be larger than n, the -C estimated dimension of state vector.) -C -C M (input) INTEGER -C The number of system inputs. M >= 0. -C When M = 0, no system inputs are processed. -C -C L (input) INTEGER -C The number of system outputs. L > 0. -C -C NSMP (input) INTEGER -C The number of rows of matrices U and Y (number of -C samples, t). (When sequential data processing is used, -C NSMP is the number of samples of the current data -C block.) -C NSMP >= 2*(M+L+1)*NOBR - 1, for non-sequential -C processing; -C NSMP >= 2*NOBR, for sequential processing. -C The total number of samples when calling the routine with -C BATCH = 'L' should be at least 2*(M+L+1)*NOBR - 1. -C The NSMP argument may vary from a cycle to another in -C sequential data processing, but NOBR, M, and L should -C be kept constant. For efficiency, it is advisable to use -C NSMP as large as possible. -C -C U (input) DOUBLE PRECISION array, dimension (LDU,M) -C The leading NSMP-by-M part of this array must contain the -C t-by-m input-data sequence matrix U, -C U = [u_1 u_2 ... u_m]. Column j of U contains the -C NSMP values of the j-th input component for consecutive -C time increments. -C If M = 0, this array is not referenced. -C -C LDU INTEGER -C The leading dimension of the array U. -C LDU >= NSMP, if M > 0; -C LDU >= 1, if M = 0. -C -C Y (input) DOUBLE PRECISION array, dimension (LDY,L) -C The leading NSMP-by-L part of this array must contain the -C t-by-l output-data sequence matrix Y, -C Y = [y_1 y_2 ... y_l]. Column j of Y contains the -C NSMP values of the j-th output component for consecutive -C time increments. -C -C LDY INTEGER -C The leading dimension of the array Y. LDY >= NSMP. -C -C R (output) DOUBLE PRECISION array, dimension -C ( LDR,2*(M+L)*NOBR ) -C If INFO = 0 and BATCH = 'L' or 'O', the leading -C 2*(M+L)*NOBR-by-2*(M+L)*NOBR upper triangular part of this -C array contains the upper triangular factor R from the -C QR factorization of the concatenated block Hankel -C matrices. -C -C LDR INTEGER -C The leading dimension of the array R. -C LDR >= 2*(M+L)*NOBR. -C -C Workspace -C -C IWORK INTEGER array, dimension (M+L) -C -C DWORK DOUBLE PRECISION array, dimension (LDWORK) -C On exit, if INFO = 0, DWORK(1) returns the optimal -C value of LDWORK. -C On exit, if INFO = -16, DWORK(1) returns the minimum -C value of LDWORK. -C The first (M+L)*2*NOBR*(M+L+c) elements of DWORK should -C be preserved during successive calls of the routine -C with BATCH = 'F' or 'I', till the final call with -C BATCH = 'L', where -C c = 1, if the successive data blocks do not belong to a -C single experiment (CONCT = 'N'); -C c = 2, if the successive data blocks belong to a single -C experiment (CONCT = 'C'). -C -C LDWORK INTEGER -C The length of the array DWORK. -C LDWORK >= (M+L)*2*NOBR*(M+L+3), -C if BATCH <> 'O' and CONCT = 'C'; -C LDWORK >= (M+L)*2*NOBR*(M+L+1), -C if BATCH = 'F' or 'I' and CONCT = 'N'; -C LDWORK >= (M+L)*4*NOBR*(M+L+1)+(M+L)*2*NOBR, -C if BATCH = 'L' and CONCT = 'N', -C or BATCH = 'O'. -C -C Warning Indicator -C -C IWARN INTEGER -C = 0: no warning; -C = 1: the number of 100 cycles in sequential data -C processing has been exhausted without signaling -C that the last block of data was get. -C -C Error Indicator -C -C INFO INTEGER -C = 0: successful exit; -C < 0: if INFO = -i, the i-th argument had an illegal -C value; -C = 1: the fast QR factorization algorithm failed. The -C matrix H'*H is not (numerically) positive definite. -C -C METHOD -C -C Consider the t x 2(m+l)s matrix H of concatenated block Hankel -C matrices -C -C H = [ Uf' Up' Y' ], for METH = 'M', -C s+1,2s,t 1,s,t 1,2s,t -C -C H = [ U' Y' ], for METH = 'N', -C 1,2s,t 1,2s,t -C -C where Up , Uf , U , and Y are block -C 1,s,t s+1,2s,t 1,2s,t 1,2s,t -C Hankel matrices defined in terms of the input and output data [3]. -C The fast QR algorithm uses a factorization of H'*H which exploits -C the block-Hankel structure, via a displacement rank technique [5]. -C -C REFERENCES -C -C [1] Verhaegen M., and Dewilde, P. -C Subspace Model Identification. Part 1: The output-error -C state-space model identification class of algorithms. -C Int. J. Control, 56, pp. 1187-1210, 1992. -C -C [2] Verhaegen M. -C Subspace Model Identification. Part 3: Analysis of the -C ordinary output-error state-space model identification -C algorithm. -C Int. J. Control, 58, pp. 555-586, 1993. -C -C [3] Verhaegen M. -C Identification of the deterministic part of MIMO state space -C models given in innovations form from input-output data. -C Automatica, Vol.30, No.1, pp.61-74, 1994. -C -C [4] Van Overschee, P., and De Moor, B. -C N4SID: Subspace Algorithms for the Identification of -C Combined Deterministic-Stochastic Systems. -C Automatica, Vol.30, No.1, pp. 75-93, 1994. -C -C [5] Kressner, D., Mastronardi, N., Sima, V., Van Dooren, P., and -C Van Huffel, S. -C A Fast Algorithm for Subspace State-space System -C Identification via Exploitation of the Displacement Structure. -C J. Comput. Appl. Math., Vol.132, No.1, pp. 71-81, 2001. -C -C NUMERICAL ASPECTS -C -C The implemented method is reliable and efficient. Numerical -C difficulties are possible when the matrix H'*H is nearly rank -C defficient. The method cannot be used if the matrix H'*H is not -C numerically positive definite. -C 2 3 2 -C The algorithm requires 0(2t(m+l) s)+0(4(m+l) s ) floating point -C operations. -C -C CONTRIBUTORS -C -C V. Sima, Katholieke Universiteit Leuven, June 2000. -C Partly based on Matlab codes developed by N. Mastronardi, -C Katholieke Universiteit Leuven, February 2000. -C -C REVISIONS -C -C V. Sima, July 2000, August 2000, Feb. 2004, May 2009. -C -C KEYWORDS -C -C Displacement rank, Hankel matrix, Householder transformation, -C identification methods, multivariable systems. -C -C ****************************************************************** -C -C .. Parameters .. - DOUBLE PRECISION ZERO, ONE - PARAMETER ( ZERO = 0.0D0, ONE = 1.0D0 ) - INTEGER MAXCYC - PARAMETER ( MAXCYC = 100 ) -C .. Scalar Arguments .. - INTEGER INFO, IWARN, L, LDR, LDU, LDWORK, LDY, M, NOBR, - $ NSMP - CHARACTER BATCH, CONCT, METH -C .. Array Arguments .. - INTEGER IWORK(*) - DOUBLE PRECISION DWORK(*), R(LDR, *), U(LDU, *), Y(LDY, *) -C .. Local Scalars .. - DOUBLE PRECISION BETA, CS, SN, UPD, TAU - INTEGER I, ICJ, ICOL, ICONN, ICYCLE, IERR, IMAX, ING, - $ INGC, INGP, IPG, IPGC, IPY, IREV, ITAU, J, JD, - $ JDS, JWORK, K, LDRWRK, LLNOBR, LNOBR, LNRG, - $ MAXWRK, MINWRK, MMNOBR, MNOBR, MNRG, NOBR2, - $ NOBR21, NR, NRG, NS, NSM, NSMPSM - LOGICAL CONNEC, FIRST, INTERM, LAST, MOESP, N4SID, - $ ONEBCH -C .. Local Arrays .. - DOUBLE PRECISION DUM(1) -C .. External Functions .. - LOGICAL LSAME - INTEGER IDAMAX - EXTERNAL IDAMAX, LSAME -C .. External Subroutines .. - EXTERNAL DCOPY, DGEMM, DGEQRF, DLACPY, DLARF, DLARFG, - $ DLASET, DORMQR, DSCAL, DSWAP, DSYRK, MA02ED, - $ MA02FD, MB04ID, MB04OD, XERBLA -C .. Intrinsic Functions .. - INTRINSIC ABS, INT, MAX, SQRT -C .. Save Statement .. -C ICYCLE is used to count the cycles for BATCH = 'I'. -C MAXWRK is used to store the optimal workspace. -C NSMPSM is used to sum up the NSMP values for BATCH <> 'O'. - SAVE ICYCLE, MAXWRK, NSMPSM -C .. -C .. Executable Statements .. -C -C Decode the scalar input parameters. -C - MOESP = LSAME( METH, 'M' ) - N4SID = LSAME( METH, 'N' ) - ONEBCH = LSAME( BATCH, 'O' ) - FIRST = LSAME( BATCH, 'F' ) .OR. ONEBCH - INTERM = LSAME( BATCH, 'I' ) - LAST = LSAME( BATCH, 'L' ) .OR. ONEBCH - IF( .NOT.ONEBCH ) THEN - CONNEC = LSAME( CONCT, 'C' ) - ELSE - CONNEC = .FALSE. - END IF - MNOBR = M*NOBR - LNOBR = L*NOBR - MMNOBR = MNOBR + MNOBR - LLNOBR = LNOBR + LNOBR - NOBR2 = 2*NOBR - NOBR21 = NOBR2 - 1 - IWARN = 0 - INFO = 0 - IF( FIRST ) THEN - ICYCLE = 1 - MAXWRK = 1 - NSMPSM = 0 - END IF - NSMPSM = NSMPSM + NSMP - NR = MMNOBR + LLNOBR -C -C Check the scalar input parameters. -C - IF( .NOT.( MOESP .OR. N4SID ) ) THEN - INFO = -1 - ELSE IF( .NOT.( FIRST .OR. INTERM .OR. LAST ) ) THEN - INFO = -2 - ELSE IF( .NOT. ONEBCH ) THEN - IF( .NOT.( CONNEC .OR. LSAME( CONCT, 'N' ) ) ) - $ INFO = -3 - END IF - IF( INFO.EQ.0 ) THEN - IF( NOBR.LE.0 ) THEN - INFO = -4 - ELSE IF( M.LT.0 ) THEN - INFO = -5 - ELSE IF( L.LE.0 ) THEN - INFO = -6 - ELSE IF( NSMP.LT.NOBR2 .OR. - $ ( LAST .AND. NSMPSM.LT.NR+NOBR21 ) ) THEN - INFO = -7 - ELSE IF( LDU.LT.1 .OR. ( M.GT.0 .AND. LDU.LT.NSMP ) ) THEN - INFO = -9 - ELSE IF( LDY.LT.NSMP ) THEN - INFO = -11 - ELSE IF( LDR.LT.NR ) THEN - INFO = -13 - ELSE -C -C Compute workspace. -C NRG is the number of positive (or negative) generators. -C - NRG = M + L + 1 - IF ( .NOT.ONEBCH .AND. CONNEC ) THEN - MINWRK = NR*( NRG + 2 ) - ELSE IF ( FIRST .OR. INTERM ) THEN - MINWRK = NR*NRG - ELSE - MINWRK = 2*NR*NRG + NR - END IF - MAXWRK = MAX( MINWRK, MAXWRK ) -C - IF( LDWORK.LT.MINWRK ) - $ INFO = -16 - END IF - END IF -C -C Return if there are illegal arguments. -C - IF( INFO.NE.0 ) THEN - NSMPSM = 0 - IF ( INFO.EQ.-16 ) - $ DWORK( 1 ) = MINWRK - CALL XERBLA( 'IB01MY', -INFO ) - RETURN - END IF -C -C Compute the R factor from a fast QR factorization of the -C matrix H, a concatenation of two block Hankel matrices. -C Specifically, a displacement rank technique is applied to -C the block Toeplitz matrix, G = (P*H)'*(P*H), where P is a -C 2-by-2 block diagonal matrix, having as diagonal blocks identity -C matrices with columns taken in the reverse order. -C The technique builds and processes the generators of G. The -C matrices G and G1 = H'*H have the same R factor. -C -C Set the parameters for constructing the correlations of the -C current block. -C NSM is the number of processed samples in U and Y, t - 2s. -C IPG and ING are pointers to the "positive" and "negative" -C generators, stored row-wise in the workspace. All "positive" -C generators are stored before any "negative" generators. -C If BATCH <> 'O' and CONCT = 'C', the "connection" elements of -C two successive batches are stored in the same workspace as the -C "negative" generators (which will be computed later on). -C IPY is a pointer to the Y part of the "positive" generators. -C LDRWRK is used as a leading dimension for the workspace part used -C to store the "connection" elements. -C - NS = NSMP - NOBR21 - NSM = NS - 1 - MNRG = M*NRG - LNRG = L*NRG -C - LDRWRK = 2*NOBR2 - IF( FIRST ) THEN - UPD = ZERO - ELSE - UPD = ONE - END IF - DUM(1) = ZERO -C - IPG = 1 - IPY = IPG + M - ING = IPG + NRG*NR - ICONN = ING -C - IF( .NOT.FIRST .AND. CONNEC ) THEN -C -C Restore the saved (M+L)*2*NOBR "connection" elements of -C U and Y into their appropriate position in sequential -C processing. The process is performed column-wise, in -C reverse order, first for Y and then for U. -C ICONN is a pointer to the first saved "connection" element. -C Workspace: need (M+L)*2*NOBR*(M+L+3). -C - IREV = ICONN + NR - ICOL = ICONN + 2*NR -C - DO 10 I = 2, M + L - IREV = IREV - NOBR2 - ICOL = ICOL - LDRWRK - CALL DCOPY( NOBR2, DWORK(IREV), 1, DWORK(ICOL), 1 ) - 10 CONTINUE -C - IF ( M.GT.0 ) - $ CALL DLACPY( 'Full', NOBR2, M, U, LDU, DWORK(ICONN+NOBR2), - $ LDRWRK ) - CALL DLACPY( 'Full', NOBR2, L, Y, LDY, - $ DWORK(ICONN+LDRWRK*M+NOBR2), LDRWRK ) - END IF -C - IF ( M.GT.0 ) THEN -C -C Let Guu(i,j) = Guu0(i,j) + u_i*u_j' + u_(i+1)*u_(j+1)' + -C ... + u_(i+NSM-1)*u_(j+NSM-1)', -C where u_i' is the i-th row of U, j = 1 : 2s, i = 1 : j, -C NSM = NSMP - 2s, and Guu0(i,j) is a zero matrix for -C BATCH = 'O' or 'F', and it is the matrix Guu(i,j) computed -C till the current block for BATCH = 'I' or 'L'. The matrix -C Guu(i,j) is m-by-m, and Guu(j,j) is symmetric. The -C submatrices of the first block-row, Guu(1,j), are needed only. -C -C Compute/update Guu(1,1). -C - IF( .NOT.FIRST .AND. CONNEC ) - $ CALL DSYRK( 'Upper', 'Transpose', M, NOBR2, ONE, - $ DWORK(ICONN), LDRWRK, UPD, DWORK(IPG), NRG ) - CALL DSYRK( 'Upper', 'Transpose', M, NSM, ONE, U, LDU, UPD, - $ DWORK(IPG), NRG ) - CALL MA02ED( 'Upper', M, DWORK(IPG), NRG ) -C - JD = 1 -C - IF( FIRST .OR. .NOT.CONNEC ) THEN -C - DO 20 J = 2, NOBR2 - JD = JD + M -C -C Compute/update Guu(1,j). -C - CALL DGEMM( 'Transpose', 'NoTranspose', M, M, NSM, ONE, - $ U, LDU, U(J,1), LDU, UPD, - $ DWORK(IPG+(JD-1)*NRG), NRG ) - 20 CONTINUE -C - ELSE -C - DO 30 J = 2, NOBR2 - JD = JD + M -C -C Compute/update Guu(1,j) for sequential processing -C with connected blocks. -C - CALL DGEMM( 'Transpose', 'NoTranspose', M, M, NOBR2, - $ ONE, DWORK(ICONN), LDRWRK, DWORK(ICONN+J-1), - $ LDRWRK, UPD, DWORK(IPG+(JD-1)*NRG), NRG ) - CALL DGEMM( 'Transpose', 'NoTranspose', M, M, NSM, ONE, - $ U, LDU, U(J,1), LDU, ONE, - $ DWORK(IPG+(JD-1)*NRG), NRG ) - 30 CONTINUE -C - END IF -C -C Let Guy(i,j) = Guy0(i,j) + u_i*y_j' + u_(i+1)*y_(j+1)' + -C ... + u_(i+NSM-1)*y_(j+NSM-1)', -C where u_i' is the i-th row of U, y_j' is the j-th row -C of Y, j = 1 : 2s, i = 1 : 2s, NSM = NSMP - 2s, and -C Guy0(i,j) is a zero matrix for BATCH = 'O' or 'F', and it -C is the matrix Guy(i,j) computed till the current block for -C BATCH = 'I' or 'L'. Guy(i,j) is m-by-L. The submatrices -C of the first block-row, Guy(1,j), as well as the transposes -C of the submatrices of the first block-column, i.e., Gyu(1,j), -C are needed only. -C - JD = MMNOBR + 1 -C - IF( FIRST .OR. .NOT.CONNEC ) THEN -C - DO 40 J = 1, NOBR2 -C -C Compute/update Guy(1,j). -C - CALL DGEMM( 'Transpose', 'NoTranspose', M, L, NSM, ONE, - $ U, LDU, Y(J,1), LDY, UPD, - $ DWORK(IPG+(JD-1)*NRG), NRG ) - JD = JD + L - 40 CONTINUE -C - ELSE -C - DO 50 J = 1, NOBR2 -C -C Compute/update Guy(1,j) for sequential processing -C with connected blocks. -C - CALL DGEMM( 'Transpose', 'NoTranspose', M, L, NOBR2, - $ ONE, DWORK(ICONN), LDRWRK, - $ DWORK(ICONN+LDRWRK*M+J-1), LDRWRK, UPD, - $ DWORK(IPG+(JD-1)*NRG), NRG ) - CALL DGEMM( 'Transpose', 'NoTranspose', M, L, NSM, ONE, - $ U, LDU, Y(J,1), LDY, ONE, - $ DWORK(IPG+(JD-1)*NRG), NRG ) - JD = JD + L - 50 CONTINUE -C - END IF -C -C Now, the first M "positive" generators have been built. -C Transpose Guy(1,1) in the first block of the Y part of the -C "positive" generators. -C - DO 60 J = 1, L - CALL DCOPY( M, DWORK(IPG+(MMNOBR+J-1)*NRG), 1, - $ DWORK(IPY+J-1), NRG ) - 60 CONTINUE -C - JD = 1 -C - IF( FIRST .OR. .NOT.CONNEC ) THEN -C - DO 70 J = 2, NOBR2 - JD = JD + M -C -C Compute/update Gyu(1,j). -C - CALL DGEMM( 'Transpose', 'NoTranspose', L, M, NSM, ONE, - $ Y, LDY, U(J,1), LDU, UPD, - $ DWORK(IPY+(JD-1)*NRG), NRG ) - 70 CONTINUE -C - ELSE -C - DO 80 J = 2, NOBR2 - JD = JD + M -C -C Compute/update Gyu(1,j) for sequential processing -C with connected blocks. -C - CALL DGEMM( 'Transpose', 'NoTranspose', L, M, NOBR2, - $ ONE, DWORK(ICONN+LDRWRK*M), LDRWRK, - $ DWORK(ICONN+J-1), LDRWRK, UPD, - $ DWORK(IPY+(JD-1)*NRG), NRG ) - CALL DGEMM( 'Transpose', 'NoTranspose', L, M, NSM, ONE, - $ Y, LDY, U(J,1), LDU, ONE, - $ DWORK(IPY+(JD-1)*NRG), NRG ) - 80 CONTINUE -C - END IF -C - END IF -C -C Let Gyy(i,j) = Gyy0(i,j) + y_i*y_i' + y_(i+1)*y_(i+1)' + ... + -C y_(i+NSM-1)*y_(i+NSM-1)', -C where y_i' is the i-th row of Y, j = 1 : 2s, i = 1 : j, -C NSM = NSMP - 2s, and Gyy0(i,j) is a zero matrix for -C BATCH = 'O' or 'F', and it is the matrix Gyy(i,j) computed till -C the current block for BATCH = 'I' or 'L'. Gyy(i,j) is L-by-L, -C and Gyy(j,j) is symmetric. The submatrices of the first -C block-row, Gyy(1,j), are needed only. -C - JD = MMNOBR + 1 -C -C Compute/update Gyy(1,1). -C - IF( .NOT.FIRST .AND. CONNEC ) - $ CALL DSYRK( 'Upper', 'Transpose', L, NOBR2, ONE, - $ DWORK(ICONN+LDRWRK*M), LDRWRK, UPD, - $ DWORK(IPY+MMNOBR*NRG), NRG ) - CALL DSYRK( 'Upper', 'Transpose', L, NSM, ONE, Y, LDY, UPD, - $ DWORK(IPY+MMNOBR*NRG), NRG ) - CALL MA02ED( 'Upper', L, DWORK(IPY+MMNOBR*NRG), NRG ) -C - IF( FIRST .OR. .NOT.CONNEC ) THEN -C - DO 90 J = 2, NOBR2 - JD = JD + L -C -C Compute/update Gyy(1,j). -C - CALL DGEMM( 'Transpose', 'NoTranspose', L, L, NSM, ONE, Y, - $ LDY, Y(J,1), LDY, UPD, DWORK(IPY+(JD-1)*NRG), - $ NRG ) - 90 CONTINUE -C - ELSE -C - DO 100 J = 2, NOBR2 - JD = JD + L -C -C Compute/update Gyy(1,j) for sequential processing with -C connected blocks. -C - CALL DGEMM( 'Transpose', 'NoTranspose', L, L, NOBR2, ONE, - $ DWORK(ICONN+LDRWRK*M), LDRWRK, - $ DWORK(ICONN+LDRWRK*M+J-1), LDRWRK, UPD, - $ DWORK(IPY+(JD-1)*NRG), NRG ) - CALL DGEMM( 'Transpose', 'NoTranspose', L, L, NSM, ONE, Y, - $ LDY, Y(J,1), LDY, ONE, DWORK(IPY+(JD-1)*NRG), - $ NRG ) - 100 CONTINUE -C - END IF -C - IF ( .NOT.LAST ) THEN - IF ( FIRST ) THEN -C -C For sequential processing, save the first 2*NOBR-1 rows of -C the first block of U and Y in the appropriate -C (M+L)*(2*NOBR-1) locations of DWORK starting at (1+M)*NRG. -C These will be used to construct the last negative generator. -C - JD = NRG - IF ( M.GT.0 ) THEN - CALL DCOPY( M, DUM, 0, DWORK(JD), NRG ) -C - DO 110 J = 1, NOBR21 - JD = JD + MNRG - CALL DCOPY( M, U(J,1), LDU, DWORK(JD), NRG ) - 110 CONTINUE -C - JD = JD + MNRG - END IF - CALL DCOPY( L, DUM, 0, DWORK(JD), NRG ) -C - DO 120 J = 1, NOBR21 - JD = JD + LNRG - CALL DCOPY( L, Y(J,1), LDY, DWORK(JD), NRG ) - 120 CONTINUE -C - END IF -C - IF ( CONNEC ) THEN -C -C For sequential processing with connected data blocks, -C save the remaining ("connection") elements of U and Y -C in (M+L)*2*NOBR locations of DWORK starting at ICONN. -C - IF ( M.GT.0 ) - $ CALL DLACPY( 'Full', NOBR2, M, U(NS,1), LDU, - $ DWORK(ICONN), NOBR2 ) - CALL DLACPY( 'Full', NOBR2, L, Y(NS,1), LDY, - $ DWORK(ICONN+MMNOBR), NOBR2 ) - END IF -C -C Return to get new data. -C - ICYCLE = ICYCLE + 1 - IF ( ICYCLE.GT.MAXCYC ) - $ IWARN = 1 - RETURN - END IF -C - IF ( LAST ) THEN -C -C Try to compute the R factor. -C -C Scale the first M+L positive generators and set the first -C M+L negative generators. -C Workspace: need (M+L)*4*NOBR*(M+L+1)+M+L. -C - JWORK = NRG*2*NR + 1 - CALL DCOPY( M, DWORK(IPG), NRG+1, DWORK(JWORK), 1 ) - CALL DCOPY( L, DWORK(IPY+MMNOBR*NRG), NRG+1, DWORK(JWORK+M), - $ 1 ) -C - DO 130 I = 1, M + L - IWORK(I) = IDAMAX( M+L, DWORK(JWORK), 1 ) - DWORK(JWORK+IWORK(I)-1) = ZERO - 130 CONTINUE -C - DO 150 I = 1, M + L - IMAX = IWORK(I) - IF ( IMAX.LE.M ) THEN - ICOL = IMAX - ELSE - ICOL = MMNOBR - M + IMAX - END IF - BETA = SQRT( ABS( DWORK(IPG+IMAX-1+(ICOL-1)*NRG) ) ) - IF ( BETA.EQ.ZERO ) THEN -C -C Error exit. -C - INFO = 1 - RETURN - END IF - CALL DSCAL( NR, ONE / BETA, DWORK(IPG+IMAX-1), NRG ) - CALL DCOPY( NR, DWORK(IPG+IMAX-1), NRG, DWORK(ING+IMAX-1), - $ NRG ) - DWORK(IPG+IMAX-1+(ICOL-1)*NRG) = BETA - DWORK(ING+IMAX-1+(ICOL-1)*NRG) = ZERO -C - DO 140 J = I + 1, M + L - DWORK(IPG+IWORK(J)-1+(ICOL-1)*NRG) = ZERO - 140 CONTINUE -C - 150 CONTINUE -C -C Compute the last two generators. -C - IF ( .NOT.FIRST ) THEN -C -C For sequential processing, move the stored last negative -C generator. -C - CALL DCOPY( NR, DWORK(NRG), NRG, DWORK(ING+NRG-1), NRG ) - END IF -C - JD = NRG - IF ( M.GT.0 ) THEN -C - DO 160 J = NS, NSMP - CALL DCOPY( M, U(J,1), LDU, DWORK(JD), NRG ) - JD = JD + MNRG - 160 CONTINUE -C - END IF -C - DO 170 J = NS, NSMP - CALL DCOPY( L, Y(J,1), LDY, DWORK(JD), NRG ) - JD = JD + LNRG - 170 CONTINUE -C - IF ( FIRST ) THEN - IF ( M.GT.0 ) THEN - CALL DCOPY( M, DUM, 0, DWORK(JD), NRG ) -C - DO 180 J = 1, NOBR21 - JD = JD + MNRG - CALL DCOPY( M, U(J,1), LDU, DWORK(JD), NRG ) - 180 CONTINUE -C - JD = JD + MNRG - END IF - CALL DCOPY( L, DUM, 0, DWORK(JD), NRG ) -C - DO 190 J = 1, NOBR21 - JD = JD + LNRG - CALL DCOPY( L, Y(J,1), LDY, DWORK(JD), NRG ) - 190 CONTINUE -C - END IF -C - ITAU = JWORK - IPGC = IPG + MMNOBR*NRG -C - IF ( M.GT.0 ) THEN -C -C Process the input part of the generators. -C - JWORK = ITAU + M -C -C Reduce the first M columns of the matrix G1 of positive -C generators to an upper triangular form. -C Workspace: need (M+L)*4*NOBR*(M+L+1)+2*M; -C prefer (M+L)*4*NOBR*(M+L+1)+M+M*NB. -C - INGC = ING - CALL DGEQRF( NRG, M, DWORK(IPG), NRG, DWORK(ITAU), - $ DWORK(JWORK), LDWORK-JWORK+1, IERR ) - MAXWRK = MAX( MAXWRK, INT( DWORK(JWORK) ) + JWORK - 1 ) -C -C Workspace: need (M+L)*4*NOBR*(M+L+1)+(M+L)*2*NOBR; -C prefer (M+L)*4*NOBR*(M+L+1)+M+ -C ((M+L)*2*NOBR-M)*NB. -C - CALL DORMQR( 'Left', 'Transpose', NRG, NR-M, M, DWORK(IPG), - $ NRG, DWORK(ITAU), DWORK(IPG+MNRG), NRG, - $ DWORK(JWORK), LDWORK-JWORK+1, IERR ) - MAXWRK = MAX( MAXWRK, INT( DWORK(JWORK) ) + JWORK - 1 ) -C -C Annihilate, column by column, the first M columns of the -C matrix G2 of negative generators, using Householder -C transformations and modified hyperbolic plane rotations. -C In the DLARF calls, ITAU is a pointer to the workspace -C array. -C - DO 210 J = 1, M - CALL DLARFG( NRG, DWORK(INGC), DWORK(INGC+1), 1, TAU ) - BETA = DWORK(INGC) - DWORK(INGC) = ONE - INGP = INGC + NRG - CALL DLARF( 'Left', NRG, NR-J, DWORK(INGC), 1, TAU, - $ DWORK(INGP), NRG, DWORK(ITAU) ) - DWORK(INGC) = BETA -C -C Compute the coefficients of the modified hyperbolic -C rotation. -C - CALL MA02FD( DWORK(IPG+(J-1)*(NRG+1)), DWORK(INGC), CS, - $ SN, IERR ) - IF( IERR.NE.0 ) THEN -C -C Error return: the matrix H'*H is not (numerically) -C positive definite. -C - INFO = 1 - RETURN - END IF -C - DO 200 I = J*NRG, ( NR - 1 )*NRG, NRG - DWORK(IPG+J-1+I) = ( DWORK(IPG+J-1+I) - - $ SN * DWORK(ING+I) ) / CS - DWORK(ING+I) = -SN * DWORK(IPG+J-1+I) + - $ CS * DWORK(ING+I) - 200 CONTINUE -C - INGC = INGP - 210 CONTINUE -C -C Save one block row of R, and shift the generators for the -C calculation of the following row. -C - CALL DLACPY( 'Upper', M, NR, DWORK(IPG), NRG, R, LDR ) -C - DO 220 I = ( MMNOBR - M )*NRG, MNRG, -MNRG - CALL DLACPY( 'Full', M, M, DWORK(IPG+I-MNRG), NRG, - $ DWORK(IPG+I), NRG ) - 220 CONTINUE -C - DO 230 I = ( NR - L )*NRG, ( MMNOBR + L )*NRG, -LNRG - CALL DLACPY( 'Full', M, L, DWORK(IPG+I-LNRG), NRG, - $ DWORK(IPG+I), NRG ) - 230 CONTINUE -C - CALL DLASET( 'Full', M, L, ZERO, ZERO, DWORK(IPGC), NRG ) -C -C Update the input part of generators using Schur algorithm. -C Workspace: need (M+L)*4*NOBR*(M+L+1)+2*NOBR*(M+L)-M. -C - JDS = MNRG - ICOL = M -C - DO 280 K = 2, NOBR2 - CALL MB04OD( 'Full', M, NR-ICOL-M, L+1, DWORK(IPG+JDS), - $ NRG, DWORK(IPY+JDS), NRG, - $ DWORK(IPG+JDS+MNRG), NRG, - $ DWORK(IPY+JDS+MNRG), NRG, DWORK(ITAU), - $ DWORK(JWORK) ) -C - DO 250 J = 1, M - ICJ = ICOL + J - CALL DLARFG( NRG, DWORK(INGC), DWORK(INGC+1), 1, TAU ) - BETA = DWORK(INGC) - DWORK(INGC) = ONE - INGP = INGC + NRG - CALL DLARF( 'Left', NRG, NR-ICJ, DWORK(INGC), 1, TAU, - $ DWORK(INGP), NRG, DWORK(ITAU) ) - DWORK(INGC) = BETA -C -C Compute the coefficients of the modified hyperbolic -C rotation. -C - CALL MA02FD( DWORK(IPG+J-1+(ICJ-1)*NRG), DWORK(INGC), - $ CS, SN, IERR ) - IF( IERR.NE.0 ) THEN -C -C Error return: the matrix H'*H is not (numerically) -C positive definite. -C - INFO = 1 - RETURN - END IF -C - DO 240 I = ICJ*NRG, ( NR - 1 )*NRG, NRG - DWORK(IPG+J-1+I) = ( DWORK(IPG+J-1+I) - - $ SN * DWORK(ING+I) ) / CS - DWORK(ING+I) = -SN * DWORK(IPG+J-1+I) + - $ CS * DWORK(ING+I) - 240 CONTINUE -C - INGC = INGP - 250 CONTINUE -C -C Save one block row of R, and shift the generators for the -C calculation of the following row. -C - CALL DLACPY( 'Upper', M, NR-ICOL, DWORK(IPG+JDS), NRG, - $ R(ICOL+1,ICOL+1), LDR ) - ICOL = ICOL + M -C - DO 260 I = ( MMNOBR - M )*NRG, ICOL*NRG, -MNRG - CALL DLACPY( 'Full', M, M, DWORK(IPG+I-MNRG), NRG, - $ DWORK(IPG+I), NRG ) - 260 CONTINUE -C - DO 270 I = ( NR - L )*NRG, ( MMNOBR + L )*NRG, -LNRG - CALL DLACPY( 'Full', M, L, DWORK(IPG+I-LNRG), NRG, - $ DWORK(IPG+I), NRG ) - 270 CONTINUE -C - CALL DLASET( 'Full', M, L, ZERO, ZERO, DWORK(IPGC), NRG ) - JDS = JDS + MNRG - 280 CONTINUE -C - END IF -C -C Process the output part of the generators. -C - JWORK = ITAU + L -C -C Reduce the first L columns of the submatrix -C G1(1:M+L+1,2*M*NOBR+1:2*(M+L)*NOBR) to upper triangular form. -C Workspace: need (M+L)*4*NOBR*(M+L+1)+2*L; -C prefer (M+L)*4*NOBR*(M+L+1)+L+L*NB. -C - INGC = ING + MMNOBR*NRG - CALL DGEQRF( NRG, L, DWORK(IPGC), NRG, DWORK(ITAU), - $ DWORK(JWORK), LDWORK-JWORK+1, IERR ) - MAXWRK = MAX( MAXWRK, INT( DWORK(JWORK) ) + JWORK - 1 ) -C -C Workspace: need (M+L)*4*NOBR*(M+L+1)+L*2*NOBR; -C prefer (M+L)*4*NOBR*(M+L+1)+L+(L*2*NOBR-L)*NB. -C - CALL DORMQR( 'Left', 'Transpose', NRG, LLNOBR-L, L, - $ DWORK(IPGC), NRG, DWORK(ITAU), DWORK(IPGC+LNRG), - $ NRG, DWORK(JWORK), LDWORK-JWORK+1, IERR ) - MAXWRK = MAX( MAXWRK, INT( DWORK(JWORK) ) + JWORK - 1 ) -C -C Annihilate, column by column, the first L columns of the -C output part of the matrix G2 of negative generators, using -C Householder transformations and modified hyperbolic rotations. -C - DO 300 J = 1, L - CALL DLARFG( NRG, DWORK(INGC), DWORK(INGC+1), 1, TAU ) - BETA = DWORK(INGC) - DWORK(INGC) = ONE - INGP = INGC + NRG - CALL DLARF( 'Left', NRG, LLNOBR-J, DWORK(INGC), 1, TAU, - $ DWORK(INGP), NRG, DWORK(ITAU) ) - DWORK(INGC) = BETA -C -C Compute the coefficients of the modified hyperbolic -C rotation. -C - CALL MA02FD( DWORK(IPGC+(J-1)*(NRG+1)), DWORK(INGC), CS, SN, - $ IERR ) - IF( IERR.NE.0 ) THEN -C -C Error return: the matrix H'*H is not (numerically) -C positive definite. -C - INFO = 1 - RETURN - END IF -C - DO 290 I = ( J + MMNOBR )*NRG, ( NR - 1 )*NRG, NRG - DWORK(IPG+J-1+I) = ( DWORK(IPG+J-1+I) - - $ SN * DWORK(ING+I) ) / CS - DWORK(ING+I) = -SN * DWORK(IPG+J-1+I) + - $ CS * DWORK(ING+I) - 290 CONTINUE -C - INGC = INGP - 300 CONTINUE -C -C Save one block row of R, and shift the generators for the -C calculation of the following row. -C - CALL DLACPY( 'Upper', L, LLNOBR, DWORK(IPGC), NRG, - $ R(MMNOBR+1,MMNOBR+1), LDR ) -C - DO 310 I = ( NR - L )*NRG, ( MMNOBR + L )*NRG, -LNRG - CALL DLACPY( 'Full', L, L, DWORK(IPG+I-LNRG), NRG, - $ DWORK(IPG+I), NRG ) - 310 CONTINUE -C -C Update the output part of generators using the Schur algorithm. -C Workspace: need (M+L)*4*NOBR*(M+L+1)+2*NOBR*L-L. -C - JDS = LNRG - ICOL = L -C - DO 350 K = 2, NOBR2 - CALL MB04OD( 'Full', L, LLNOBR-ICOL-L, M+1, DWORK(IPGC+JDS), - $ NRG, DWORK(IPGC+L+JDS), NRG, - $ DWORK(IPGC+JDS+LNRG), NRG, - $ DWORK(IPGC+L+JDS+LNRG), NRG, DWORK(ITAU), - $ DWORK(JWORK) ) -C - DO 330 J = 1, L - ICJ = ICOL + J - CALL DLARFG( NRG, DWORK(INGC), DWORK(INGC+1), 1, TAU ) - BETA = DWORK(INGC) - DWORK(INGC) = ONE - INGP = INGC + NRG - CALL DLARF( 'Left', NRG, LLNOBR-ICJ, DWORK(INGC), 1, - $ TAU, DWORK(INGP), NRG, DWORK(ITAU) ) - DWORK(INGC) = BETA -C -C Compute the coefficients of the modified hyperbolic -C rotation. -C - CALL MA02FD( DWORK(IPGC+J-1+(ICJ-1)*NRG), DWORK(INGC), - $ CS, SN, IERR ) - IF( IERR.NE.0 ) THEN -C -C Error return: the matrix H'*H is not (numerically) -C positive definite. -C - INFO = 1 - RETURN - END IF -C - DO 320 I = ( ICJ + MMNOBR )*NRG, ( NR - 1 )*NRG, NRG - DWORK(IPG+J-1+I) = ( DWORK(IPG+J-1+I) - - $ SN * DWORK(ING+I) ) / CS - DWORK(ING+I) = -SN * DWORK(IPG+J-1+I) + - $ CS * DWORK(ING+I) - 320 CONTINUE -C - INGC = INGP - 330 CONTINUE -C -C Save one block row of R, and shift the generators for the -C calculation of the following row. -C - CALL DLACPY( 'Upper', L, LLNOBR-ICOL, DWORK(IPGC+JDS), NRG, - $ R(MMNOBR+ICOL+1,MMNOBR+ICOL+1), LDR ) -C - DO 340 I = ( NR - L )*NRG, ( MMNOBR + ICOL )*NRG, -LNRG - CALL DLACPY( 'Full', L, L, DWORK(IPG+I-LNRG), NRG, - $ DWORK(IPG+I), NRG ) - 340 CONTINUE -C - ICOL = ICOL + L - JDS = JDS + LNRG - 350 CONTINUE -C - IF ( MOESP .AND. M.GT.0 ) THEN -C -C For the MOESP algorithm, interchange the past and future -C input parts of the R factor, and compute the new R factor -C using a specialized QR factorization. A tailored fast -C QR factorization for the MOESP algorithm could be slightly -C more efficient. -C - DO 360 J = 1, MNOBR - CALL DSWAP( J, R(1,J), 1, R(1,MNOBR+J), 1 ) - CALL DCOPY( MNOBR, R(J+1,MNOBR+J), 1, R(J+1,J), 1 ) - CALL DCOPY( MMNOBR-J, DUM, 0, R(J+1,MNOBR+J), 1 ) - 360 CONTINUE -C -C Triangularize the first two block columns (using structure), -C and apply the transformation to the corresponding part of -C the remaining block columns. -C Workspace: need 2*(M+L)*NOBR. -C - ITAU = 1 - JWORK = ITAU + MMNOBR - CALL MB04ID( MMNOBR, MMNOBR, MNOBR-1, LLNOBR, R, LDR, - $ R(1,MMNOBR+1), LDR, DWORK(ITAU), - $ DWORK(JWORK), LDWORK-JWORK+1, IERR ) - MAXWRK = MAX( MAXWRK, INT( DWORK(JWORK) ) + JWORK - 1 ) - END IF - END IF -C - NSMPSM = 0 - ICYCLE = 1 -C -C Return optimal workspace in DWORK(1). -C - DWORK( 1 ) = MAXWRK - MAXWRK = 1 - RETURN -C -C *** Last line of IB01MY *** - END diff --git a/mex/sources/libslicot/IB01ND.f b/mex/sources/libslicot/IB01ND.f deleted file mode 100644 index ad315b4cd..000000000 --- a/mex/sources/libslicot/IB01ND.f +++ /dev/null @@ -1,731 +0,0 @@ - SUBROUTINE IB01ND( METH, JOBD, NOBR, M, L, R, LDR, SV, TOL, IWORK, - $ DWORK, LDWORK, IWARN, INFO ) -C -C SLICOT RELEASE 5.0. -C -C Copyright (c) 2002-2009 NICONET e.V. -C -C This program is free software: you can redistribute it and/or -C modify it under the terms of the GNU General Public License as -C published by the Free Software Foundation, either version 2 of -C the License, or (at your option) any later version. -C -C This program is distributed in the hope that it will be useful, -C but WITHOUT ANY WARRANTY; without even the implied warranty of -C MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the -C GNU General Public License for more details. -C -C You should have received a copy of the GNU General Public License -C along with this program. If not, see -C . -C -C PURPOSE -C -C To find the singular value decomposition (SVD) giving the system -C order, using the triangular factor of the concatenated block -C Hankel matrices. Related preliminary calculations needed for -C computing the system matrices are also performed. -C -C ARGUMENTS -C -C Mode Parameters -C -C METH CHARACTER*1 -C Specifies the subspace identification method to be used, -C as follows: -C = 'M': MOESP algorithm with past inputs and outputs; -C = 'N': N4SID algorithm. -C -C JOBD CHARACTER*1 -C Specifies whether or not the matrices B and D should later -C be computed using the MOESP approach, as follows: -C = 'M': the matrices B and D should later be computed -C using the MOESP approach; -C = 'N': the matrices B and D should not be computed using -C the MOESP approach. -C This parameter is not relevant for METH = 'N'. -C -C Input/Output Parameters -C -C NOBR (input) INTEGER -C The number of block rows, s, in the input and output -C block Hankel matrices. NOBR > 0. -C -C M (input) INTEGER -C The number of system inputs. M >= 0. -C -C L (input) INTEGER -C The number of system outputs. L > 0. -C -C R (input/output) DOUBLE PRECISION array, dimension -C ( LDR,2*(M+L)*NOBR ) -C On entry, the leading 2*(M+L)*NOBR-by-2*(M+L)*NOBR upper -C triangular part of this array must contain the upper -C triangular factor R from the QR factorization of the -C concatenated block Hankel matrices. Denote R_ij, -C i,j = 1:4, the ij submatrix of R, partitioned by -C M*NOBR, M*NOBR, L*NOBR, and L*NOBR rows and columns. -C On exit, if INFO = 0, the leading -C 2*(M+L)*NOBR-by-2*(M+L)*NOBR upper triangular part of this -C array contains the matrix S, the processed upper -C triangular factor R, as required by other subroutines. -C Specifically, let S_ij, i,j = 1:4, be the ij submatrix -C of S, partitioned by M*NOBR, L*NOBR, M*NOBR, and -C L*NOBR rows and columns. The submatrix S_22 contains -C the matrix of left singular vectors needed subsequently. -C Useful information is stored in S_11 and in the -C block-column S_14 : S_44. For METH = 'M' and JOBD = 'M', -C the upper triangular part of S_31 contains the upper -C triangular factor in the QR factorization of the matrix -C R_1c = [ R_12' R_22' R_11' ]', and S_12 contains the -C corresponding leading part of the transformed matrix -C R_2c = [ R_13' R_23' R_14' ]'. For METH = 'N', the -C subarray S_41 : S_43 contains the transpose of the -C matrix contained in S_14 : S_34. -C -C LDR INTEGER -C The leading dimension of the array R. -C LDR >= MAX( 2*(M+L)*NOBR, 3*M*NOBR ), -C for METH = 'M' and JOBD = 'M'; -C LDR >= 2*(M+L)*NOBR, for METH = 'M' and JOBD = 'N' or -C for METH = 'N'. -C -C SV (output) DOUBLE PRECISION array, dimension ( L*NOBR ) -C The singular values of the relevant part of the triangular -C factor from the QR factorization of the concatenated block -C Hankel matrices. -C -C Tolerances -C -C TOL DOUBLE PRECISION -C The tolerance to be used for estimating the rank of -C matrices. If the user sets TOL > 0, then the given value -C of TOL is used as a lower bound for the reciprocal -C condition number; an m-by-n matrix whose estimated -C condition number is less than 1/TOL is considered to -C be of full rank. If the user sets TOL <= 0, then an -C implicitly computed, default tolerance, defined by -C TOLDEF = m*n*EPS, is used instead, where EPS is the -C relative machine precision (see LAPACK Library routine -C DLAMCH). -C This parameter is not used for METH = 'M'. -C -C Workspace -C -C IWORK INTEGER array, dimension ((M+L)*NOBR) -C This parameter is not referenced for METH = 'M'. -C -C DWORK DOUBLE PRECISION array, dimension (LDWORK) -C On exit, if INFO = 0, DWORK(1) returns the optimal value -C of LDWORK, and, for METH = 'N', DWORK(2) and DWORK(3) -C contain the reciprocal condition numbers of the -C triangular factors of the matrices U_f and r_1 [6]. -C On exit, if INFO = -12, DWORK(1) returns the minimum -C value of LDWORK. -C -C LDWORK INTEGER -C The length of the array DWORK. -C LDWORK >= max( (2*M-1)*NOBR, (M+L)*NOBR, 5*L*NOBR ), -C if METH = 'M' and JOBD = 'M'; -C LDWORK >= 5*L*NOBR, if METH = 'M' and JOBD = 'N'; -C LDWORK >= 5*(M+L)*NOBR+1, if METH = 'N'. -C For good performance, LDWORK should be larger. -C -C Warning Indicator -C -C IWARN INTEGER -C = 0: no warning; -C = 4: the least squares problems with coefficient matrix -C U_f, used for computing the weighted oblique -C projection (for METH = 'N'), have a rank-deficient -C coefficient matrix; -C = 5: the least squares problem with coefficient matrix -C r_1 [6], used for computing the weighted oblique -C projection (for METH = 'N'), has a rank-deficient -C coefficient matrix. -C -C Error Indicator -C -C INFO INTEGER -C = 0: successful exit; -C < 0: if INFO = -i, the i-th argument had an illegal -C value; -C = 2: the singular value decomposition (SVD) algorithm did -C not converge. -C -C METHOD -C -C A singular value decomposition (SVD) of a certain matrix is -C computed, which reveals the order n of the system as the number -C of "non-zero" singular values. For the MOESP approach, this matrix -C is [ R_24' R_34' ]' := R(ms+1:(2m+l)s,(2m+l)s+1:2(m+l)s), -C where R is the upper triangular factor R constructed by SLICOT -C Library routine IB01MD. For the N4SID approach, a weighted -C oblique projection is computed from the upper triangular factor R -C and its SVD is then found. -C -C REFERENCES -C -C [1] Verhaegen M., and Dewilde, P. -C Subspace Model Identification. Part 1: The output-error -C state-space model identification class of algorithms. -C Int. J. Control, 56, pp. 1187-1210, 1992. -C -C [2] Verhaegen M. -C Subspace Model Identification. Part 3: Analysis of the -C ordinary output-error state-space model identification -C algorithm. -C Int. J. Control, 58, pp. 555-586, 1993. -C -C [3] Verhaegen M. -C Identification of the deterministic part of MIMO state space -C models given in innovations form from input-output data. -C Automatica, Vol.30, No.1, pp.61-74, 1994. -C -C [4] Van Overschee, P., and De Moor, B. -C N4SID: Subspace Algorithms for the Identification of -C Combined Deterministic-Stochastic Systems. -C Automatica, Vol.30, No.1, pp. 75-93, 1994. -C -C [5] Van Overschee, P., and De Moor, B. -C Subspace Identification for Linear Systems: Theory - -C Implementation - Applications. -C Kluwer Academic Publishers, Boston/London/Dordrecht, 1996. -C -C [6] Sima, V. -C Subspace-based Algorithms for Multivariable System -C Identification. -C Studies in Informatics and Control, 5, pp. 335-344, 1996. -C -C NUMERICAL ASPECTS -C -C The implemented method is numerically stable. -C 3 -C The algorithm requires 0(((m+l)s) ) floating point operations. -C -C CONTRIBUTOR -C -C V. Sima, Research Institute for Informatics, Bucharest, Aug. 1999. -C -C REVISIONS -C -C Feb. 2000, Feb. 2001, Feb. 2004, March 2005. -C -C KEYWORDS -C -C Identification methods, multivariable systems, QR decomposition, -C singular value decomposition. -C -C ****************************************************************** -C -C .. Parameters .. - DOUBLE PRECISION ZERO, ONE, TWO, THREE - PARAMETER ( ZERO = 0.0D0, ONE = 1.0D0, TWO = 2.0D0, - $ THREE = 3.0D0 ) -C .. Scalar Arguments .. - DOUBLE PRECISION TOL - INTEGER INFO, IWARN, L, LDR, LDWORK, M, NOBR - CHARACTER JOBD, METH -C .. Array Arguments .. - DOUBLE PRECISION DWORK(*), R(LDR, *), SV(*) - INTEGER IWORK(*) -C .. Local Scalars .. - DOUBLE PRECISION EPS, RCOND1, RCOND2, SVLMAX, THRESH, TOLL - INTEGER I, IERR, ITAU, ITAU2, ITAU3, J, JWORK, LLMNOB, - $ LLNOBR, LMMNOB, LMNOBR, LNOBR, MAXWRK, MINWRK, - $ MMNOBR, MNOBR, NR, NR2, NR3, NR4, NRSAVE, RANK, - $ RANK1 - LOGICAL JOBDM, MOESP, N4SID -C .. Local Arrays .. - DOUBLE PRECISION DUM(1), SVAL(3) -C .. External Functions .. - LOGICAL LSAME - INTEGER ILAENV - DOUBLE PRECISION DLAMCH - EXTERNAL DLAMCH, ILAENV, LSAME -C .. External Subroutines .. - EXTERNAL DCOPY, DGEQRF, DLACPY, DLASET, DORMQR, DSWAP, - $ DTRCON, MA02AD, MB03OD, MB03UD, MB04ID, MB04IY, - $ MB04OD, XERBLA -C .. Intrinsic Functions .. - INTRINSIC INT, MAX -C .. -C .. Executable Statements .. -C -C Decode the scalar input parameters. -C - MOESP = LSAME( METH, 'M' ) - N4SID = LSAME( METH, 'N' ) - JOBDM = LSAME( JOBD, 'M' ) - MNOBR = M*NOBR - LNOBR = L*NOBR - LLNOBR = LNOBR + LNOBR - LMNOBR = LNOBR + MNOBR - MMNOBR = MNOBR + MNOBR - LMMNOB = MMNOBR + LNOBR - NR = LMNOBR + LMNOBR - IWARN = 0 - INFO = 0 -C -C Check the scalar input parameters. -C - IF( .NOT.( MOESP .OR. N4SID ) ) THEN - INFO = -1 - ELSE IF( MOESP .AND. .NOT.( JOBDM .OR. LSAME( JOBD, 'N' ) ) ) THEN - INFO = -2 - ELSE IF( NOBR.LE.0 ) THEN - INFO = -3 - ELSE IF( M.LT.0 ) THEN - INFO = -4 - ELSE IF( L.LE.0 ) THEN - INFO = -5 - ELSE IF( LDR.LT.NR .OR. ( MOESP .AND. JOBDM .AND. - $ LDR.LT.3*MNOBR ) ) THEN - INFO = -7 - ELSE -C -C Compute workspace. -C (Note: Comments in the code beginning "Workspace:" describe the -C minimal amount of workspace needed at that point in the code, -C as well as the preferred amount for good performance. -C NB refers to the optimal block size for the immediately -C following subroutine, as returned by ILAENV.) -C - MINWRK = 1 - IF ( LDWORK.GE.1 ) THEN - IF ( MOESP ) THEN - MINWRK = 5*LNOBR - IF ( JOBDM ) - $ MINWRK = MAX( MMNOBR - NOBR, LMNOBR, MINWRK ) - MAXWRK = LNOBR + LNOBR*ILAENV( 1, 'DGEQRF', ' ', LMNOBR, - $ LNOBR, -1, -1 ) - ELSE -C - MINWRK = MAX( MINWRK, 5*LMNOBR + 1 ) - MAXWRK = MAX( MNOBR + MNOBR*ILAENV( 1, 'DGEQRF', ' ', - $ MMNOBR, MNOBR, -1, -1 ), - $ MNOBR + LLNOBR*ILAENV( 1, 'DORMQR', 'LT', - $ MMNOBR, LLNOBR, MNOBR, -1 ) ) - MAXWRK = MAX( MAXWRK, MNOBR + LNOBR*ILAENV( 1, 'DORMQR', - $ 'LN', MMNOBR, LNOBR, MNOBR, - $ -1 ) ) - MAXWRK = MAX( MAXWRK, LNOBR + LNOBR*ILAENV( 1, 'DGEQRF', - $ ' ', LMMNOB, LNOBR, -1, -1 ) ) - END IF - MAXWRK = MAX( MINWRK, MAXWRK ) - END IF -C - IF( LDWORK.LT.MINWRK ) THEN - INFO = -12 - DWORK( 1 ) = MINWRK - END IF - END IF -C -C Return if there are illegal arguments. -C - IF( INFO.NE.0 ) THEN - CALL XERBLA( 'IB01ND', -INFO ) - RETURN - END IF -C -C Compute pointers to the needed blocks of R. -C - NR2 = MNOBR + 1 - NR3 = MMNOBR + 1 - NR4 = LMMNOB + 1 - ITAU = 1 - JWORK = ITAU + MNOBR -C - IF( MOESP ) THEN -C -C MOESP approach. -C - IF( M.GT.0 .AND. JOBDM ) THEN -C -C Rearrange the blocks of R: -C Copy the (1,1) block into the position (3,2) and -C copy the (1,4) block into (3,3). -C - CALL DLACPY( 'Upper', MNOBR, MNOBR, R, LDR, R(NR3,NR2), - $ LDR ) - CALL DLACPY( 'Full', MNOBR, LNOBR, R(1,NR4), LDR, - $ R(NR3,NR3), LDR ) -C -C Using structure, triangularize the matrix -C R_1c = [ R_12' R_22' R_11' ]' -C and then apply the transformations to the matrix -c R_2c = [ R_13' R_23' R_14' ]'. -C Workspace: need M*NOBR + MAX(M-1,L)*NOBR. -C - CALL MB04OD( 'Upper', MNOBR, LNOBR, MNOBR, R(NR2,NR2), LDR, - $ R(NR3,NR2), LDR, R(NR2,NR3), LDR, R(NR3,NR3), - $ LDR, DWORK(ITAU), DWORK(JWORK) ) - CALL MB04ID( MMNOBR, MNOBR, MNOBR-1, LNOBR, R(1,NR2), LDR, - $ R(1,NR3), LDR, DWORK(ITAU), DWORK(JWORK), - $ LDWORK-JWORK+1, IERR ) - MAXWRK = MAX( MAXWRK, INT( DWORK(JWORK) ) + JWORK - 1 ) -C -C Copy the leading M*NOBR x M*NOBR and M*NOBR x L*NOBR -C submatrices of R_1c and R_2c, respectively, into their -C final positions, required by SLICOT Library routine IB01PD. -C - CALL DLACPY( 'Upper', MNOBR, MNOBR, R(1,NR2), LDR, - $ R(LMNOBR+1,1), LDR ) - CALL DLACPY( 'Full', MNOBR, LNOBR, R(1,NR3), LDR, R(1,NR2), - $ LDR ) - END IF -C -C Copy [ R_24' R_34' ]' in [ R_22' R_32' ]'. -C - CALL DLACPY( 'Full', LMNOBR, LNOBR, R(NR2,NR4), LDR, - $ R(NR2,NR2), LDR ) -C -C Triangularize the matrix in [ R_22' R_32' ]'. -C Workspace: need 2*L*NOBR; prefer L*NOBR + L*NOBR*NB. -C - JWORK = ITAU + LNOBR - CALL DGEQRF( LMNOBR, LNOBR, R(NR2,NR2), LDR, DWORK(ITAU), - $ DWORK(JWORK), LDWORK-JWORK+1, IERR ) -C - ELSE -C -C N4SID approach. -C - DUM(1) = ZERO - LLMNOB = LLNOBR + MNOBR -C -C Set the precision parameters. A threshold value EPS**(2/3) is -C used for deciding to use pivoting or not, where EPS is the -C relative machine precision (see LAPACK Library routine DLAMCH). -C - TOLL = TOL - EPS = DLAMCH( 'Precision' ) - THRESH = EPS**( TWO/THREE ) -C - IF( M.GT.0 ) THEN -C -C For efficiency of later calculations, interchange the first -C two block-columns. The corresponding submatrices are -C redefined according to their new position. -C - DO 10 I = 1, MNOBR - CALL DSWAP( I, R(1,I), 1, R(1,MNOBR+I), 1 ) - CALL DCOPY( MNOBR, R(I+1,MNOBR+I), 1, R(I+1,I), 1 ) - CALL DCOPY( MMNOBR-I, DUM, 0, R(I+1,MNOBR+I), 1 ) - 10 CONTINUE -C -C Now, -C -C U_f = [ R_11' R_21' 0 0 ]', -C U_p = [ R_12' 0 0 0 ]', -C Y_p = [ R_13' R_23' R_33' 0 ]', and -C Y_f = [ R_14' R_24' R_34' R_44' ]', -C -C where R_21, R_12, R_33, and R_44 are upper triangular. -C Define W_p := [ U_p Y_p ]. -C -C Prepare the computation of residuals of the two least -C squares problems giving the weighted oblique projection P: -C -C r_1 = W_p - U_f X_1, X_1 = arg min || U_f X - W_p ||, -C r_2 = Y_f - U_f X_2, X_2 = arg min || U_f X - Y_f ||, -C -C P = (arg min || r_1 X - r_2 ||)' r_1'. (1) -C -C Alternately, P' is given by the projection -C P' = Q_1 (Q_1)' r_2, -C where Q_1 contains the first k columns of the orthogonal -C matrix in the QR factorization of r_1, k := rank(r_1). -C -C Triangularize the matrix U_f = q r (using structure), and -C apply the transformation q' to the corresponding part of -C the matrices W_p, and Y_f. -C Workspace: need 2*(M+L)*NOBR. -C - CALL MB04ID( MMNOBR, MNOBR, MNOBR-1, LLMNOB, R, LDR, - $ R(1,NR2), LDR, DWORK(ITAU), DWORK(JWORK), - $ LDWORK-JWORK+1, IERR ) - MAXWRK = MAX( MAXWRK, INT( DWORK(JWORK) ) + JWORK - 1 ) -C -C Save updated Y_f (transposed) in the last block-row of R. -C - CALL MA02AD( 'Full', LMMNOB, LNOBR, R(1,NR4), LDR, R(NR4,1), - $ LDR ) -C -C Check the condition of the triangular factor r and decide -C to use pivoting or not. -C Workspace: need 4*M*NOBR. -C - CALL DTRCON( '1-norm', 'Upper', 'NonUnit', MNOBR, R, LDR, - $ RCOND1, DWORK(JWORK), IWORK, IERR ) -C - IF( TOLL.LE.ZERO ) - $ TOLL = MNOBR*MNOBR*EPS - IF ( RCOND1.GT.MAX( TOLL, THRESH ) ) THEN -C -C U_f is considered full rank and no pivoting is used. -C - CALL DLASET( 'Full', MNOBR, LLMNOB, ZERO, ZERO, R(1,NR2), - $ LDR ) - ELSE -C -C Save information about q in the (2,1) block of R. -C Use QR factorization with column pivoting, r P = Q R. -C Information on Q is stored in the strict lower triangle -C of R_11 and in DWORK(ITAU2). -C - DO 20 I = 1, MNOBR - 1 - DO 15 J = MMNOBR, NR2, -1 - R(J,I) = R(J-MNOBR+I,I) - 15 CONTINUE - CALL DCOPY( MNOBR-I, DUM, 0, R(I+1,I), 1 ) - IWORK(I) = 0 - 20 CONTINUE -C - IWORK(MNOBR) = 0 -C -C Workspace: need 5*M*NOBR+1. -C prefer 4*M*NOBR + (M*NOBR+1)*NB. -C - ITAU2 = JWORK - JWORK = ITAU2 + MNOBR - SVLMAX = ZERO - CALL MB03OD( 'QR', MNOBR, MNOBR, R, LDR, IWORK, TOLL, - $ SVLMAX, DWORK(ITAU2), RANK, SVAL, - $ DWORK(JWORK), LDWORK-JWORK+1, IERR ) - MAXWRK = MAX( MAXWRK, INT( DWORK(JWORK) ) + JWORK - 1 ) -C -C Workspace: need 2*M*NOBR + (M+2*L)*NOBR; -C prefer 2*M*NOBR + (M+2*L)*NOBR*NB. -C - CALL DORMQR( 'Left', 'Transpose', MNOBR, LLMNOB, MNOBR, - $ R, LDR, DWORK(ITAU2), R(1,NR2), LDR, - $ DWORK(JWORK), LDWORK-JWORK+1, IERR ) - MAXWRK = MAX( MAXWRK, INT( DWORK(JWORK) ) + JWORK - 1 ) - IF ( RANK.LT.MNOBR ) THEN -C -C The least squares problem is rank-deficient. -C - IWARN = 4 - END IF -C -C Determine residuals r_1 and r_2: premultiply by Q and -C then by q. -C Workspace: need 2*M*NOBR + (M+2*L)*NOBR); -C prefer 2*M*NOBR + (M+2*L)*NOBR*NB. -C - CALL DLASET( 'Full', RANK, LLMNOB, ZERO, ZERO, R(1,NR2), - $ LDR ) - CALL DORMQR( 'Left', 'NoTranspose', MNOBR, LLMNOB, MNOBR, - $ R, LDR, DWORK(ITAU2), R(1,NR2), LDR, - $ DWORK(JWORK), LDWORK-JWORK+1, IERR ) - MAXWRK = MAX( MAXWRK, INT( DWORK(JWORK) ) + JWORK - 1 ) - JWORK = ITAU2 -C -C Restore the transformation q. -C - DO 30 I = 1, MNOBR - 1 - DO 25 J = NR2, MMNOBR - R(J-MNOBR+I,I) = R(J,I) - 25 CONTINUE - 30 CONTINUE -C - END IF -C -C Premultiply by the transformation q (apply transformations -C in backward order). -C Workspace: need M*NOBR + (M+2*L)*NOBR; -C prefer larger. -C - CALL MB04IY( 'Left', 'NoTranspose', MMNOBR, LLMNOB, MNOBR, - $ MNOBR-1, R, LDR, DWORK(ITAU), R(1,NR2), LDR, - $ DWORK(JWORK), LDWORK-JWORK+1, IERR ) - MAXWRK = MAX( MAXWRK, INT( DWORK(JWORK) ) + JWORK - 1 ) -C - ELSE -C -C Save Y_f (transposed) in the last block-row of R. -C - CALL MA02AD( 'Full', LMMNOB, LNOBR, R(1,NR4), LDR, R(NR4,1), - $ LDR ) - RCOND1 = ONE - END IF -C -C Triangularize the matrix r_1 for determining the oblique -C projection P in least squares problem in (1). Exploit the -C fact that the third block-row of r_1 has the structure -C [ 0 T ], where T is an upper triangular matrix. Then apply -C the corresponding transformations Q' to the matrix r_2. -C Workspace: need 2*M*NOBR; -C prefer M*NOBR + M*NOBR*NB. -C - CALL DGEQRF( MMNOBR, MNOBR, R(1,NR2), LDR, DWORK(ITAU), - $ DWORK(JWORK), LDWORK-JWORK+1, IERR ) -C -C Workspace: need M*NOBR + 2*L*NOBR; -C prefer M*NOBR + 2*L*NOBR*NB. -C - CALL DORMQR( 'Left', 'Transpose', MMNOBR, LLNOBR, MNOBR, - $ R(1,NR2), LDR, DWORK(ITAU), R(1,NR3), LDR, - $ DWORK(JWORK), LDWORK-JWORK+1, IERR ) - NRSAVE = NR2 -C - ITAU2 = JWORK - JWORK = ITAU2 + LNOBR - CALL MB04ID( LMNOBR, LNOBR, LNOBR-1, LNOBR, R(NR2,NR3), LDR, - $ R(NR2,NR4), LDR, DWORK(ITAU2), DWORK(JWORK), - $ LDWORK-JWORK+1, IERR ) - MAXWRK = MAX( MAXWRK, INT( DWORK(JWORK) ) + JWORK - 1 ) -C -C Check the condition of the triangular matrix of order (m+l)*s -C just determined, and decide to use pivoting or not. -C Workspace: need 4*(M+L)*NOBR. -C - CALL DTRCON( '1-norm', 'Upper', 'NonUnit', LMNOBR, R(1,NR2), - $ LDR, RCOND2, DWORK(JWORK), IWORK, IERR ) -C - IF( TOL.LE.ZERO ) - $ TOLL = LMNOBR*LMNOBR*EPS - IF ( RCOND2.LE.MAX( TOLL, THRESH ) ) THEN - IF ( M.GT.0 ) THEN -C -C Save information about Q in R_11 (in the strict lower -C triangle), R_21 and R_31 (transposed information). -C - CALL DLACPY( 'Lower', MMNOBR-1, MNOBR, R(2,NR2), LDR, - $ R(2,1), LDR ) - NRSAVE = 1 -C - DO 40 I = NR2, LMNOBR - CALL DCOPY( MNOBR, R(I+1,MNOBR+I), 1, R(MNOBR+I,1), - $ LDR ) - 40 CONTINUE -C - END IF -C - CALL DLASET( 'Lower', LMNOBR-1, LMNOBR-1, ZERO, ZERO, - $ R(2,NR2), LDR ) -C -C Use QR factorization with column pivoting. -C Workspace: need 5*(M+L)*NOBR+1. -C prefer 4*(M+L)*NOBR + ((M+L)*NOBR+1)*NB. -C - DO 50 I = 1, LMNOBR - IWORK(I) = 0 - 50 CONTINUE -C - ITAU3 = JWORK - JWORK = ITAU3 + LMNOBR - SVLMAX = ZERO - CALL MB03OD( 'QR', LMNOBR, LMNOBR, R(1,NR2), LDR, IWORK, - $ TOLL, SVLMAX, DWORK(ITAU3), RANK1, SVAL, - $ DWORK(JWORK), LDWORK-JWORK+1, IERR ) - MAXWRK = MAX( MAXWRK, INT( DWORK(JWORK) ) + JWORK - 1 ) -C -C Workspace: need 2*(M+L)*NOBR + L*NOBR; -C prefer 2*(M+L)*NOBR + L*NOBR*NB. -C - CALL DORMQR( 'Left', 'Transpose', LMNOBR, LNOBR, LMNOBR, - $ R(1,NR2), LDR, DWORK(ITAU3), R(1,NR4), LDR, - $ DWORK(JWORK), LDWORK-JWORK+1, IERR ) - MAXWRK = MAX( MAXWRK, INT( DWORK(JWORK) ) + JWORK - 1 ) - IF ( RANK1.LT.LMNOBR ) THEN -C -C The least squares problem is rank-deficient. -C - IWARN = 5 - END IF -C -C Apply the orthogonal transformations, in backward order, to -C [r_2(1:rank(r_1),:)' 0]', to obtain P'. -C Workspace: need 2*(M+L)*NOBR + L*NOBR; -C prefer 2*(M+L)*NOBR + L*NOBR*NB. -C - CALL DLASET( 'Full', LMNOBR-RANK1, LNOBR, ZERO, ZERO, - $ R(RANK1+1,NR4), LDR ) - CALL DORMQR( 'Left', 'NoTranspose', LMNOBR, LNOBR, LMNOBR, - $ R(1,NR2), LDR, DWORK(ITAU3), R(1,NR4), LDR, - $ DWORK(JWORK), LDWORK-JWORK+1, IERR ) - MAXWRK = MAX( MAXWRK, INT( DWORK(JWORK) ) + JWORK - 1 ) - JWORK = ITAU3 -C - IF ( M.GT.0 ) THEN -C -C Restore the saved transpose matrix from R_31. -C - DO 60 I = NR2, LMNOBR - CALL DCOPY( MNOBR, R(MNOBR+I,1), LDR, R(I+1,MNOBR+I), - $ 1 ) - 60 CONTINUE -C - END IF -C - END IF -C -C Workspace: need M*NOBR + L*NOBR; -C prefer larger. -C - CALL MB04IY( 'Left', 'NoTranspose', LMNOBR, LNOBR, LNOBR, - $ LNOBR-1, R(NR2,NR3), LDR, DWORK(ITAU2), - $ R(NR2,NR4), LDR, DWORK(JWORK), LDWORK-JWORK+1, - $ IERR ) - MAXWRK = MAX( MAXWRK, INT( DWORK(JWORK) ) + JWORK - 1 ) -C -C Workspace: need M*NOBR + L*NOBR; -C prefer M*NOBR + L*NOBR*NB. -C - JWORK = ITAU2 - CALL DORMQR( 'Left', 'NoTranspose', MMNOBR, LNOBR, MNOBR, - $ R(1,NRSAVE), LDR, DWORK(ITAU), R(1,NR4), LDR, - $ DWORK(JWORK), LDWORK-JWORK+1, IERR ) -C -C Now, the matrix P' is available in R_14 : R_34. -C Triangularize the matrix P'. -C Workspace: need 2*L*NOBR; -C prefer L*NOBR + L*NOBR*NB. -C - JWORK = ITAU + LNOBR - CALL DGEQRF( LMMNOB, LNOBR, R(1,NR4), LDR, DWORK(ITAU), - $ DWORK(JWORK), LDWORK-JWORK+1, IERR ) -C -C Copy the triangular factor to its final position, R_22. -C - CALL DLACPY( 'Upper', LNOBR, LNOBR, R(1,NR4), LDR, R(NR2,NR2), - $ LDR ) -C -C Restore Y_f. -C - CALL MA02AD( 'Full', LNOBR, LMMNOB, R(NR4,1), LDR, R(1,NR4), - $ LDR ) - END IF -C -C Find the singular value decomposition of R_22. -C Workspace: need 5*L*NOBR. -C - CALL MB03UD( 'NoVectors', 'Vectors', LNOBR, R(NR2,NR2), LDR, - $ DUM, 1, SV, DWORK, LDWORK, IERR ) - IF ( IERR.NE.0 ) THEN - INFO = 2 - RETURN - END IF - MAXWRK = MAX( MAXWRK, INT( DWORK(1) ) ) -C -C Transpose R(m*s+1:(m+L)*s,m*s+1:(m+L)*s) in-situ; its -C columns will then be the singular vectors needed subsequently. -C - DO 70 I = NR2+1, LMNOBR - CALL DSWAP( LMNOBR-I+1, R(I,I-1), 1, R(I-1,I), LDR ) - 70 CONTINUE -C -C Return optimal workspace in DWORK(1) and reciprocal condition -C numbers, if METH = 'N'. -C - DWORK(1) = MAXWRK - IF ( N4SID ) THEN - DWORK(2) = RCOND1 - DWORK(3) = RCOND2 - END IF - RETURN -C -C *** Last line of IB01ND *** - END diff --git a/mex/sources/libslicot/IB01OD.f b/mex/sources/libslicot/IB01OD.f deleted file mode 100644 index 69d22c5ea..000000000 --- a/mex/sources/libslicot/IB01OD.f +++ /dev/null @@ -1,214 +0,0 @@ - SUBROUTINE IB01OD( CTRL, NOBR, L, SV, N, TOL, IWARN, INFO ) -C -C SLICOT RELEASE 5.0. -C -C Copyright (c) 2002-2009 NICONET e.V. -C -C This program is free software: you can redistribute it and/or -C modify it under the terms of the GNU General Public License as -C published by the Free Software Foundation, either version 2 of -C the License, or (at your option) any later version. -C -C This program is distributed in the hope that it will be useful, -C but WITHOUT ANY WARRANTY; without even the implied warranty of -C MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the -C GNU General Public License for more details. -C -C You should have received a copy of the GNU General Public License -C along with this program. If not, see -C . -C -C PURPOSE -C -C To estimate the system order, based on the singular values of the -C relevant part of the triangular factor of the concatenated block -C Hankel matrices. -C -C ARGUMENTS -C -C Mode Parameters -C -C CTRL CHARACTER*1 -C Specifies whether or not the user's confirmation of the -C system order estimate is desired, as follows: -C = 'C': user's confirmation; -C = 'N': no confirmation. -C If CTRL = 'C', a reverse communication routine, IB01OY, -C is called, and, after inspecting the singular values and -C system order estimate, n, the user may accept n or set -C a new value. -C IB01OY is not called by the routine if CTRL = 'N'. -C -C Input/Output Parameters -C -C NOBR (input) INTEGER -C The number of block rows, s, in the processed input and -C output block Hankel matrices. NOBR > 0. -C -C L (input) INTEGER -C The number of system outputs. L > 0. -C -C SV (input) DOUBLE PRECISION array, dimension ( L*NOBR ) -C The singular values of the relevant part of the triangular -C factor from the QR factorization of the concatenated block -C Hankel matrices. -C -C N (output) INTEGER -C The estimated order of the system. -C -C Tolerances -C -C TOL DOUBLE PRECISION -C Absolute tolerance used for determining an estimate of -C the system order. If TOL >= 0, the estimate is -C indicated by the index of the last singular value greater -C than or equal to TOL. (Singular values less than TOL -C are considered as zero.) When TOL = 0, an internally -C computed default value, TOL = NOBR*EPS*SV(1), is used, -C where SV(1) is the maximal singular value, and EPS is -C the relative machine precision (see LAPACK Library routine -C DLAMCH). When TOL < 0, the estimate is indicated by the -C index of the singular value that has the largest -C logarithmic gap to its successor. -C -C Warning Indicator -C -C IWARN INTEGER -C = 0: no warning; -C = 3: all singular values were exactly zero, hence N = 0. -C (Both input and output were identically zero.) -C -C Error Indicator -C -C INFO INTEGER -C = 0: successful exit; -C < 0: if INFO = -i, the i-th argument had an illegal -C value. -C -C METHOD -C -C The singular values are compared to the given, or default TOL, and -C the estimated order n is returned, possibly after user's -C confirmation. -C -C CONTRIBUTOR -C -C V. Sima, Research Institute for Informatics, Bucharest, Aug. 1999. -C -C REVISIONS -C -C August 2000. -C -C KEYWORDS -C -C Identification methods, multivariable systems, singular value -C decomposition. -C -C ****************************************************************** -C -C .. Parameters .. - DOUBLE PRECISION ZERO - PARAMETER ( ZERO = 0.0D0 ) -C .. Scalar Arguments .. - DOUBLE PRECISION TOL - INTEGER INFO, IWARN, L, N, NOBR - CHARACTER CTRL -C .. Array Arguments .. - DOUBLE PRECISION SV(*) -C .. Local Scalars .. - DOUBLE PRECISION GAP, RNRM, TOLL - INTEGER I, IERR, LNOBR - LOGICAL CONTRL -C .. External Functions .. - LOGICAL LSAME - DOUBLE PRECISION DLAMCH - EXTERNAL DLAMCH, LSAME -C .. External Subroutines .. - EXTERNAL IB01OY, XERBLA -C .. Intrinsic Functions .. - INTRINSIC DBLE, LOG10 -C .. -C .. Executable Statements .. -C -C Check the scalar input parameters. -C - CONTRL = LSAME( CTRL, 'C' ) - LNOBR = L*NOBR - IWARN = 0 - INFO = 0 - IF( .NOT.( CONTRL .OR. LSAME( CTRL, 'N' ) ) ) THEN - INFO = -1 - ELSE IF( NOBR.LE.0 ) THEN - INFO = -2 - ELSE IF( L.LE.0 ) THEN - INFO = -3 - END IF -C - IF( INFO.NE.0 ) THEN - CALL XERBLA( 'IB01OD', -INFO ) - RETURN - END IF -C -C Set TOL if necessay. -C - TOLL = TOL - IF ( TOLL.EQ.ZERO) - $ TOLL = DLAMCH( 'Precision' )*SV(1)*DBLE( NOBR ) -C -C Obtain the system order. -C - N = 0 - IF ( SV(1).NE.ZERO ) THEN - N = NOBR - IF ( TOLL.GE.ZERO) THEN -C -C Estimate n based on the tolerance TOLL. -C - DO 10 I = 1, NOBR - 1 - IF ( SV(I+1).LT.TOLL ) THEN - N = I - GO TO 30 - END IF - 10 CONTINUE - ELSE -C -C Estimate n based on the largest logarithmic gap between -C two consecutive singular values. -C - GAP = ZERO - DO 20 I = 1, NOBR - 1 - RNRM = SV(I+1) - IF ( RNRM.NE.ZERO ) THEN - RNRM = LOG10( SV(I) ) - LOG10( RNRM ) - IF ( RNRM.GT.GAP ) THEN - GAP = RNRM - N = I - END IF - ELSE - IF ( GAP.EQ.ZERO ) - $ N = I - GO TO 30 - END IF - 20 CONTINUE - END IF - END IF -C - 30 CONTINUE - IF ( N.EQ.0 ) THEN -C -C Return with N = 0 if all singular values are zero. -C - IWARN = 3 - RETURN - END IF -C - IF ( CONTRL ) THEN -C -C Ask confirmation of the system order. -C - CALL IB01OY( LNOBR, NOBR-1, N, SV, IERR ) - END IF - RETURN -C -C *** Last line of IB01OD *** - END diff --git a/mex/sources/libslicot/IB01OY.f b/mex/sources/libslicot/IB01OY.f deleted file mode 100644 index 1e475d751..000000000 --- a/mex/sources/libslicot/IB01OY.f +++ /dev/null @@ -1,175 +0,0 @@ - SUBROUTINE IB01OY( NS, NMAX, N, SV, INFO ) -C -C SLICOT RELEASE 5.0. -C -C Copyright (c) 2002-2009 NICONET e.V. -C -C This program is free software: you can redistribute it and/or -C modify it under the terms of the GNU General Public License as -C published by the Free Software Foundation, either version 2 of -C the License, or (at your option) any later version. -C -C This program is distributed in the hope that it will be useful, -C but WITHOUT ANY WARRANTY; without even the implied warranty of -C MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the -C GNU General Public License for more details. -C -C You should have received a copy of the GNU General Public License -C along with this program. If not, see -C . -C -C PURPOSE -C -C To ask for user's confirmation of the system order found by -C SLICOT Library routine IB01OD. This routine may be modified, -C but its interface must be preserved. -C -C ARGUMENTS -C -C Input/Output Parameters -C -C NS (input) INTEGER -C The number of singular values. NS > 0. -C -C NMAX (input) INTEGER -C The maximum value of the system order. 0 <= NMAX <= NS. -C -C N (input/output) INTEGER -C On entry, the estimate of the system order computed by -C IB01OD routine. 0 <= N <= NS. -C On exit, the user's estimate of the system order, which -C could be identical with the input value of N. -C Note that the output value of N should be less than -C or equal to NMAX. -C -C SV (input) DOUBLE PRECISION array, dimension ( NS ) -C The singular values, in descending order, used for -C determining the system order. -C -C Error Indicator -C -C INFO INTEGER -C = 0: successful exit; -C < 0: if INFO = -i, the i-th argument had an illegal -C value. -C -C CONTRIBUTORS -C -C V. Sima, Research Institute for Informatics, Bucharest, Aug. 1999. -C -C REVISIONS -C -C - -C -C KEYWORDS -C -C Identification, parameter estimation, singular values, structure -C identification. -C -C ********************************************************************* -C -C .. Parameters .. - INTEGER INTRMN, OUTRMN - PARAMETER ( INTRMN = 5, OUTRMN = 6 ) -C INTRMN is the unit number for the (terminal) input device. -C OUTRMN is the unit number for the (terminal) output device. -C .. -C .. Scalar Arguments .. - INTEGER INFO, N, NMAX, NS -C .. -C .. Array Arguments .. - DOUBLE PRECISION SV( * ) -C .. -C .. Local Scalars .. - LOGICAL YES - INTEGER I - CHARACTER ANS -C .. -C .. External Functions .. - LOGICAL LSAME - EXTERNAL LSAME -C .. -C .. External Subroutines .. - EXTERNAL XERBLA -C -C .. Executable Statements .. -C -C Check the scalar input parameters. -C - INFO = 0 - IF( NS.LE.0 ) THEN - INFO = -1 - ELSE IF( NMAX.LT.0 .OR. NMAX.GT.NS ) THEN - INFO = -2 - ELSE IF( N.LT.0 .OR. N.GT.NS ) THEN - INFO = -3 - END IF -C - IF( INFO.NE.0 ) THEN - CALL XERBLA( 'IB01OY', -INFO ) - RETURN - END IF -C - WRITE( OUTRMN, '(/'' Singular values (in descending order) used'', - $ '' to estimate the system order:'', // - $ (5D15.8) )' ) ( SV(I), I = 1, NS ) - WRITE( OUTRMN, '(/'' Estimated order of the system, n = '', I5 )' - $ ) N - WRITE( OUTRMN, '(/'' Do you want this value of n to be used'', - $ '' to determine the system matrices?'' )' ) -C - 10 CONTINUE - WRITE( OUTRMN, '(/'' Type "yes" or "no": '' )' ) - READ ( INTRMN, '( A )' ) ANS - YES = LSAME( ANS, 'Y' ) - IF( YES ) THEN - IF( N.LE.NMAX ) THEN -C -C The value of n is adequate and has been confirmed. -C - RETURN - ELSE -C -C The estimated value of n is not acceptable. -C - WRITE( OUTRMN, '(/'' n should be less than or equal'', - $ '' to '', I5 )' ) NMAX - WRITE( OUTRMN, '( '' (It may be useful to restart'', - $ '' with a larger tolerance.)'' )' ) - GO TO 20 - END IF -C - ELSE IF( LSAME( ANS, 'N' ) ) THEN - GO TO 20 - ELSE -C -C Wrong answer should be re-entered. -C - GO TO 10 - END IF -C -C Enter the desired value of n. -C - 20 CONTINUE - WRITE( OUTRMN,'(/'' Enter the desired value of n (n <= '', I5, - $ ''); n = '' )' ) NMAX - READ ( INTRMN, * ) N - IF ( N.LT.0 ) THEN -C -C The specified value of n is not acceptable. -C - WRITE( OUTRMN, '(/'' n should be larger than zero.'' )' ) - GO TO 20 - ELSE IF ( N.GT.NMAX ) THEN -C -C The specified value of n is not acceptable. -C - WRITE( OUTRMN, '(/'' n should be less than or equal to '', - $ I5 )' ) NMAX - GO TO 20 - END IF -C - RETURN -C -C *** Last line of IB01OY *** - END diff --git a/mex/sources/libslicot/IB01PD.f b/mex/sources/libslicot/IB01PD.f deleted file mode 100644 index 45c3e0f11..000000000 --- a/mex/sources/libslicot/IB01PD.f +++ /dev/null @@ -1,1232 +0,0 @@ - SUBROUTINE IB01PD( METH, JOB, JOBCV, NOBR, N, M, L, NSMPL, R, - $ LDR, A, LDA, C, LDC, B, LDB, D, LDD, Q, LDQ, - $ RY, LDRY, S, LDS, O, LDO, TOL, IWORK, DWORK, - $ LDWORK, IWARN, INFO ) -C -C SLICOT RELEASE 5.0. -C -C Copyright (c) 2002-2009 NICONET e.V. -C -C This program is free software: you can redistribute it and/or -C modify it under the terms of the GNU General Public License as -C published by the Free Software Foundation, either version 2 of -C the License, or (at your option) any later version. -C -C This program is distributed in the hope that it will be useful, -C but WITHOUT ANY WARRANTY; without even the implied warranty of -C MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the -C GNU General Public License for more details. -C -C You should have received a copy of the GNU General Public License -C along with this program. If not, see -C . -C -C PURPOSE -C -C To estimate the matrices A, C, B, and D of a linear time-invariant -C (LTI) state space model, using the singular value decomposition -C information provided by other routines. Optionally, the system and -C noise covariance matrices, needed for the Kalman gain, are also -C determined. -C -C ARGUMENTS -C -C Mode Parameters -C -C METH CHARACTER*1 -C Specifies the subspace identification method to be used, -C as follows: -C = 'M': MOESP algorithm with past inputs and outputs; -C = 'N': N4SID algorithm. -C -C JOB CHARACTER*1 -C Specifies which matrices should be computed, as follows: -C = 'A': compute all system matrices, A, B, C, and D; -C = 'C': compute the matrices A and C only; -C = 'B': compute the matrix B only; -C = 'D': compute the matrices B and D only. -C -C JOBCV CHARACTER*1 -C Specifies whether or not the covariance matrices are to -C be computed, as follows: -C = 'C': the covariance matrices should be computed; -C = 'N': the covariance matrices should not be computed. -C -C Input/Output Parameters -C -C NOBR (input) INTEGER -C The number of block rows, s, in the input and output -C Hankel matrices processed by other routines. NOBR > 1. -C -C N (input) INTEGER -C The order of the system. NOBR > N > 0. -C -C M (input) INTEGER -C The number of system inputs. M >= 0. -C -C L (input) INTEGER -C The number of system outputs. L > 0. -C -C NSMPL (input) INTEGER -C If JOBCV = 'C', the total number of samples used for -C calculating the covariance matrices. -C NSMPL >= 2*(M+L)*NOBR. -C This parameter is not meaningful if JOBCV = 'N'. -C -C R (input/workspace) DOUBLE PRECISION array, dimension -C ( LDR,2*(M+L)*NOBR ) -C On entry, the leading 2*(M+L)*NOBR-by-2*(M+L)*NOBR part -C of this array must contain the relevant data for the MOESP -C or N4SID algorithms, as constructed by SLICOT Library -C routines IB01AD or IB01ND. Let R_ij, i,j = 1:4, be the -C ij submatrix of R (denoted S in IB01AD and IB01ND), -C partitioned by M*NOBR, L*NOBR, M*NOBR, and L*NOBR -C rows and columns. The submatrix R_22 contains the matrix -C of left singular vectors used. Also needed, for -C METH = 'N' or JOBCV = 'C', are the submatrices R_11, -C R_14 : R_44, and, for METH = 'M' and JOB <> 'C', the -C submatrices R_31 and R_12, containing the processed -C matrices R_1c and R_2c, respectively, as returned by -C SLICOT Library routines IB01AD or IB01ND. -C Moreover, if METH = 'N' and JOB = 'A' or 'C', the -C block-row R_41 : R_43 must contain the transpose of the -C block-column R_14 : R_34 as returned by SLICOT Library -C routines IB01AD or IB01ND. -C The remaining part of R is used as workspace. -C On exit, part of this array is overwritten. Specifically, -C if METH = 'M', R_22 and R_31 are overwritten if -C JOB = 'B' or 'D', and R_12, R_22, R_14 : R_34, -C and possibly R_11 are overwritten if JOBCV = 'C'; -C if METH = 'N', all needed submatrices are overwritten. -C -C LDR INTEGER -C The leading dimension of the array R. -C LDR >= 2*(M+L)*NOBR. -C -C A (input or output) DOUBLE PRECISION array, dimension -C (LDA,N) -C On entry, if METH = 'N' and JOB = 'B' or 'D', the -C leading N-by-N part of this array must contain the system -C state matrix. -C If METH = 'M' or (METH = 'N' and JOB = 'A' or 'C'), -C this array need not be set on input. -C On exit, if JOB = 'A' or 'C' and INFO = 0, the -C leading N-by-N part of this array contains the system -C state matrix. -C -C LDA INTEGER -C The leading dimension of the array A. -C LDA >= N, if JOB = 'A' or 'C', or METH = 'N' and -C JOB = 'B' or 'D'; -C LDA >= 1, otherwise. -C -C C (input or output) DOUBLE PRECISION array, dimension -C (LDC,N) -C On entry, if METH = 'N' and JOB = 'B' or 'D', the -C leading L-by-N part of this array must contain the system -C output matrix. -C If METH = 'M' or (METH = 'N' and JOB = 'A' or 'C'), -C this array need not be set on input. -C On exit, if JOB = 'A' or 'C' and INFO = 0, or -C INFO = 3 (or INFO >= 0, for METH = 'M'), the leading -C L-by-N part of this array contains the system output -C matrix. -C -C LDC INTEGER -C The leading dimension of the array C. -C LDC >= L, if JOB = 'A' or 'C', or METH = 'N' and -C JOB = 'B' or 'D'; -C LDC >= 1, otherwise. -C -C B (output) DOUBLE PRECISION array, dimension (LDB,M) -C If M > 0, JOB = 'A', 'B', or 'D' and INFO = 0, the -C leading N-by-M part of this array contains the system -C input matrix. If M = 0 or JOB = 'C', this array is -C not referenced. -C -C LDB INTEGER -C The leading dimension of the array B. -C LDB >= N, if M > 0 and JOB = 'A', 'B', or 'D'; -C LDB >= 1, if M = 0 or JOB = 'C'. -C -C D (output) DOUBLE PRECISION array, dimension (LDD,M) -C If M > 0, JOB = 'A' or 'D' and INFO = 0, the leading -C L-by-M part of this array contains the system input-output -C matrix. If M = 0 or JOB = 'C' or 'B', this array is -C not referenced. -C -C LDD INTEGER -C The leading dimension of the array D. -C LDD >= L, if M > 0 and JOB = 'A' or 'D'; -C LDD >= 1, if M = 0 or JOB = 'C' or 'B'. -C -C Q (output) DOUBLE PRECISION array, dimension (LDQ,N) -C If JOBCV = 'C', the leading N-by-N part of this array -C contains the positive semidefinite state covariance matrix -C to be used as state weighting matrix when computing the -C Kalman gain. -C This parameter is not referenced if JOBCV = 'N'. -C -C LDQ INTEGER -C The leading dimension of the array Q. -C LDQ >= N, if JOBCV = 'C'; -C LDQ >= 1, if JOBCV = 'N'. -C -C RY (output) DOUBLE PRECISION array, dimension (LDRY,L) -C If JOBCV = 'C', the leading L-by-L part of this array -C contains the positive (semi)definite output covariance -C matrix to be used as output weighting matrix when -C computing the Kalman gain. -C This parameter is not referenced if JOBCV = 'N'. -C -C LDRY INTEGER -C The leading dimension of the array RY. -C LDRY >= L, if JOBCV = 'C'; -C LDRY >= 1, if JOBCV = 'N'. -C -C S (output) DOUBLE PRECISION array, dimension (LDS,L) -C If JOBCV = 'C', the leading N-by-L part of this array -C contains the state-output cross-covariance matrix to be -C used as cross-weighting matrix when computing the Kalman -C gain. -C This parameter is not referenced if JOBCV = 'N'. -C -C LDS INTEGER -C The leading dimension of the array S. -C LDS >= N, if JOBCV = 'C'; -C LDS >= 1, if JOBCV = 'N'. -C -C O (output) DOUBLE PRECISION array, dimension ( LDO,N ) -C If METH = 'M' and JOBCV = 'C', or METH = 'N', -C the leading L*NOBR-by-N part of this array contains -C the estimated extended observability matrix, i.e., the -C first N columns of the relevant singular vectors. -C If METH = 'M' and JOBCV = 'N', this array is not -C referenced. -C -C LDO INTEGER -C The leading dimension of the array O. -C LDO >= L*NOBR, if JOBCV = 'C' or METH = 'N'; -C LDO >= 1, otherwise. -C -C Tolerances -C -C TOL DOUBLE PRECISION -C The tolerance to be used for estimating the rank of -C matrices. If the user sets TOL > 0, then the given value -C of TOL is used as a lower bound for the reciprocal -C condition number; an m-by-n matrix whose estimated -C condition number is less than 1/TOL is considered to -C be of full rank. If the user sets TOL <= 0, then an -C implicitly computed, default tolerance, defined by -C TOLDEF = m*n*EPS, is used instead, where EPS is the -C relative machine precision (see LAPACK Library routine -C DLAMCH). -C -C Workspace -C -C IWORK INTEGER array, dimension (LIWORK) -C LIWORK = N, if METH = 'M' and M = 0 -C or JOB = 'C' and JOBCV = 'N'; -C LIWORK = M*NOBR+N, if METH = 'M', JOB = 'C', -C and JOBCV = 'C'; -C LIWORK = max(L*NOBR,M*NOBR), if METH = 'M', JOB <> 'C', -C and JOBCV = 'N'; -C LIWORK = max(L*NOBR,M*NOBR+N), if METH = 'M', JOB <> 'C', -C and JOBCV = 'C'; -C LIWORK = max(M*NOBR+N,M*(N+L)), if METH = 'N'. -C -C DWORK DOUBLE PRECISION array, dimension (LDWORK) -C On exit, if INFO = 0, DWORK(1) returns the optimal value -C of LDWORK, and DWORK(2), DWORK(3), DWORK(4), and -C DWORK(5) contain the reciprocal condition numbers of the -C triangular factors of the matrices, defined in the code, -C GaL (GaL = Un(1:(s-1)*L,1:n)), R_1c (if METH = 'M'), -C M (if JOBCV = 'C' or METH = 'N'), and Q or T (see -C SLICOT Library routines IB01PY or IB01PX), respectively. -C If METH = 'N', DWORK(3) is set to one without any -C calculations. Similarly, if METH = 'M' and JOBCV = 'N', -C DWORK(4) is set to one. If M = 0 or JOB = 'C', -C DWORK(3) and DWORK(5) are set to one. -C On exit, if INFO = -30, DWORK(1) returns the minimum -C value of LDWORK. -C -C LDWORK INTEGER -C The length of the array DWORK. -C LDWORK >= max( LDW1,LDW2 ), where, if METH = 'M', -C LDW1 >= max( 2*(L*NOBR-L)*N+2*N, (L*NOBR-L)*N+N*N+7*N ), -C if JOB = 'C' or JOB = 'A' and M = 0; -C LDW1 >= max( 2*(L*NOBR-L)*N+N*N+7*N, -C (L*NOBR-L)*N+N+6*M*NOBR, (L*NOBR-L)*N+N+ -C max( L+M*NOBR, L*NOBR + -C max( 3*L*NOBR+1, M ) ) ) -C if M > 0 and JOB = 'A', 'B', or 'D'; -C LDW2 >= 0, if JOBCV = 'N'; -C LDW2 >= max( (L*NOBR-L)*N+Aw+2*N+max(5*N,(2*M+L)*NOBR+L), -C 4*(M*NOBR+N)+1, M*NOBR+2*N+L ), -C if JOBCV = 'C', -C where Aw = N+N*N, if M = 0 or JOB = 'C'; -C Aw = 0, otherwise; -C and, if METH = 'N', -C LDW1 >= max( (L*NOBR-L)*N+2*N+(2*M+L)*NOBR+L, -C 2*(L*NOBR-L)*N+N*N+8*N, N+4*(M*NOBR+N)+1, -C M*NOBR+3*N+L ); -C LDW2 >= 0, if M = 0 or JOB = 'C'; -C LDW2 >= M*NOBR*(N+L)*(M*(N+L)+1)+ -C max( (N+L)**2, 4*M*(N+L)+1 ), -C if M > 0 and JOB = 'A', 'B', or 'D'. -C For good performance, LDWORK should be larger. -C -C Warning Indicator -C -C IWARN INTEGER -C = 0: no warning; -C = 4: a least squares problem to be solved has a -C rank-deficient coefficient matrix; -C = 5: the computed covariance matrices are too small. -C The problem seems to be a deterministic one. -C -C Error Indicator -C -C INFO INTEGER -C = 0: successful exit; -C < 0: if INFO = -i, the i-th argument had an illegal -C value; -C = 2: the singular value decomposition (SVD) algorithm did -C not converge; -C = 3: a singular upper triangular matrix was found. -C -C METHOD -C -C In the MOESP approach, the matrices A and C are first -C computed from an estimated extended observability matrix [1], -C and then, the matrices B and D are obtained by solving an -C extended linear system in a least squares sense. -C In the N4SID approach, besides the estimated extended -C observability matrix, the solutions of two least squares problems -C are used to build another least squares problem, whose solution -C is needed to compute the system matrices A, C, B, and D. The -C solutions of the two least squares problems are also optionally -C used by both approaches to find the covariance matrices. -C -C REFERENCES -C -C [1] Verhaegen M., and Dewilde, P. -C Subspace Model Identification. Part 1: The output-error state- -C space model identification class of algorithms. -C Int. J. Control, 56, pp. 1187-1210, 1992. -C -C [2] Van Overschee, P., and De Moor, B. -C N4SID: Two Subspace Algorithms for the Identification -C of Combined Deterministic-Stochastic Systems. -C Automatica, Vol.30, No.1, pp. 75-93, 1994. -C -C [3] Van Overschee, P. -C Subspace Identification : Theory - Implementation - -C Applications. -C Ph. D. Thesis, Department of Electrical Engineering, -C Katholieke Universiteit Leuven, Belgium, Feb. 1995. -C -C [4] Sima, V. -C Subspace-based Algorithms for Multivariable System -C Identification. -C Studies in Informatics and Control, 5, pp. 335-344, 1996. -C -C NUMERICAL ASPECTS -C -C The implemented method is numerically stable. -C -C FURTHER COMMENTS -C -C In some applications, it is useful to compute the system matrices -C using two calls to this routine, the first one with JOB = 'C', -C and the second one with JOB = 'B' or 'D'. This is slightly less -C efficient than using a single call with JOB = 'A', because some -C calculations are repeated. If METH = 'N', all the calculations -C at the first call are performed again at the second call; -C moreover, it is required to save the needed submatrices of R -C before the first call and restore them before the second call. -C If the covariance matrices are desired, JOBCV should be set -C to 'C' at the second call. If B and D are both needed, they -C should be computed at once. -C It is possible to compute the matrices A and C using the MOESP -C algorithm (METH = 'M'), and the matrices B and D using the N4SID -C algorithm (METH = 'N'). This combination could be slightly more -C efficient than N4SID algorithm alone and it could be more accurate -C than MOESP algorithm. No saving/restoring is needed in such a -C combination, provided JOBCV is set to 'N' at the first call. -C Recommended usage: either one call with JOB = 'A', or -C first call with METH = 'M', JOB = 'C', JOBCV = 'N', -C second call with METH = 'M', JOB = 'D', JOBCV = 'C', or -C first call with METH = 'M', JOB = 'C', JOBCV = 'N', -C second call with METH = 'N', JOB = 'D', JOBCV = 'C'. -C -C CONTRIBUTOR -C -C V. Sima, Research Institute for Informatics, Bucharest, Dec. 1999. -C -C REVISIONS -C -C March 2000, Feb. 2001, Sep. 2001, March 2005. -C -C KEYWORDS -C -C Identification methods; least squares solutions; multivariable -C systems; QR decomposition; singular value decomposition. -C -C ****************************************************************** -C -C .. Parameters .. - DOUBLE PRECISION ZERO, ONE, TWO, THREE - PARAMETER ( ZERO = 0.0D0, ONE = 1.0D0, TWO = 2.0D0, - $ THREE = 3.0D0 ) -C .. Scalar Arguments .. - DOUBLE PRECISION TOL - INTEGER INFO, IWARN, L, LDA, LDB, LDC, LDD, LDO, LDQ, - $ LDR, LDRY, LDS, LDWORK, M, N, NOBR, NSMPL - CHARACTER JOB, JOBCV, METH -C .. Array Arguments .. - DOUBLE PRECISION A(LDA, *), B(LDB, *), C(LDC, *), D(LDD, *), - $ DWORK(*), O(LDO, *), Q(LDQ, *), R(LDR, *), - $ RY(LDRY, *), S(LDS, *) - INTEGER IWORK( * ) -C .. Local Scalars .. - DOUBLE PRECISION EPS, RCOND1, RCOND2, RCOND3, RCOND4, RNRM, - $ SVLMAX, THRESH, TOLL, TOLL1 - INTEGER I, IAW, ID, IERR, IGAL, IHOUS, ISV, ITAU, - $ ITAU1, ITAU2, IU, IUN2, IWARNL, IX, JWORK, - $ LDUN2, LDUNN, LDW, LMMNOB, LMMNOL, LMNOBR, - $ LNOBR, LNOBRN, MAXWRK, MINWRK, MNOBR, MNOBRN, - $ N2, NCOL, NN, NPL, NR, NR2, NR3, NR4, NR4MN, - $ NR4PL, NROW, RANK, RANK11, RANKM - CHARACTER FACT, JOBP, JOBPY - LOGICAL FULLR, MOESP, N4SID, SHIFT, WITHAL, WITHB, - $ WITHC, WITHCO, WITHD -C .. Local Array .. - DOUBLE PRECISION SVAL(3) -C .. External Functions .. - LOGICAL LSAME - INTEGER ILAENV - DOUBLE PRECISION DLAMCH, DLANGE - EXTERNAL DLAMCH, DLANGE, ILAENV, LSAME -C .. External Subroutines .. - EXTERNAL DCOPY, DGEMM, DGEQRF, DLACPY, DLASET, DORMQR, - $ DSYRK, DTRCON, DTRSM, DTRTRS, IB01PX, IB01PY, - $ MA02AD, MA02ED, MB02QY, MB02UD, MB03OD, XERBLA -C .. Intrinsic Functions .. - INTRINSIC DBLE, MAX -C .. Executable Statements .. -C -C Decode the scalar input parameters. -C - MOESP = LSAME( METH, 'M' ) - N4SID = LSAME( METH, 'N' ) - WITHAL = LSAME( JOB, 'A' ) - WITHC = LSAME( JOB, 'C' ) .OR. WITHAL - WITHD = LSAME( JOB, 'D' ) .OR. WITHAL - WITHB = LSAME( JOB, 'B' ) .OR. WITHD - WITHCO = LSAME( JOBCV, 'C' ) - MNOBR = M*NOBR - LNOBR = L*NOBR - LMNOBR = LNOBR + MNOBR - LMMNOB = LNOBR + 2*MNOBR - MNOBRN = MNOBR + N - LNOBRN = LNOBR - N - LDUN2 = LNOBR - L - LDUNN = LDUN2*N - LMMNOL = LMMNOB + L - NR = LMNOBR + LMNOBR - NPL = N + L - N2 = N + N - NN = N*N - MINWRK = 1 - IWARN = 0 - INFO = 0 -C -C Check the scalar input parameters. -C - IF( .NOT.( MOESP .OR. N4SID ) ) THEN - INFO = -1 - ELSE IF( .NOT.( WITHB .OR. WITHC ) ) THEN - INFO = -2 - ELSE IF( .NOT.( WITHCO .OR. LSAME( JOBCV, 'N' ) ) ) THEN - INFO = -3 - ELSE IF( NOBR.LE.1 ) THEN - INFO = -4 - ELSE IF( N.LE.0 .OR. N.GE.NOBR ) THEN - INFO = -5 - ELSE IF( M.LT.0 ) THEN - INFO = -6 - ELSE IF( L.LE.0 ) THEN - INFO = -7 - ELSE IF( WITHCO .AND. NSMPL.LT.NR ) THEN - INFO = -8 - ELSE IF( LDR.LT.NR ) THEN - INFO = -10 - ELSE IF( LDA.LT.1 .OR. ( ( WITHC .OR. ( WITHB .AND. N4SID ) ) - $ .AND. LDA.LT.N ) ) THEN - INFO = -12 - ELSE IF( LDC.LT.1 .OR. ( ( WITHC .OR. ( WITHB .AND. N4SID ) ) - $ .AND. LDC.LT.L ) ) THEN - INFO = -14 - ELSE IF( LDB.LT.1 .OR. ( WITHB .AND. LDB.LT.N .AND. M.GT.0 ) ) - $ THEN - INFO = -16 - ELSE IF( LDD.LT.1 .OR. ( WITHD .AND. LDD.LT.L .AND. M.GT.0 ) ) - $ THEN - INFO = -18 - ELSE IF( LDQ.LT.1 .OR. ( WITHCO .AND. LDQ.LT.N ) ) THEN - INFO = -20 - ELSE IF( LDRY.LT.1 .OR. ( WITHCO .AND. LDRY.LT.L ) ) THEN - INFO = -22 - ELSE IF( LDS.LT.1 .OR. ( WITHCO .AND. LDS.LT.N ) ) THEN - INFO = -24 - ELSE IF( LDO.LT.1 .OR. ( ( WITHCO .OR. N4SID ) .AND. - $ LDO.LT.LNOBR ) ) THEN - INFO = -26 - ELSE -C -C Compute workspace. -C (Note: Comments in the code beginning "Workspace:" describe the -C minimal amount of workspace needed at that point in the code, -C as well as the preferred amount for good performance. -C NB refers to the optimal block size for the immediately -C following subroutine, as returned by ILAENV.) -C - IAW = 0 - MINWRK = LDUNN + 4*N - MAXWRK = LDUNN + N + N*ILAENV( 1, 'DGEQRF', ' ', LDUN2, N, -1, - $ -1 ) - IF( MOESP ) THEN - ID = 0 - IF( WITHC ) THEN - MINWRK = MAX( MINWRK, 2*LDUNN + N2, LDUNN + NN + 7*N ) - MAXWRK = MAX( MAXWRK, 2*LDUNN + N + N*ILAENV( 1, - $ 'DORMQR', 'LT', LDUN2, N, N, -1 ) ) - END IF - ELSE - ID = N - END IF -C - IF( ( M.GT.0 .AND. WITHB ) .OR. N4SID ) THEN - MINWRK = MAX( MINWRK, 2*LDUNN + NN + ID + 7*N ) - IF ( MOESP ) - $ MINWRK = MAX( MINWRK, LDUNN + N + 6*MNOBR, LDUNN + N + - $ MAX( L + MNOBR, LNOBR + - $ MAX( 3*LNOBR + 1, M ) ) ) - ELSE - IF( MOESP ) - $ IAW = N + NN - END IF -C - IF( N4SID .OR. WITHCO ) THEN - MINWRK = MAX( MINWRK, LDUNN + IAW + N2 + MAX( 5*N, LMMNOL ), - $ ID + 4*MNOBRN+1, ID + MNOBRN + NPL ) - MAXWRK = MAX( MAXWRK, LDUNN + IAW + N2 + - $ MAX( N*ILAENV( 1, 'DGEQRF', ' ', LNOBR, N, -1, - $ -1 ), LMMNOB* - $ ILAENV( 1, 'DORMQR', 'LT', LNOBR, - $ LMMNOB, N, -1 ), LMMNOL* - $ ILAENV( 1, 'DORMQR', 'LT', LDUN2, - $ LMMNOL, N, -1 ) ), - $ ID + N + N*ILAENV( 1, 'DGEQRF', ' ', LMNOBR, - $ N, -1, -1 ), - $ ID + N + NPL*ILAENV( 1, 'DORMQR', 'LT', - $ LMNOBR, NPL, N, -1 ) ) - IF( N4SID .AND. ( M.GT.0 .AND. WITHB ) ) - $ MINWRK = MAX( MINWRK, MNOBR*NPL*( M*NPL + 1 ) + - $ MAX( NPL**2, 4*M*NPL + 1 ) ) - END IF - MAXWRK = MAX( MINWRK, MAXWRK ) -C - IF ( LDWORK.LT.MINWRK ) THEN - INFO = -30 - DWORK( 1 ) = MINWRK - END IF - END IF -C -C Return if there are illegal arguments. -C - IF( INFO.NE.0 ) THEN - CALL XERBLA( 'IB01PD', -INFO ) - RETURN - END IF -C - NR2 = MNOBR + 1 - NR3 = LMNOBR + 1 - NR4 = LMMNOB + 1 -C -C Set the precision parameters. A threshold value EPS**(2/3) is -C used for deciding to use pivoting or not, where EPS is the -C relative machine precision (see LAPACK Library routine DLAMCH). -C - EPS = DLAMCH( 'Precision' ) - THRESH = EPS**( TWO/THREE ) - SVLMAX = ZERO - RCOND4 = ONE -C -C Let Un be the matrix of left singular vectors (stored in R_22). -C Copy un1 = GaL = Un(1:(s-1)*L,1:n) in the workspace. -C - IGAL = 1 - CALL DLACPY( 'Full', LDUN2, N, R(NR2,NR2), LDR, DWORK(IGAL), - $ LDUN2 ) -C -C Factor un1 = Q1*[r1' 0]' (' means transposition). -C Workspace: need L*(NOBR-1)*N+2*N, -C prefer L*(NOBR-1)*N+N+N*NB. -C - ITAU1 = IGAL + LDUNN - JWORK = ITAU1 + N - LDW = JWORK - CALL DGEQRF( LDUN2, N, DWORK(IGAL), LDUN2, DWORK(ITAU1), - $ DWORK(JWORK), LDWORK-JWORK+1, IERR ) -C -C Compute the reciprocal of the condition number of r1. -C Workspace: need L*(NOBR-1)*N+4*N. -C - CALL DTRCON( '1-norm', 'Upper', 'NonUnit', N, DWORK(IGAL), LDUN2, - $ RCOND1, DWORK(JWORK), IWORK, INFO ) -C - TOLL1 = TOL - IF( TOLL1.LE.ZERO ) - $ TOLL1 = NN*EPS -C - IF ( ( M.GT.0 .AND. WITHB ) .OR. N4SID ) THEN - JOBP = 'P' - IF ( WITHAL ) THEN - JOBPY = 'D' - ELSE - JOBPY = JOB - END IF - ELSE - JOBP = 'N' - END IF -C - IF ( MOESP ) THEN - NCOL = 0 - IUN2 = JWORK - IF ( WITHC ) THEN -C -C Set C = Un(1:L,1:n) and then compute the system matrix A. -C -C Set un2 = Un(L+1:L*s,1:n) in DWORK(IUN2). -C Workspace: need 2*L*(NOBR-1)*N+N. -C - CALL DLACPY( 'Full', L, N, R(NR2,NR2), LDR, C, LDC ) - CALL DLACPY( 'Full', LDUN2, N, R(NR2+L,NR2), LDR, - $ DWORK(IUN2), LDUN2 ) -C -C Note that un1 has already been factored as -C un1 = Q1*[r1' 0]' and usually (generically, assuming -C observability) has full column rank. -C Update un2 <-- Q1'*un2 in DWORK(IUN2) and save its -C first n rows in A. -C Workspace: need 2*L*(NOBR-1)*N+2*N; -C prefer 2*L*(NOBR-1)*N+N+N*NB. -C - JWORK = IUN2 + LDUNN - CALL DORMQR( 'Left', 'Transpose', LDUN2, N, N, DWORK(IGAL), - $ LDUN2, DWORK(ITAU1), DWORK(IUN2), LDUN2, - $ DWORK(JWORK), LDWORK-JWORK+1, IERR ) - CALL DLACPY( 'Full', N, N, DWORK(IUN2), LDUN2, A, LDA ) - NCOL = N - JWORK = IUN2 - END IF -C - IF ( RCOND1.GT.MAX( TOLL1, THRESH ) ) THEN -C -C The triangular factor r1 is considered to be of full rank. -C Solve for A (if requested), r1*A = un2(1:n,:) in A. -C - IF ( WITHC ) THEN - CALL DTRTRS( 'Upper', 'NoTranspose', 'NonUnit', N, N, - $ DWORK(IGAL), LDUN2, A, LDA, IERR ) - IF ( IERR.GT.0 ) THEN - INFO = 3 - RETURN - END IF - END IF - RANK = N - ELSE -C -C Rank-deficient triangular factor r1. Use SVD of r1, -C r1 = U*S*V', also for computing A (if requested) from -C r1*A = un2(1:n,:). Matrix U is computed in DWORK(IU), -C and V' overwrites r1. If B is requested, the -C pseudoinverse of r1 and then of GaL are also computed -C in R(NR3,NR2). -C Workspace: need c*L*(NOBR-1)*N+N*N+7*N, -C where c = 1 if B and D are not needed, -C c = 2 if B and D are needed; -C prefer larger. -C - IU = IUN2 - ISV = IU + NN - JWORK = ISV + N - IF ( M.GT.0 .AND. WITHB ) THEN -C -C Save the elementary reflectors used for computing r1, -C if B, D are needed. -C Workspace: need 2*L*(NOBR-1)*N+2*N+N*N. -C - IHOUS = JWORK - JWORK = IHOUS + LDUNN - CALL DLACPY( 'Lower', LDUN2, N, DWORK(IGAL), LDUN2, - $ DWORK(IHOUS), LDUN2 ) - ELSE - IHOUS = IGAL - END IF -C - CALL MB02UD( 'Not factored', 'Left', 'NoTranspose', JOBP, N, - $ NCOL, ONE, TOLL1, RANK, DWORK(IGAL), LDUN2, - $ DWORK(IU), N, DWORK(ISV), A, LDA, R(NR3,NR2), - $ LDR, DWORK(JWORK), LDWORK-JWORK+1, IERR ) - IF ( IERR.NE.0 ) THEN - INFO = 2 - RETURN - END IF - MAXWRK = MAX( MAXWRK, INT( DWORK(JWORK) ) + JWORK - 1 ) -C - IF ( RANK.EQ.0 ) THEN - JOBP = 'N' - ELSE IF ( M.GT.0 .AND. WITHB ) THEN -C -C Compute pinv(GaL) in R(NR3,NR2) if B, D are needed. -C Workspace: need 2*L*(NOBR-1)*N+N*N+3*N; -C prefer 2*L*(NOBR-1)*N+N*N+2*N+N*NB. -C - CALL DLASET( 'Full', N, LDUN2-N, ZERO, ZERO, - $ R(NR3,NR2+N), LDR ) - CALL DORMQR( 'Right', 'Transpose', N, LDUN2, N, - $ DWORK(IHOUS), LDUN2, DWORK(ITAU1), - $ R(NR3,NR2), LDR, DWORK(JWORK), - $ LDWORK-JWORK+1, IERR ) - MAXWRK = MAX( MAXWRK, INT( DWORK(JWORK) ) + JWORK - 1 ) - IF ( WITHCO ) THEN -C -C Save pinv(GaL) in DWORK(IGAL). -C - CALL DLACPY( 'Full', N, LDUN2, R(NR3,NR2), LDR, - $ DWORK(IGAL), N ) - END IF - JWORK = IUN2 - END IF - LDW = JWORK - END IF -C - IF ( M.GT.0 .AND. WITHB ) THEN -C -C Computation of B and D. -C -C Compute the reciprocal of the condition number of R_1c. -C Workspace: need L*(NOBR-1)*N+N+3*M*NOBR. -C - CALL DTRCON( '1-norm', 'Upper', 'NonUnit', MNOBR, R(NR3,1), - $ LDR, RCOND2, DWORK(JWORK), IWORK, IERR ) -C - TOLL = TOL - IF( TOLL.LE.ZERO ) - $ TOLL = MNOBR*MNOBR*EPS -C -C Compute the right hand side and solve for K (in R_23), -C K*R_1c' = u2'*R_2c', -C where u2 = Un(:,n+1:L*s), and K is (Ls-n) x ms. -C - CALL DGEMM( 'Transpose', 'Transpose', LNOBRN, MNOBR, LNOBR, - $ ONE, R(NR2,NR2+N), LDR, R(1,NR2), LDR, ZERO, - $ R(NR2,NR3), LDR ) -C - IF ( RCOND2.GT.MAX( TOLL, THRESH ) ) THEN -C -C The triangular factor R_1c is considered to be of full -C rank. Solve for K, K*R_1c' = u2'*R_2c'. -C - CALL DTRSM( 'Right', 'Upper', 'Transpose', 'Non-unit', - $ LNOBRN, MNOBR, ONE, R(NR3,1), LDR, - $ R(NR2,NR3), LDR ) - ELSE -C -C Rank-deficient triangular factor R_1c. Use SVD of R_1c -C for computing K from K*R_1c' = u2'*R_2c', where -C R_1c = U1*S1*V1'. Matrix U1 is computed in R_33, -C and V1' overwrites R_1c. -C Workspace: need L*(NOBR-1)*N+N+6*M*NOBR; -C prefer larger. -C - ISV = LDW - JWORK = ISV + MNOBR - CALL MB02UD( 'Not factored', 'Right', 'Transpose', - $ 'No pinv', LNOBRN, MNOBR, ONE, TOLL, RANK11, - $ R(NR3,1), LDR, R(NR3,NR3), LDR, DWORK(ISV), - $ R(NR2,NR3), LDR, DWORK(JWORK), 1, - $ DWORK(JWORK), LDWORK-JWORK+1, IERR ) - IF ( IERR.NE.0 ) THEN - INFO = 2 - RETURN - END IF - MAXWRK = MAX( MAXWRK, INT( DWORK(JWORK) ) + JWORK - 1 ) - JWORK = LDW - END IF -C -C Compute the triangular factor of the structured matrix Q -C and apply the transformations to the matrix Kexpand, where -C Q and Kexpand are defined in SLICOT Library routine -C IB01PY. Compute also the matrices B, D. -C Workspace: need L*(NOBR-1)*N+N+max(L+M*NOBR,L*NOBR+ -C max(3*L*NOBR+1,M)); -C prefer larger. -C - IF ( WITHCO ) - $ CALL DLACPY( 'Full', LNOBR, N, R(NR2,NR2), LDR, O, LDO ) - CALL IB01PY( METH, JOBPY, NOBR, N, M, L, RANK, R(NR2,NR2), - $ LDR, DWORK(IGAL), LDUN2, DWORK(ITAU1), - $ R(NR3,NR2), LDR, R(NR2,NR3), LDR, R(NR4,NR2), - $ LDR, R(NR4,NR3), LDR, B, LDB, D, LDD, TOL, - $ IWORK, DWORK(JWORK), LDWORK-JWORK+1, IWARN, - $ INFO ) - IF ( INFO.NE.0 ) - $ RETURN - MAXWRK = MAX( MAXWRK, INT( DWORK(JWORK) ) + JWORK - 1 ) - RCOND4 = DWORK(JWORK+1) - IF ( WITHCO ) - $ CALL DLACPY( 'Full', LNOBR, N, O, LDO, R(NR2,1), LDR ) -C - ELSE - RCOND2 = ONE - END IF -C - IF ( .NOT.WITHCO ) THEN - RCOND3 = ONE - GO TO 30 - END IF - ELSE -C -C For N4SID, set RCOND2 to one. -C - RCOND2 = ONE - END IF -C -C If needed, save the first n columns, representing Gam, of the -C matrix of left singular vectors, Un, in R_21 and in O. -C - IF ( N4SID .OR. ( WITHC .AND. .NOT.WITHAL ) ) THEN - IF ( M.GT.0 ) - $ CALL DLACPY( 'Full', LNOBR, N, R(NR2,NR2), LDR, R(NR2,1), - $ LDR ) - CALL DLACPY( 'Full', LNOBR, N, R(NR2,NR2), LDR, O, LDO ) - END IF -C -C Computations for covariance matrices, and system matrices (N4SID). -C Solve the least squares problems Gam*Y = R4(1:L*s,1:(2*m+L)*s), -C GaL*X = R4(L+1:L*s,:), where -C GaL = Gam(1:L*(s-1),:), Gam has full column rank, and -C R4 = [ R_14' R_24' R_34' R_44L' ], R_44L = R_44(1:L,:), as -C returned by SLICOT Library routine IB01ND. -C First, find the QR factorization of Gam, Gam = Q*R. -C Workspace: need L*(NOBR-1)*N+Aw+3*N; -C prefer L*(NOBR-1)*N+Aw+2*N+N*NB, where -C Aw = N+N*N, if (M = 0 or JOB = 'C'), rank(r1) < N, -C and METH = 'M'; -C Aw = 0, otherwise. -C - ITAU2 = LDW - JWORK = ITAU2 + N - CALL DGEQRF( LNOBR, N, R(NR2,1), LDR, DWORK(ITAU2), - $ DWORK(JWORK), LDWORK-JWORK+1, IERR ) -C -C For METH = 'M' or when JOB = 'B' or 'D', transpose -C [ R_14' R_24' R_34' ]' in the last block-row of R, obtaining Z, -C and for METH = 'N' and JOB = 'A' or 'C', use the matrix Z -C already available in the last block-row of R, and then apply -C the transformations, Z <-- Q'*Z. -C Workspace: need L*(NOBR-1)*N+Aw+2*N+(2*M+L)*NOBR; -C prefer L*(NOBR-1)*N+Aw+2*N+(2*M+L)*NOBR*NB. -C - IF ( MOESP .OR. ( WITHB .AND. .NOT. WITHAL ) ) - $ CALL MA02AD( 'Full', LMMNOB, LNOBR, R(1,NR4), LDR, R(NR4,1), - $ LDR ) - CALL DORMQR( 'Left', 'Transpose', LNOBR, LMMNOB, N, R(NR2,1), LDR, - $ DWORK(ITAU2), R(NR4,1), LDR, DWORK(JWORK), - $ LDWORK-JWORK+1, IERR ) -C -C Solve for Y, RY = Z in Z and save the transpose of the -C solution Y in the second block-column of R. -C - CALL DTRTRS( 'Upper', 'NoTranspose', 'NonUnit', N, LMMNOB, - $ R(NR2,1), LDR, R(NR4,1), LDR, IERR ) - IF ( IERR.GT.0 ) THEN - INFO = 3 - RETURN - END IF - CALL MA02AD( 'Full', N, LMMNOB, R(NR4,1), LDR, R(1,NR2), LDR ) - NR4MN = NR4 - N - NR4PL = NR4 + L - NROW = LMMNOL -C -C SHIFT is .TRUE. if some columns of R_14 : R_44L should be -C shifted to the right, to avoid overwriting useful information. -C - SHIFT = M.EQ.0 .AND. LNOBR.LT.N2 -C - IF ( RCOND1.GT.MAX( TOLL1, THRESH ) ) THEN -C -C The triangular factor r1 of GaL (GaL = Q1*r1) is -C considered to be of full rank. -C -C Transpose [ R_14' R_24' R_34' R_44L' ]'(:,L+1:L*s) in the -C last block-row of R (beginning with the (L+1)-th row), -C obtaining Z1, and then apply the transformations, -C Z1 <-- Q1'*Z1. -C Workspace: need L*(NOBR-1)*N+Aw+2*N+ (2*M+L)*NOBR + L; -C prefer L*(NOBR-1)*N+Aw+2*N+((2*M+L)*NOBR + L)*NB. -C - CALL MA02AD( 'Full', LMMNOL, LDUN2, R(1,NR4PL), LDR, - $ R(NR4PL,1), LDR ) - CALL DORMQR( 'Left', 'Transpose', LDUN2, LMMNOL, N, - $ DWORK(IGAL), LDUN2, DWORK(ITAU1), R(NR4PL,1), LDR, - $ DWORK(JWORK), LDWORK-JWORK+1, IERR ) -C -C Solve for X, r1*X = Z1 in Z1, and copy the transpose of X -C into the last part of the third block-column of R. -C - CALL DTRTRS( 'Upper', 'NoTranspose', 'NonUnit', N, LMMNOL, - $ DWORK(IGAL), LDUN2, R(NR4PL,1), LDR, IERR ) - IF ( IERR.GT.0 ) THEN - INFO = 3 - RETURN - END IF -C - IF ( SHIFT ) THEN - NR4MN = NR4 -C - DO 10 I = L - 1, 0, -1 - CALL DCOPY( LMMNOL, R(1,NR4+I), 1, R(1,NR4+N+I), 1 ) - 10 CONTINUE -C - END IF - CALL MA02AD( 'Full', N, LMMNOL, R(NR4PL,1), LDR, R(1,NR4MN), - $ LDR ) - NROW = 0 - END IF -C - IF ( N4SID .OR. NROW.GT.0 ) THEN -C -C METH = 'N' or rank-deficient triangular factor r1. -C For METH = 'N', use SVD of r1, r1 = U*S*V', for computing -C X' from X'*GaL' = Z1', if rank(r1) < N. Matrix U is -C computed in DWORK(IU) and V' overwrites r1. Then, the -C pseudoinverse of GaL is determined in R(NR4+L,NR2). -C For METH = 'M', the pseudoinverse of GaL is already available -C if M > 0 and B is requested; otherwise, the SVD of r1 is -C available in DWORK(IU), DWORK(ISV), and DWORK(IGAL). -C Workspace for N4SID: need 2*L*(NOBR-1)*N+N*N+8*N; -C prefer larger. -C - IF ( MOESP ) THEN - FACT = 'F' - IF ( M.GT.0 .AND. WITHB ) - $ CALL DLACPY( 'Full', N, LDUN2, DWORK(IGAL), N, - $ R(NR4PL,NR2), LDR ) - ELSE -C -C Save the elementary reflectors used for computing r1. -C - IHOUS = JWORK - CALL DLACPY( 'Lower', LDUN2, N, DWORK(IGAL), LDUN2, - $ DWORK(IHOUS), LDUN2 ) - FACT = 'N' - IU = IHOUS + LDUNN - ISV = IU + NN - JWORK = ISV + N - END IF -C - CALL MB02UD( FACT, 'Right', 'Transpose', JOBP, NROW, N, ONE, - $ TOLL1, RANK, DWORK(IGAL), LDUN2, DWORK(IU), N, - $ DWORK(ISV), R(1,NR4PL), LDR, R(NR4PL,NR2), LDR, - $ DWORK(JWORK), LDWORK-JWORK+1, IERR ) - IF ( NROW.GT.0 ) THEN - IF ( SHIFT ) THEN - NR4MN = NR4 - CALL DLACPY( 'Full', LMMNOL, L, R(1,NR4), LDR, - $ R(1,NR4-L), LDR ) - CALL DLACPY( 'Full', LMMNOL, N, R(1,NR4PL), LDR, - $ R(1,NR4MN), LDR ) - CALL DLACPY( 'Full', LMMNOL, L, R(1,NR4-L), LDR, - $ R(1,NR4+N), LDR ) - ELSE - CALL DLACPY( 'Full', LMMNOL, N, R(1,NR4PL), LDR, - $ R(1,NR4MN), LDR ) - END IF - END IF -C - IF ( N4SID ) THEN - IF ( IERR.NE.0 ) THEN - INFO = 2 - RETURN - END IF - MAXWRK = MAX( MAXWRK, INT( DWORK(JWORK) ) + JWORK - 1 ) -C -C Compute pinv(GaL) in R(NR4+L,NR2). -C Workspace: need 2*L*(NOBR-1)*N+3*N; -C prefer 2*L*(NOBR-1)*N+2*N+N*NB. -C - JWORK = IU - CALL DLASET( 'Full', N, LDUN2-N, ZERO, ZERO, R(NR4PL,NR2+N), - $ LDR ) - CALL DORMQR( 'Right', 'Transpose', N, LDUN2, N, - $ DWORK(IHOUS), LDUN2, DWORK(ITAU1), - $ R(NR4PL,NR2), LDR, DWORK(JWORK), - $ LDWORK-JWORK+1, IERR ) - MAXWRK = MAX( MAXWRK, INT( DWORK(JWORK) ) + JWORK - 1 ) - END IF - END IF -C -C For METH = 'N', find part of the solution (corresponding to A -C and C) and, optionally, for both METH = 'M', or METH = 'N', -C find the residual of the least squares problem that gives the -C covariances, M*V = N, where -C ( R_11 ) -C M = ( Y' ), N = ( X' R4'(:,1:L) ), V = V(n+m*s, n+L), -C ( 0 0 ) -C with M((2*m+L)*s+L, n+m*s), N((2*m+L)*s+L, n+L), R4' being -C stored in the last block-column of R. The last L rows of M -C are not explicitly considered. Note that, for efficiency, the -C last m*s columns of M are in the first positions of arrray R. -C This permutation does not affect the residual, only the -C solution. (The solution is not needed for METH = 'M'.) -C Note that R_11 corresponds to the future outputs for both -C METH = 'M', or METH = 'N' approaches. (For METH = 'N', the -C first two block-columns have been interchanged.) -C For METH = 'N', A and C are obtained as follows: -C [ A' C' ] = V(m*s+1:m*s+n,:). -C -C First, find the QR factorization of Y'(m*s+1:(2*m+L)*s,:) -C and apply the transformations to the corresponding part of N. -C Compress the workspace for N4SID by moving the scalar reflectors -C corresponding to Q. -C Workspace: need d*N+2*N; -C prefer d*N+N+N*NB; -C where d = 0, for MOESP, and d = 1, for N4SID. -C - IF ( MOESP ) THEN - ITAU = 1 - ELSE - CALL DCOPY( N, DWORK(ITAU2), 1, DWORK, 1 ) - ITAU = N + 1 - END IF -C - JWORK = ITAU + N - CALL DGEQRF( LMNOBR, N, R(NR2,NR2), LDR, DWORK(ITAU), - $ DWORK(JWORK), LDWORK-JWORK+1, IERR ) -C -C Workspace: need d*N+N+(N+L); -C prefer d*N+N+(N+L)*NB. -C - CALL DORMQR( 'Left', 'Transpose', LMNOBR, NPL, N, R(NR2,NR2), LDR, - $ DWORK(ITAU), R(NR2,NR4MN), LDR, DWORK(JWORK), - $ LDWORK-JWORK+1, IERR ) -C - CALL DLASET( 'Lower', L-1, L-1, ZERO, ZERO, R(NR4+1,NR4), LDR ) -C -C Now, matrix M with permuted block-columns has been -C triangularized. -C Compute the reciprocal of the condition number of its -C triangular factor in R(1:m*s+n,1:m*s+n). -C Workspace: need d*N+3*(M*NOBR+N). -C - JWORK = ITAU - CALL DTRCON( '1-norm', 'Upper', 'NonUnit', MNOBRN, R, LDR, RCOND3, - $ DWORK(JWORK), IWORK, INFO ) -C - TOLL = TOL - IF( TOLL.LE.ZERO ) - $ TOLL = MNOBRN*MNOBRN*EPS - IF ( RCOND3.GT.MAX( TOLL, THRESH ) ) THEN -C -C The triangular factor is considered to be of full rank. -C Solve for V(m*s+1:m*s+n,:), giving [ A' C' ]. -C - FULLR = .TRUE. - RANKM = MNOBRN - IF ( N4SID ) - $ CALL DTRSM( 'Left', 'Upper', 'NoTranspose', 'NonUnit', N, - $ NPL, ONE, R(NR2,NR2), LDR, R(NR2,NR4MN), LDR ) - ELSE - FULLR = .FALSE. -C -C Use QR factorization (with pivoting). For METH = 'N', save -C (and then restore) information about the QR factorization of -C Gam, for later use. Note that R_11 could be modified by -C MB03OD, but the corresponding part of N is also modified -C accordingly. -C Workspace: need d*N+4*(M*NOBR+N)+1; -C prefer d*N+3*(M*NOBR+N)+(M*NOBR+N+1)*NB. -C - DO 20 I = 1, MNOBRN - IWORK(I) = 0 - 20 CONTINUE -C - IF ( N4SID .AND. ( M.GT.0 .AND. WITHB ) ) - $ CALL DLACPY( 'Full', LNOBR, N, R(NR2,1), LDR, R(NR4,1), - $ LDR ) - JWORK = ITAU + MNOBRN - CALL DLASET( 'Lower', MNOBRN-1, MNOBRN, ZERO, ZERO, R(2,1), - $ LDR ) - CALL MB03OD( 'QR', MNOBRN, MNOBRN, R, LDR, IWORK, TOLL, - $ SVLMAX, DWORK(ITAU), RANKM, SVAL, DWORK(JWORK), - $ LDWORK-JWORK+1, IERR ) - MAXWRK = MAX( MAXWRK, INT( DWORK(JWORK) ) + JWORK - 1 ) -C -C Workspace: need d*N+M*NOBR+N+N+L; -C prefer d*N+M*NOBR+N+(N+L)*NB. -C - CALL DORMQR( 'Left', 'Transpose', MNOBRN, NPL, MNOBRN, - $ R, LDR, DWORK(ITAU), R(1,NR4MN), LDR, - $ DWORK(JWORK), LDWORK-JWORK+1, IERR ) - MAXWRK = MAX( MAXWRK, INT( DWORK(JWORK) ) + JWORK - 1 ) - END IF -C - IF ( WITHCO ) THEN -C -C The residual (transposed) of the least squares solution -C (multiplied by a matrix with orthogonal columns) is stored -C in the rows RANKM+1:(2*m+L)*s+L of V, and it should be -C squared-up for getting the covariance matrices. (Generically, -C RANKM = m*s+n.) -C - RNRM = ONE/DBLE( NSMPL ) - IF ( MOESP ) THEN - CALL DSYRK( 'Upper', 'Transpose', NPL, LMMNOL-RANKM, RNRM, - $ R(RANKM+1,NR4MN), LDR, ZERO, R, LDR ) - CALL DLACPY( 'Upper', N, N, R, LDR, Q, LDQ ) - CALL DLACPY( 'Full', N, L, R(1,N+1), LDR, S, LDS ) - CALL DLACPY( 'Upper', L, L, R(N+1,N+1), LDR, RY, LDRY ) - ELSE - CALL DSYRK( 'Upper', 'Transpose', NPL, LMMNOL-RANKM, RNRM, - $ R(RANKM+1,NR4MN), LDR, ZERO, DWORK(JWORK), NPL ) - CALL DLACPY( 'Upper', N, N, DWORK(JWORK), NPL, Q, LDQ ) - CALL DLACPY( 'Full', N, L, DWORK(JWORK+N*NPL), NPL, S, - $ LDS ) - CALL DLACPY( 'Upper', L, L, DWORK(JWORK+N*(NPL+1)), NPL, RY, - $ LDRY ) - END IF - CALL MA02ED( 'Upper', N, Q, LDQ ) - CALL MA02ED( 'Upper', L, RY, LDRY ) -C -C Check the magnitude of the residual. -C - RNRM = DLANGE( '1-norm', LMMNOL-RANKM, NPL, R(RANKM+1,NR4MN), - $ LDR, DWORK(JWORK) ) - IF ( RNRM.LT.THRESH ) - $ IWARN = 5 - END IF -C - IF ( N4SID ) THEN - IF ( .NOT.FULLR ) THEN - IWARN = 4 -C -C Compute part of the solution of the least squares problem, -C M*V = N, for the rank-deficient problem. -C Remark: this computation should not be performed before the -C symmetric updating operation above. -C Workspace: need M*NOBR+3*N+L; -C prefer larger. -C - CALL MB03OD( 'No QR', N, N, R(NR2,NR2), LDR, IWORK, TOLL1, - $ SVLMAX, DWORK(ITAU), RANKM, SVAL, DWORK(JWORK), - $ LDWORK-JWORK+1, IERR ) - CALL MB02QY( N, N, NPL, RANKM, R(NR2,NR2), LDR, IWORK, - $ R(NR2,NR4MN), LDR, DWORK(ITAU+MNOBR), - $ DWORK(JWORK), LDWORK-JWORK+1, INFO ) - MAXWRK = MAX( MAXWRK, INT( DWORK(JWORK) ) + JWORK - 1 ) - JWORK = ITAU - IF ( M.GT.0 .AND. WITHB ) - $ CALL DLACPY( 'Full', LNOBR, N, R(NR4,1), LDR, R(NR2,1), - $ LDR ) - END IF -C - IF ( WITHC ) THEN -C -C Obtain A and C, noting that block-permutations have been -C implicitly used. -C - CALL MA02AD( 'Full', N, N, R(NR2,NR4MN), LDR, A, LDA ) - CALL MA02AD( 'Full', N, L, R(NR2,NR4MN+N), LDR, C, LDC ) - ELSE -C -C Use the given A and C. -C - CALL MA02AD( 'Full', N, N, A, LDA, R(NR2,NR4MN), LDR ) - CALL MA02AD( 'Full', L, N, C, LDC, R(NR2,NR4MN+N), LDR ) - END IF -C - IF ( M.GT.0 .AND. WITHB ) THEN -C -C Obtain B and D. -C First, compute the transpose of the matrix K as -C N(1:m*s,:) - M(1:m*s,m*s+1:m*s+n)*[A' C'], in the first -C m*s rows of R(1,NR4MN). -C - CALL DGEMM ( 'NoTranspose', 'NoTranspose', MNOBR, NPL, N, - $ -ONE, R(1,NR2), LDR, R(NR2,NR4MN), LDR, ONE, - $ R(1,NR4MN), LDR ) -C -C Denote M = pinv(GaL) and construct -C -C [ [ A ] -1 ] [ R ] -C and L = [ [ ] R 0 ] Q', where Gam = Q * [ ]. -C [ [ C ] ] [ 0 ] -C -C Then, solve the least squares problem. -C - CALL DLACPY( 'Full', N, N, A, LDA, R(NR2,NR4), LDR ) - CALL DLACPY( 'Full', L, N, C, LDC, R(NR2+N,NR4), LDR ) - CALL DTRSM( 'Right', 'Upper', 'NoTranspose', 'NonUnit', - $ NPL, N, ONE, R(NR2,1), LDR, R(NR2,NR4), LDR ) - CALL DLASET( 'Full', NPL, LNOBRN, ZERO, ZERO, R(NR2,NR4+N), - $ LDR ) -C -C Workspace: need 2*N+L; prefer N + (N+L)*NB. -C - CALL DORMQR( 'Right', 'Transpose', NPL, LNOBR, N, R(NR2,1), - $ LDR, DWORK, R(NR2,NR4), LDR, DWORK(JWORK), - $ LDWORK-JWORK+1, IERR ) -C -C Obtain the matrix K by transposition, and find B and D. -C Workspace: need NOBR*(M*(N+L))**2+M*NOBR*(N+L)+ -C max((N+L)**2,4*M*(N+L)+1); -C prefer larger. -C - CALL MA02AD( 'Full', MNOBR, NPL, R(1,NR4MN), LDR, - $ R(NR2,NR3), LDR ) - IX = MNOBR*NPL**2*M + 1 - JWORK = IX + MNOBR*NPL - CALL IB01PX( JOBPY, NOBR, N, M, L, R, LDR, O, LDO, - $ R(NR2,NR4), LDR, R(NR4PL,NR2), LDR, R(NR2,NR3), - $ LDR, DWORK, MNOBR*NPL, DWORK(IX), B, LDB, D, - $ LDD, TOL, IWORK, DWORK(JWORK), LDWORK-JWORK+1, - $ IWARNL, INFO ) - IF ( INFO.NE.0 ) - $ RETURN - IWARN = MAX( IWARN, IWARNL ) - MAXWRK = MAX( MAXWRK, INT( DWORK(JWORK) ) + JWORK - 1 ) - RCOND4 = DWORK(JWORK+1) -C - END IF - END IF -C - 30 CONTINUE -C -C Return optimal workspace in DWORK(1) and reciprocal condition -C numbers in the next locations. -C - DWORK(1) = MAXWRK - DWORK(2) = RCOND1 - DWORK(3) = RCOND2 - DWORK(4) = RCOND3 - DWORK(5) = RCOND4 - RETURN -C -C *** Last line of IB01PD *** - END diff --git a/mex/sources/libslicot/IB01PX.f b/mex/sources/libslicot/IB01PX.f deleted file mode 100644 index cf19feb43..000000000 --- a/mex/sources/libslicot/IB01PX.f +++ /dev/null @@ -1,474 +0,0 @@ - SUBROUTINE IB01PX( JOB, NOBR, N, M, L, UF, LDUF, UN, LDUN, UL, - $ LDUL, PGAL, LDPGAL, K, LDK, R, LDR, X, B, LDB, - $ D, LDD, TOL, IWORK, DWORK, LDWORK, IWARN, - $ INFO ) -C -C SLICOT RELEASE 5.0. -C -C Copyright (c) 2002-2009 NICONET e.V. -C -C This program is free software: you can redistribute it and/or -C modify it under the terms of the GNU General Public License as -C published by the Free Software Foundation, either version 2 of -C the License, or (at your option) any later version. -C -C This program is distributed in the hope that it will be useful, -C but WITHOUT ANY WARRANTY; without even the implied warranty of -C MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the -C GNU General Public License for more details. -C -C You should have received a copy of the GNU General Public License -C along with this program. If not, see -C . -C -C PURPOSE -C -C To build and solve the least squares problem T*X = Kv, and -C estimate the matrices B and D of a linear time-invariant (LTI) -C state space model, using the solution X, and the singular -C value decomposition information and other intermediate results, -C provided by other routines. -C -C The matrix T is computed as a sum of Kronecker products, -C -C T = T + kron(Uf(:,(i-1)*m+1:i*m),N_i), for i = 1 : s, -C -C (with T initialized by zero), where Uf is the triangular -C factor of the QR factorization of the future input part (see -C SLICOT Library routine IB01ND), N_i is given by the i-th block -C row of the matrix -C -C [ Q_11 Q_12 ... Q_1,s-2 Q_1,s-1 Q_1s ] [ I_L 0 ] -C [ Q_12 Q_13 ... Q_1,s-1 Q_1s 0 ] [ ] -C N = [ Q_13 Q_14 ... Q_1s 0 0 ] * [ ], -C [ : : : : : ] [ ] -C [ Q_1s 0 ... 0 0 0 ] [ 0 GaL ] -C -C and where -C -C [ -L_1|1 ] [ M_i-1 - L_1|i ] -C Q_11 = [ ], Q_1i = [ ], i = 2:s, -C [ I_L - L_2|1 ] [ -L_2|i ] -C -C are (n+L)-by-L matrices, and GaL is built from the first n -C relevant singular vectors, GaL = Un(1:L(s-1),1:n), computed -C by IB01ND. -C -C The vector Kv is vec(K), with the matrix K defined by -C -C K = [ K_1 K_2 K_3 ... K_s ], -C -C where K_i = K(:,(i-1)*m+1:i*m), i = 1:s, is (n+L)-by-m. -C The given matrices are Uf, GaL, and -C -C [ L_1|1 ... L_1|s ] -C L = [ ], (n+L)-by-L*s, -C [ L_2|1 ... L_2|s ] -C -C M = [ M_1 ... M_s-1 ], n-by-L*(s-1), and -C K, (n+L)-by-m*s. -C -C Matrix M is the pseudoinverse of the matrix GaL, computed by -C SLICOT Library routine IB01PD. -C -C ARGUMENTS -C -C Mode Parameters -C -C JOB CHARACTER*1 -C Specifies which of the matrices B and D should be -C computed, as follows: -C = 'B': compute the matrix B, but not the matrix D; -C = 'D': compute both matrices B and D. -C -C Input/Output Parameters -C -C NOBR (input) INTEGER -C The number of block rows, s, in the input and output -C Hankel matrices processed by other routines. NOBR > 1. -C -C N (input) INTEGER -C The order of the system. NOBR > N > 0. -C -C M (input) INTEGER -C The number of system inputs. M >= 0. -C -C L (input) INTEGER -C The number of system outputs. L > 0. -C -C UF (input/output) DOUBLE PRECISION array, dimension -C ( LDUF,M*NOBR ) -C On entry, the leading M*NOBR-by-M*NOBR upper triangular -C part of this array must contain the upper triangular -C factor of the QR factorization of the future input part, -C as computed by SLICOT Library routine IB01ND. -C The strict lower triangle need not be set to zero. -C On exit, the leading M*NOBR-by-M*NOBR upper triangular -C part of this array is unchanged, and the strict lower -C triangle is set to zero. -C -C LDUF INTEGER -C The leading dimension of the array UF. -C LDUF >= MAX( 1, M*NOBR ). -C -C UN (input) DOUBLE PRECISION array, dimension ( LDUN,N ) -C The leading L*(NOBR-1)-by-N part of this array must -C contain the matrix GaL, i.e., the leading part of the -C first N columns of the matrix Un of relevant singular -C vectors. -C -C LDUN INTEGER -C The leading dimension of the array UN. -C LDUN >= L*(NOBR-1). -C -C UL (input/output) DOUBLE PRECISION array, dimension -C ( LDUL,L*NOBR ) -C On entry, the leading (N+L)-by-L*NOBR part of this array -C must contain the given matrix L. -C On exit, if M > 0, the leading (N+L)-by-L*NOBR part of -C this array is overwritten by the matrix -C [ Q_11 Q_12 ... Q_1,s-2 Q_1,s-1 Q_1s ]. -C -C LDUL INTEGER -C The leading dimension of the array UL. LDUL >= N+L. -C -C PGAL (input) DOUBLE PRECISION array, dimension -C ( LDPGAL,L*(NOBR-1) ) -C The leading N-by-L*(NOBR-1) part of this array must -C contain the pseudoinverse of the matrix GaL, computed by -C SLICOT Library routine IB01PD. -C -C LDPGAL INTEGER -C The leading dimension of the array PGAL. LDPGAL >= N. -C -C K (input) DOUBLE PRECISION array, dimension ( LDK,M*NOBR ) -C The leading (N+L)-by-M*NOBR part of this array must -C contain the given matrix K. -C -C LDK INTEGER -C The leading dimension of the array K. LDK >= N+L. -C -C R (output) DOUBLE PRECISION array, dimension ( LDR,M*(N+L) ) -C The leading (N+L)*M*NOBR-by-M*(N+L) part of this array -C contains details of the complete orthogonal factorization -C of the coefficient matrix T of the least squares problem -C which is solved for getting the system matrices B and D. -C -C LDR INTEGER -C The leading dimension of the array R. -C LDR >= MAX( 1, (N+L)*M*NOBR ). -C -C X (output) DOUBLE PRECISION array, dimension -C ( (N+L)*M*NOBR ) -C The leading M*(N+L) elements of this array contain the -C least squares solution of the system T*X = Kv. -C The remaining elements are used as workspace (to store the -C corresponding part of the vector Kv = vec(K)). -C -C B (output) DOUBLE PRECISION array, dimension ( LDB,M ) -C The leading N-by-M part of this array contains the system -C input matrix. -C -C LDB INTEGER -C The leading dimension of the array B. LDB >= N. -C -C D (output) DOUBLE PRECISION array, dimension ( LDD,M ) -C If JOB = 'D', the leading L-by-M part of this array -C contains the system input-output matrix. -C If JOB = 'B', this array is not referenced. -C -C LDD INTEGER -C The leading dimension of the array D. -C LDD >= L, if JOB = 'D'; -C LDD >= 1, if JOB = 'B'. -C -C Tolerances -C -C TOL DOUBLE PRECISION -C The tolerance to be used for estimating the rank of -C matrices. If the user sets TOL > 0, then the given value -C of TOL is used as a lower bound for the reciprocal -C condition number; an m-by-n matrix whose estimated -C condition number is less than 1/TOL is considered to -C be of full rank. If the user sets TOL <= 0, then an -C implicitly computed, default tolerance, defined by -C TOLDEF = m*n*EPS, is used instead, where EPS is the -C relative machine precision (see LAPACK Library routine -C DLAMCH). -C -C Workspace -C -C IWORK INTEGER array, dimension ( M*(N+L) ) -C -C DWORK DOUBLE PRECISION array, dimension ( LDWORK ) -C On exit, if INFO = 0, DWORK(1) returns the optimal value -C of LDWORK, and, if M > 0, DWORK(2) contains the -C reciprocal condition number of the triangular factor of -C the matrix T. -C On exit, if INFO = -26, DWORK(1) returns the minimum -C value of LDWORK. -C -C LDWORK INTEGER -C The length of the array DWORK. -C LDWORK >= MAX( (N+L)*(N+L), 4*M*(N+L)+1 ). -C For good performance, LDWORK should be larger. -C -C Warning Indicator -C -C IWARN INTEGER -C = 0: no warning; -C = 4: the least squares problem to be solved has a -C rank-deficient coefficient matrix. -C -C Error Indicator -C -C INFO INTEGER -C = 0: successful exit; -C < 0: if INFO = -i, the i-th argument had an illegal -C value. -C -C METHOD -C -C The matrix T is computed, evaluating the sum of Kronecker -C products, and then the linear system T*X = Kv is solved in a -C least squares sense. The matrices B and D are then directly -C obtained from the least squares solution. -C -C REFERENCES -C -C [1] Verhaegen M., and Dewilde, P. -C Subspace Model Identification. Part 1: The output-error -C state-space model identification class of algorithms. -C Int. J. Control, 56, pp. 1187-1210, 1992. -C -C [2] Van Overschee, P., and De Moor, B. -C N4SID: Two Subspace Algorithms for the Identification -C of Combined Deterministic-Stochastic Systems. -C Automatica, Vol.30, No.1, pp. 75-93, 1994. -C -C [3] Van Overschee, P. -C Subspace Identification : Theory - Implementation - -C Applications. -C Ph. D. Thesis, Department of Electrical Engineering, -C Katholieke Universiteit Leuven, Belgium, Feb. 1995. -C -C NUMERICAL ASPECTS -C -C The implemented method is numerically stable. -C -C CONTRIBUTOR -C -C V. Sima, Katholieke Universiteit Leuven, Feb. 2000. -C -C REVISIONS -C -C V. Sima, Katholieke Universiteit Leuven, Sep. 2001. -C -C KEYWORDS -C -C Identification methods; least squares solutions; multivariable -C systems; QR decomposition; singular value decomposition. -C -C ****************************************************************** -C -C .. Parameters .. - DOUBLE PRECISION ZERO, ONE - PARAMETER ( ZERO = 0.0D0, ONE = 1.0D0 ) -C .. Scalar Arguments .. - DOUBLE PRECISION TOL - INTEGER INFO, IWARN, L, LDB, LDD, LDK, LDPGAL, LDR, - $ LDUF, LDUL, LDUN, LDWORK, M, N, NOBR - CHARACTER JOB -C .. Array Arguments .. - DOUBLE PRECISION B(LDB, *), D(LDD, *), DWORK(*), K(LDK, *), - $ PGAL(LDPGAL, *), R(LDR, *), UF(LDUF, *), - $ UL(LDUL, *), UN(LDUN, *), X(*) - INTEGER IWORK( * ) -C .. Local Scalars .. - DOUBLE PRECISION RCOND, TOLL - INTEGER I, IERR, J, JWORK, LDUN2, LNOBR, LP1, MAXWRK, - $ MINWRK, MKRON, MNOBR, NKRON, NP1, NPL, RANK - LOGICAL WITHB, WITHD -C .. External Functions .. - LOGICAL LSAME - DOUBLE PRECISION DLAMCH - EXTERNAL DLAMCH, LSAME -C .. External Subroutines .. - EXTERNAL DGELSY, DGEMM, DLACPY, DLASET, DTRCON, MB01VD, - $ XERBLA -C .. Intrinsic Functions .. - INTRINSIC MAX -C .. Executable Statements .. -C -C Decode the scalar input parameters. -C - WITHD = LSAME( JOB, 'D' ) - WITHB = LSAME( JOB, 'B' ) .OR. WITHD - MNOBR = M*NOBR - LNOBR = L*NOBR - LDUN2 = LNOBR - L - LP1 = L + 1 - NP1 = N + 1 - NPL = N + L - IWARN = 0 - INFO = 0 -C -C Check the scalar input parameters. -C - IF( .NOT.WITHB ) THEN - INFO = -1 - ELSE IF( NOBR.LE.1 ) THEN - INFO = -2 - ELSE IF( N.GE.NOBR .OR. N.LE.0 ) THEN - INFO = -3 - ELSE IF( M.LT.0 ) THEN - INFO = -4 - ELSE IF( L.LE.0 ) THEN - INFO = -5 - ELSE IF( LDUF.LT.MAX( 1, MNOBR ) ) THEN - INFO = -7 - ELSE IF( LDUN.LT.LDUN2 ) THEN - INFO = -9 - ELSE IF( LDUL.LT.NPL ) THEN - INFO = -11 - ELSE IF( LDPGAL.LT.N ) THEN - INFO = -13 - ELSE IF( LDK.LT.NPL ) THEN - INFO = -15 - ELSE IF( LDR.LT.MAX( 1, MNOBR*NPL ) ) THEN - INFO = -17 - ELSE IF( LDB.LT.N ) THEN - INFO = -20 - ELSE IF( LDD.LT.1 .OR. ( WITHD .AND. LDD.LT.L ) ) THEN - INFO = -22 - ELSE -C -C Compute workspace. -C (Note: Comments in the code beginning "Workspace:" describe the -C minimal amount of workspace needed at that point in the code, -C as well as the preferred amount for good performance. -C NB refers to the optimal block size for the immediately -C following subroutine, as returned by ILAENV.) -C - MINWRK = MAX( NPL*NPL, 4*M*NPL + 1 ) -C - IF ( LDWORK.LT.MINWRK ) THEN - INFO = -26 - DWORK( 1 ) = MINWRK - END IF - END IF -C -C Return if there are illegal arguments. -C - IF( INFO.NE.0 ) THEN - CALL XERBLA( 'IB01PX', -INFO ) - RETURN - END IF -C -C Quick return if possible. -C - IF( M.EQ.0 ) THEN - DWORK(1) = ONE - RETURN - END IF -C -C Construct the matrix [ Q_11 Q_12 ... Q_1,s-1 Q_1s ] in UL. -C - DO 20 J = 1, L -C - DO 10 I = 1, NPL - UL(I,J) = -UL(I,J) - 10 CONTINUE -C - UL(N+J,J) = ONE + UL(N+J,J) - 20 CONTINUE -C - DO 50 J = LP1, LNOBR -C - DO 30 I = 1, N - UL(I,J) = PGAL(I,J-L) - UL(I,J) - 30 CONTINUE -C - DO 40 I = NP1, NPL - UL(I,J) = -UL(I,J) - 40 CONTINUE -C - 50 CONTINUE -C -C Compute the coefficient matrix T using Kronecker products. -C Workspace: (N+L)*(N+L). -C In the same loop, vectorize K in X. -C - CALL DLASET( 'Full', MNOBR*NPL, M*NPL, ZERO, ZERO, R, LDR ) - CALL DLASET( 'Lower', MNOBR-1, MNOBR-1, ZERO, ZERO, UF(2,1), - $ LDUF ) - JWORK = NPL*L + 1 -C - DO 60 I = 1, NOBR - CALL DLACPY( 'Full', NPL, L, UL(1,(I-1)*L+1), LDUL, DWORK, - $ NPL ) - IF ( I.LT.NOBR ) THEN - CALL DGEMM ( 'NoTranspose', 'NoTranspose', NPL, N, - $ L*(NOBR-I), ONE, UL(1,I*L+1), LDUL, UN, LDUN, - $ ZERO, DWORK(JWORK), NPL ) - ELSE - CALL DLASET( 'Full', NPL, N, ZERO, ZERO, DWORK(JWORK), NPL ) - END IF - CALL MB01VD( 'NoTranspose', 'NoTranspose', MNOBR, M, NPL, - $ NPL, ONE, ONE, UF(1,(I-1)*M+1), LDUF, DWORK, - $ NPL, R, LDR, MKRON, NKRON, IERR ) - CALL DLACPY( 'Full', NPL, M, K(1,(I-1)*M+1), LDK, - $ X((I-1)*NKRON+1), NPL ) - 60 CONTINUE -C -C Compute the tolerance. -C - TOLL = TOL - IF( TOLL.LE.ZERO ) - $ TOLL = MKRON*NKRON*DLAMCH( 'Precision' ) -C -C Solve the least square problem T*X = vec(K). -C Workspace: need 4*M*(N+L)+1; -C prefer 3*M*(N+L)+(M*(N+L)+1)*NB. -C - DO 70 I = 1, NKRON - IWORK(I) = 0 - 70 CONTINUE -C - CALL DGELSY( MKRON, NKRON, 1, R, LDR, X, MKRON, IWORK, TOLL, RANK, - $ DWORK, LDWORK, IERR ) - MAXWRK = DWORK(1) -C -C Compute the reciprocal of the condition number of the triangular -C factor R of T. -C Workspace: need 3*M*(N+L). -C - CALL DTRCON( '1-norm', 'Upper', 'NonUnit', NKRON, R, LDR, RCOND, - $ DWORK, IWORK, IERR ) -C - IF ( RANK.LT.NKRON ) THEN -C -C The least squares problem is rank-deficient. -C - IWARN = 4 - END IF -C -C Construct the matrix D, if needed. -C - IF ( WITHD ) - $ CALL DLACPY( 'Full', L, M, X, NPL, D, LDD ) -C -C Construct the matrix B. -C - CALL DLACPY( 'Full', N, M, X(LP1), NPL, B, LDB ) -C -C Return optimal workspace in DWORK(1) and reciprocal condition -C number in DWORK(2). -C - DWORK(1) = MAX( MINWRK, MAXWRK ) - DWORK(2) = RCOND -C - RETURN -C -C *** Last line of IB01PX *** - END diff --git a/mex/sources/libslicot/IB01PY.f b/mex/sources/libslicot/IB01PY.f deleted file mode 100644 index 4b4ff2f5e..000000000 --- a/mex/sources/libslicot/IB01PY.f +++ /dev/null @@ -1,768 +0,0 @@ - SUBROUTINE IB01PY( METH, JOB, NOBR, N, M, L, RANKR1, UL, LDUL, - $ R1, LDR1, TAU1, PGAL, LDPGAL, K, LDK, R, LDR, - $ H, LDH, B, LDB, D, LDD, TOL, IWORK, DWORK, - $ LDWORK, IWARN, INFO ) -C -C SLICOT RELEASE 5.0. -C -C Copyright (c) 2002-2009 NICONET e.V. -C -C This program is free software: you can redistribute it and/or -C modify it under the terms of the GNU General Public License as -C published by the Free Software Foundation, either version 2 of -C the License, or (at your option) any later version. -C -C This program is distributed in the hope that it will be useful, -C but WITHOUT ANY WARRANTY; without even the implied warranty of -C MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the -C GNU General Public License for more details. -C -C You should have received a copy of the GNU General Public License -C along with this program. If not, see -C . -C -C PURPOSE -C -C 1. To compute the triangular (QR) factor of the p-by-L*s -C structured matrix Q, -C -C [ Q_1s Q_1,s-1 Q_1,s-2 ... Q_12 Q_11 ] -C [ 0 Q_1s Q_1,s-1 ... Q_13 Q_12 ] -C Q = [ 0 0 Q_1s ... Q_14 Q_13 ], -C [ : : : : : ] -C [ 0 0 0 ... 0 Q_1s ] -C -C and apply the transformations to the p-by-m matrix Kexpand, -C -C [ K_1 ] -C [ K_2 ] -C Kexpand = [ K_3 ], -C [ : ] -C [ K_s ] -C -C where, for MOESP approach (METH = 'M'), p = s*(L*s-n), and -C Q_1i = u2(L*(i-1)+1:L*i,:)' is (Ls-n)-by-L, for i = 1:s, -C u2 = Un(1:L*s,n+1:L*s), K_i = K(:,(i-1)*m+1:i*m) (i = 1:s) -C is (Ls-n)-by-m, and for N4SID approach (METH = 'N'), p = s*(n+L), -C and -C -C [ -L_1|1 ] [ M_i-1 - L_1|i ] -C Q_11 = [ ], Q_1i = [ ], i = 2:s, -C [ I_L - L_2|1 ] [ -L_2|i ] -C -C are (n+L)-by-L matrices, and -C K_i = K(:,(i-1)*m+1:i*m), i = 1:s, is (n+L)-by-m. -C The given matrices are: -C For METH = 'M', u2 = Un(1:L*s,n+1:L*s), -C K(1:Ls-n,1:m*s); -C -C [ L_1|1 ... L_1|s ] -C For METH = 'N', L = [ ], (n+L)-by-L*s, -C [ L_2|1 ... L_2|s ] -C -C M = [ M_1 ... M_s-1 ], n-by-L*(s-1), and -C K, (n+L)-by-m*s. -C Matrix M is the pseudoinverse of the matrix GaL, -C built from the first n relevant singular -C vectors, GaL = Un(1:L(s-1),1:n), and computed -C by SLICOT Library routine IB01PD for METH = 'N'. -C -C Matrix Q is triangularized (in R), exploiting its structure, -C and the transformations are applied from the left to Kexpand. -C -C 2. To estimate the matrices B and D of a linear time-invariant -C (LTI) state space model, using the factor R, transformed matrix -C Kexpand, and the singular value decomposition information provided -C by other routines. -C -C IB01PY routine is intended for speed and efficient use of the -C memory space. It is generally not recommended for METH = 'N', as -C IB01PX routine can produce more accurate results. -C -C ARGUMENTS -C -C Mode Parameters -C -C METH CHARACTER*1 -C Specifies the subspace identification method to be used, -C as follows: -C = 'M': MOESP algorithm with past inputs and outputs; -C = 'N': N4SID algorithm. -C -C JOB CHARACTER*1 -C Specifies whether or not the matrices B and D should be -C computed, as follows: -C = 'B': compute the matrix B, but not the matrix D; -C = 'D': compute both matrices B and D; -C = 'N': do not compute the matrices B and D, but only the -C R factor of Q and the transformed Kexpand. -C -C Input/Output Parameters -C -C NOBR (input) INTEGER -C The number of block rows, s, in the input and output -C Hankel matrices processed by other routines. NOBR > 1. -C -C N (input) INTEGER -C The order of the system. NOBR > N > 0. -C -C M (input) INTEGER -C The number of system inputs. M >= 0. -C -C L (input) INTEGER -C The number of system outputs. L > 0. -C -C RANKR1 (input) INTEGER -C The effective rank of the upper triangular matrix r1, -C i.e., the triangular QR factor of the matrix GaL, -C computed by SLICOT Library routine IB01PD. It is also -C the effective rank of the matrix GaL. 0 <= RANKR1 <= N. -C If JOB = 'N', or M = 0, or METH = 'N', this -C parameter is not used. -C -C UL (input/workspace) DOUBLE PRECISION array, dimension -C ( LDUL,L*NOBR ) -C On entry, if METH = 'M', the leading L*NOBR-by-L*NOBR -C part of this array must contain the matrix Un of -C relevant singular vectors. The first N columns of UN -C need not be specified for this routine. -C On entry, if METH = 'N', the leading (N+L)-by-L*NOBR -C part of this array must contain the given matrix L. -C On exit, the leading LDF-by-L*(NOBR-1) part of this array -C is overwritten by the matrix F of the algorithm in [4], -C where LDF = MAX( 1, L*NOBR-N-L ), if METH = 'M'; -C LDF = N, if METH = 'N'. -C -C LDUL INTEGER -C The leading dimension of the array UL. -C LDUL >= L*NOBR, if METH = 'M'; -C LDUL >= N+L, if METH = 'N'. -C -C R1 (input) DOUBLE PRECISION array, dimension ( LDR1,N ) -C If JOB <> 'N', M > 0, METH = 'M', and RANKR1 = N, -C the leading L*(NOBR-1)-by-N part of this array must -C contain details of the QR factorization of the matrix -C GaL, as computed by SLICOT Library routine IB01PD. -C Specifically, the leading N-by-N upper triangular part -C must contain the upper triangular factor r1 of GaL, -C and the lower L*(NOBR-1)-by-N trapezoidal part, together -C with array TAU1, must contain the factored form of the -C orthogonal matrix Q1 in the QR factorization of GaL. -C If JOB = 'N', or M = 0, or METH = 'N', or METH = 'M' -C and RANKR1 < N, this array is not referenced. -C -C LDR1 INTEGER -C The leading dimension of the array R1. -C LDR1 >= L*(NOBR-1), if JOB <> 'N', M > 0, METH = 'M', -C and RANKR1 = N; -C LDR1 >= 1, otherwise. -C -C TAU1 (input) DOUBLE PRECISION array, dimension ( N ) -C If JOB <> 'N', M > 0, METH = 'M', and RANKR1 = N, -C this array must contain the scalar factors of the -C elementary reflectors used in the QR factorization of the -C matrix GaL, computed by SLICOT Library routine IB01PD. -C If JOB = 'N', or M = 0, or METH = 'N', or METH = 'M' -C and RANKR1 < N, this array is not referenced. -C -C PGAL (input) DOUBLE PRECISION array, dimension -C ( LDPGAL,L*(NOBR-1) ) -C If METH = 'N', or JOB <> 'N', M > 0, METH = 'M' and -C RANKR1 < N, the leading N-by-L*(NOBR-1) part of this -C array must contain the pseudoinverse of the matrix GaL, -C as computed by SLICOT Library routine IB01PD. -C If METH = 'M' and JOB = 'N', or M = 0, or -C RANKR1 = N, this array is not referenced. -C -C LDPGAL INTEGER -C The leading dimension of the array PGAL. -C LDPGAL >= N, if METH = 'N', or JOB <> 'N', M > 0, -C and METH = 'M' and RANKR1 < N; -C LDPGAL >= 1, otherwise. -C -C K (input/output) DOUBLE PRECISION array, dimension -C ( LDK,M*NOBR ) -C On entry, the leading (p/s)-by-M*NOBR part of this array -C must contain the given matrix K defined above. -C On exit, the leading (p/s)-by-M*NOBR part of this array -C contains the transformed matrix K. -C -C LDK INTEGER -C The leading dimension of the array K. LDK >= p/s. -C -C R (output) DOUBLE PRECISION array, dimension ( LDR,L*NOBR ) -C If JOB = 'N', or M = 0, or Q has full rank, the -C leading L*NOBR-by-L*NOBR upper triangular part of this -C array contains the R factor of the QR factorization of -C the matrix Q. -C If JOB <> 'N', M > 0, and Q has not a full rank, the -C leading L*NOBR-by-L*NOBR upper trapezoidal part of this -C array contains details of the complete orhogonal -C factorization of the matrix Q, as constructed by SLICOT -C Library routines MB03OD and MB02QY. -C -C LDR INTEGER -C The leading dimension of the array R. LDR >= L*NOBR. -C -C H (output) DOUBLE PRECISION array, dimension ( LDH,M ) -C If JOB = 'N' or M = 0, the leading L*NOBR-by-M part -C of this array contains the updated part of the matrix -C Kexpand corresponding to the upper triangular factor R -C in the QR factorization of the matrix Q. -C If JOB <> 'N', M > 0, and METH = 'N' or METH = 'M' -C and RANKR1 < N, the leading L*NOBR-by-M part of this -C array contains the minimum norm least squares solution of -C the linear system Q*X = Kexpand, from which the matrices -C B and D are found. The first NOBR-1 row blocks of X -C appear in the reverse order in H. -C If JOB <> 'N', M > 0, METH = 'M' and RANKR1 = N, the -C leading L*(NOBR-1)-by-M part of this array contains the -C matrix product Q1'*X, and the subarray -C L*(NOBR-1)+1:L*NOBR-by-M contains the corresponding -C submatrix of X, with X defined in the phrase above. -C -C LDH INTEGER -C The leading dimension of the array H. LDH >= L*NOBR. -C -C B (output) DOUBLE PRECISION array, dimension ( LDB,M ) -C If M > 0, JOB = 'B' or 'D' and INFO = 0, the leading -C N-by-M part of this array contains the system input -C matrix. -C If M = 0 or JOB = 'N', this array is not referenced. -C -C LDB INTEGER -C The leading dimension of the array B. -C LDB >= N, if M > 0 and JOB = 'B' or 'D'; -C LDB >= 1, if M = 0 or JOB = 'N'. -C -C D (output) DOUBLE PRECISION array, dimension ( LDD,M ) -C If M > 0, JOB = 'D' and INFO = 0, the leading -C L-by-M part of this array contains the system input-output -C matrix. -C If M = 0 or JOB = 'B' or 'N', this array is not -C referenced. -C -C LDD INTEGER -C The leading dimension of the array D. -C LDD >= L, if M > 0 and JOB = 'D'; -C LDD >= 1, if M = 0 or JOB = 'B' or 'N'. -C -C Tolerances -C -C TOL DOUBLE PRECISION -C The tolerance to be used for estimating the rank of -C matrices. If the user sets TOL > 0, then the given value -C of TOL is used as a lower bound for the reciprocal -C condition number; an m-by-n matrix whose estimated -C condition number is less than 1/TOL is considered to -C be of full rank. If the user sets TOL <= 0, then an -C implicitly computed, default tolerance, defined by -C TOLDEF = m*n*EPS, is used instead, where EPS is the -C relative machine precision (see LAPACK Library routine -C DLAMCH). -C This parameter is not used if M = 0 or JOB = 'N'. -C -C Workspace -C -C IWORK INTEGER array, dimension ( LIWORK ) -C where LIWORK >= 0, if JOB = 'N', or M = 0; -C LIWORK >= L*NOBR, if JOB <> 'N', and M > 0. -C -C DWORK DOUBLE PRECISION array, dimension ( LDWORK ) -C On exit, if INFO = 0, DWORK(1) returns the optimal value -C of LDWORK, and, if JOB <> 'N', and M > 0, DWORK(2) -C contains the reciprocal condition number of the triangular -C factor of the matrix R. -C On exit, if INFO = -28, DWORK(1) returns the minimum -C value of LDWORK. -C -C LDWORK INTEGER -C The length of the array DWORK. -C LDWORK >= MAX( 2*L, L*NOBR, L+M*NOBR ), -C if JOB = 'N', or M = 0; -C LDWORK >= MAX( L+M*NOBR, L*NOBR + MAX( 3*L*NOBR+1, M ) ), -C if JOB <> 'N', and M > 0. -C For good performance, LDWORK should be larger. -C -C Warning Indicator -C -C IWARN INTEGER -C = 0: no warning; -C = 4: the least squares problem to be solved has a -C rank-deficient coefficient matrix. -C -C Error Indicator -C -C INFO INTEGER -C = 0: successful exit; -C < 0: if INFO = -i, the i-th argument had an illegal -C value; -C = 3: a singular upper triangular matrix was found. -C -C METHOD -C -C The QR factorization is computed exploiting the structure, -C as described in [4]. -C The matrices B and D are then obtained by solving certain -C linear systems in a least squares sense. -C -C REFERENCES -C -C [1] Verhaegen M., and Dewilde, P. -C Subspace Model Identification. Part 1: The output-error -C state-space model identification class of algorithms. -C Int. J. Control, 56, pp. 1187-1210, 1992. -C -C [2] Van Overschee, P., and De Moor, B. -C N4SID: Two Subspace Algorithms for the Identification -C of Combined Deterministic-Stochastic Systems. -C Automatica, Vol.30, No.1, pp. 75-93, 1994. -C -C [3] Van Overschee, P. -C Subspace Identification : Theory - Implementation - -C Applications. -C Ph. D. Thesis, Department of Electrical Engineering, -C Katholieke Universiteit Leuven, Belgium, Feb. 1995. -C -C [4] Sima, V. -C Subspace-based Algorithms for Multivariable System -C Identification. -C Studies in Informatics and Control, 5, pp. 335-344, 1996. -C -C NUMERICAL ASPECTS -C -C The implemented method for computing the triangular factor and -C updating Kexpand is numerically stable. -C -C FURTHER COMMENTS -C -C The computed matrices B and D are not the least squares solutions -C delivered by either MOESP or N4SID algorithms, except for the -C special case n = s - 1, L = 1. However, the computed B and D are -C frequently good enough estimates, especially for METH = 'M'. -C Better estimates could be obtained by calling SLICOT Library -C routine IB01PX, but it is less efficient, and requires much more -C workspace. -C -C CONTRIBUTOR -C -C V. Sima, Research Institute for Informatics, Bucharest, Oct. 1999. -C -C REVISIONS -C -C Feb. 2000, Sep. 2001, March 2005. -C -C KEYWORDS -C -C Identification methods; least squares solutions; multivariable -C systems; QR decomposition; singular value decomposition. -C -C ****************************************************************** -C -C .. Parameters .. - DOUBLE PRECISION ZERO, ONE, TWO, THREE - PARAMETER ( ZERO = 0.0D0, ONE = 1.0D0, TWO = 2.0D0, - $ THREE = 3.0D0 ) -C .. Scalar Arguments .. - DOUBLE PRECISION TOL - INTEGER INFO, IWARN, L, LDB, LDD, LDH, LDK, LDPGAL, - $ LDR, LDR1, LDUL, LDWORK, M, N, NOBR, RANKR1 - CHARACTER JOB, METH -C .. Array Arguments .. - DOUBLE PRECISION B(LDB, *), D(LDD, *), DWORK(*), H(LDH, *), - $ K(LDK, *), PGAL(LDPGAL, *), R(LDR, *), - $ R1(LDR1, *), TAU1(*), UL(LDUL, *) - INTEGER IWORK( * ) -C .. Local Scalars .. - DOUBLE PRECISION EPS, RCOND, SVLMAX, THRESH, TOLL - INTEGER I, IERR, ITAU, J, JI, JL, JM, JWORK, LDUN2, - $ LNOBR, LP1, MAXWRK, MINWRK, MNOBR, NOBRH, - $ NROW, NROWML, RANK - LOGICAL MOESP, N4SID, WITHB, WITHD -C .. Local Array .. - DOUBLE PRECISION SVAL(3) -C .. External Functions .. - LOGICAL LSAME - INTEGER ILAENV - DOUBLE PRECISION DLAMCH - EXTERNAL DLAMCH, ILAENV, LSAME -C .. External Subroutines .. - EXTERNAL DGEMM, DGEQRF, DLACPY, DLASET, DORMQR, DSWAP, - $ DTRCON, DTRSM, DTRTRS, MA02AD, MB02QY, MB03OD, - $ MB04OD, MB04OY, XERBLA -C .. Intrinsic Functions .. - INTRINSIC INT, MAX, MOD -C .. Executable Statements .. -C -C Decode the scalar input parameters. -C - MOESP = LSAME( METH, 'M' ) - N4SID = LSAME( METH, 'N' ) - WITHD = LSAME( JOB, 'D' ) - WITHB = LSAME( JOB, 'B' ) .OR. WITHD - MNOBR = M*NOBR - LNOBR = L*NOBR - LDUN2 = LNOBR - L - LP1 = L + 1 - IF ( MOESP ) THEN - NROW = LNOBR - N - ELSE - NROW = N + L - END IF - NROWML = NROW - L - IWARN = 0 - INFO = 0 -C -C Check the scalar input parameters. -C - IF( .NOT.( MOESP .OR. N4SID ) ) THEN - INFO = -1 - ELSE IF( .NOT.( WITHB .OR. LSAME( JOB, 'N' ) ) ) THEN - INFO = -2 - ELSE IF( NOBR.LE.1 ) THEN - INFO = -3 - ELSE IF( N.GE.NOBR .OR. N.LE.0 ) THEN - INFO = -4 - ELSE IF( M.LT.0 ) THEN - INFO = -5 - ELSE IF( L.LE.0 ) THEN - INFO = -6 - ELSE IF( ( MOESP .AND. WITHB .AND. M.GT.0 ) .AND. - $ ( RANKR1.LT.ZERO .OR. RANKR1.GT.N ) ) THEN - INFO = -7 - ELSE IF( ( MOESP .AND. LDUL.LT.LNOBR ) .OR. - $ ( N4SID .AND. LDUL.LT.NROW ) ) THEN - INFO = -9 - ELSE IF( LDR1.LT.1 .OR. ( M.GT.0 .AND. WITHB .AND. MOESP .AND. - $ LDR1.LT.LDUN2 .AND. RANKR1.EQ.N ) ) THEN - INFO = -11 - ELSE IF( LDPGAL.LT.1 .OR. - $ ( LDPGAL.LT.N .AND. ( N4SID .OR. ( WITHB .AND. M.GT.0 - $ .AND. ( MOESP .AND. RANKR1.LT.N ) ) ) ) ) - $ THEN - INFO = -14 - ELSE IF( LDK.LT.NROW ) THEN - INFO = -16 - ELSE IF( LDR.LT.LNOBR ) THEN - INFO = -18 - ELSE IF( LDH.LT.LNOBR ) THEN - INFO = -20 - ELSE IF( LDB.LT.1 .OR. ( M.GT.0 .AND. WITHB .AND. LDB.LT.N ) ) - $ THEN - INFO = -22 - ELSE IF( LDD.LT.1 .OR. ( M.GT.0 .AND. WITHD .AND. LDD.LT.L ) ) - $ THEN - INFO = -24 - ELSE -C -C Compute workspace. -C (Note: Comments in the code beginning "Workspace:" describe the -C minimal amount of workspace needed at that point in the code, -C as well as the preferred amount for good performance. -C NB refers to the optimal block size for the immediately -C following subroutine, as returned by ILAENV.) -C - MINWRK = MAX( 2*L, LNOBR, L + MNOBR ) - MAXWRK = MINWRK - MAXWRK = MAX( MAXWRK, L + L*ILAENV( 1, 'DGEQRF', ' ', NROW, L, - $ -1, -1 ) ) - MAXWRK = MAX( MAXWRK, L + LDUN2*ILAENV( 1, 'DORMQR', 'LT', - $ NROW, LDUN2, L, -1 ) ) - MAXWRK = MAX( MAXWRK, L + MNOBR*ILAENV( 1, 'DORMQR', 'LT', - $ NROW, MNOBR, L, -1 ) ) -C - IF( M.GT.0 .AND. WITHB ) THEN - MINWRK = MAX( MINWRK, 4*LNOBR+1, LNOBR + M ) - MAXWRK = MAX( MINWRK, MAXWRK, LNOBR + - $ M*ILAENV( 1, 'DORMQR', 'LT', LNOBR, M, LNOBR, - $ -1 ) ) - END IF -C - IF ( LDWORK.LT.MINWRK ) THEN - INFO = -28 - DWORK( 1 ) = MINWRK - END IF - END IF -C -C Return if there are illegal arguments. -C - IF( INFO.NE.0 ) THEN - CALL XERBLA( 'IB01PY', -INFO ) - RETURN - END IF -C -C Construct in R the first block-row of Q, i.e., the -C (p/s)-by-L*s matrix [ Q_1s ... Q_12 Q_11 ], where -C Q_1i, defined above, is (p/s)-by-L, for i = 1:s. -C - IF ( MOESP ) THEN -C - DO 10 I = 1, NOBR - CALL MA02AD( 'Full', L, NROW, UL(L*(I-1)+1,N+1), LDUL, - $ R(1,L*(NOBR-I)+1), LDR ) - 10 CONTINUE -C - ELSE - JL = LNOBR - JM = LDUN2 -C - DO 50 JI = 1, LDUN2, L -C - DO 40 J = JI + L - 1, JI, -1 -C - DO 20 I = 1, N - R(I,J) = PGAL(I,JM) - UL(I,JL) - 20 CONTINUE -C - DO 30 I = N + 1, NROW - R(I,J) = -UL(I,JL) - 30 CONTINUE -C - JL = JL - 1 - JM = JM - 1 - 40 CONTINUE -C - 50 CONTINUE -C - DO 70 J = LNOBR, LDUN2 + 1, -1 -C - DO 60 I = 1, NROW - R(I,J) = -UL(I,JL) - 60 CONTINUE -C - JL = JL - 1 - R(N+J-LDUN2,J) = ONE + R(N+J-LDUN2,J) - 70 CONTINUE - END IF -C -C Triangularize the submatrix Q_1s using an orthogonal matrix S. -C Workspace: need 2*L, prefer L+L*NB. -C - ITAU = 1 - JWORK = ITAU + L -C - CALL DGEQRF( NROW, L, R, LDR, DWORK(ITAU), DWORK(JWORK), - $ LDWORK-JWORK+1, IERR ) -C -C Apply the transformation S' to the matrix -C [ Q_1,s-1 ... Q_11 ]. Therefore, -C -C [ R P_s-1 P_s-2 ... P_2 P_1 ] -C S'[ Q_1,s ... Q_11 ] = [ ]. -C [ 0 F_s-1 F_s-2 ... F_2 F_1 ] -C -C Workspace: need L*NOBR, prefer L+(L*NOBR-L)*NB. -C - CALL DORMQR( 'Left', 'Transpose', NROW, LDUN2, L, R, LDR, - $ DWORK(ITAU), R(1,LP1), LDR, DWORK(JWORK), - $ LDWORK-JWORK+1, IERR ) -C -C Apply the transformation S' to each of the submatrices K_i of -C Kexpand = [ K_1' K_2' ... K_s' ]', K_i = K(:,(i-1)*m+1:i*m) -C (i = 1:s) being (p/s)-by-m. Denote ( H_i' G_i' )' = S'K_i -C (i = 1:s), where H_i has L rows. -C Finally, H_i is saved in H(L*(i-1)+1:L*i,1:m), i = 1:s. -C (G_i is in K(L+1:p/s,(i-1)*m+1:i*m), i = 1:s.) -C Workspace: need L+M*NOBR, prefer L+M*NOBR*NB. -C - CALL DORMQR( 'Left', 'Transpose', NROW, MNOBR, L, R, LDR, - $ DWORK(ITAU), K, LDK, DWORK(JWORK), LDWORK-JWORK+1, - $ IERR ) -C -C Put the rows to be annihilated (matrix F) in UL(1:p/s-L,1:L*s-L). -C - CALL DLACPY( 'Full', NROWML, LDUN2, R(LP1,LP1), LDR, UL, LDUL ) -C -C Now, the structure of the transformed matrices is: -C -C [ R P_s-1 P_s-2 ... P_2 P_1 ] [ H_1 ] -C [ 0 R P_s-1 ... P_3 P_2 ] [ H_2 ] -C [ 0 0 R ... P_4 P_3 ] [ H_3 ] -C [ : : : : : ] [ : ] -C [ 0 0 0 ... R P_s-1 ] [ H_s-1 ] -C Q = [ 0 0 0 ... 0 R ], Kexpand = [ H_s ], -C [ 0 F_s-1 F_s-2 ... F_2 F_1 ] [ G_1 ] -C [ 0 0 F_s-1 ... F_3 F_2 ] [ G_2 ] -C [ : : : : : ] [ : ] -C [ 0 0 0 ... 0 F_s-1 ] [ G_s-1 ] -C [ 0 0 0 ... 0 0 ] [ G_s ] -C -C where the block-rows have been permuted, to better exploit the -C structure. The block-rows having R on the diagonal are dealt -C with successively in the array R. -C The F submatrices are stored in the array UL, as a block-row. -C -C Copy H_1 in H(1:L,1:m). -C - CALL DLACPY( 'Full', L, M, K, LDK, H, LDH ) -C -C Triangularize the transformed matrix exploiting its structure. -C Workspace: need L+MAX(L-1,L*NOBR-2*L,M*(NOBR-1)). -C - DO 90 I = 1, NOBR - 1 -C -C Copy part of the preceding block-row and then annihilate the -C current submatrix F_s-i using an orthogonal matrix modifying -C the corresponding submatrix R. Simultaneously, apply the -C transformation to the corresponding block-rows of the matrices -C R and F. -C - CALL DLACPY( 'Upper', L, LNOBR-L*I, R(L*(I-1)+1,L*(I-1)+1), - $ LDR, R(L*I+1,L*I+1), LDR ) - CALL MB04OD( 'Full', L, LNOBR-L*(I+1), NROWML, R(L*I+1,L*I+1), - $ LDR, UL(1,L*(I-1)+1), LDUL, R(L*I+1,L*(I+1)+1), - $ LDR, UL(1,L*I+1), LDUL, DWORK(ITAU), DWORK(JWORK) - $ ) -C -C Apply the transformation to the corresponding block-rows of -C the matrix G and copy H_(i+1) in H(L*i+1:L*(i+1),1:m). -C - DO 80 J = 1, L - CALL MB04OY( NROWML, M*(NOBR-I), UL(1,L*(I-1)+J), DWORK(J), - $ K(J,M*I+1), LDK, K(LP1,1), LDK, DWORK(JWORK) ) - 80 CONTINUE -C - CALL DLACPY( 'Full', L, M, K(1,M*I+1), LDK, H(L*I+1,1), LDH ) - 90 CONTINUE -C -C Return if only the factorization is needed. -C - IF( M.EQ.0 .OR. .NOT.WITHB ) THEN - DWORK(1) = MAXWRK - RETURN - END IF -C -C Set the precision parameters. A threshold value EPS**(2/3) is -C used for deciding to use pivoting or not, where EPS is the -C relative machine precision (see LAPACK Library routine DLAMCH). -C - EPS = DLAMCH( 'Precision' ) - THRESH = EPS**( TWO/THREE ) - TOLL = TOL - IF( TOLL.LE.ZERO ) - $ TOLL = LNOBR*LNOBR*EPS - SVLMAX = ZERO -C -C Compute the reciprocal of the condition number of the triangular -C factor R of Q. -C Workspace: need 3*L*NOBR. -C - CALL DTRCON( '1-norm', 'Upper', 'NonUnit', LNOBR, R, LDR, RCOND, - $ DWORK, IWORK, IERR ) -C - IF ( RCOND.GT.MAX( TOLL, THRESH ) ) THEN -C -C The triangular factor R is considered to be of full rank. -C Solve for X, R*X = H. -C - CALL DTRSM( 'Left', 'Upper', 'NoTranspose', 'Non-unit', - $ LNOBR, M, ONE, R, LDR, H, LDH ) - ELSE -C -C Rank-deficient triangular factor R. Compute the -C minimum-norm least squares solution of R*X = H using -C the complete orthogonal factorization of R. -C - DO 100 I = 1, LNOBR - IWORK(I) = 0 - 100 CONTINUE -C -C Workspace: need 4*L*NOBR+1; -C prefer 3*L*NOBR+(L*NOBR+1)*NB. -C - JWORK = ITAU + LNOBR - CALL DLASET( 'Lower', LNOBR-1, LNOBR, ZERO, ZERO, R(2,1), LDR ) - CALL MB03OD( 'QR', LNOBR, LNOBR, R, LDR, IWORK, TOLL, SVLMAX, - $ DWORK(ITAU), RANK, SVAL, DWORK(JWORK), - $ LDWORK-JWORK+1, IERR ) - MAXWRK = MAX( MAXWRK, INT( DWORK(JWORK) ) + JWORK - 1 ) -C -C Workspace: need L*NOBR+M; prefer L*NOBR+M*NB. -C - CALL DORMQR( 'Left', 'Transpose', LNOBR, M, LNOBR, R, LDR, - $ DWORK(ITAU), H, LDH, DWORK(JWORK), LDWORK-JWORK+1, - $ IERR ) - IF ( RANK.LT.LNOBR ) THEN -C -C The least squares problem is rank-deficient. -C - IWARN = 4 - END IF -C -C Workspace: need L*NOBR+max(L*NOBR,M); prefer larger. -C - CALL MB02QY( LNOBR, LNOBR, M, RANK, R, LDR, IWORK, H, LDH, - $ DWORK(ITAU), DWORK(JWORK), LDWORK-JWORK+1, IERR ) - MAXWRK = MAX( MAXWRK, INT( DWORK(JWORK) ) + JWORK - 1 ) - END IF -C -C Construct the matrix D, if needed. -C - IF ( WITHD ) - $ CALL DLACPY( 'Full', L, M, H(LDUN2+1,1), LDH, D, LDD ) -C -C Compute B by solving another linear system (possibly in -C a least squares sense). -C -C Make a block-permutation of the rows of the right-hand side, H, -C to construct the matrix -C -C [ H(L*(s-2)+1:L*(s-1),:); ... H(L+1:L*2,:); H(1:L),:) ] -C -C in H(1:L*s-L,1:n). -C - NOBRH = NOBR/2 + MOD( NOBR, 2 ) - 1 -C - DO 120 J = 1, M -C - DO 110 I = 1, NOBRH - CALL DSWAP( L, H(L*(I-1)+1,J), 1, H(L*(NOBR-I-1)+1,J), 1 ) - 110 CONTINUE -C - 120 CONTINUE -C -C Solve for B the matrix equation GaL*B = H(1:L*s-L,:), using -C the available QR factorization of GaL, if METH = 'M' and -C rank(GaL) = n, or the available pseudoinverse of GaL, otherwise. -C - IF ( MOESP .AND. RANKR1.EQ.N ) THEN -C -C The triangular factor r1 of GaL is considered to be of -C full rank. Compute Q1'*H in H and then solve for B, -C r1*B = H(1:n,:) in B, where Q1 is the orthogonal matrix -C in the QR factorization of GaL. -C Workspace: need M; prefer M*NB. -C - CALL DORMQR( 'Left', 'Transpose', LDUN2, M, N, R1, LDR1, - $ TAU1, H, LDH, DWORK, LDWORK, IERR ) - MAXWRK = MAX( MAXWRK, INT( DWORK(1) ) ) -C -C Compute the solution in B. -C - CALL DLACPY( 'Full', N, M, H, LDH, B, LDB ) -C - CALL DTRTRS( 'Upper', 'NoTranspose', 'NonUnit', N, M, R1, LDR1, - $ B, LDB, IERR ) - IF ( IERR.GT.0 ) THEN - INFO = 3 - RETURN - END IF - ELSE -C -C Rank-deficient triangular factor r1. Use the available -C pseudoinverse of GaL for computing B from GaL*B = H. -C - CALL DGEMM ( 'NoTranspose', 'NoTranspose', N, M, LDUN2, ONE, - $ PGAL, LDPGAL, H, LDH, ZERO, B, LDB ) - END IF -C -C Return optimal workspace in DWORK(1) and reciprocal condition -C number in DWORK(2). -C - DWORK(1) = MAXWRK - DWORK(2) = RCOND -C - RETURN -C -C *** Last line of IB01PY *** - END diff --git a/mex/sources/libslicot/IB01QD.f b/mex/sources/libslicot/IB01QD.f deleted file mode 100644 index 93bf15663..000000000 --- a/mex/sources/libslicot/IB01QD.f +++ /dev/null @@ -1,1081 +0,0 @@ - SUBROUTINE IB01QD( JOBX0, JOB, N, M, L, NSMP, A, LDA, C, LDC, U, - $ LDU, Y, LDY, X0, B, LDB, D, LDD, TOL, IWORK, - $ DWORK, LDWORK, IWARN, INFO ) -C -C SLICOT RELEASE 5.0. -C -C Copyright (c) 2002-2009 NICONET e.V. -C -C This program is free software: you can redistribute it and/or -C modify it under the terms of the GNU General Public License as -C published by the Free Software Foundation, either version 2 of -C the License, or (at your option) any later version. -C -C This program is distributed in the hope that it will be useful, -C but WITHOUT ANY WARRANTY; without even the implied warranty of -C MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the -C GNU General Public License for more details. -C -C You should have received a copy of the GNU General Public License -C along with this program. If not, see -C . -C -C PURPOSE -C -C To estimate the initial state and the system matrices B and D -C of a linear time-invariant (LTI) discrete-time system, given the -C matrix pair (A,C) and the input and output trajectories of the -C system. The model structure is : -C -C x(k+1) = Ax(k) + Bu(k), k >= 0, -C y(k) = Cx(k) + Du(k), -C -C where x(k) is the n-dimensional state vector (at time k), -C u(k) is the m-dimensional input vector, -C y(k) is the l-dimensional output vector, -C and A, B, C, and D are real matrices of appropriate dimensions. -C Matrix A is assumed to be in a real Schur form. -C -C ARGUMENTS -C -C Mode Parameters -C -C JOBX0 CHARACTER*1 -C Specifies whether or not the initial state should be -C computed, as follows: -C = 'X': compute the initial state x(0); -C = 'N': do not compute the initial state (x(0) is known -C to be zero). -C -C JOB CHARACTER*1 -C Specifies which matrices should be computed, as follows: -C = 'B': compute the matrix B only (D is known to be zero); -C = 'D': compute the matrices B and D. -C -C Input/Output Parameters -C -C N (input) INTEGER -C The order of the system. N >= 0. -C -C M (input) INTEGER -C The number of system inputs. M >= 0. -C -C L (input) INTEGER -C The number of system outputs. L > 0. -C -C NSMP (input) INTEGER -C The number of rows of matrices U and Y (number of -C samples, t). -C NSMP >= N*M + a + e, where -C a = 0, if JOBX0 = 'N'; -C a = N, if JOBX0 = 'X'; -C e = 0, if JOBX0 = 'X' and JOB = 'B'; -C e = 1, if JOBX0 = 'N' and JOB = 'B'; -C e = M, if JOB = 'D'. -C -C A (input) DOUBLE PRECISION array, dimension (LDA,N) -C The leading N-by-N part of this array must contain the -C system state matrix A in a real Schur form. -C -C LDA INTEGER -C The leading dimension of the array A. LDA >= MAX(1,N). -C -C C (input) DOUBLE PRECISION array, dimension (LDC,N) -C The leading L-by-N part of this array must contain the -C system output matrix C (corresponding to the real Schur -C form of A). -C -C LDC INTEGER -C The leading dimension of the array C. LDC >= L. -C -C U (input/output) DOUBLE PRECISION array, dimension (LDU,M) -C On entry, the leading NSMP-by-M part of this array must -C contain the t-by-m input-data sequence matrix U, -C U = [u_1 u_2 ... u_m]. Column j of U contains the -C NSMP values of the j-th input component for consecutive -C time increments. -C On exit, if JOB = 'D', the leading NSMP-by-M part of -C this array contains details of the QR factorization of -C the t-by-m matrix U, possibly computed sequentially -C (see METHOD). -C If JOB = 'B', this array is unchanged on exit. -C If M = 0, this array is not referenced. -C -C LDU INTEGER -C The leading dimension of the array U. -C LDU >= MAX(1,NSMP), if M > 0; -C LDU >= 1, if M = 0. -C -C Y (input) DOUBLE PRECISION array, dimension (LDY,L) -C The leading NSMP-by-L part of this array must contain the -C t-by-l output-data sequence matrix Y, -C Y = [y_1 y_2 ... y_l]. Column j of Y contains the -C NSMP values of the j-th output component for consecutive -C time increments. -C -C LDY INTEGER -C The leading dimension of the array Y. LDY >= MAX(1,NSMP). -C -C X0 (output) DOUBLE PRECISION array, dimension (N) -C If JOBX0 = 'X', the estimated initial state of the -C system, x(0). -C If JOBX0 = 'N', x(0) is set to zero without any -C calculations. -C -C B (output) DOUBLE PRECISION array, dimension (LDB,M) -C If N > 0, M > 0, and INFO = 0, the leading N-by-M -C part of this array contains the system input matrix B -C in the coordinates corresponding to the real Schur form -C of A. -C If N = 0 or M = 0, this array is not referenced. -C -C LDB INTEGER -C The leading dimension of the array B. -C LDB >= N, if N > 0 and M > 0; -C LDB >= 1, if N = 0 or M = 0. -C -C D (output) DOUBLE PRECISION array, dimension (LDD,M) -C If M > 0, JOB = 'D', and INFO = 0, the leading -C L-by-M part of this array contains the system input-output -C matrix D. -C If M = 0 or JOB = 'B', this array is not referenced. -C -C LDD INTEGER -C The leading dimension of the array D. -C LDD >= L, if M > 0 and JOB = 'D'; -C LDD >= 1, if M = 0 or JOB = 'B'. -C -C Tolerances -C -C TOL DOUBLE PRECISION -C The tolerance to be used for estimating the rank of -C matrices. If the user sets TOL > 0, then the given value -C of TOL is used as a lower bound for the reciprocal -C condition number; a matrix whose estimated condition -C number is less than 1/TOL is considered to be of full -C rank. If the user sets TOL <= 0, then EPS is used -C instead, where EPS is the relative machine precision -C (see LAPACK Library routine DLAMCH). TOL <= 1. -C -C Workspace -C -C IWORK INTEGER array, dimension (LIWORK), where -C LIWORK >= N*M + a, if JOB = 'B', -C LIWORK >= max( N*M + a, M ), if JOB = 'D', -C with a = 0, if JOBX0 = 'N'; -C a = N, if JOBX0 = 'X'. -C -C DWORK DOUBLE PRECISION array, dimension (LDWORK) -C On exit, if INFO = 0, DWORK(1) returns the optimal value -C of LDWORK; DWORK(2) contains the reciprocal condition -C number of the triangular factor of the QR factorization of -C the matrix W2 (see METHOD); if M > 0 and JOB = 'D', -C DWORK(3) contains the reciprocal condition number of the -C triangular factor of the QR factorization of U. -C On exit, if INFO = -23, DWORK(1) returns the minimum -C value of LDWORK. -C -C LDWORK INTEGER -C The length of the array DWORK. -C LDWORK >= max( LDW1, min( LDW2, LDW3 ) ), where -C LDW1 = 2, if M = 0 or JOB = 'B', -C LDW1 = 3, if M > 0 and JOB = 'D', -C LDWa = t*L*(r + 1) + max( N + max( d, f ), 6*r ), -C LDW2 = LDWa, if M = 0 or JOB = 'B', -C LDW2 = max( LDWa, t*L*(r + 1) + 2*M*M + 6*M ), -C if M > 0 and JOB = 'D', -C LDWb = (b + r)*(r + 1) + -C max( q*(r + 1) + N*N*M + c + max( d, f ), 6*r ), -C LDW3 = LDWb, if M = 0 or JOB = 'B', -C LDW3 = max( LDWb, (b + r)*(r + 1) + 2*M*M + 6*M ), -C if M > 0 and JOB = 'D', -C r = N*M + a, -C a = 0, if JOBX0 = 'N', -C a = N, if JOBX0 = 'X'; -C b = 0, if JOB = 'B', -C b = L*M, if JOB = 'D'; -C c = 0, if JOBX0 = 'N', -C c = L*N, if JOBX0 = 'X'; -C d = 0, if JOBX0 = 'N', -C d = 2*N*N + N, if JOBX0 = 'X'; -C f = 2*r, if JOB = 'B' or M = 0, -C f = M + max( 2*r, M ), if JOB = 'D' and M > 0; -C q = b + r*L. -C For good performance, LDWORK should be larger. -C If LDWORK >= LDW2 or -C LDWORK >= t*L*(r + 1) + (b + r)*(r + 1) + N*N*M + c + -C max( d, f ), -C then standard QR factorizations of the matrices U and/or -C W2 (see METHOD) are used. -C Otherwise, the QR factorizations are computed sequentially -C by performing NCYCLE cycles, each cycle (except possibly -C the last one) processing s < t samples, where s is -C chosen from the equation -C LDWORK = s*L*(r + 1) + (b + r)*(r + 1) + N*N*M + c + -C max( d, f ). -C (s is at least N*M+a+e, the minimum value of NSMP.) -C The computational effort may increase and the accuracy may -C decrease with the decrease of s. Recommended value is -C LDWORK = LDW2, assuming a large enough cache size, to -C also accommodate A, C, U, and Y. -C -C Warning Indicator -C -C IWARN INTEGER -C = 0: no warning; -C = 4: the least squares problem to be solved has a -C rank-deficient coefficient matrix. -C -C Error Indicator -C -C INFO INTEGER -C = 0: successful exit; -C < 0: if INFO = -i, the i-th argument had an illegal -C value; -C = 2: the singular value decomposition (SVD) algorithm did -C not converge. -C -C METHOD -C -C An extension and refinement of the method in [1,2] is used. -C Specifically, denoting -C -C X = [ vec(D')' vec(B)' x0' ]', -C -C where vec(M) is the vector obtained by stacking the columns of -C the matrix M, then X is the least squares solution of the -C system S*X = vec(Y), with the matrix S = [ diag(U) W ], -C defined by -C -C ( U | | ... | | | ... | | ) -C ( U | 11 | ... | n1 | 12 | ... | nm | ) -C S = ( : | y | ... | y | y | ... | y | P*Gamma ), -C ( : | | ... | | | ... | | ) -C ( U | | ... | | | ... | | ) -C ij -C diag(U) having L block rows and columns. In this formula, y -C are the outputs of the system for zero initial state computed -C using the following model, for j = 1:m, and for i = 1:n, -C ij ij ij -C x (k+1) = Ax (k) + e_i u_j(k), x (0) = 0, -C -C ij ij -C y (k) = Cx (k), -C -C where e_i is the i-th n-dimensional unit vector, Gamma is -C given by -C -C ( C ) -C ( C*A ) -C Gamma = ( C*A^2 ), -C ( : ) -C ( C*A^(t-1) ) -C -C and P is a permutation matrix that groups together the rows of -C Gamma depending on the same row of C, namely -C [ c_j; c_j*A; c_j*A^2; ... c_j*A^(t-1) ], for j = 1:L. -C The first block column, diag(U), is not explicitly constructed, -C but its structure is exploited. The last block column is evaluated -C using powers of A with exponents 2^k. No interchanges are applied. -C A special QR decomposition of the matrix S is computed. Let -C U = q*[ r' 0 ]' be the QR decomposition of U, if M > 0, where -C r is M-by-M. Then, diag(q') is applied to W and vec(Y). -C The block-rows of S and vec(Y) are implicitly permuted so that -C matrix S becomes -C -C ( diag(r) W1 ) -C ( 0 W2 ), -C -C where W1 has L*M rows. Then, the QR decomposition of W2 is -C computed (sequentially, if M > 0) and used to obtain B and x0. -C The intermediate results and the QR decomposition of U are -C needed to find D. If a triangular factor is too ill conditioned, -C then singular value decomposition (SVD) is employed. SVD is not -C generally needed if the input sequence is sufficiently -C persistently exciting and NSMP is large enough. -C If the matrix W cannot be stored in the workspace (i.e., -C LDWORK < LDW2), the QR decompositions of W2 and U are -C computed sequentially. -C -C REFERENCES -C -C [1] Verhaegen M., and Varga, A. -C Some Experience with the MOESP Class of Subspace Model -C Identification Methods in Identifying the BO105 Helicopter. -C Report TR R165-94, DLR Oberpfaffenhofen, 1994. -C -C [2] Sima, V., and Varga, A. -C RASP-IDENT : Subspace Model Identification Programs. -C Deutsche Forschungsanstalt fur Luft- und Raumfahrt e. V., -C Report TR R888-94, DLR Oberpfaffenhofen, Oct. 1994. -C -C NUMERICAL ASPECTS -C -C The implemented method is numerically stable. -C -C FURTHER COMMENTS -C -C The algorithm for computing the system matrices B and D is -C less efficient than the MOESP or N4SID algorithms implemented in -C SLICOT Library routine IB01PD, because a large least squares -C problem has to be solved, but the accuracy is better, as the -C computed matrices B and D are fitted to the input and output -C trajectories. However, if matrix A is unstable, the computed -C matrices B and D could be inaccurate. -C -C CONTRIBUTOR -C -C V. Sima, Research Institute for Informatics, Bucharest, Apr. 2000. -C -C REVISIONS -C -C - -C -C KEYWORDS -C -C Identification methods; least squares solutions; multivariable -C systems; QR decomposition; singular value decomposition. -C -C ****************************************************************** -C -C .. Parameters .. - DOUBLE PRECISION ZERO, ONE, TWO, THREE - PARAMETER ( ZERO = 0.0D0, ONE = 1.0D0, TWO = 2.0D0, - $ THREE = 3.0D0 ) -C .. Scalar Arguments .. - DOUBLE PRECISION TOL - INTEGER INFO, IWARN, L, LDA, LDB, LDC, LDD, LDU, - $ LDWORK, LDY, M, N, NSMP - CHARACTER JOB, JOBX0 -C .. Array Arguments .. - DOUBLE PRECISION A(LDA, *), B(LDB, *), C(LDC, *), D(LDD, *), - $ DWORK(*), U(LDU, *), X0(*), Y(LDY, *) - INTEGER IWORK(*) -C .. Local Scalars .. - DOUBLE PRECISION RCOND, RCONDU, TOLL - INTEGER I, I2, IA, IAS, IC, ICYCLE, IE, IERR, IEXPON, - $ IG, IGAM, IGS, INI, INIH, INIR, INIS, INY, - $ INYGAM, IQ, IREM, IRHS, ISIZE, ISV, ITAU, - $ ITAUU, IUPNT, IX, IXINIT, IXSAVE, IY, IYPNT, J, - $ JWORK, K, LDDW, LDR, LDW2, LDW3, LM, LN, LNOB, - $ MAXWRK, MINSMP, MINWLS, MINWRK, N2M, NCOL, - $ NCP1, NCYCLE, NM, NN, NOBS, NROW, NSMPL, RANK - LOGICAL FIRST, NCYC, POWER2, WITHB, WITHD, WITHX0 -C .. Local Arrays .. - DOUBLE PRECISION DUM(1) -C .. External Functions .. - LOGICAL LSAME - INTEGER ILAENV - DOUBLE PRECISION DLAMCH - EXTERNAL DLAMCH, ILAENV, LSAME -C .. External Subroutines .. - EXTERNAL DAXPY, DCOPY, DGELSS, DGEMV, DGEQRF, DLACPY, - $ DLASET, DORMQR, DTRCON, DTRMM, DTRMV, DTRSM, - $ MA02AD, MB01TD, MB02UD, MB04OD, MB04OY, XERBLA -C .. Intrinsic Functions .. - INTRINSIC DBLE, INT, LOG, MAX, MIN, MOD -C .. Executable Statements .. -C -C Check the input parameters. -C - WITHD = LSAME( JOB, 'D' ) - WITHB = LSAME( JOB, 'B' ) .OR. WITHD - WITHX0 = LSAME( JOBX0, 'X' ) -C - IWARN = 0 - INFO = 0 - LM = L*M - LN = L*N - NN = N*N - NM = N*M - N2M = N*NM - NCOL = NM - IF( WITHX0 ) - $ NCOL = NCOL + N - MINSMP = NCOL - IF( WITHD ) THEN - MINSMP = MINSMP + M - IQ = MINSMP - ELSE IF ( .NOT.WITHX0 ) THEN - IQ = MINSMP - MINSMP = MINSMP + 1 - ELSE - IQ = MINSMP - END IF -C - IF( .NOT.( WITHX0 .OR. LSAME( JOBX0, 'N' ) ) ) THEN - INFO = -1 - ELSE IF( .NOT.WITHB ) THEN - INFO = -2 - ELSE IF( N.LT.0 ) THEN - INFO = -3 - ELSE IF( M.LT.0 ) THEN - INFO = -4 - ELSE IF( L.LE.0 ) THEN - INFO = -5 - ELSE IF( NSMP.LT.MINSMP ) THEN - INFO = -6 - ELSE IF( LDA.LT.MAX( 1, N ) ) THEN - INFO = -8 - ELSE IF( LDC.LT.L ) THEN - INFO = -10 - ELSE IF( LDU.LT.1 .OR. ( M.GT.0 .AND. LDU.LT.NSMP ) ) THEN - INFO = -12 - ELSE IF( LDY.LT.MAX( 1, NSMP ) ) THEN - INFO = -14 - ELSE IF( LDB.LT.1 .OR. ( LDB.LT.N .AND. M.GT.0 ) ) - $ THEN - INFO = -17 - ELSE IF( LDD.LT.1 .OR. ( WITHD .AND. LDD.LT.L .AND. M.GT.0 ) ) - $ THEN - INFO = -19 - ELSE IF( TOL.GT.ONE ) THEN - INFO = -20 - END IF -C -C Compute workspace. -C (Note: Comments in the code beginning "Workspace:" describe the -C minimal amount of workspace needed at that point in the code, -C as well as the preferred amount for good performance. -C NB refers to the optimal block size for the immediately -C following subroutine, as returned by ILAENV.) -C - NSMPL = NSMP*L - IQ = IQ*L - NCP1 = NCOL + 1 - ISIZE = NSMPL*NCP1 - IF ( N.GT.0 .AND. WITHX0 ) THEN - IC = 2*NN + N - ELSE - IC = 0 - END IF - MINWLS = NCOL*NCP1 - IF ( WITHD ) - $ MINWLS = MINWLS + LM*NCP1 - IF ( M.GT.0 .AND. WITHD ) THEN - IA = M + MAX( 2*NCOL, M ) - ELSE - IA = 2*NCOL - END IF - ITAU = N2M + MAX( IC, IA ) - IF ( WITHX0 ) - $ ITAU = ITAU + LN - LDW2 = ISIZE + MAX( N + MAX( IC, IA ), 6*NCOL ) - LDW3 = MINWLS + MAX( IQ*NCP1 + ITAU, 6*NCOL ) - IF ( M.GT.0 .AND. WITHD ) THEN - LDW2 = MAX( LDW2, ISIZE + 2*M*M + 6*M ) - LDW3 = MAX( LDW3, MINWLS + 2*M*M + 6*M ) - END IF - MINWRK = MIN( LDW2, LDW3 ) - MINWRK = MAX( MINWRK, 2 ) - IF ( M.GT.0 .AND. WITHD ) - $ MINWRK = MAX( MINWRK, 3 ) - IF ( INFO.EQ.0 .AND. LDWORK.GE.MINWRK ) THEN - IF ( M.GT.0 .AND. WITHD ) THEN - MAXWRK = ISIZE + N + M + - $ MAX( M*ILAENV( 1, 'DGEQRF', ' ', NSMP, M, -1, -1 ), - $ NCOL + NCOL*ILAENV( 1, 'DGEQRF', ' ', NSMP-M, - $ NCOL, -1, -1 ) ) - MAXWRK = MAX( MAXWRK, ISIZE + N + M + - $ MAX( NCP1*ILAENV( 1, 'DORMQR', 'LT', NSMP, - $ NCP1, M, -1 ), - $ NCOL + ILAENV( 1, 'DORMQR', 'LT', - $ NSMP-M, 1, NCOL, -1 ) ) ) - ELSE - MAXWRK = ISIZE + N + NCOL + - $ MAX( NCOL*ILAENV( 1, 'DGEQRF', ' ', NSMPL, NCOL, - $ -1, -1 ), - $ ILAENV( 1, 'DORMQR', 'LT',NSMPL, 1, NCOL, - $ -1 ) ) - END IF - MAXWRK = MAX( MAXWRK, MINWRK ) - END IF -C - IF ( INFO.EQ.0 .AND. LDWORK.LT.MINWRK ) THEN - INFO = -23 - DWORK(1) = MINWRK - END IF -C -C Return if there are illegal arguments. -C - IF( INFO.NE.0 ) THEN - CALL XERBLA( 'IB01QD', -INFO ) - RETURN - END IF -C -C Quick return if possible. -C - IF ( MAX( N, M ).EQ.0 ) THEN - DWORK(2) = ONE - IF ( M.GT.0 .AND. WITHD ) THEN - DWORK(1) = THREE - DWORK(3) = ONE - ELSE - DWORK(1) = TWO - END IF - RETURN - END IF -C -C Set up the least squares problem, either directly, if enough -C workspace, or sequentially, otherwise. -C - IYPNT = 1 - IUPNT = 1 - LDDW = ( LDWORK - MINWLS - ITAU )/NCP1 - NOBS = MIN( NSMP, LDDW/L ) -C - IF ( LDWORK.GE.LDW2 .OR. NSMP.LE.NOBS ) THEN -C -C Enough workspace for solving the problem directly. -C - NCYCLE = 1 - NOBS = NSMP - LDDW = MAX( 1, NSMPL ) - IF ( WITHD ) THEN - INIR = M + 1 - ELSE - INIR = 1 - END IF - INY = 1 - INIS = 1 - ELSE -C -C NCYCLE > 1 cycles are needed for solving the problem -C sequentially, taking NOBS samples in each cycle (or the -C remaining samples in the last cycle). -C - LNOB = L*NOBS - LDDW = MAX( 1, LNOB ) - NCYCLE = NSMP/NOBS - IF ( MOD( NSMP, NOBS ).NE.0 ) - $ NCYCLE = NCYCLE + 1 - INIR = 1 - INIH = INIR + NCOL*NCOL - INIS = INIH + NCOL - IF ( WITHD ) THEN - INY = INIS + LM*NCP1 - ELSE - INY = INIS - END IF - END IF -C - NCYC = NCYCLE.GT.1 - INYGAM = INY + LDDW*NM - IRHS = INY + LDDW*NCOL - IXINIT = IRHS + LDDW - IF( NCYC ) THEN - IC = IXINIT + N2M - IF ( WITHX0 ) THEN - IA = IC + LN - ELSE - IA = IC - END IF - LDR = MAX( 1, NCOL ) - IE = INY - ELSE - IF ( WITHD ) THEN - INIH = IRHS + M - ELSE - INIH = IRHS - END IF - IA = IXINIT + N - LDR = LDDW - IE = IXINIT - END IF - IF ( N.GT.0 .AND. WITHX0 ) - $ IAS = IA + NN -C - ITAUU = IA - IF ( WITHD ) THEN - ITAU = ITAUU + M - ELSE - ITAU = ITAUU - END IF - DUM(1) = ZERO -C - DO 190 ICYCLE = 1, NCYCLE - FIRST = ICYCLE.EQ.1 - IF ( .NOT.FIRST ) THEN - IF ( ICYCLE.EQ.NCYCLE ) THEN - NOBS = NSMP - ( NCYCLE - 1 )*NOBS - LNOB = L*NOBS - END IF - END IF -C - IY = INY - IXSAVE = IXINIT -C -C Compute the M*N output trajectories for zero initial state -C or for the saved final state value of the previous cycle. -C This can be performed in parallel. -C Workspace: need s*L*(r + 1) + b + w, -C where r = M*N + a, s = NOBS, -C a = 0, if JOBX0 = 'N'; -C a = N, if JOBX0 = 'X'; -C b = N, if NCYCLE = 1; -C b = N*N*M, if NCYCLE > 1; -C w = 0, if NCYCLE = 1; -C w = r*(r+1), if NCYCLE > 1, JOB = 'B'; -C w = (M*L+r)*(r+1), if NCYCLE > 1, JOB = 'D'. -C - DO 40 J = 1, M - DO 30 I = 1, N -C ij -C Compute the y trajectory and put the vectorized form -C of it in an appropriate column of DWORK. To gain in -C efficiency, a specialization of SLICOT Library routine -C TF01ND is used. -C - IF ( FIRST ) - $ CALL DCOPY( N, DUM, 0, DWORK(IXSAVE), 1 ) - CALL DCOPY( N, DWORK(IXSAVE), 1, X0, 1 ) - INI = IY -C - DO 20 K = 1, NOBS - CALL DGEMV( 'No transpose', L, N, ONE, C, LDC, X0, 1, - $ ZERO, DWORK(IY), NOBS ) - IY = IY + 1 - CALL DTRMV( 'Upper', 'No transpose', 'Non-unit', N, - $ A, LDA, X0, 1 ) -C - DO 10 IX = 2, N - X0(IX) = X0(IX) + A(IX,IX-1)*DWORK(IXSAVE+IX-2) - 10 CONTINUE -C - X0(I) = X0(I) + U(IUPNT+K-1,J) - CALL DCOPY( N, X0, 1, DWORK(IXSAVE), 1 ) - 20 CONTINUE -C - IF ( NCYC ) - $ IXSAVE = IXSAVE + N - IY = INI + LDDW - 30 CONTINUE -C - 40 CONTINUE -C - IF ( N.GT.0 .AND. WITHX0 ) THEN -C -C Compute the permuted extended observability matrix Gamma -C ij -C in the following N columns of DWORK (after the y -C trajectories). Gamma is directly constructed in the -C required row structure. -C Workspace: need s*L*(r + 1) + 2*N*N + N + b + c + w, -C where c = 0, if NCYCLE = 1; -C c = L*N, if NCYCLE > 1. -C - JWORK = IAS + NN - IG = INYGAM - IEXPON = INT( LOG( DBLE( NOBS ) )/LOG( TWO ) ) - IREM = NOBS - 2**IEXPON - POWER2 = IREM.EQ.0 - IF ( .NOT.POWER2 ) - $ IEXPON = IEXPON + 1 -C - IF ( FIRST ) THEN -C - DO 50 I = 1, N - CALL DCOPY( L, C(1,I), 1, DWORK(IG), NOBS ) - IG = IG + LDDW - 50 CONTINUE -C - ELSE -C - DO 60 I = IC, IC + LN - 1, L - CALL DCOPY( L, DWORK(I), 1, DWORK(IG), NOBS ) - IG = IG + LDDW - 60 CONTINUE -C - END IF -C p -C Use powers of the matrix A: A , p = 2**(J-1). -C - CALL DLACPY( 'Upper', N, N, A, LDA, DWORK(IA), N ) - IF( N.GT.1 ) - $ CALL DCOPY( N-1, A(2,1), LDA+1, DWORK(IA+1), N+1 ) - I2 = 1 - NROW = 0 -C - DO 90 J = 1, IEXPON - IGAM = INYGAM - IF ( J.LT.IEXPON .OR. POWER2 ) THEN - NROW = I2 - ELSE - NROW = IREM - END IF -C - DO 80 I = 1, L - CALL DLACPY( 'Full', NROW, N, DWORK(IGAM), LDDW, - $ DWORK(IGAM+I2), LDDW ) - CALL DTRMM( 'Right', 'Upper', 'No Transpose', - $ 'Non Unit', NROW, N, ONE, DWORK(IA), N, - $ DWORK(IGAM+I2), LDDW ) - IG = IGAM -C p -C Compute the contribution of the subdiagonal of A -C to the product. -C - DO 70 IX = 1, N - 1 - CALL DAXPY( NROW, DWORK(IA+(IX-1)*N+IX), - $ DWORK(IG+LDDW), 1, DWORK(IG+I2), 1 ) - IG = IG + LDDW - 70 CONTINUE -C - IGAM = IGAM + NOBS - 80 CONTINUE -C - IF ( J.LT.IEXPON ) THEN - CALL DLACPY( 'Upper', N, N, DWORK(IA), N, DWORK(IAS), - $ N ) - IF( N.GT.1 ) - $ CALL DCOPY( N-1, DWORK(IA+1), N+1, DWORK(IAS+1), - $ N+1 ) - CALL MB01TD( N, DWORK(IAS), N, DWORK(IA), N, - $ DWORK(JWORK), IERR ) - I2 = I2*2 - END IF - 90 CONTINUE -C - IF ( NCYC .AND. ICYCLE.LT.NCYCLE ) THEN - IG = INYGAM + I2 + NROW - 1 - IGS = IG -C - DO 100 I = IC, IC + LN - 1, L - CALL DCOPY( L, DWORK(IG), NOBS, DWORK(I), 1 ) - IG = IG + LDDW - 100 CONTINUE -C - CALL DTRMM( 'Right', 'Upper', 'No Transpose', 'Non Unit', - $ L, N, ONE, A, LDA, DWORK(IC), L ) - IG = IGS -C -C Compute the contribution of the subdiagonal of A to the -C product. -C - DO 110 IX = 1, N - 1 - CALL DAXPY( L, A(IX+1,IX), DWORK(IG+LDDW), NOBS, - $ DWORK(IC+(IX-1)*L), 1 ) - IG = IG + LDDW - 110 CONTINUE -C - END IF - END IF -C -C Setup (part of) the right hand side of the least squares -C problem. -C - IY = IRHS -C - DO 120 K = 1, L - CALL DCOPY( NOBS, Y(IYPNT,K), 1, DWORK(IY), 1 ) - IY = IY + NOBS - 120 CONTINUE -C -C Compress the data using a special QR factorization. -C Workspace: need v + y, -C where v = s*L*(r + 1) + b + c + w + x, -C x = M, y = max( 2*r, M ), -C if JOB = 'D' and M > 0, -C x = 0, y = 2*r, if JOB = 'B' or M = 0. -C - IF ( M.GT.0 .AND. WITHD ) THEN -C -C Case 1: D is requested. -C - JWORK = ITAU - IF ( FIRST ) THEN - INI = INY + M -C -C Compress the first or single segment of U, U1 = Q1*R1. -C Workspace: need v + M; -C prefer v + M*NB. -C - CALL DGEQRF( NOBS, M, U, LDU, DWORK(ITAUU), DWORK(JWORK), - $ LDWORK-JWORK+1, IERR ) -C ij -C Apply diag(Q1') to the matrix [ y Gamma Y ]. -C Workspace: need v + r + 1, -C prefer v + (r + 1)*NB. -C - DO 130 K = 1, L - CALL DORMQR( 'Left', 'Transpose', NOBS, NCP1, M, U, - $ LDU, DWORK(ITAUU), DWORK(INY+(K-1)*NOBS), - $ LDDW, DWORK(JWORK), LDWORK-JWORK+1, - $ IERR ) - 130 CONTINUE -C - IF ( NCOL.GT.0 ) THEN -C -C Compress the first part of the first data segment of -C ij -C [ y Gamma ]. -C Workspace: need v + 2*r, -C prefer v + r + r*NB. -C - JWORK = ITAU + NCOL - CALL DGEQRF( NOBS-M, NCOL, DWORK(INI), LDDW, - $ DWORK(ITAU), DWORK(JWORK), - $ LDWORK-JWORK+1, IERR ) -C -C Apply the transformation to the corresponding right -C hand side part. -C Workspace: need v + r + 1, -C prefer v + r + NB. -C - CALL DORMQR( 'Left', 'Transpose', NOBS-M, 1, NCOL, - $ DWORK(INI), LDDW, DWORK(ITAU), - $ DWORK(IRHS+M), LDDW, DWORK(JWORK), - $ LDWORK-JWORK+1, IERR ) -C -C Compress the remaining parts of the first data segment -C ij -C of [ y Gamma ]. -C Workspace: need v + r - 1. -C - DO 140 K = 2, L - CALL MB04OD( 'Full', NCOL, 1, NOBS-M, DWORK(INI), - $ LDDW, DWORK(INI+(K-1)*NOBS), LDDW, - $ DWORK(IRHS+M), LDDW, - $ DWORK(IRHS+M+(K-1)*NOBS), LDDW, - $ DWORK(ITAU), DWORK(JWORK) ) - 140 CONTINUE -C - END IF -C - IF ( NCYC ) THEN -C ij -C Save the triangular factor of [ y Gamma ], the -C corresponding right hand side, and the first M rows -C in each NOBS group of rows. -C Workspace: need v. -C - CALL DLACPY( 'Upper', NCOL, NCP1, DWORK(INI), LDDW, - $ DWORK(INIR), LDR ) -C - DO 150 K = 1, L - CALL DLACPY( 'Full', M, NCP1, - $ DWORK(INY +(K-1)*NOBS), LDDW, - $ DWORK(INIS+(K-1)*M), LM ) - 150 CONTINUE -C - END IF - ELSE -C -C Compress the current data segment of U, Ui = Qi*Ri, -C i = ICYCLE. -C Workspace: need v + r + 1. -C - CALL MB04OD( 'Full', M, NCP1, NOBS, U, LDU, U(IUPNT,1), - $ LDU, DWORK(INIS), LM, DWORK(INY), LDDW, - $ DWORK(ITAUU), DWORK(JWORK) ) -C -C Apply diag(Qi') to the appropriate part of the matrix -C ij -C [ y Gamma Y ]. -C Workspace: need v + r + 1. -C - DO 170 K = 2, L -C - DO 160 IX = 1, M - CALL MB04OY( NOBS, NCP1, U(IUPNT,IX), - $ DWORK(ITAUU+IX-1), - $ DWORK(INIS+(K-1)*M+IX-1), LM, - $ DWORK(INY+(K-1)*NOBS), LDDW, - $ DWORK(JWORK) ) - 160 CONTINUE -C - 170 CONTINUE -C - IF ( NCOL.GT.0 ) THEN -C - JWORK = ITAU + NCOL -C -C Compress the current (but not the first) data segment -C ij -C of [ y Gamma ]. -C Workspace: need v + r - 1. -C - DO 180 K = 1, L - CALL MB04OD( 'Full', NCOL, 1, NOBS, DWORK(INIR), - $ LDR, DWORK(INY+(K-1)*NOBS), LDDW, - $ DWORK(INIH), LDR, - $ DWORK(IRHS+(K-1)*NOBS), LDDW, - $ DWORK(ITAU), DWORK(JWORK) ) - 180 CONTINUE -C - END IF - END IF -C - ELSE IF ( NCOL.GT.0 ) THEN -C -C Case 2: D is known to be zero. -C - JWORK = ITAU + NCOL - IF ( FIRST ) THEN -C -C Compress the first or single data segment of -C ij -C [ y Gamma ]. -C Workspace: need v + 2*r, -C prefer v + r + r*NB. -C - CALL DGEQRF( LDDW, NCOL, DWORK(INY), LDDW, DWORK(ITAU), - $ DWORK(JWORK), LDWORK-JWORK+1, IERR ) -C -C Apply the transformation to the right hand side. -C Workspace: need v + r + 1, -C prefer v + r + NB. -C - CALL DORMQR( 'Left', 'Transpose', LDDW, 1, NCOL, - $ DWORK(INY), LDDW, DWORK(ITAU), DWORK(IRHS), - $ LDDW, DWORK(JWORK), LDWORK-JWORK+1, IERR ) - IF ( NCYC ) THEN -C ij -C Save the triangular factor of [ y Gamma ] and the -C corresponding right hand side. -C Workspace: need v. -C - CALL DLACPY( 'Upper', NCOL, NCP1, DWORK(INY), LDDW, - $ DWORK(INIR), LDR ) - END IF - ELSE -C -C Compress the current (but not the first) data segment. -C Workspace: need v + r - 1. -C - CALL MB04OD( 'Full', NCOL, 1, LNOB, DWORK(INIR), LDR, - $ DWORK(INY), LDDW, DWORK(INIH), LDR, - $ DWORK(IRHS), LDDW, DWORK(ITAU), - $ DWORK(JWORK) ) - END IF - END IF -C - IUPNT = IUPNT + NOBS - IYPNT = IYPNT + NOBS - 190 CONTINUE -C -C Estimate the reciprocal condition number of the triangular factor -C of the QR decomposition. -C Workspace: need u + 3*r, where -C u = t*L*(r + 1), if NCYCLE = 1; -C u = w, if NCYCLE > 1. -C - CALL DTRCON( '1-norm', 'Upper', 'No Transpose', NCOL, DWORK(INIR), - $ LDR, RCOND, DWORK(IE), IWORK, IERR ) -C - TOLL = TOL - IF ( TOLL.LE.ZERO ) - $ TOLL = DLAMCH( 'Precision' ) - IF ( RCOND.LE.TOLL**( TWO/THREE ) ) THEN - IWARN = 4 -C -C The least squares problem is ill-conditioned. -C Use SVD to solve it. -C Workspace: need u + 6*r; -C prefer larger. -C - IF ( NCOL.GT.1 ) - $ CALL DLASET( 'Lower', NCOL-1, NCOL-1, ZERO, ZERO, - $ DWORK(INIR+1), LDR ) - ISV = IE - JWORK = ISV + NCOL - CALL DGELSS( NCOL, NCOL, 1, DWORK(INIR), LDR, DWORK(INIH), LDR, - $ DWORK(ISV), TOLL, RANK, DWORK(JWORK), - $ LDWORK-JWORK+1, IERR ) - IF ( IERR.GT.0 ) THEN -C -C Return if SVD algorithm did not converge. -C - INFO = 2 - RETURN - END IF - MAXWRK = MAX( MAXWRK, INT( DWORK(JWORK) ) - JWORK + 1 ) - ELSE -C -C Find the least squares solution using QR decomposition only. -C - CALL DTRSM( 'Left', 'Upper', 'No Transpose', 'Non Unit', NCOL, - $ 1, ONE, DWORK(INIR), LDR, DWORK(INIH), LDR ) - END IF -C -C Setup the estimated n-by-m input matrix B, and the estimated -C initial state of the system x0. -C - CALL DLACPY( 'Full', N, M, DWORK(INIH), N, B, LDB ) -C - IF ( N.GT.0 .AND. WITHX0 ) THEN - CALL DCOPY( N, DWORK(INIH+NM), 1, X0, 1 ) - ELSE - CALL DCOPY( N, DUM, 0, X0, 1 ) - END IF -C - IF ( M.GT.0 .AND. WITHD ) THEN -C -C Compute the estimated l-by-m input/output matrix D. -C - IF ( NCYC ) THEN - IRHS = INIS + LM*NCOL - CALL DGEMV( 'No Transpose', LM, NCOL, -ONE, DWORK(INIS), - $ LM, DWORK(INIH), 1, ONE, DWORK(IRHS), 1 ) - ELSE -C - DO 200 K = 1, L - CALL DGEMV( 'No Transpose', M, NCOL, -ONE, - $ DWORK(INIS+(K-1)*NOBS), LDDW, DWORK(INIH), 1, - $ ONE, DWORK(IRHS+(K-1)*NOBS), 1 ) - 200 CONTINUE -C - DO 210 K = 2, L - CALL DCOPY( M, DWORK(IRHS+(K-1)*NOBS), 1, - $ DWORK(IRHS+(K-1)*M), 1 ) - 210 CONTINUE -C - END IF -C -C Estimate the reciprocal condition number of the triangular -C factor of the QR decomposition of the matrix U. -C Workspace: need u + 3*M. -C - CALL DTRCON( '1-norm', 'Upper', 'No Transpose', M, U, LDU, - $ RCONDU, DWORK(IE), IWORK, IERR ) - IF ( RCONDU.LE.TOLL**( TWO/THREE ) ) THEN - IWARN = 4 -C -C The least squares problem is ill-conditioned. -C Use SVD to solve it. (QR decomposition of U is preserved.) -C Workspace: need u + 2*M*M + 6*M; -C prefer larger. -C - IQ = IE + M*M - ISV = IQ + M*M - JWORK = ISV + M - CALL DLACPY( 'Upper', M, M, U, LDU, DWORK(IE), M ) - CALL MB02UD( 'Not Factored', 'Left', 'No Transpose', - $ 'No Pinv', M, L, ONE, TOLL, RANK, DWORK(IE), - $ M, DWORK(IQ), M, DWORK(ISV), DWORK(IRHS), M, - $ DUM, 1, DWORK(JWORK), LDWORK-JWORK+1, IERR ) - IF ( IERR.GT.0 ) THEN -C -C Return if SVD algorithm did not converge. -C - INFO = 2 - RETURN - END IF - MAXWRK = MAX( MAXWRK, INT( DWORK(JWORK) ) - JWORK + 1 ) - ELSE - CALL DTRSM( 'Left', 'Upper', 'No Transpose', 'Non Unit', M, - $ L, ONE, U, LDU, DWORK(IRHS), M ) - END IF - CALL MA02AD( 'Full', M, L, DWORK(IRHS), M, D, LDD ) -C - END IF -C - DWORK(1) = MAXWRK - DWORK(2) = RCOND - IF ( M.GT.0 .AND. WITHD ) - $ DWORK(3) = RCONDU -C - RETURN -C -C *** End of IB01QD *** - END diff --git a/mex/sources/libslicot/IB01RD.f b/mex/sources/libslicot/IB01RD.f deleted file mode 100644 index b5eaf6125..000000000 --- a/mex/sources/libslicot/IB01RD.f +++ /dev/null @@ -1,762 +0,0 @@ - SUBROUTINE IB01RD( JOB, N, M, L, NSMP, A, LDA, B, LDB, C, LDC, D, - $ LDD, U, LDU, Y, LDY, X0, TOL, IWORK, DWORK, - $ LDWORK, IWARN, INFO ) -C -C SLICOT RELEASE 5.0. -C -C Copyright (c) 2002-2009 NICONET e.V. -C -C This program is free software: you can redistribute it and/or -C modify it under the terms of the GNU General Public License as -C published by the Free Software Foundation, either version 2 of -C the License, or (at your option) any later version. -C -C This program is distributed in the hope that it will be useful, -C but WITHOUT ANY WARRANTY; without even the implied warranty of -C MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the -C GNU General Public License for more details. -C -C You should have received a copy of the GNU General Public License -C along with this program. If not, see -C . -C -C PURPOSE -C -C To estimate the initial state of a linear time-invariant (LTI) -C discrete-time system, given the system matrices (A,B,C,D) and -C the input and output trajectories of the system. The model -C structure is : -C -C x(k+1) = Ax(k) + Bu(k), k >= 0, -C y(k) = Cx(k) + Du(k), -C -C where x(k) is the n-dimensional state vector (at time k), -C u(k) is the m-dimensional input vector, -C y(k) is the l-dimensional output vector, -C and A, B, C, and D are real matrices of appropriate dimensions. -C Matrix A is assumed to be in a real Schur form. -C -C ARGUMENTS -C -C Mode Parameters -C -C JOB CHARACTER*1 -C Specifies whether or not the matrix D is zero, as follows: -C = 'Z': the matrix D is zero; -C = 'N': the matrix D is not zero. -C -C Input/Output Parameters -C -C N (input) INTEGER -C The order of the system. N >= 0. -C -C M (input) INTEGER -C The number of system inputs. M >= 0. -C -C L (input) INTEGER -C The number of system outputs. L > 0. -C -C NSMP (input) INTEGER -C The number of rows of matrices U and Y (number of -C samples used, t). NSMP >= N. -C -C A (input) DOUBLE PRECISION array, dimension (LDA,N) -C The leading N-by-N part of this array must contain the -C system state matrix A in a real Schur form. -C -C LDA INTEGER -C The leading dimension of the array A. LDA >= MAX(1,N). -C -C B (input) DOUBLE PRECISION array, dimension (LDB,M) -C The leading N-by-M part of this array must contain the -C system input matrix B (corresponding to the real Schur -C form of A). -C If N = 0 or M = 0, this array is not referenced. -C -C LDB INTEGER -C The leading dimension of the array B. -C LDB >= N, if N > 0 and M > 0; -C LDB >= 1, if N = 0 or M = 0. -C -C C (input) DOUBLE PRECISION array, dimension (LDC,N) -C The leading L-by-N part of this array must contain the -C system output matrix C (corresponding to the real Schur -C form of A). -C -C LDC INTEGER -C The leading dimension of the array C. LDC >= L. -C -C D (input) DOUBLE PRECISION array, dimension (LDD,M) -C The leading L-by-M part of this array must contain the -C system input-output matrix. -C If M = 0 or JOB = 'Z', this array is not referenced. -C -C LDD INTEGER -C The leading dimension of the array D. -C LDD >= L, if M > 0 and JOB = 'N'; -C LDD >= 1, if M = 0 or JOB = 'Z'. -C -C U (input) DOUBLE PRECISION array, dimension (LDU,M) -C If M > 0, the leading NSMP-by-M part of this array must -C contain the t-by-m input-data sequence matrix U, -C U = [u_1 u_2 ... u_m]. Column j of U contains the -C NSMP values of the j-th input component for consecutive -C time increments. -C If M = 0, this array is not referenced. -C -C LDU INTEGER -C The leading dimension of the array U. -C LDU >= MAX(1,NSMP), if M > 0; -C LDU >= 1, if M = 0. -C -C Y (input) DOUBLE PRECISION array, dimension (LDY,L) -C The leading NSMP-by-L part of this array must contain the -C t-by-l output-data sequence matrix Y, -C Y = [y_1 y_2 ... y_l]. Column j of Y contains the -C NSMP values of the j-th output component for consecutive -C time increments. -C -C LDY INTEGER -C The leading dimension of the array Y. LDY >= MAX(1,NSMP). -C -C X0 (output) DOUBLE PRECISION array, dimension (N) -C The estimated initial state of the system, x(0). -C -C Tolerances -C -C TOL DOUBLE PRECISION -C The tolerance to be used for estimating the rank of -C matrices. If the user sets TOL > 0, then the given value -C of TOL is used as a lower bound for the reciprocal -C condition number; a matrix whose estimated condition -C number is less than 1/TOL is considered to be of full -C rank. If the user sets TOL <= 0, then EPS is used -C instead, where EPS is the relative machine precision -C (see LAPACK Library routine DLAMCH). TOL <= 1. -C -C Workspace -C -C IWORK INTEGER array, dimension (N) -C -C DWORK DOUBLE PRECISION array, dimension (LDWORK) -C On exit, if INFO = 0, DWORK(1) returns the optimal value -C of LDWORK and DWORK(2) contains the reciprocal condition -C number of the triangular factor of the QR factorization of -C the matrix Gamma (see METHOD). -C On exit, if INFO = -22, DWORK(1) returns the minimum -C value of LDWORK. -C -C LDWORK INTEGER -C The length of the array DWORK. -C LDWORK >= max( 2, min( LDW1, LDW2 ) ), where -C LDW1 = t*L*(N + 1) + 2*N + max( 2*N*N, 4*N ), -C LDW2 = N*(N + 1) + 2*N + -C max( q*(N + 1) + 2*N*N + L*N, 4*N ), -C q = N*L. -C For good performance, LDWORK should be larger. -C If LDWORK >= LDW1, then standard QR factorization of -C the matrix Gamma (see METHOD) is used. Otherwise, the -C QR factorization is computed sequentially by performing -C NCYCLE cycles, each cycle (except possibly the last one) -C processing s samples, where s is chosen by equating -C LDWORK to LDW2, for q replaced by s*L. -C The computational effort may increase and the accuracy may -C decrease with the decrease of s. Recommended value is -C LDRWRK = LDW1, assuming a large enough cache size, to -C also accommodate A, B, C, D, U, and Y. -C -C Warning Indicator -C -C IWARN INTEGER -C = 0: no warning; -C = 4: the least squares problem to be solved has a -C rank-deficient coefficient matrix. -C -C Error Indicator -C -C INFO INTEGER -C = 0: successful exit; -C < 0: if INFO = -i, the i-th argument had an illegal -C value; -C = 2: the singular value decomposition (SVD) algorithm did -C not converge. -C -C METHOD -C -C An extension and refinement of the method in [1] is used. -C Specifically, the output y0(k) of the system for zero initial -C state is computed for k = 0, 1, ..., t-1 using the given model. -C Then the following least squares problem is solved for x(0) -C -C ( C ) ( y(0) - y0(0) ) -C ( C*A ) ( y(1) - y0(1) ) -C Gamma * x(0) = ( : ) * x(0) = ( : ). -C ( : ) ( : ) -C ( C*A^(t-1) ) ( y(t-1) - y0(t-1) ) -C -C The coefficient matrix Gamma is evaluated using powers of A with -C exponents 2^k. The QR decomposition of this matrix is computed. -C If its triangular factor R is too ill conditioned, then singular -C value decomposition of R is used. -C -C If the coefficient matrix cannot be stored in the workspace (i.e., -C LDWORK < LDW1), the QR decomposition is computed sequentially. -C -C REFERENCES -C -C [1] Verhaegen M., and Varga, A. -C Some Experience with the MOESP Class of Subspace Model -C Identification Methods in Identifying the BO105 Helicopter. -C Report TR R165-94, DLR Oberpfaffenhofen, 1994. -C -C NUMERICAL ASPECTS -C -C The implemented method is numerically stable. -C -C CONTRIBUTOR -C -C V. Sima, Research Institute for Informatics, Bucharest, Apr. 2000. -C -C REVISIONS -C -C V. Sima, Research Institute for Informatics, Bucharest, Feb. 2004. -C -C KEYWORDS -C -C Identification methods; least squares solutions; multivariable -C systems; QR decomposition; singular value decomposition. -C -C ****************************************************************** -C -C .. Parameters .. - DOUBLE PRECISION ZERO, ONE, TWO, THREE - PARAMETER ( ZERO = 0.0D0, ONE = 1.0D0, TWO = 2.0D0, - $ THREE = 3.0D0 ) -C IBLOCK is a threshold value for switching to a block algorithm -C for U (to avoid row by row passing through U). - INTEGER IBLOCK - PARAMETER ( IBLOCK = 16384 ) -C .. Scalar Arguments .. - DOUBLE PRECISION TOL - INTEGER INFO, IWARN, L, LDA, LDB, LDC, LDD, LDU, - $ LDWORK, LDY, M, N, NSMP - CHARACTER JOB -C .. Array Arguments .. - DOUBLE PRECISION A(LDA, *), B(LDB, *), C(LDC, *), D(LDD, *), - $ DWORK(*), U(LDU, *), X0(*), Y(LDY, *) - INTEGER IWORK(*) -C .. Local Scalars .. - DOUBLE PRECISION RCOND, TOLL - INTEGER I2, IA, IAS, IC, ICYCLE, IE, IERR, IEXPON, - $ IG, INIGAM, INIH, INIR, INIT, IQ, IREM, IRHS, - $ ISIZE, ISV, ITAU, IU, IUPNT, IUT, IUTRAN, IX, - $ IXINIT, IY, IYPNT, J, JWORK, K, LDDW, LDR, - $ LDW1, LDW2, MAXWRK, MINSMP, MINWLS, MINWRK, NC, - $ NCP1, NCYCLE, NN, NOBS, NRBL, NROW, NSMPL, RANK - LOGICAL BLOCK, FIRST, NCYC, POWER2, SWITCH, WITHD -C .. Local Arrays .. - DOUBLE PRECISION DUM(1) -C .. External Functions .. - LOGICAL LSAME - INTEGER ILAENV - DOUBLE PRECISION DLAMCH - EXTERNAL DLAMCH, ILAENV, LSAME -C .. External Subroutines .. - EXTERNAL DAXPY, DCOPY, DGELSS, DGEMV, DGEQRF, DLACPY, - $ DLASET, DORMQR, DTRCON, DTRMM, DTRMV, DTRSV, - $ MA02AD, MB01TD, MB04OD, XERBLA -C .. Intrinsic Functions .. - INTRINSIC DBLE, INT, LOG, MAX, MIN, MOD -C .. Executable Statements .. -C -C Check the input parameters. -C - WITHD = LSAME( JOB, 'N' ) - IWARN = 0 - INFO = 0 - NN = N*N - MINSMP = N -C - IF( .NOT.( LSAME( JOB, 'Z' ) .OR. WITHD ) ) THEN - INFO = -1 - ELSE IF( N.LT.0 ) THEN - INFO = -2 - ELSE IF( M.LT.0 ) THEN - INFO = -3 - ELSE IF( L.LE.0 ) THEN - INFO = -4 - ELSE IF( NSMP.LT.MINSMP ) THEN - INFO = -5 - ELSE IF( LDA.LT.MAX( 1, N ) ) THEN - INFO = -7 - ELSE IF( LDB.LT.1 .OR. ( LDB.LT.N .AND. M.GT.0 ) ) THEN - INFO = -9 - ELSE IF( LDC.LT.L ) THEN - INFO = -11 - ELSE IF( LDD.LT.1 .OR. ( WITHD .AND. LDD.LT.L .AND. M.GT.0 ) ) - $ THEN - INFO = -13 - ELSE IF( LDU.LT.1 .OR. ( M.GT.0 .AND. LDU.LT.NSMP ) ) THEN - INFO = -15 - ELSE IF( LDY.LT.MAX( 1, NSMP ) ) THEN - INFO = -17 - ELSE IF( TOL.GT.ONE ) THEN - INFO = -19 - END IF -C -C Compute workspace. -C (Note: Comments in the code beginning "Workspace:" describe the -C minimal amount of workspace needed at that point in the code, -C as well as the preferred amount for good performance. -C NB refers to the optimal block size for the immediately -C following subroutine, as returned by ILAENV.) -C - NSMPL = NSMP*L - IQ = MINSMP*L - NCP1 = N + 1 - ISIZE = NSMPL*NCP1 - IC = 2*NN - MINWLS = MINSMP*NCP1 - ITAU = IC + L*N - LDW1 = ISIZE + 2*N + MAX( IC, 4*N ) - LDW2 = MINWLS + 2*N + MAX( IQ*NCP1 + ITAU, 4*N ) - MINWRK = MAX( MIN( LDW1, LDW2 ), 2 ) - IF ( INFO.EQ.0 .AND. LDWORK.GE.MINWRK ) THEN - MAXWRK = ISIZE + 2*N + MAX( N*ILAENV( 1, 'DGEQRF', ' ', NSMPL, - $ N, -1, -1 ), - $ ILAENV( 1, 'DORMQR', 'LT', NSMPL, - $ 1, N, -1 ) ) - MAXWRK = MAX( MAXWRK, MINWRK ) - END IF -C - IF ( INFO.EQ.0 .AND. LDWORK.LT.MINWRK ) THEN - INFO = -22 - DWORK(1) = MINWRK - END IF -C -C Return if there are illegal arguments. -C - IF( INFO.NE.0 ) THEN - CALL XERBLA( 'IB01RD', -INFO ) - RETURN - END IF -C -C Quick return if possible. -C - IF ( N.EQ.0 ) THEN - DWORK(1) = TWO - DWORK(2) = ONE - RETURN - END IF -C -C Set up the least squares problem, either directly, if enough -C workspace, or sequentially, otherwise. -C - IYPNT = 1 - IUPNT = 1 - INIR = 1 - IF ( LDWORK.GE.LDW1 ) THEN -C -C Enough workspace for solving the problem directly. -C - NCYCLE = 1 - NOBS = NSMP - LDDW = NSMPL - INIGAM = 1 - ELSE -C -C NCYCLE > 1 cycles are needed for solving the problem -C sequentially, taking NOBS samples in each cycle (or the -C remaining samples in the last cycle). -C - JWORK = LDWORK - MINWLS - 2*N - ITAU - LDDW = JWORK/NCP1 - NOBS = LDDW/L - LDDW = L*NOBS - NCYCLE = NSMP/NOBS - IF ( MOD( NSMP, NOBS ).NE.0 ) - $ NCYCLE = NCYCLE + 1 - INIH = INIR + NN - INIGAM = INIH + N - END IF -C - NCYC = NCYCLE.GT.1 - IRHS = INIGAM + LDDW*N - IXINIT = IRHS + LDDW - IC = IXINIT + N - IF( NCYC ) THEN - IA = IC + L*N - LDR = N - IE = INIGAM - ELSE - INIH = IRHS - IA = IC - LDR = LDDW - IE = IXINIT - END IF - IUTRAN = IA - IAS = IA + NN - ITAU = IA - DUM(1) = ZERO -C -C Set block parameters for passing through the array U. -C - BLOCK = M.GT.1 .AND. NSMP*M.GE.IBLOCK - IF ( BLOCK ) THEN - NRBL = ( LDWORK - IUTRAN + 1 )/M - NC = NOBS/NRBL - IF ( MOD( NOBS, NRBL ).NE.0 ) - $ NC = NC + 1 - INIT = ( NC - 1 )*NRBL - BLOCK = BLOCK .AND. NRBL.GT.1 - END IF -C -C Perform direct of sequential compression of the matrix Gamma. -C - DO 150 ICYCLE = 1, NCYCLE - FIRST = ICYCLE.EQ.1 - IF ( .NOT.FIRST ) THEN - IF ( ICYCLE.EQ.NCYCLE ) THEN - NOBS = NSMP - ( NCYCLE - 1 )*NOBS - LDDW = L*NOBS - IF ( BLOCK ) THEN - NC = NOBS/NRBL - IF ( MOD( NOBS, NRBL ).NE.0 ) - $ NC = NC + 1 - INIT = ( NC - 1 )*NRBL - END IF - END IF - END IF -C -C Compute the extended observability matrix Gamma. -C Workspace: need s*L*(N + 1) + 2*N*N + 2*N + a + w, -C where s = NOBS, -C a = 0, w = 0, if NCYCLE = 1, -C a = L*N, w = N*(N + 1), if NCYCLE > 1; -C prefer as above, with s = t, a = w = 0. -C - JWORK = IAS + NN - IEXPON = INT( LOG( DBLE( NOBS ) )/LOG( TWO ) ) - IREM = L*( NOBS - 2**IEXPON ) - POWER2 = IREM.EQ.0 - IF ( .NOT.POWER2 ) - $ IEXPON = IEXPON + 1 -C - IF ( FIRST ) THEN - CALL DLACPY( 'Full', L, N, C, LDC, DWORK(INIGAM), LDDW ) - ELSE - CALL DLACPY( 'Full', L, N, DWORK(IC), L, DWORK(INIGAM), - $ LDDW ) - END IF -C p -C Use powers of the matrix A: A , p = 2**(J-1). -C - CALL DLACPY( 'Upper', N, N, A, LDA, DWORK(IA), N ) - IF ( N.GT.1 ) - $ CALL DCOPY( N-1, A(2,1), LDA+1, DWORK(IA+1), N+1 ) - I2 = L - NROW = 0 -C - DO 20 J = 1, IEXPON - IG = INIGAM - IF ( J.LT.IEXPON .OR. POWER2 ) THEN - NROW = I2 - ELSE - NROW = IREM - END IF -C - CALL DLACPY( 'Full', NROW, N, DWORK(IG), LDDW, DWORK(IG+I2), - $ LDDW ) - CALL DTRMM( 'Right', 'Upper', 'No Transpose', 'Non Unit', - $ NROW, N, ONE, DWORK(IA), N, DWORK(IG+I2), - $ LDDW ) -C p -C Compute the contribution of the subdiagonal of A to the -C product. -C - DO 10 IX = 1, N - 1 - CALL DAXPY( NROW, DWORK(IA+(IX-1)*N+IX), DWORK(IG+LDDW), - $ 1, DWORK(IG+I2), 1 ) - IG = IG + LDDW - 10 CONTINUE -C - IF ( J.LT.IEXPON ) THEN - CALL DLACPY( 'Upper', N, N, DWORK(IA), N, DWORK(IAS), N ) - CALL DCOPY( N-1, DWORK(IA+1), N+1, DWORK(IAS+1), N+1 ) - CALL MB01TD( N, DWORK(IAS), N, DWORK(IA), N, - $ DWORK(JWORK), IERR ) - I2 = I2*2 - END IF - 20 CONTINUE -C - IF ( NCYC ) THEN - IG = INIGAM + I2 + NROW - L - CALL DLACPY( 'Full', L, N, DWORK(IG), LDDW, DWORK(IC), L ) - CALL DTRMM( 'Right', 'Upper', 'No Transpose', 'Non Unit', L, - $ N, ONE, A, LDA, DWORK(IC), L ) -C -C Compute the contribution of the subdiagonal of A to the -C product. -C - DO 30 IX = 1, N - 1 - CALL DAXPY( L, A(IX+1,IX), DWORK(IG+LDDW), 1, - $ DWORK(IC+(IX-1)*L), 1 ) - IG = IG + LDDW - 30 CONTINUE -C - END IF -C -C Setup (part of) the right hand side of the least squares -C problem starting from DWORK(IRHS); use the estimated output -C trajectory for zero initial state, or for the saved final state -C value of the previous cycle. -C A specialization of SLICOT Library routine TF01ND is used. -C For large input sets (NSMP*M >= IBLOCK), chunks of U are -C transposed, to reduce the number of row-wise passes. -C Workspace: need s*L*(N + 1) + N + w; -C prefer as above, with s = t, w = 0. -C - IF ( FIRST ) - $ CALL DCOPY( N, DUM, 0, DWORK(IXINIT), 1 ) - CALL DCOPY( N, DWORK(IXINIT), 1, X0, 1 ) - IY = IRHS -C - DO 40 J = 1, L - CALL DCOPY( NOBS, Y(IYPNT,J), 1, DWORK(IY), L ) - IY = IY + 1 - 40 CONTINUE -C - IY = IRHS - IU = IUPNT - IF ( M.GT.0 ) THEN - IF ( WITHD ) THEN -C - IF ( BLOCK ) THEN - SWITCH = .TRUE. - NROW = NRBL -C - DO 60 K = 1, NOBS - IF ( MOD( K-1, NROW ).EQ.0 .AND. SWITCH ) THEN - IUT = IUTRAN - IF ( K.GT.INIT ) THEN - NROW = NOBS - INIT - SWITCH = .FALSE. - END IF - CALL MA02AD( 'Full', NROW, M, U(IU,1), LDU, - $ DWORK(IUT), M ) - IU = IU + NROW - END IF - CALL DGEMV( 'No transpose', L, N, -ONE, C, LDC, X0, - $ 1, ONE, DWORK(IY), 1 ) - CALL DGEMV( 'No transpose', L, M, -ONE, D, LDD, - $ DWORK(IUT), 1, ONE, DWORK(IY), 1 ) - CALL DTRMV( 'Upper', 'No transpose', 'Non-unit', N, - $ A, LDA, X0, 1 ) -C - DO 50 IX = 2, N - X0(IX) = X0(IX) + A(IX,IX-1)*DWORK(IXINIT+IX-2) - 50 CONTINUE -C - CALL DGEMV( 'No transpose', N, M, ONE, B, LDB, - $ DWORK(IUT), 1, ONE, X0, 1 ) - CALL DCOPY( N, X0, 1, DWORK(IXINIT), 1 ) - IY = IY + L - IUT = IUT + M - 60 CONTINUE -C - ELSE -C - DO 80 K = 1, NOBS - CALL DGEMV( 'No transpose', L, N, -ONE, C, LDC, X0, - $ 1, ONE, DWORK(IY), 1 ) - CALL DGEMV( 'No transpose', L, M, -ONE, D, LDD, - $ U(IU,1), LDU, ONE, DWORK(IY), 1 ) - CALL DTRMV( 'Upper', 'No transpose', 'Non-unit', N, - $ A, LDA, X0, 1 ) -C - DO 70 IX = 2, N - X0(IX) = X0(IX) + A(IX,IX-1)*DWORK(IXINIT+IX-2) - 70 CONTINUE -C - CALL DGEMV( 'No transpose', N, M, ONE, B, LDB, - $ U(IU,1), LDU, ONE, X0, 1 ) - CALL DCOPY( N, X0, 1, DWORK(IXINIT), 1 ) - IY = IY + L - IU = IU + 1 - 80 CONTINUE -C - END IF -C - ELSE -C - IF ( BLOCK ) THEN - SWITCH = .TRUE. - NROW = NRBL -C - DO 100 K = 1, NOBS - IF ( MOD( K-1, NROW ).EQ.0 .AND. SWITCH ) THEN - IUT = IUTRAN - IF ( K.GT.INIT ) THEN - NROW = NOBS - INIT - SWITCH = .FALSE. - END IF - CALL MA02AD( 'Full', NROW, M, U(IU,1), LDU, - $ DWORK(IUT), M ) - IU = IU + NROW - END IF - CALL DGEMV( 'No transpose', L, N, -ONE, C, LDC, X0, - $ 1, ONE, DWORK(IY), 1 ) - CALL DTRMV( 'Upper', 'No transpose', 'Non-unit', N, - $ A, LDA, X0, 1 ) -C - DO 90 IX = 2, N - X0(IX) = X0(IX) + A(IX,IX-1)*DWORK(IXINIT+IX-2) - 90 CONTINUE -C - CALL DGEMV( 'No transpose', N, M, ONE, B, LDB, - $ DWORK(IUT), 1, ONE, X0, 1 ) - CALL DCOPY( N, X0, 1, DWORK(IXINIT), 1 ) - IY = IY + L - IUT = IUT + M - 100 CONTINUE -C - ELSE -C - DO 120 K = 1, NOBS - CALL DGEMV( 'No transpose', L, N, -ONE, C, LDC, X0, - $ 1, ONE, DWORK(IY), 1 ) - CALL DTRMV( 'Upper', 'No transpose', 'Non-unit', N, - $ A, LDA, X0, 1 ) -C - DO 110 IX = 2, N - X0(IX) = X0(IX) + A(IX,IX-1)*DWORK(IXINIT+IX-2) - 110 CONTINUE -C - CALL DGEMV( 'No transpose', N, M, ONE, B, LDB, - $ U(IU,1), LDU, ONE, X0, 1 ) - CALL DCOPY( N, X0, 1, DWORK(IXINIT), 1 ) - IY = IY + L - IU = IU + 1 - 120 CONTINUE -C - END IF -C - END IF -C - ELSE -C - DO 140 K = 1, NOBS - CALL DGEMV( 'No transpose', L, N, -ONE, C, LDC, X0, 1, - $ ONE, DWORK(IY), 1 ) - CALL DTRMV( 'Upper', 'No transpose', 'Non-unit', N, A, - $ LDA, X0, 1 ) -C - DO 130 IX = 2, N - X0(IX) = X0(IX) + A(IX,IX-1)*DWORK(IXINIT+IX-2) - 130 CONTINUE -C - CALL DCOPY( N, X0, 1, DWORK(IXINIT), 1 ) - IY = IY + L - 140 CONTINUE -C - END IF -C -C Compress the data using (sequential) QR factorization. -C Workspace: need v + 2*N; -C where v = s*L*(N + 1) + N + a + w. -C - JWORK = ITAU + N - IF ( FIRST ) THEN -C -C Compress the first data segment of Gamma. -C Workspace: need v + 2*N, -C prefer v + N + N*NB. -C - CALL DGEQRF( LDDW, N, DWORK(INIGAM), LDDW, DWORK(ITAU), - $ DWORK(JWORK), LDWORK-JWORK+1, IERR ) -C -C Apply the transformation to the right hand side part. -C Workspace: need v + N + 1, -C prefer v + N + NB. -C - CALL DORMQR( 'Left', 'Transpose', LDDW, 1, N, DWORK(INIGAM), - $ LDDW, DWORK(ITAU), DWORK(IRHS), LDDW, - $ DWORK(JWORK), LDWORK-JWORK+1, IERR ) -C - IF ( NCYC ) THEN -C -C Save the triangular factor of Gamma and the -C corresponding right hand side. -C - CALL DLACPY( 'Upper', N, NCP1, DWORK(INIGAM), LDDW, - $ DWORK(INIR), LDR ) - END IF - ELSE -C -C Compress the current (but not the first) data segment of -C Gamma. -C Workspace: need v + N - 1. -C - CALL MB04OD( 'Full', N, 1, LDDW, DWORK(INIR), LDR, - $ DWORK(INIGAM), LDDW, DWORK(INIH), LDR, - $ DWORK(IRHS), LDDW, DWORK(ITAU), DWORK(JWORK) ) - END IF -C - IUPNT = IUPNT + NOBS - IYPNT = IYPNT + NOBS - 150 CONTINUE -C -C Estimate the reciprocal condition number of the triangular factor -C of the QR decomposition. -C Workspace: need u + 3*N, where -C u = t*L*(N + 1), if NCYCLE = 1; -C u = w, if NCYCLE > 1. -C - CALL DTRCON( '1-norm', 'Upper', 'No Transpose', N, DWORK(INIR), - $ LDR, RCOND, DWORK(IE), IWORK, IERR ) -C - TOLL = TOL - IF ( TOLL.LE.ZERO ) - $ TOLL = DLAMCH( 'Precision' ) - IF ( RCOND.LE.TOLL**( TWO/THREE ) ) THEN - IWARN = 4 -C -C The least squares problem is ill-conditioned. -C Use SVD to solve it. -C Workspace: need u + 6*N; -C prefer larger. -C - CALL DLASET( 'Lower', N-1, N-1, ZERO, ZERO, DWORK(INIR+1), - $ LDR ) - ISV = IE - JWORK = ISV + N - CALL DGELSS( N, N, 1, DWORK(INIR), LDR, DWORK(INIH), LDR, - $ DWORK(ISV), TOLL, RANK, DWORK(JWORK), - $ LDWORK-JWORK+1, IERR ) - IF ( IERR.GT.0 ) THEN -C -C Return if SVD algorithm did not converge. -C - INFO = 2 - RETURN - END IF - MAXWRK = MAX( MAXWRK, INT( DWORK(JWORK) ) - JWORK + 1 ) - ELSE -C -C Find the least squares solution using QR decomposition only. -C - CALL DTRSV( 'Upper', 'No Transpose', 'Non Unit', N, - $ DWORK(INIR), LDR, DWORK(INIH), 1 ) - END IF -C -C Return the estimated initial state of the system x0. -C - CALL DCOPY( N, DWORK(INIH), 1, X0, 1 ) -C - DWORK(1) = MAXWRK - DWORK(2) = RCOND -C - RETURN -C -C *** End of IB01RD *** - END diff --git a/mex/sources/libslicot/IB03AD.f b/mex/sources/libslicot/IB03AD.f deleted file mode 100644 index 9ba63187c..000000000 --- a/mex/sources/libslicot/IB03AD.f +++ /dev/null @@ -1,1076 +0,0 @@ - SUBROUTINE IB03AD( INIT, ALG, STOR, NOBR, M, L, NSMP, N, NN, - $ ITMAX1, ITMAX2, NPRINT, U, LDU, Y, LDY, X, LX, - $ TOL1, TOL2, IWORK, DWORK, LDWORK, IWARN, INFO ) -C -C SLICOT RELEASE 5.0. -C -C Copyright (c) 2002-2009 NICONET e.V. -C -C This program is free software: you can redistribute it and/or -C modify it under the terms of the GNU General Public License as -C published by the Free Software Foundation, either version 2 of -C the License, or (at your option) any later version. -C -C This program is distributed in the hope that it will be useful, -C but WITHOUT ANY WARRANTY; without even the implied warranty of -C MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the -C GNU General Public License for more details. -C -C You should have received a copy of the GNU General Public License -C along with this program. If not, see -C . -C -C PURPOSE -C -C To compute a set of parameters for approximating a Wiener system -C in a least-squares sense, using a neural network approach and a -C Levenberg-Marquardt algorithm. Conjugate gradients (CG) or -C Cholesky algorithms are used to solve linear systems of equations. -C The Wiener system is represented as -C -C x(t+1) = A*x(t) + B*u(t) -C z(t) = C*x(t) + D*u(t), -C -C y(t) = f(z(t),wb(1:L)), -C -C where t = 1, 2, ..., NSMP, and f is a nonlinear function, -C evaluated by the SLICOT Library routine NF01AY. The parameter -C vector X is partitioned as X = ( wb(1), ..., wb(L), theta ), -C where wb(i), i = 1 : L, correspond to the nonlinear part, and -C theta corresponds to the linear part. See SLICOT Library routine -C NF01AD for further details. -C -C The sum of squares of the error functions, defined by -C -C e(t) = y(t) - Y(t), t = 1, 2, ..., NSMP, -C -C is minimized, where Y(t) is the measured output vector. The -C functions and their Jacobian matrices are evaluated by SLICOT -C Library routine NF01BB (the FCN routine in the call of MD03AD). -C -C ARGUMENTS -C -C Mode Parameters -C -C INIT CHARACTER*1 -C Specifies which parts have to be initialized, as follows: -C = 'L' : initialize the linear part only, X already -C contains an initial approximation of the -C nonlinearity; -C = 'S' : initialize the static nonlinearity only, X -C already contains an initial approximation of the -C linear part; -C = 'B' : initialize both linear and nonlinear parts; -C = 'N' : do not initialize anything, X already contains -C an initial approximation. -C If INIT = 'S' or 'B', the error functions for the -C nonlinear part, and their Jacobian matrices, are evaluated -C by SLICOT Library routine NF01BA (used as a second FCN -C routine in the MD03AD call for the initialization step, -C see METHOD). -C -C ALG CHARACTER*1 -C Specifies the algorithm used for solving the linear -C systems involving a Jacobian matrix J, as follows: -C = 'D' : a direct algorithm, which computes the Cholesky -C factor of the matrix J'*J + par*I is used, where -C par is the Levenberg factor; -C = 'I' : an iterative Conjugate Gradients algorithm, which -C only needs the matrix J, is used. -C In both cases, matrix J is stored in a compressed form. -C -C STOR CHARACTER*1 -C If ALG = 'D', specifies the storage scheme for the -C symmetric matrix J'*J, as follows: -C = 'F' : full storage is used; -C = 'P' : packed storage is used. -C The option STOR = 'F' usually ensures a faster execution. -C This parameter is not relevant if ALG = 'I'. -C -C Input/Output Parameters -C -C NOBR (input) INTEGER -C If INIT = 'L' or 'B', NOBR is the number of block rows, s, -C in the input and output block Hankel matrices to be -C processed for estimating the linear part. NOBR > 0. -C (In the MOESP theory, NOBR should be larger than n, -C the estimated dimension of state vector.) -C This parameter is ignored if INIT is 'S' or 'N'. -C -C M (input) INTEGER -C The number of system inputs. M >= 0. -C -C L (input) INTEGER -C The number of system outputs. L >= 0, and L > 0, if -C INIT = 'L' or 'B'. -C -C NSMP (input) INTEGER -C The number of input and output samples, t. NSMP >= 0, and -C NSMP >= 2*(M+L+1)*NOBR - 1, if INIT = 'L' or 'B'. -C -C N (input/output) INTEGER -C The order of the linear part. -C If INIT = 'L' or 'B', and N < 0 on entry, the order is -C assumed unknown and it will be found by the routine. -C Otherwise, the input value will be used. If INIT = 'S' -C or 'N', N must be non-negative. The values N >= NOBR, -C or N = 0, are not acceptable if INIT = 'L' or 'B'. -C -C NN (input) INTEGER -C The number of neurons which shall be used to approximate -C the nonlinear part. NN >= 0. -C -C ITMAX1 (input) INTEGER -C The maximum number of iterations for the initialization of -C the static nonlinearity. -C This parameter is ignored if INIT is 'N' or 'L'. -C Otherwise, ITMAX1 >= 0. -C -C ITMAX2 (input) INTEGER -C The maximum number of iterations. ITMAX2 >= 0. -C -C NPRINT (input) INTEGER -C This parameter enables controlled printing of iterates if -C it is positive. In this case, FCN is called with IFLAG = 0 -C at the beginning of the first iteration and every NPRINT -C iterations thereafter and immediately prior to return, -C and the current error norm is printed. Other intermediate -C results could be printed by modifying the corresponding -C FCN routine (NF01BA and/or NF01BB). If NPRINT <= 0, no -C special calls of FCN with IFLAG = 0 are made. -C -C U (input) DOUBLE PRECISION array, dimension (LDU, M) -C The leading NSMP-by-M part of this array must contain the -C set of input samples, -C U = ( U(1,1),...,U(1,M); ...; U(NSMP,1),...,U(NSMP,M) ). -C -C LDU INTEGER -C The leading dimension of array U. LDU >= MAX(1,NSMP). -C -C Y (input) DOUBLE PRECISION array, dimension (LDY, L) -C The leading NSMP-by-L part of this array must contain the -C set of output samples, -C Y = ( Y(1,1),...,Y(1,L); ...; Y(NSMP,1),...,Y(NSMP,L) ). -C -C LDY INTEGER -C The leading dimension of array Y. LDY >= MAX(1,NSMP). -C -C X (input/output) DOUBLE PRECISION array dimension (LX) -C On entry, if INIT = 'L', the leading (NN*(L+2) + 1)*L part -C of this array must contain the initial parameters for -C the nonlinear part of the system. -C On entry, if INIT = 'S', the elements lin1 : lin2 of this -C array must contain the initial parameters for the linear -C part of the system, corresponding to the output normal -C form, computed by SLICOT Library routine TB01VD, where -C lin1 = (NN*(L+2) + 1)*L + 1; -C lin2 = (NN*(L+2) + 1)*L + N*(L+M+1) + L*M. -C On entry, if INIT = 'N', the elements 1 : lin2 of this -C array must contain the initial parameters for the -C nonlinear part followed by the initial parameters for the -C linear part of the system, as specified above. -C This array need not be set on entry if INIT = 'B'. -C On exit, the elements 1 : lin2 of this array contain the -C optimal parameters for the nonlinear part followed by the -C optimal parameters for the linear part of the system, as -C specified above. -C -C LX (input/output) INTEGER -C On entry, this parameter must contain the intended length -C of X. If N >= 0, then LX >= NX := lin2 (see parameter X). -C If N is unknown (N < 0 on entry), a large enough estimate -C of N should be used in the formula of lin2. -C On exit, if N < 0 on entry, but LX is not large enough, -C then this parameter contains the actual length of X, -C corresponding to the computed N. Otherwise, its value -C is unchanged. -C -C Tolerances -C -C TOL1 DOUBLE PRECISION -C If INIT = 'S' or 'B' and TOL1 >= 0, TOL1 is the tolerance -C which measures the relative error desired in the sum of -C squares, for the initialization step of nonlinear part. -C Termination occurs when the actual relative reduction in -C the sum of squares is at most TOL1. In addition, if -C ALG = 'I', TOL1 also measures the relative residual of -C the solutions computed by the CG algorithm (for the -C initialization step). Termination of a CG process occurs -C when the relative residual is at most TOL1. -C If the user sets TOL1 < 0, then SQRT(EPS) is used -C instead TOL1, where EPS is the machine precision -C (see LAPACK Library routine DLAMCH). -C This parameter is ignored if INIT is 'N' or 'L'. -C -C TOL2 DOUBLE PRECISION -C If TOL2 >= 0, TOL2 is the tolerance which measures the -C relative error desired in the sum of squares, for the -C whole optimization process. Termination occurs when the -C actual relative reduction in the sum of squares is at -C most TOL2. -C If ALG = 'I', TOL2 also measures the relative residual of -C the solutions computed by the CG algorithm (for the whole -C optimization). Termination of a CG process occurs when the -C relative residual is at most TOL2. -C If the user sets TOL2 < 0, then SQRT(EPS) is used -C instead TOL2. This default value could require many -C iterations, especially if TOL1 is larger. If INIT = 'S' -C or 'B', it is advisable that TOL2 be larger than TOL1, -C and spend more time with cheaper iterations. -C -C Workspace -C -C IWORK INTEGER array, dimension (MAX( 3, LIW1, LIW2 )), where -C LIW1 = LIW2 = 0, if INIT = 'S' or 'N'; otherwise, -C LIW1 = M+L; -C LIW2 = MAX(M*NOBR+N,M*(N+L)). -C On output, if INFO = 0, IWORK(1) and IWORK(2) return the -C (total) number of function and Jacobian evaluations, -C respectively (including the initialization step, if it was -C performed), and if INIT = 'L' or INIT = 'B', IWORK(3) -C specifies how many locations of DWORK contain reciprocal -C condition number estimates (see below); otherwise, -C IWORK(3) = 0. -C -C DWORK DOUBLE PRECISION array dimesion (LDWORK) -C On entry, if desired, and if INIT = 'S' or 'B', the -C entries DWORK(1:4) are set to initialize the random -C numbers generator for the nonlinear part parameters (see -C the description of the argument XINIT of SLICOT Library -C routine MD03AD); this enables to obtain reproducible -C results. The same seed is used for all outputs. -C On exit, if INFO = 0, DWORK(1) returns the optimal value -C of LDWORK, DWORK(2) returns the residual error norm (the -C sum of squares), DWORK(3) returns the number of iterations -C performed, DWORK(4) returns the number of conjugate -C gradients iterations performed, and DWORK(5) returns the -C final Levenberg factor, for optimizing the parameters of -C both the linear part and the static nonlinearity part. -C If INIT = 'S' or INIT = 'B' and INFO = 0, then the -C elements DWORK(6) to DWORK(10) contain the corresponding -C five values for the initialization step (see METHOD). -C (If L > 1, DWORK(10) contains the maximum of the Levenberg -C factors for all outputs.) If INIT = 'L' or INIT = 'B', and -C INFO = 0, DWORK(11) to DWORK(10+IWORK(3)) contain -C reciprocal condition number estimates set by SLICOT -C Library routines IB01AD, IB01BD, and IB01CD. -C On exit, if INFO = -23, DWORK(1) returns the minimum -C value of LDWORK. -C -C LDWORK INTEGER -C The length of the array DWORK. -C In the formulas below, N should be taken not larger than -C NOBR - 1, if N < 0 on entry. -C LDWORK = MAX( LW1, LW2, LW3, LW4 ), where -C LW1 = 0, if INIT = 'S' or 'N'; otherwise, -C LW1 = MAX( 2*(M+L)*NOBR*(2*(M+L)*(NOBR+1)+3) + L*NOBR, -C 4*(M+L)*NOBR*(M+L)*NOBR + (N+L)*(N+M) + -C MAX( LDW1, LDW2 ), -C (N+L)*(N+M) + N + N*N + 2 + N*(N+M+L) + -C MAX( 5*N, 2, MIN( LDW3, LDW4 ), LDW5, LDW6 ), -C where, -C LDW1 >= MAX( 2*(L*NOBR-L)*N+2*N, (L*NOBR-L)*N+N*N+7*N, -C L*NOBR*N + -C MAX( (L*NOBR-L)*N+2*N + (2*M+L)*NOBR+L, -C 2*(L*NOBR-L)*N+N*N+8*N, -C N+4*(M*NOBR+N)+1, M*NOBR+3*N+L ) ) -C LDW2 >= 0, if M = 0; -C LDW2 >= L*NOBR*N + M*NOBR*(N+L)*(M*(N+L)+1) + -C MAX( (N+L)**2, 4*M*(N+L)+1 ), if M > 0; -C LDW3 = NSMP*L*(N+1) + 2*N + MAX( 2*N*N, 4*N ), -C LDW4 = N*(N+1) + 2*N + -C MAX( N*L*(N+1) + 2*N*N + L*N, 4*N ); -C LDW5 = NSMP*L + (N+L)*(N+M) + 3*N+M+L; -C LDW6 = NSMP*L + (N+L)*(N+M) + N + -C MAX(1, N*N*L + N*L + N, N*N + -C MAX(N*N + N*MAX(N,L) + 6*N + MIN(N,L), -C N*M)); -C LW2 = LW3 = 0, if INIT = 'L' or 'N'; otherwise, -C LW2 = NSMP*L + -C MAX( 5, NSMP + 2*BSN + NSMP*BSN + -C MAX( 2*NN + BSN, LDW7 ) ); -C LDW7 = BSN*BSN, if ALG = 'D' and STOR = 'F'; -C LDW7 = BSN*(BSN+1)/2, if ALG = 'D' and STOR = 'P'; -C LDW7 = 3*BSN + NSMP, if ALG = 'I'; -C LW3 = MAX( LDW8, NSMP*L + (N+L)*(2*N+M) + 2*N ); -C LDW8 = NSMP*L + (N+L)*(N+M) + 3*N+M+L, if M > 0; -C LDW8 = NSMP*L + (N+L)*N + 2*N+L, if M = 0; -C LW4 = MAX( 5, NSMP*L + 2*NX + NSMP*L*( BSN + LTHS ) + -C MAX( L1 + NX, NSMP*L + L1, L2 ) ), -C L0 = MAX( N*(N+L), N+M+L ), if M > 0; -C L0 = MAX( N*(N+L), L ), if M = 0; -C L1 = NSMP*L + MAX( 2*NN, (N+L)*(N+M) + 2*N + L0); -C L2 = NX*NX, if ALG = 'D' and STOR = 'F'; -C L2 = NX*(NX+1)/2, if ALG = 'D' and STOR = 'P'; -C L2 = 3*NX + NSMP*L, if ALG = 'I', -C with BSN = NN*( L + 2 ) + 1, -C LTHS = N*( L + M + 1 ) + L*M. -C For optimum performance LDWORK should be larger. -C -C Warning Indicator -C -C IWARN INTEGER -C = 0: no warning; -C < 0: the user set IFLAG = IWARN in (one of) the -C subroutine(s) FCN, i.e., NF01BA, if INIT = 'S' -C or 'B', and/or NF01BB; this value cannot be returned -C without changing the FCN routine(s); -C otherwise, IWARN has the value k*100 + j*10 + i, -C where k is defined below, i refers to the whole -C optimization process, and j refers to the -C initialization step (j = 0, if INIT = 'L' or 'N'), -C and the possible values for i and j have the -C following meaning (where TOL* denotes TOL1 or TOL2, -C and similarly for ITMAX*): -C = 1: the number of iterations has reached ITMAX* without -C satisfying the convergence condition; -C = 2: if alg = 'I' and in an iteration of the Levenberg- -C Marquardt algorithm, the CG algorithm finished -C after 3*NX iterations (or 3*(lin1-1) iterations, for -C the initialization phase), without achieving the -C precision required in the call; -C = 3: the cosine of the angle between the vector of error -C function values and any column of the Jacobian is at -C most FACTOR*EPS in absolute value (FACTOR = 100); -C = 4: TOL* is too small: no further reduction in the sum -C of squares is possible. -C The digit k is normally 0, but if INIT = 'L' or 'B', it -C can have a value in the range 1 to 6 (see IB01AD, IB01BD -C and IB01CD). In all these cases, the entries DWORK(1:5), -C DWORK(6:10) (if INIT = 'S' or 'B'), and -C DWORK(11:10+IWORK(3)) (if INIT = 'L' or 'B'), are set as -C described above. -C -C Error Indicator -C -C INFO INTEGER -C = 0: successful exit; -C < 0: if INFO = -i, the i-th argument had an illegal -C value; -C otherwise, INFO has the value k*100 + j*10 + i, -C where k is defined below, i refers to the whole -C optimization process, and j refers to the -C initialization step (j = 0, if INIT = 'L' or 'N'), -C and the possible values for i and j have the -C following meaning: -C = 1: the routine FCN returned with INFO <> 0 for -C IFLAG = 1; -C = 2: the routine FCN returned with INFO <> 0 for -C IFLAG = 2; -C = 3: ALG = 'D' and SLICOT Library routines MB02XD or -C NF01BU (or NF01BV, if INIT = 'S' or 'B') or -C ALG = 'I' and SLICOT Library routines MB02WD or -C NF01BW (or NF01BX, if INIT = 'S' or 'B') returned -C with INFO <> 0. -C In addition, if INIT = 'L' or 'B', i could also be -C = 4: if a Lyapunov equation could not be solved; -C = 5: if the identified linear system is unstable; -C = 6: if the QR algorithm failed on the state matrix -C of the identified linear system. -C The digit k is normally 0, but if INIT = 'L' or 'B', it -C can have a value in the range 1 to 10 (see IB01AD/IB01BD). -C -C METHOD -C -C If INIT = 'L' or 'B', the linear part of the system is -C approximated using the combined MOESP and N4SID algorithm. If -C necessary, this algorithm can also choose the order, but it is -C advantageous if the order is already known. -C -C If INIT = 'S' or 'B', the output of the approximated linear part -C is computed and used to calculate an approximation of the static -C nonlinearity using the Levenberg-Marquardt algorithm [1]. -C This step is referred to as the (nonlinear) initialization step. -C -C As last step, the Levenberg-Marquardt algorithm is used again to -C optimize the parameters of the linear part and the static -C nonlinearity as a whole. Therefore, it is necessary to parametrise -C the matrices of the linear part. The output normal form [2] -C parameterisation is used. -C -C The Jacobian is computed analytically, for the nonlinear part, and -C numerically, for the linear part. -C -C REFERENCES -C -C [1] Kelley, C.T. -C Iterative Methods for Optimization. -C Society for Industrial and Applied Mathematics (SIAM), -C Philadelphia (Pa.), 1999. -C -C [2] Peeters, R.L.M., Hanzon, B., and Olivi, M. -C Balanced realizations of discrete-time stable all-pass -C systems and the tangential Schur algorithm. -C Proceedings of the European Control Conference, -C 31 August - 3 September 1999, Karlsruhe, Germany. -C Session CP-6, Discrete-time Systems, 1999. -C -C CONTRIBUTORS -C -C A. Riedel, R. Schneider, Chemnitz University of Technology, -C Oct. 2000, during a stay at University of Twente, NL. -C V. Sima, Research Institute for Informatics, Bucharest, Dec. 2001. -C -C REVISIONS -C -C V. Sima, Research Institute for Informatics, Bucharest, Mar. 2001, -C Mar. 2002, Apr. 2002, Feb. 2004, March 2005, Nov. 2005. -C -C KEYWORDS -C -C Conjugate gradients, least-squares approximation, -C Levenberg-Marquardt algorithm, matrix operations, optimization. -C -C ****************************************************************** -C -C .. Parameters .. - DOUBLE PRECISION ZERO - PARAMETER ( ZERO = 0.0D0 ) -C The upper triangular part is used in MD03AD; - CHARACTER UPLO - PARAMETER ( UPLO = 'U' ) -C For INIT = 'L' or 'B', additional parameters are set: -C The following six parameters are used in the call of IB01AD; - CHARACTER IALG, BATCH, CONCT, CTRL, JOBD, METH - PARAMETER ( IALG = 'Fast QR', BATCH = 'One batch', - $ CONCT = 'Not connect', CTRL = 'Not confirm', - $ JOBD = 'Not MOESP', METH = 'MOESP' ) -C The following three parameters are used in the call of IB01BD; - CHARACTER JOB, JOBCK, METHB - PARAMETER ( JOB = 'All matrices', - $ JOBCK = 'No Kalman gain', - $ METHB = 'Combined MOESP+N4SID' ) -C The following two parameters are used in the call of IB01CD; - CHARACTER COMUSE, JOBXD - PARAMETER ( COMUSE = 'Use B, D', - $ JOBXD = 'D also' ) -C TOLN controls the estimated order in IB01AD (default value); - DOUBLE PRECISION TOLN - PARAMETER ( TOLN = -1.0D0 ) -C RCOND controls the rank decisions in IB01AD, IB01BD, and IB01CD -C (default); - DOUBLE PRECISION RCOND - PARAMETER ( RCOND = -1.0D0 ) -C .. Scalar Arguments .. - CHARACTER ALG, INIT, STOR - INTEGER INFO, ITMAX1, ITMAX2, IWARN, L, LDU, LDWORK, - $ LDY, LX, M, N, NN, NOBR, NPRINT, NSMP - DOUBLE PRECISION TOL1, TOL2 -C .. Array Arguments .. - DOUBLE PRECISION DWORK(*), U(LDU, *), X(*), Y(LDY, *) - INTEGER IWORK(*) -C .. Local Scalars .. - INTEGER AC, BD, BSN, I, IA, IB, IK, INFOL, IQ, IR, - $ IRCND, IRCNDB, IRY, IS, ISAD, ISV, IV, IW1, IW2, - $ IWARNL, IX, IX0, J, JWORK, LDAC, LDR, LIPAR, - $ LNOL, LTHS, ML, MNO, N2, NFEV, NJEV, NS, NSML, - $ NTHS, NX, WRKOPT, Z - LOGICAL CHOL, FULL, INIT1, INIT2 -C .. Local Arrays .. - LOGICAL BWORK(1) - INTEGER IPAR(7) - DOUBLE PRECISION RCND(16), SEED(4), WORK(5) -C .. External Functions .. - EXTERNAL LSAME - LOGICAL LSAME -C .. External Subroutines .. - EXTERNAL DCOPY, IB01AD, IB01BD, IB01CD, MD03AD, NF01BA, - $ NF01BB, NF01BU, NF01BV, NF01BW, NF01BX, TB01VD, - $ TB01VY, TF01MX, XERBLA -C .. Intrinsic Functions .. - INTRINSIC INT, MAX, MIN -C .. -C .. Executable Statements .. -C - CHOL = LSAME( ALG, 'D' ) - FULL = LSAME( STOR, 'F' ) - INIT1 = LSAME( INIT, 'B' ) .OR. LSAME( INIT, 'L' ) - INIT2 = LSAME( INIT, 'B' ) .OR. LSAME( INIT, 'S' ) -C - ML = M + L - INFO = 0 - IWARN = 0 - IF ( .NOT.( INIT1 .OR. INIT2 .OR. LSAME( INIT, 'N' ) ) ) THEN - INFO = -1 - ELSEIF ( .NOT.( CHOL .OR. LSAME( ALG, 'I' ) ) ) THEN - INFO = -2 - ELSEIF ( CHOL .AND. .NOT.( FULL .OR. LSAME( STOR, 'P' ) ) ) THEN - INFO = -3 - ELSEIF ( INIT1 .AND. NOBR.LE.0 ) THEN - INFO = -4 - ELSEIF ( M.LT.0 ) THEN - INFO = -5 - ELSEIF ( L.LT.0 .OR. ( INIT1 .AND. L.EQ.0 ) ) THEN - INFO = -6 - ELSEIF ( NSMP.LT.0 .OR. - $ ( INIT1 .AND. NSMP.LT.2*( ML + 1 )*NOBR - 1 ) ) THEN - INFO = -7 - ELSEIF ( ( N.LT.0 .AND. .NOT.INIT1 ) .OR. - $ ( ( N.EQ.0 .OR. N.GE.NOBR ) .AND. INIT1 ) ) THEN - INFO = -8 - ELSEIF ( NN.LT.0 ) THEN - INFO = -9 - ELSEIF ( INIT2 .AND. ( ITMAX1.LT.0 ) ) THEN - INFO = -10 - ELSEIF ( ITMAX2.LT.0 ) THEN - INFO = -11 - ELSEIF ( LDU.LT.MAX( 1, NSMP ) ) THEN - INFO = -14 - ELSEIF ( LDY.LT.MAX( 1, NSMP ) ) THEN - INFO = -16 - ELSE - LNOL = L*NOBR - L - MNO = M*NOBR - BSN = NN*( L + 2 ) + 1 - NTHS = BSN*L - NSML = NSMP*L - IF ( N.GT.0 ) THEN - LDAC = N + L - ISAD = LDAC*( N + M ) - N2 = N*N - END IF -C -C Check the workspace size. -C - JWORK = 0 - IF ( INIT1 ) THEN -C Workspace for IB01AD. - JWORK = 2*ML*NOBR*( 2*ML*( NOBR + 1 ) + 3 ) + L*NOBR - IF ( N.GT.0 ) THEN -C Workspace for IB01BD. - IW1 = MAX( 2*LNOL*N + 2*N, LNOL*N + N2 + 7*N, L*NOBR*N + - $ MAX( LNOL*N + 2*N + ( M + ML )*NOBR + L, - $ 2*LNOL*N + N2 + 8*N, N + 4*( MNO + N ) + - $ 1, MNO + 3*N + L ) ) - IF ( M.GT.0 ) THEN - IW2 = L*NOBR*N + MNO*LDAC*( M*LDAC + 1 ) + - $ MAX( LDAC**2, 4*M*LDAC + 1 ) - ELSE - IW2 = 0 - END IF - JWORK = MAX( JWORK, - $ ( 2*ML*NOBR )**2 + ISAD + MAX( IW1, IW2 ) ) -C Workspace for IB01CD. - IW1 = NSML*( N + 1 ) + 2*N + MAX( 2*N2, 4*N ) - IW2 = N*( N + 1 ) + 2*N + - $ MAX( N*L*( N + 1 ) + 2*N2 + L*N, 4*N ) - JWORK = MAX( JWORK, ISAD + 2 + N*( N + 1 + LDAC + M ) + - $ MAX( 5*N, 2, MIN( IW1, IW2 ) ) ) -C Workspace for TF01MX. - JWORK = MAX( JWORK, NSML + ISAD + LDAC + 2*N + M ) -C Workspace for TB01VD. - JWORK = MAX( JWORK, NSML + ISAD + N + - $ MAX( 1, N2*L + N*L + N, - $ N2 + MAX( N2 + N*MAX( N, L ) + - $ 6*N + MIN( N, L ), N*M ) ) ) - END IF - END IF -C - IF ( INIT2 ) THEN -C Workspace for MD03AD (initialization of the nonlinear part). - IF ( CHOL ) THEN - IF ( FULL ) THEN - IW1 = BSN**2 - ELSE - IW1 = ( BSN*( BSN + 1 ) )/2 - END IF - ELSE - IW1 = 3*BSN + NSMP - END IF - JWORK = MAX( JWORK, NSML + - $ MAX( 5, NSMP + 2*BSN + NSMP*BSN + - $ MAX( 2*NN + BSN, IW1 ) ) ) - IF ( N.GT.0 .AND. .NOT.INIT1 ) THEN -C Workspace for TB01VY. - JWORK = MAX( JWORK, NSML + LDAC*( 2*N + M ) + 2*N ) -C Workspace for TF01MX. - IF ( M.GT.0 ) THEN - IW1 = N + M - ELSE - IW1 = 0 - END IF - JWORK = MAX( JWORK, NSML + ISAD + IW1 + LDAC + N ) - END IF - END IF -C - IF ( N.GE.0 ) THEN -C -C Find the number of parameters. -C - LTHS = N*( ML + 1 ) + L*M - NX = NTHS + LTHS -C - IF ( LX.LT.NX ) THEN - INFO = -18 - CALL XERBLA( 'IB03AD', -INFO ) - RETURN - END IF -C -C Workspace for MD03AD (whole optimization). -C - IF ( M.GT.0 ) THEN - IW1 = LDAC + M - ELSE - IW1 = L - END IF - IW1 = NSML + MAX( 2*NN, ISAD + 2*N + MAX( N*LDAC, IW1 ) ) - IF ( CHOL ) THEN - IF ( FULL ) THEN - IW2 = NX**2 - ELSE - IW2 = ( NX*( NX + 1 ) )/2 - END IF - ELSE - IW2 = 3*NX + NSML - END IF - JWORK = MAX( JWORK, - $ 5, NSML + 2*NX + NSML*( BSN + LTHS ) + - $ MAX( IW1 + NX, NSML + IW1, IW2 ) ) - END IF -C - IF ( LDWORK.LT.JWORK ) THEN - INFO = -23 - DWORK(1) = JWORK - END IF - END IF -C - IF( INFO.NE.0 ) THEN - CALL XERBLA( 'IB03AD', -INFO ) - RETURN - ENDIF -C -C Initialize the pointers to system matrices and save the possible -C seed for random numbers generation. -C - Z = 1 - AC = Z + NSML - CALL DCOPY( 4, DWORK, 1, SEED, 1 ) -C - WRKOPT = 1 -C - IF ( INIT1 ) THEN -C -C Initialize the linear part. -C If N < 0, the order of the system is determined by IB01AD; -C otherwise, the given order will be used. -C The workspace needed is defined for the options set above -C in the PARAMETER statements. -C Workspace: need: 2*(M+L)*NOBR*(2*(M+L)*(NOBR+1)+3) + L*NOBR; -C prefer: larger. -C Integer workspace: M+L. (If METH = 'N', (M+L)*NOBR.) -C - NS = N - IR = 1 - ISV = 2*ML*NOBR - LDR = ISV - IF ( LSAME( JOBD, 'M' ) ) - $ LDR = MAX( LDR, 3*MNO ) - ISV = IR + LDR*ISV - JWORK = ISV + L*NOBR -C - CALL IB01AD( METH, IALG, JOBD, BATCH, CONCT, CTRL, NOBR, M, L, - $ NSMP, U, LDU, Y, LDY, N, DWORK(IR), LDR, - $ DWORK(ISV), RCOND, TOLN, IWORK, DWORK(JWORK), - $ LDWORK-JWORK+1, IWARNL, INFOL ) -C - IF( INFOL.NE.0 ) THEN - INFO = 100*INFOL - RETURN - END IF - IF( IWARNL.NE.0 ) - $ IWARN = 100*IWARNL - WRKOPT = MAX( WRKOPT, INT( DWORK(JWORK) ) + JWORK - 1 ) - IRCND = 0 - IF ( LSAME( METH, 'N' ) ) THEN - IRCND = 2 - CALL DCOPY( IRCND, DWORK(JWORK+1), 1, RCND, 1 ) - END IF -C - IF ( NS.GE.0 ) THEN - N = NS - ELSE -C -C Find the number of parameters. -C - LDAC = N + L - ISAD = LDAC*( N + M ) - N2 = N*N - LTHS = N*( ML + 1 ) + L*M - NX = NTHS + LTHS -C - IF ( LX.LT.NX ) THEN - LX = NX - INFO = -18 - CALL XERBLA( 'IB03AD', -INFO ) - RETURN - END IF -C Workspace for IB01BD. - IW1 = MAX( 2*LNOL*N + 2*N, LNOL*N + N2 + 7*N, L*NOBR*N + - $ MAX( LNOL*N + 2*N + ( M + ML )*NOBR + L, - $ 2*LNOL*N + N2 + 8*N, N + 4*( MNO + N ) + 1, - $ MNO + 3*N + L ) ) - IF ( M.GT.0 ) THEN - IW2 = L*NOBR*N + MNO*LDAC*( M*LDAC + 1 ) + - $ MAX( LDAC**2, 4*M*LDAC + 1 ) - ELSE - IW2 = 0 - END IF - JWORK = ISV + ISAD + MAX( IW1, IW2 ) -C Workspace for IB01CD. - IW1 = NSML*( N + 1 ) + 2*N + MAX( 2*N2, 4*N ) - IW2 = N*( N + 1 ) + 2*N + MAX( N*L*( N + 1 ) + 2*N2 + L*N, - $ 4*N ) - JWORK = MAX( JWORK, ISAD + 2 + N*( N + 1 + LDAC + M ) + - $ MAX( 5*N, 2, MIN( IW1, IW2 ) ) ) -C Workspace for TF01MX. - JWORK = MAX( JWORK, NSML + ISAD + LDAC + 2*N + M ) -C Workspace for TB01VD. - JWORK = MAX( JWORK, NSML + ISAD + N + - $ MAX( 1, N2*L + N*L + N, - $ N2 + MAX( N2 + N*MAX( N, L ) + - $ 6*N + MIN( N, L ), N*M ) ) ) -C Workspace for MD03AD (whole optimization). - IF ( M.GT.0 ) THEN - IW1 = LDAC + M - ELSE - IW1 = L - END IF - IW1 = NSML + MAX( 2*NN, ISAD + 2*N + MAX( N*LDAC, IW1 ) ) - IF ( CHOL ) THEN - IF ( FULL ) THEN - IW2 = NX**2 - ELSE - IW2 = ( NX*( NX + 1 ) )/2 - END IF - ELSE - IW2 = 3*NX + NSML - END IF - JWORK = MAX( JWORK, - $ 5, NSML + 2*NX + NSML*( BSN + LTHS ) + - $ MAX( IW1 + NX, NSML + IW1, IW2 ) ) - IF ( LDWORK.LT.JWORK ) THEN - INFO = -23 - DWORK(1) = JWORK - CALL XERBLA( 'IB03AD', -INFO ) - RETURN - END IF - END IF -C - BD = AC + LDAC*N - IX = BD + LDAC*M - IA = ISV - IB = IA + LDAC*N - IQ = IB + LDAC*M - IF ( LSAME( JOBCK, 'N' ) ) THEN - IRY = IQ - IS = IQ - IK = IQ - JWORK = IQ - ELSE - IRY = IQ + N2 - IS = IRY + L*L - IK = IS + N*L - JWORK = IK + N*L - END IF -C -C The workspace needed is defined for the options set above -C in the PARAMETER statements. -C Workspace: -C need: 4*(M+L)*NOBR*(M+L)*NOBR + (N+L)*(N+M) + -C max( LDW1,LDW2 ), where, -C LDW1 >= max( 2*(L*NOBR-L)*N+2*N, (L*NOBR-L)*N+N*N+7*N, -C L*NOBR*N + -C max( (L*NOBR-L)*N+2*N + (2*M+L)*NOBR+L, -C 2*(L*NOBR-L)*N+N*N+8*N, -C N+4*(M*NOBR+N)+1, M*NOBR+3*N+L ) ) -C LDW2 >= 0, if M = 0; -C LDW2 >= L*NOBR*N+M*NOBR*(N+L)*(M*(N+L)+1)+ -C max( (N+L)**2, 4*M*(N+L)+1 ), if M > 0; -C prefer: larger. -C Integer workspace: MAX(M*NOBR+N,M*(N+L)). -C - CALL IB01BD( METHB, JOB, JOBCK, NOBR, N, M, L, NSMP, DWORK(IR), - $ LDR, DWORK(IA), LDAC, DWORK(IA+N), LDAC, - $ DWORK(IB), LDAC, DWORK(IB+N), LDAC, DWORK(IQ), N, - $ DWORK(IRY), L, DWORK(IS), N, DWORK(IK), N, RCOND, - $ IWORK, DWORK(JWORK), LDWORK-JWORK+1, BWORK, - $ IWARNL, INFOL ) -C - IF( INFOL.EQ.-30 ) THEN - INFO = -23 - DWORK(1) = DWORK(JWORK) - CALL XERBLA( 'IB03AD', -INFO ) - RETURN - END IF - IF( INFOL.NE.0 ) THEN - INFO = 100*INFOL - RETURN - END IF - IF( IWARNL.NE.0 ) - $ IWARN = 100*IWARNL - WRKOPT = MAX( WRKOPT, INT( DWORK(JWORK) ) + JWORK - 1 ) - IRCNDB = 4 - IF ( LSAME( JOBCK, 'K' ) ) - $ IRCNDB = IRCNDB + 8 - CALL DCOPY( IRCNDB, DWORK(JWORK+1), 1, RCND(IRCND+1), 1 ) - IRCND = IRCND + IRCNDB -C -C Copy the system matrices to the beginning of DWORK, to save -C space, and redefine the pointers. -C - CALL DCOPY( ISAD, DWORK(IA), 1, DWORK, 1 ) - IA = 1 - IB = IA + LDAC*N - IX0 = IB + LDAC*M - IV = IX0 + N -C -C Compute the initial condition of the system. On normal exit, -C DWORK(i), i = JWORK+2:JWORK+1+N*N, -C DWORK(j), j = JWORK+2+N*N:JWORK+1+N*N+L*N, and -C DWORK(k), k = JWORK+2+N*N+L*N:JWORK+1+N*N+L*N+N*M, -C contain the transformed system matrices At, Ct, and Bt, -C respectively, corresponding to the real Schur form of the -C estimated system state matrix A. The transformation matrix is -C stored in DWORK(IV:IV+N*N-1). -C The workspace needed is defined for the options set above -C in the PARAMETER statements. -C Workspace: -C need: (N+L)*(N+M) + N + N*N + 2 + N*( N + M + L ) + -C max( 5*N, 2, min( LDW1, LDW2 ) ), where, -C LDW1 = NSMP*L*(N + 1) + 2*N + max( 2*N*N, 4*N), -C LDW2 = N*(N + 1) + 2*N + -C max( N*L*(N + 1) + 2*N*N + L*N, 4*N); -C prefer: larger. -C Integer workspace: N. -C - JWORK = IV + N2 - CALL IB01CD( 'X needed', COMUSE, JOBXD, N, M, L, NSMP, - $ DWORK(IA), LDAC, DWORK(IB), LDAC, DWORK(IA+N), - $ LDAC, DWORK(IB+N), LDAC, U, LDU, Y, LDY, - $ DWORK(IX0), DWORK(IV), N, RCOND, IWORK, - $ DWORK(JWORK), LDWORK-JWORK+1, IWARNL, INFOL ) -C - IF( INFOL.EQ.-26 ) THEN - INFO = -23 - DWORK(1) = DWORK(JWORK) - CALL XERBLA( 'IB03AD', -INFO ) - RETURN - END IF - IF( INFOL.EQ.1 ) - $ INFOL = 10 - IF( INFOL.NE.0 ) THEN - INFO = 100*INFOL - RETURN - END IF - IF( IWARNL.NE.0 ) - $ IWARN = 100*IWARNL - WRKOPT = MAX( WRKOPT, INT( DWORK(JWORK) ) + JWORK - 1 ) - IRCND = IRCND + 1 - RCND(IRCND) = DWORK(JWORK+1) -C -C Now, save the system matrices and x0 in the final location. -C - IF ( IV.LT.AC ) THEN - CALL DCOPY( ISAD+N, DWORK(IA), 1, DWORK(AC), 1 ) - ELSE - DO 5 J = AC + ISAD + N - 1, AC, -1 - DWORK(J) = DWORK(IA+J-AC) - 5 CONTINUE - END IF -C -C Compute the output of the linear part. -C Workspace: need NSMP*L + (N + L)*(N + M) + 3*N + M + L, -C if M > 0; -C NSMP*L + (N + L)*N + 2*N + L, if M = 0; -C prefer larger. -C - JWORK = IX + N - CALL DCOPY( N, DWORK(IX), 1, X(NTHS+1), 1 ) - CALL TF01MX( N, M, L, NSMP, DWORK(AC), LDAC, U, LDU, X(NTHS+1), - $ DWORK(Z), NSMP, DWORK(JWORK), LDWORK-JWORK+1, - $ INFO ) -C -C Convert the state-space representation to output normal form. -C Workspace: -C need: NSMP*L + (N + L)*(N + M) + N + -C MAX(1, N*N*L + N*L + N, N*N + -C MAX(N*N + N*MAX(N,L) + 6*N + MIN(N,L), N*M)); -C prefer: larger. -C - CALL TB01VD( 'Apply', N, M, L, DWORK(AC), LDAC, DWORK(BD), - $ LDAC, DWORK(AC+N), LDAC, DWORK(BD+N), LDAC, - $ DWORK(IX), X(NTHS+1), LTHS, DWORK(JWORK), - $ LDWORK-JWORK+1, INFOL ) -C - IF( INFOL.GT.0 ) THEN - INFO = INFOL + 3 - RETURN - END IF - WRKOPT = MAX( WRKOPT, INT( DWORK(JWORK) ) + JWORK - 1 ) -C - END IF -C - LIPAR = 7 - IW1 = 0 - IW2 = 0 -C - IF ( INIT2 ) THEN -C -C Initialize the nonlinear part. -C - IF ( .NOT.INIT1 ) THEN - BD = AC + LDAC*N - IX = BD + LDAC*M -C -C Convert the output normal form to state-space model. -C Workspace: need NSMP*L + (N + L)*(2*N + M) + 2*N. -C (NSMP*L locations are reserved for the output of the linear -C part.) -C - JWORK = IX + N - CALL TB01VY( 'Apply', N, M, L, X(NTHS+1), LTHS, DWORK(AC), - $ LDAC, DWORK(BD), LDAC, DWORK(AC+N), LDAC, - $ DWORK(BD+N), LDAC, DWORK(IX), DWORK(JWORK), - $ LDWORK-JWORK+1, INFO ) -C -C Compute the output of the linear part. -C Workspace: need NSMP*L + (N + L)*(N + M) + 3*N + M + L, -C if M > 0; -C NSMP*L + (N + L)*N + 2*N + L, if M = 0; -C prefer larger. -C - CALL TF01MX( N, M, L, NSMP, DWORK(AC), LDAC, U, LDU, - $ DWORK(IX), DWORK(Z), NSMP, DWORK(JWORK), - $ LDWORK-JWORK+1, INFO ) - END IF -C -C Optimize the parameters of the nonlinear part. -C Workspace: -C need NSMP*L + -C MAX( 5, NSMP + 2*BSN + NSMP*BSN + -C MAX( 2*NN + BSN, DW( sol ) ) ), -C where, if ALG = 'D', -C DW( sol ) = BSN*BSN, if STOR = 'F'; -C DW( sol ) = BSN*(BSN+1)/2, if STOR = 'P'; -C and DW( sol ) = 3*BSN + NSMP, if ALG = 'I'; -C prefer larger. -C - JWORK = AC - WORK(1) = ZERO - CALL DCOPY( 4, WORK(1), 0, WORK(2), 1 ) -C -C Set the integer parameters needed, including the number of -C neurons. -C - IPAR(1) = NSMP - IPAR(2) = L - IPAR(3) = NN -C - DO 10 I = 0, L - 1 - CALL DCOPY( 4, SEED, 1, DWORK(JWORK), 1 ) - IF ( CHOL ) THEN - CALL MD03AD( 'Random initialization', ALG, STOR, UPLO, - $ NF01BA, NF01BV, NSMP, BSN, ITMAX1, NPRINT, - $ IPAR, LIPAR, DWORK(Z), NSMP, Y(1,I+1), LDY, - $ X(I*BSN+1), NFEV, NJEV, TOL1, TOL1, - $ DWORK(JWORK), LDWORK-JWORK+1, IWARNL, - $ INFOL ) - ELSE - CALL MD03AD( 'Random initialization', ALG, STOR, UPLO, - $ NF01BA, NF01BX, NSMP, BSN, ITMAX1, NPRINT, - $ IPAR, LIPAR, DWORK(Z), NSMP, Y(1,I+1), LDY, - $ X(I*BSN+1), NFEV, NJEV, TOL1, TOL1, - $ DWORK(JWORK), LDWORK-JWORK+1, IWARNL, - $ INFOL ) - END IF -C - IF( INFOL.NE.0 ) THEN - INFO = 10*INFOL - RETURN - END IF - IF ( IWARNL.LT.0 ) THEN - INFO = INFOL - IWARN = IWARNL - GO TO 20 - ELSEIF ( IWARNL.GT.0 ) THEN - IF ( IWARN.GT.100 ) THEN - IWARN = MAX( IWARN, ( IWARN/100 )*100 + 10*IWARNL ) - ELSE - IWARN = MAX( IWARN, 10*IWARNL ) - END IF - END IF - WORK(1) = MAX( WORK(1), DWORK(JWORK) ) - WORK(2) = MAX( WORK(2), DWORK(JWORK+1) ) - WORK(5) = MAX( WORK(5), DWORK(JWORK+4) ) - WORK(3) = WORK(3) + DWORK(JWORK+2) - WORK(4) = WORK(4) + DWORK(JWORK+3) - IW1 = NFEV + IW1 - IW2 = NJEV + IW2 - 10 CONTINUE -C - ENDIF -C -C Main iteration. -C Workspace: need MAX( 5, NFUN + 2*NX + NFUN*( BSN + LTHS ) + -C MAX( LDW1 + NX, NFUN + LDW1, DW( sol ) ) ), -C where NFUN = NSMP*L, and -C LDW1 = NFUN + MAX( 2*NN, (N + L)*(N + M) + 2*N + -C MAX( N*(N + L), N + M + L )), -C if M > 0, -C LDW1 = NFUN + MAX( 2*NN, (N + L)*N + 2*N + -C MAX( N*(N + L), L ) ), -C if M = 0; -C if ALG = 'D', -C DW( sol ) = NX*NX, if STOR = 'F'; -C DW( sol ) = NX*(NX+1)/2, if STOR = 'P'; -C and DW( sol ) = 3*NX + NFUN, if ALG = 'I', -C and DW( f ) is the workspace needed by the -C subroutine f; -C prefer larger. -C -C Set the integer parameters describing the Jacobian structure -C and the number of neurons. -C - IPAR(1) = LTHS - IPAR(2) = L - IPAR(3) = NSMP - IPAR(4) = BSN - IPAR(5) = M - IPAR(6) = N - IPAR(7) = NN -C - IF ( CHOL ) THEN - CALL MD03AD( 'Given initialization', ALG, STOR, UPLO, NF01BB, - $ NF01BU, NSML, NX, ITMAX2, NPRINT, IPAR, LIPAR, - $ U, LDU, Y, LDY, X, NFEV, NJEV, TOL2, TOL2, - $ DWORK, LDWORK, IWARNL, INFO ) - ELSE - CALL MD03AD( 'Given initialization', ALG, STOR, UPLO, NF01BB, - $ NF01BW, NSML, NX, ITMAX2, NPRINT, IPAR, LIPAR, - $ U, LDU, Y, LDY, X, NFEV, NJEV, TOL2, TOL2, - $ DWORK, LDWORK, IWARNL, INFO ) - END IF -C - IF( INFO.NE.0 ) - $ RETURN -C - 20 CONTINUE - IWORK(1) = IW1 + NFEV - IWORK(2) = IW2 + NJEV - IF ( IWARNL.LT.0 ) THEN - IWARN = IWARNL - ELSE - IWARN = IWARN + IWARNL - END IF - IF ( INIT2 ) - $ CALL DCOPY( 5, WORK, 1, DWORK(6), 1 ) - IF ( INIT1 ) THEN - IWORK(3) = IRCND - CALL DCOPY( IRCND, RCND, 1, DWORK(11), 1 ) - ELSE - IWORK(3) = 0 - END IF - RETURN -C -C *** Last line of IB03AD *** - END diff --git a/mex/sources/libslicot/IB03BD.f b/mex/sources/libslicot/IB03BD.f deleted file mode 100644 index a1e0e86de..000000000 --- a/mex/sources/libslicot/IB03BD.f +++ /dev/null @@ -1,1087 +0,0 @@ - SUBROUTINE IB03BD( INIT, NOBR, M, L, NSMP, N, NN, ITMAX1, ITMAX2, - $ NPRINT, U, LDU, Y, LDY, X, LX, TOL1, TOL2, - $ IWORK, DWORK, LDWORK, IWARN, INFO ) -C -C SLICOT RELEASE 5.0. -C -C Copyright (c) 2002-2009 NICONET e.V. -C -C This program is free software: you can redistribute it and/or -C modify it under the terms of the GNU General Public License as -C published by the Free Software Foundation, either version 2 of -C the License, or (at your option) any later version. -C -C This program is distributed in the hope that it will be useful, -C but WITHOUT ANY WARRANTY; without even the implied warranty of -C MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the -C GNU General Public License for more details. -C -C You should have received a copy of the GNU General Public License -C along with this program. If not, see -C . -C -C PURPOSE -C -C To compute a set of parameters for approximating a Wiener system -C in a least-squares sense, using a neural network approach and a -C MINPACK-like Levenberg-Marquardt algorithm. The Wiener system -C consists of a linear part and a static nonlinearity, and it is -C represented as -C -C x(t+1) = A*x(t) + B*u(t) -C z(t) = C*x(t) + D*u(t), -C -C y(t) = f(z(t),wb(1:L)), -C -C where t = 1, 2, ..., NSMP, and f is a nonlinear function, -C evaluated by the SLICOT Library routine NF01AY. The parameter -C vector X is partitioned as X = ( wb(1), ..., wb(L), theta ), -C where theta corresponds to the linear part, and wb(i), i = 1 : L, -C correspond to the nonlinear part. See SLICOT Library routine -C NF01AD for further details. -C -C The sum of squares of the error functions, defined by -C -C e(t) = y(t) - Y(t), t = 1, 2, ..., NSMP, -C -C is minimized, where Y(t) is the measured output vector. The -C functions and their Jacobian matrices are evaluated by SLICOT -C Library routine NF01BF (the FCN routine in the call of MD03BD). -C -C ARGUMENTS -C -C Mode Parameters -C -C INIT CHARACTER*1 -C Specifies which parts have to be initialized, as follows: -C = 'L' : initialize the linear part only, X already -C contains an initial approximation of the -C nonlinearity; -C = 'S' : initialize the static nonlinearity only, X -C already contains an initial approximation of the -C linear part; -C = 'B' : initialize both linear and nonlinear parts; -C = 'N' : do not initialize anything, X already contains -C an initial approximation. -C If INIT = 'S' or 'B', the error functions for the -C nonlinear part, and their Jacobian matrices, are evaluated -C by SLICOT Library routine NF01BE (used as a second FCN -C routine in the MD03BD call for the initialization step, -C see METHOD). -C -C Input/Output Parameters -C -C NOBR (input) INTEGER -C If INIT = 'L' or 'B', NOBR is the number of block rows, s, -C in the input and output block Hankel matrices to be -C processed for estimating the linear part. NOBR > 0. -C (In the MOESP theory, NOBR should be larger than n, -C the estimated dimension of state vector.) -C This parameter is ignored if INIT is 'S' or 'N'. -C -C M (input) INTEGER -C The number of system inputs. M >= 0. -C -C L (input) INTEGER -C The number of system outputs. L >= 0, and L > 0, if -C INIT = 'L' or 'B'. -C -C NSMP (input) INTEGER -C The number of input and output samples, t. NSMP >= 0, and -C NSMP >= 2*(M+L+1)*NOBR - 1, if INIT = 'L' or 'B'. -C -C N (input/output) INTEGER -C The order of the linear part. -C If INIT = 'L' or 'B', and N < 0 on entry, the order is -C assumed unknown and it will be found by the routine. -C Otherwise, the input value will be used. If INIT = 'S' -C or 'N', N must be non-negative. The values N >= NOBR, -C or N = 0, are not acceptable if INIT = 'L' or 'B'. -C -C NN (input) INTEGER -C The number of neurons which shall be used to approximate -C the nonlinear part. NN >= 0. -C -C ITMAX1 (input) INTEGER -C The maximum number of iterations for the initialization of -C the static nonlinearity. -C This parameter is ignored if INIT is 'N' or 'L'. -C Otherwise, ITMAX1 >= 0. -C -C ITMAX2 (input) INTEGER -C The maximum number of iterations. ITMAX2 >= 0. -C -C NPRINT (input) INTEGER -C This parameter enables controlled printing of iterates if -C it is positive. In this case, FCN is called with IFLAG = 0 -C at the beginning of the first iteration and every NPRINT -C iterations thereafter and immediately prior to return, -C and the current error norm is printed. Other intermediate -C results could be printed by modifying the corresponding -C FCN routine (NF01BE and/or NF01BF). If NPRINT <= 0, no -C special calls of FCN with IFLAG = 0 are made. -C -C U (input) DOUBLE PRECISION array, dimension (LDU, M) -C The leading NSMP-by-M part of this array must contain the -C set of input samples, -C U = ( U(1,1),...,U(1,M); ...; U(NSMP,1),...,U(NSMP,M) ). -C -C LDU INTEGER -C The leading dimension of array U. LDU >= MAX(1,NSMP). -C -C Y (input) DOUBLE PRECISION array, dimension (LDY, L) -C The leading NSMP-by-L part of this array must contain the -C set of output samples, -C Y = ( Y(1,1),...,Y(1,L); ...; Y(NSMP,1),...,Y(NSMP,L) ). -C -C LDY INTEGER -C The leading dimension of array Y. LDY >= MAX(1,NSMP). -C -C X (input/output) DOUBLE PRECISION array dimension (LX) -C On entry, if INIT = 'L', the leading (NN*(L+2) + 1)*L part -C of this array must contain the initial parameters for -C the nonlinear part of the system. -C On entry, if INIT = 'S', the elements lin1 : lin2 of this -C array must contain the initial parameters for the linear -C part of the system, corresponding to the output normal -C form, computed by SLICOT Library routine TB01VD, where -C lin1 = (NN*(L+2) + 1)*L + 1; -C lin2 = (NN*(L+2) + 1)*L + N*(L+M+1) + L*M. -C On entry, if INIT = 'N', the elements 1 : lin2 of this -C array must contain the initial parameters for the -C nonlinear part followed by the initial parameters for the -C linear part of the system, as specified above. -C This array need not be set on entry if INIT = 'B'. -C On exit, the elements 1 : lin2 of this array contain the -C optimal parameters for the nonlinear part followed by the -C optimal parameters for the linear part of the system, as -C specified above. -C -C LX (input/output) INTEGER -C On entry, this parameter must contain the intended length -C of X. If N >= 0, then LX >= NX := lin2 (see parameter X). -C If N is unknown (N < 0 on entry), a large enough estimate -C of N should be used in the formula of lin2. -C On exit, if N < 0 on entry, but LX is not large enough, -C then this parameter contains the actual length of X, -C corresponding to the computed N. Otherwise, its value -C is unchanged. -C -C Tolerances -C -C TOL1 DOUBLE PRECISION -C If INIT = 'S' or 'B' and TOL1 >= 0, TOL1 is the tolerance -C which measures the relative error desired in the sum of -C squares, as well as the relative error desired in the -C approximate solution, for the initialization step of -C nonlinear part. Termination occurs when either both the -C actual and predicted relative reductions in the sum of -C squares, or the relative error between two consecutive -C iterates are at most TOL1. If the user sets TOL1 < 0, -C then SQRT(EPS) is used instead TOL1, where EPS is the -C machine precision (see LAPACK Library routine DLAMCH). -C This parameter is ignored if INIT is 'N' or 'L'. -C -C TOL2 DOUBLE PRECISION -C If TOL2 >= 0, TOL2 is the tolerance which measures the -C relative error desired in the sum of squares, as well as -C the relative error desired in the approximate solution, -C for the whole optimization process. Termination occurs -C when either both the actual and predicted relative -C reductions in the sum of squares, or the relative error -C between two consecutive iterates are at most TOL2. If the -C user sets TOL2 < 0, then SQRT(EPS) is used instead TOL2. -C This default value could require many iterations, -C especially if TOL1 is larger. If INIT = 'S' or 'B', it is -C advisable that TOL2 be larger than TOL1, and spend more -C time with cheaper iterations. -C -C Workspace -C -C IWORK INTEGER array, dimension (MAX( LIW1, LIW2, LIW3 )), where -C LIW1 = LIW2 = 0, if INIT = 'S' or 'N'; otherwise, -C LIW1 = M+L; -C LIW2 = MAX(M*NOBR+N,M*(N+L)); -C LIW3 = 3+MAX(NN*(L+2)+2,NX+L), if INIT = 'S' or 'B'; -C LIW3 = 3+NX+L, if INIT = 'L' or 'N'. -C On output, if INFO = 0, IWORK(1) and IWORK(2) return the -C (total) number of function and Jacobian evaluations, -C respectively (including the initialization step, if it was -C performed), and if INIT = 'L' or INIT = 'B', IWORK(3) -C specifies how many locations of DWORK contain reciprocal -C condition number estimates (see below); otherwise, -C IWORK(3) = 0. If INFO = 0, the entries 4 to 3+NX of IWORK -C define a permutation matrix P such that J*P = Q*R, where -C J is the final calculated Jacobian, Q is an orthogonal -C matrix (not stored), and R is upper triangular with -C diagonal elements of nonincreasing magnitude (possibly -C for each block column of J). Column j of P is column -C IWORK(3+j) of the identity matrix. Moreover, the entries -C 4+NX:3+NX+L of this array contain the ranks of the final -C submatrices S_k (see description of LMPARM in MD03BD). -C -C DWORK DOUBLE PRECISION array dimesion (LDWORK) -C On entry, if desired, and if INIT = 'S' or 'B', the -C entries DWORK(1:4) are set to initialize the random -C numbers generator for the nonlinear part parameters (see -C the description of the argument XINIT of SLICOT Library -C routine MD03BD); this enables to obtain reproducible -C results. The same seed is used for all outputs. -C On exit, if INFO = 0, DWORK(1) returns the optimal value -C of LDWORK, DWORK(2) returns the residual error norm (the -C sum of squares), DWORK(3) returns the number of iterations -C performed, and DWORK(4) returns the final Levenberg -C factor, for optimizing the parameters of both the linear -C part and the static nonlinearity part. If INIT = 'S' or -C INIT = 'B' and INFO = 0, then the elements DWORK(5) to -C DWORK(8) contain the corresponding four values for the -C initialization step (see METHOD). (If L > 1, DWORK(8) -C contains the maximum of the Levenberg factors for all -C outputs.) If INIT = 'L' or INIT = 'B', and INFO = 0, -C DWORK(9) to DWORK(8+IWORK(3)) contain reciprocal condition -C number estimates set by SLICOT Library routines IB01AD, -C IB01BD, and IB01CD. -C On exit, if INFO = -21, DWORK(1) returns the minimum -C value of LDWORK. -C -C LDWORK INTEGER -C The length of the array DWORK. -C In the formulas below, N should be taken not larger than -C NOBR - 1, if N < 0 on entry. -C LDWORK = MAX( LW1, LW2, LW3, LW4 ), where -C LW1 = 0, if INIT = 'S' or 'N'; otherwise, -C LW1 = MAX( 2*(M+L)*NOBR*(2*(M+L)*(NOBR+1)+3) + L*NOBR, -C 4*(M+L)*NOBR*(M+L)*NOBR + (N+L)*(N+M) + -C MAX( LDW1, LDW2 ), -C (N+L)*(N+M) + N + N*N + 2 + N*(N+M+L) + -C MAX( 5*N, 2, MIN( LDW3, LDW4 ), LDW5, LDW6 ), -C where, -C LDW1 >= MAX( 2*(L*NOBR-L)*N+2*N, (L*NOBR-L)*N+N*N+7*N, -C L*NOBR*N + -C MAX( (L*NOBR-L)*N+2*N + (2*M+L)*NOBR+L, -C 2*(L*NOBR-L)*N+N*N+8*N, -C N+4*(M*NOBR+N)+1, M*NOBR+3*N+L ) ) -C LDW2 >= 0, if M = 0; -C LDW2 >= L*NOBR*N + M*NOBR*(N+L)*(M*(N+L)+1) + -C MAX( (N+L)**2, 4*M*(N+L)+1 ), if M > 0; -C LDW3 = NSMP*L*(N+1) + 2*N + MAX( 2*N*N, 4*N ), -C LDW4 = N*(N+1) + 2*N + -C MAX( N*L*(N+1) + 2*N*N + L*N, 4*N ); -C LDW5 = NSMP*L + (N+L)*(N+M) + 3*N+M+L; -C LDW6 = NSMP*L + (N+L)*(N+M) + N + -C MAX(1, N*N*L + N*L + N, N*N + -C MAX(N*N + N*MAX(N,L) + 6*N + MIN(N,L), -C N*M)); -C LW2 = LW3 = 0, if INIT = 'L' or 'N'; otherwise, -C LW2 = NSMP*L + BSN + -C MAX( 4, NSMP + -C MAX( NSMP*BSN + MAX( 2*NN, 5*BSN + 1 ), -C BSN**2 + BSN + -C MAX( NSMP + 2*NN, 5*BSN ) ) ); -C LW3 = MAX( LDW7, NSMP*L + (N+L)*(2*N+M) + 2*N ); -C LDW7 = NSMP*L + (N+L)*(N+M) + 3*N+M+L, if M > 0; -C LDW7 = NSMP*L + (N+L)*N + 2*N+L, if M = 0; -C LW4 = NSMP*L + NX + -C MAX( 4, NSMP*L + -C MAX( NSMP*L*( BSN + LTHS ) + -C MAX( NSMP*L + L1, L2 + NX ), -C NX*( BSN + LTHS ) + NX + -C MAX( NSMP*L + L1, NX + L3 ) ) ), -C L0 = MAX( N*(N+L), N+M+L ), if M > 0; -C L0 = MAX( N*(N+L), L ), if M = 0; -C L1 = NSMP*L + MAX( 2*NN, (N+L)*(N+M) + 2*N + L0); -C L2 = 4*NX + 1, if L <= 1 or BSN = 0; otherwise, -C L2 = BSN + MAX(3*BSN+1,LTHS); -C L2 = MAX(L2,4*LTHS+1), if NSMP > BSN; -C L2 = MAX(L2,(NSMP-BSN)*(L-1)), if BSN < NSMP < 2*BSN; -C L3 = 4*NX, if L <= 1 or BSN = 0; -C L3 = LTHS*BSN + 2*NX + 2*MAX(BSN,LTHS), -C if L > 1 and BSN > 0, -C with BSN = NN*( L + 2 ) + 1, -C LTHS = N*( L + M + 1 ) + L*M. -C For optimum performance LDWORK should be larger. -C -C Warning Indicator -C -C IWARN INTEGER -C < 0: the user set IFLAG = IWARN in (one of) the -C subroutine(s) FCN, i.e., NF01BE, if INIT = 'S' -C or 'B', and/or NF01BF; this value cannot be returned -C without changing the FCN routine(s); -C otherwise, IWARN has the value k*100 + j*10 + i, -C where k is defined below, i refers to the whole -C optimization process, and j refers to the -C initialization step (j = 0, if INIT = 'L' or 'N'), -C and the possible values for i and j have the -C following meaning (where TOL* denotes TOL1 or TOL2, -C and similarly for ITMAX*): -C = 1: both actual and predicted relative reductions in -C the sum of squares are at most TOL*; -C = 2: relative error between two consecutive iterates is -C at most TOL*; -C = 3: conditions for i or j = 1 and i or j = 2 both hold; -C = 4: the cosine of the angle between the vector of error -C function values and any column of the Jacobian is at -C most EPS in absolute value; -C = 5: the number of iterations has reached ITMAX* without -C satisfying any convergence condition; -C = 6: TOL* is too small: no further reduction in the sum -C of squares is possible; -C = 7: TOL* is too small: no further improvement in the -C approximate solution X is possible; -C = 8: the vector of function values e is orthogonal to the -C columns of the Jacobian to machine precision. -C The digit k is normally 0, but if INIT = 'L' or 'B', it -C can have a value in the range 1 to 6 (see IB01AD, IB01BD -C and IB01CD). In all these cases, the entries DWORK(1:4), -C DWORK(5:8) (if INIT = 'S' or 'B'), and DWORK(9:8+IWORK(3)) -C (if INIT = 'L' or 'B'), are set as described above. -C -C Error Indicator -C -C INFO INTEGER -C = 0: successful exit; -C < 0: if INFO = -i, the i-th argument had an illegal -C value; -C otherwise, INFO has the value k*100 + j*10 + i, -C where k is defined below, i refers to the whole -C optimization process, and j refers to the -C initialization step (j = 0, if INIT = 'L' or 'N'), -C and the possible values for i and j have the -C following meaning: -C = 1: the routine FCN returned with INFO <> 0 for -C IFLAG = 1; -C = 2: the routine FCN returned with INFO <> 0 for -C IFLAG = 2; -C = 3: the routine QRFACT returned with INFO <> 0; -C = 4: the routine LMPARM returned with INFO <> 0. -C In addition, if INIT = 'L' or 'B', i could also be -C = 5: if a Lyapunov equation could not be solved; -C = 6: if the identified linear system is unstable; -C = 7: if the QR algorithm failed on the state matrix -C of the identified linear system. -C QRFACT and LMPARM are generic names for SLICOT Library -C routines NF01BS and NF01BP, respectively, for the whole -C optimization process, and MD03BA and MD03BB, respectively, -C for the initialization step (if INIT = 'S' or 'B'). -C The digit k is normally 0, but if INIT = 'L' or 'B', it -C can have a value in the range 1 to 10 (see IB01AD/IB01BD). -C -C METHOD -C -C If INIT = 'L' or 'B', the linear part of the system is -C approximated using the combined MOESP and N4SID algorithm. If -C necessary, this algorithm can also choose the order, but it is -C advantageous if the order is already known. -C -C If INIT = 'S' or 'B', the output of the approximated linear part -C is computed and used to calculate an approximation of the static -C nonlinearity using the Levenberg-Marquardt algorithm [1,3]. -C This step is referred to as the (nonlinear) initialization step. -C -C As last step, the Levenberg-Marquardt algorithm is used again to -C optimize the parameters of the linear part and the static -C nonlinearity as a whole. Therefore, it is necessary to parametrise -C the matrices of the linear part. The output normal form [2] -C parameterisation is used. -C -C The Jacobian is computed analytically, for the nonlinear part, and -C numerically, for the linear part. -C -C REFERENCES -C -C [1] More, J.J., Garbow, B.S, and Hillstrom, K.E. -C User's Guide for MINPACK-1. -C Applied Math. Division, Argonne National Laboratory, Argonne, -C Illinois, Report ANL-80-74, 1980. -C -C [2] Peeters, R.L.M., Hanzon, B., and Olivi, M. -C Balanced realizations of discrete-time stable all-pass -C systems and the tangential Schur algorithm. -C Proceedings of the European Control Conference, -C 31 August - 3 September 1999, Karlsruhe, Germany. -C Session CP-6, Discrete-time Systems, 1999. -C -C [3] More, J.J. -C The Levenberg-Marquardt algorithm: implementation and theory. -C In Watson, G.A. (Ed.), Numerical Analysis, Lecture Notes in -C Mathematics, vol. 630, Springer-Verlag, Berlin, Heidelberg -C and New York, pp. 105-116, 1978. -C -C NUMERICAL ASPECTS -C -C The Levenberg-Marquardt algorithm described in [3] is scaling -C invariant and globally convergent to (maybe local) minima. -C The convergence rate near a local minimum is quadratic, if the -C Jacobian is computed analytically, and linear, if the Jacobian -C is computed numerically. -C -C CONTRIBUTORS -C -C V. Sima, Research Institute for Informatics, Bucharest, Dec. 2001. -C -C REVISIONS -C -C V. Sima, March, 2002, Apr. 2002, Feb. 2004, March 2005. -C -C KEYWORDS -C -C Least-squares approximation, Levenberg-Marquardt algorithm, -C matrix operations, optimization. -C -C ****************************************************************** -C -C .. Parameters .. - DOUBLE PRECISION ZERO - PARAMETER ( ZERO = 0.0D0 ) -C FACTOR is a scaling factor for variables (see MD03BD). - DOUBLE PRECISION FACTOR - PARAMETER ( FACTOR = 100.0D0 ) -C Condition estimation and internal scaling of variables are used -C (see MD03BD). - CHARACTER COND, SCALE - PARAMETER ( COND = 'E', SCALE = 'I' ) -C Default tolerances are used in MD03BD for measuring the -C orthogonality between the vector of function values and columns -C of the Jacobian (GTOL), and for the rank estimations (TOL). - DOUBLE PRECISION GTOL, TOL - PARAMETER ( GTOL = 0.0D0, TOL = 0.0D0 ) -C For INIT = 'L' or 'B', additional parameters are set: -C The following six parameters are used in the call of IB01AD; - CHARACTER ALG, BATCH, CONCT, CTRL, JOBD, METH - PARAMETER ( ALG = 'Fast QR', BATCH = 'One batch', - $ CONCT = 'Not connect', CTRL = 'Not confirm', - $ JOBD = 'Not MOESP', METH = 'MOESP' ) -C The following three parameters are used in the call of IB01BD; - CHARACTER JOB, JOBCK, METHB - PARAMETER ( JOB = 'All matrices', - $ JOBCK = 'No Kalman gain', - $ METHB = 'Combined MOESP+N4SID' ) -C The following two parameters are used in the call of IB01CD; - CHARACTER COMUSE, JOBXD - PARAMETER ( COMUSE = 'Use B, D', - $ JOBXD = 'D also' ) -C TOLN controls the estimated order in IB01AD (default value); - DOUBLE PRECISION TOLN - PARAMETER ( TOLN = -1.0D0 ) -C RCOND controls the rank decisions in IB01AD, IB01BD, and IB01CD -C (default); - DOUBLE PRECISION RCOND - PARAMETER ( RCOND = -1.0D0 ) -C .. Scalar Arguments .. - CHARACTER INIT - INTEGER INFO, ITMAX1, ITMAX2, IWARN, L, LDU, LDWORK, - $ LDY, LX, M, N, NN, NOBR, NPRINT, NSMP - DOUBLE PRECISION TOL1, TOL2 -C .. Array Arguments .. - DOUBLE PRECISION DWORK(*), U(LDU, *), X(*), Y(LDY, *) - INTEGER IWORK(*) -C .. Local Scalars .. - INTEGER AC, BD, BSN, I, IA, IB, IDIAG, IK, INFOL, IQ, - $ IR, IRCND, IRCNDB, IRY, IS, ISAD, ISV, IV, IW1, - $ IW2, IW3, IWARNL, IX, IX0, J, JWORK, LDAC, LDR, - $ LIPAR, LNOL, LTHS, ML, MNO, N2, NFEV, NJEV, NS, - $ NSML, NTHS, NX, WRKOPT, Z - LOGICAL INIT1, INIT2 -C .. Local Arrays .. - LOGICAL BWORK(1) - INTEGER IPAR(7) - DOUBLE PRECISION RCND(16), SEED(4), WORK(4) -C .. External Functions .. - EXTERNAL LSAME - LOGICAL LSAME -C .. External Subroutines .. - EXTERNAL DCOPY, IB01AD, IB01BD, IB01CD, MD03BA, MD03BB, - $ MD03BD, NF01BE, NF01BF, NF01BP, NF01BS, TB01VD, - $ TB01VY, TF01MX, XERBLA -C .. Intrinsic Functions .. - INTRINSIC INT, MAX, MIN -C .. -C .. Executable Statements .. -C -C Check the scalar input parameters. -C - INIT1 = LSAME( INIT, 'B' ) .OR. LSAME( INIT, 'L' ) - INIT2 = LSAME( INIT, 'B' ) .OR. LSAME( INIT, 'S' ) -C - ML = M + L - INFO = 0 - IWARN = 0 - IF ( .NOT.( INIT1 .OR. INIT2 .OR. LSAME( INIT, 'N' ) ) ) THEN - INFO = -1 - ELSEIF ( INIT1 .AND. NOBR.LE.0 ) THEN - INFO = -2 - ELSEIF ( M.LT.0 ) THEN - INFO = -3 - ELSEIF ( L.LT.0 .OR. ( INIT1 .AND. L.EQ.0 ) ) THEN - INFO = -4 - ELSEIF ( NSMP.LT.0 .OR. - $ ( INIT1 .AND. NSMP.LT.2*( ML + 1 )*NOBR - 1 ) ) THEN - INFO = -5 - ELSEIF ( ( N.LT.0 .AND. .NOT.INIT1 ) .OR. - $ ( ( N.EQ.0 .OR. N.GE.NOBR ) .AND. INIT1 ) ) THEN - INFO = -6 - ELSEIF ( NN.LT.0 ) THEN - INFO = -7 - ELSEIF ( INIT2 .AND. ( ITMAX1.LT.0 ) ) THEN - INFO = -8 - ELSEIF ( ITMAX2.LT.0 ) THEN - INFO = -9 - ELSEIF ( LDU.LT.MAX( 1, NSMP ) ) THEN - INFO = -12 - ELSEIF ( LDY.LT.MAX( 1, NSMP ) ) THEN - INFO = -14 - ELSE - LNOL = L*NOBR - L - MNO = M*NOBR - BSN = NN*( L + 2 ) + 1 - NTHS = BSN*L - NSML = NSMP*L - IF ( N.GT.0 ) THEN - LDAC = N + L - ISAD = LDAC*( N + M ) - N2 = N*N - END IF -C -C Check the workspace size. -C - JWORK = 0 - IF ( INIT1 ) THEN -C Workspace for IB01AD. - JWORK = 2*ML*NOBR*( 2*ML*( NOBR + 1 ) + 3 ) + L*NOBR - IF ( N.GT.0 ) THEN -C Workspace for IB01BD. - IW1 = MAX( 2*LNOL*N + 2*N, LNOL*N + N2 + 7*N, L*NOBR*N + - $ MAX( LNOL*N + 2*N + ( M + ML )*NOBR + L, - $ 2*LNOL*N + N2 + 8*N, N + 4*( MNO + N ) + - $ 1, MNO + 3*N + L ) ) - IF ( M.GT.0 ) THEN - IW2 = L*NOBR*N + MNO*LDAC*( M*LDAC + 1 ) + - $ MAX( LDAC**2, 4*M*LDAC + 1 ) - ELSE - IW2 = 0 - END IF - JWORK = MAX( JWORK, - $ ( 2*ML*NOBR )**2 + ISAD + MAX( IW1, IW2 ) ) -C Workspace for IB01CD. - IW1 = NSML*( N + 1 ) + 2*N + MAX( 2*N2, 4*N ) - IW2 = N*( N + 1 ) + 2*N + - $ MAX( N*L*( N + 1 ) + 2*N2 + L*N, 4*N ) - JWORK = MAX( JWORK, ISAD + 2 + N*( N + 1 + LDAC + M ) + - $ MAX( 5*N, 2, MIN( IW1, IW2 ) ) ) -C Workspace for TF01MX. - JWORK = MAX( JWORK, NSML + ISAD + LDAC + 2*N + M ) -C Workspace for TB01VD. - JWORK = MAX( JWORK, NSML + ISAD + N + - $ MAX( 1, N2*L + N*L + N, - $ N2 + MAX( N2 + N*MAX( N, L ) + - $ 6*N + MIN( N, L ), N*M ) ) ) - END IF - END IF -C - IF ( INIT2 ) THEN -C Workspace for MD03BD (initialization of the nonlinear part). - JWORK = MAX( JWORK, NSML + BSN + - $ MAX( 4, NSMP + - $ MAX( NSMP*BSN + MAX( 2*NN, 5*BSN + 1 ), - $ BSN**2 + BSN + - $ MAX( NSMP + 2*NN, 5*BSN ) ) ) ) - IF ( N.GT.0 .AND. .NOT.INIT1 ) THEN -C Workspace for TB01VY. - JWORK = MAX( JWORK, NSML + LDAC*( 2*N + M ) + 2*N ) -C Workspace for TF01MX. - IF ( M.GT.0 ) THEN - IW1 = N + M - ELSE - IW1 = 0 - END IF - JWORK = MAX( JWORK, NSML + ISAD + IW1 + LDAC + N ) - END IF - END IF -C - IF ( N.GE.0 ) THEN -C -C Find the number of parameters. -C - LTHS = N*( ML + 1 ) + L*M - NX = NTHS + LTHS -C - IF ( LX.LT.NX ) THEN - INFO = -16 - CALL XERBLA( 'IB03BD', -INFO ) - RETURN - END IF -C -C Workspace for MD03BD (whole optimization). -C - IF ( M.GT.0 ) THEN - IW1 = LDAC + M - ELSE - IW1 = L - END IF - IW1 = NSML + MAX( 2*NN, ISAD + 2*N + MAX( N*LDAC, IW1 ) ) - IF ( L.LE.1 .OR. BSN.EQ.0 ) THEN - IW3 = 4*NX - IW2 = IW3 + 1 - ELSE - IW2 = BSN + MAX( 3*BSN + 1, LTHS ) - IF ( NSMP.GT.BSN ) THEN - IW2 = MAX( IW2, 4*LTHS + 1 ) - IF ( NSMP.LT.2*BSN ) - $ IW2 = MAX( IW2, ( NSMP - BSN )*( L - 1 ) ) - END IF - IW3 = LTHS*BSN + 2*NX + 2*MAX( BSN, LTHS ) - END IF - JWORK = MAX( JWORK, NSML + NX + - $ MAX( 4, NSML + - $ MAX( NSML*( BSN + LTHS ) + - $ MAX( NSML + IW1, IW2 + NX ), - $ NX*( BSN + LTHS ) + NX + - $ MAX( NSML + IW1, NX + IW3 ) ) - $ ) ) - END IF -C - IF ( LDWORK.LT.JWORK ) THEN - INFO = -21 - DWORK(1) = JWORK - END IF - END IF -C - IF( INFO.NE.0 ) THEN - CALL XERBLA( 'IB03BD', -INFO ) - RETURN - END IF -C -C Initialize the pointers to system matrices and save the possible -C seed for random numbers generation. -C - Z = 1 - AC = Z + NSML - CALL DCOPY( 4, DWORK, 1, SEED, 1 ) -C - WRKOPT = 1 -C - IF ( INIT1 ) THEN -C -C Initialize the linear part. -C If N < 0, the order of the system is determined by IB01AD; -C otherwise, the given order will be used. -C The workspace needed is defined for the options set above -C in the PARAMETER statements. -C Workspace: need: 2*(M+L)*NOBR*(2*(M+L)*(NOBR+1)+3) + L*NOBR; -C prefer: larger. -C Integer workspace: M+L. (If METH = 'N', (M+L)*NOBR.) -C - NS = N - IR = 1 - ISV = 2*ML*NOBR - LDR = ISV - IF ( LSAME( JOBD, 'M' ) ) - $ LDR = MAX( LDR, 3*MNO ) - ISV = IR + LDR*ISV - JWORK = ISV + L*NOBR -C - CALL IB01AD( METH, ALG, JOBD, BATCH, CONCT, CTRL, NOBR, M, L, - $ NSMP, U, LDU, Y, LDY, N, DWORK(IR), LDR, - $ DWORK(ISV), RCOND, TOLN, IWORK, DWORK(JWORK), - $ LDWORK-JWORK+1, IWARNL, INFOL ) -C - IF( INFOL.NE.0 ) THEN - INFO = 100*INFOL - RETURN - END IF - IF( IWARNL.NE.0 ) - $ IWARN = 100*IWARNL - WRKOPT = MAX( WRKOPT, INT( DWORK(JWORK) ) + JWORK - 1 ) - IRCND = 0 - IF ( LSAME( METH, 'N' ) ) THEN - IRCND = 2 - CALL DCOPY( IRCND, DWORK(JWORK+1), 1, RCND, 1 ) - END IF -C - IF ( NS.GE.0 ) THEN - N = NS - ELSE -C -C Find the number of parameters. -C - LDAC = N + L - ISAD = LDAC*( N + M ) - N2 = N*N - LTHS = N*( ML + 1 ) + L*M - NX = NTHS + LTHS -C - IF ( LX.LT.NX ) THEN - LX = NX - INFO = -16 - CALL XERBLA( 'IB03BD', -INFO ) - RETURN - END IF -C Workspace for IB01BD. - IW1 = MAX( 2*LNOL*N + 2*N, LNOL*N + N2 + 7*N, L*NOBR*N + - $ MAX( LNOL*N + 2*N + ( M + ML )*NOBR + L, - $ 2*LNOL*N + N2 + 8*N, N + 4*( MNO + N ) + 1, - $ MNO + 3*N + L ) ) - IF ( M.GT.0 ) THEN - IW2 = L*NOBR*N + MNO*LDAC*( M*LDAC + 1 ) + - $ MAX( LDAC**2, 4*M*LDAC + 1 ) - ELSE - IW2 = 0 - END IF - JWORK = ISV + ISAD + MAX( IW1, IW2 ) -C Workspace for IB01CD. - IW1 = NSML*( N + 1 ) + 2*N + MAX( 2*N2, 4*N ) - IW2 = N*( N + 1 ) + 2*N + MAX( N*L*( N + 1 ) + 2*N2 + L*N, - $ 4*N ) - JWORK = MAX( JWORK, ISAD + 2 + N*( N + 1 + LDAC + M ) + - $ MAX( 5*N, 2, MIN( IW1, IW2 ) ) ) -C Workspace for TF01MX. - JWORK = MAX( JWORK, NSML + ISAD + LDAC + 2*N + M ) -C Workspace for TB01VD. - JWORK = MAX( JWORK, NSML + ISAD + N + - $ MAX( 1, N2*L + N*L + N, - $ N2 + MAX( N2 + N*MAX( N, L ) + - $ 6*N + MIN( N, L ), N*M ) ) ) -C Workspace for MD03BD (whole optimization). - IF ( M.GT.0 ) THEN - IW1 = LDAC + M - ELSE - IW1 = L - END IF - IW1 = NSML + MAX( 2*NN, ISAD + 2*N + MAX( N*LDAC, IW1 ) ) - IF ( L.LE.1 .OR. BSN.EQ.0 ) THEN - IW3 = 4*NX - IW2 = IW3 + 1 - ELSE - IW2 = BSN + MAX( 3*BSN + 1, LTHS ) - IF ( NSMP.GT.BSN ) THEN - IW2 = MAX( IW2, 4*LTHS + 1 ) - IF ( NSMP.LT.2*BSN ) - $ IW2 = MAX( IW2, ( NSMP - BSN )*( L - 1 ) ) - END IF - IW3 = LTHS*BSN + 2*NX + 2*MAX( BSN, LTHS ) - END IF - JWORK = MAX( JWORK, NSML + NX + - $ MAX( 4, NSML + - $ MAX( NSML*( BSN + LTHS ) + - $ MAX( NSML + IW1, IW2 + NX ), - $ NX*( BSN + LTHS ) + NX + - $ MAX( NSML + IW1, NX + IW3 ) ) - $ ) ) - IF ( LDWORK.LT.JWORK ) THEN - INFO = -21 - DWORK(1) = JWORK - CALL XERBLA( 'IB03BD', -INFO ) - RETURN - END IF - END IF -C - BD = AC + LDAC*N - IX = BD + LDAC*M - IA = ISV - IB = IA + LDAC*N - IQ = IB + LDAC*M - IF ( LSAME( JOBCK, 'N' ) ) THEN - IRY = IQ - IS = IQ - IK = IQ - JWORK = IQ - ELSE - IRY = IQ + N2 - IS = IRY + L*L - IK = IS + N*L - JWORK = IK + N*L - END IF -C -C The workspace needed is defined for the options set above -C in the PARAMETER statements. -C Workspace: -C need: 4*(M+L)*NOBR*(M+L)*NOBR + (N+L)*(N+M) + -C max( LDW1,LDW2 ), where, -C LDW1 >= max( 2*(L*NOBR-L)*N+2*N, (L*NOBR-L)*N+N*N+7*N, -C L*NOBR*N + -C max( (L*NOBR-L)*N+2*N + (2*M+L)*NOBR+L, -C 2*(L*NOBR-L)*N+N*N+8*N, -C N+4*(M*NOBR+N)+1, M*NOBR+3*N+L ) ) -C LDW2 >= 0, if M = 0; -C LDW2 >= L*NOBR*N+M*NOBR*(N+L)*(M*(N+L)+1)+ -C max( (N+L)**2, 4*M*(N+L)+1 ), if M > 0; -C prefer: larger. -C Integer workspace: MAX(M*NOBR+N,M*(N+L)). -C - CALL IB01BD( METHB, JOB, JOBCK, NOBR, N, M, L, NSMP, DWORK(IR), - $ LDR, DWORK(IA), LDAC, DWORK(IA+N), LDAC, - $ DWORK(IB), LDAC, DWORK(IB+N), LDAC, DWORK(IQ), N, - $ DWORK(IRY), L, DWORK(IS), N, DWORK(IK), N, RCOND, - $ IWORK, DWORK(JWORK), LDWORK-JWORK+1, BWORK, - $ IWARNL, INFOL ) -C - IF( INFOL.EQ.-30 ) THEN - INFO = -21 - DWORK(1) = DWORK(JWORK) - CALL XERBLA( 'IB03BD', -INFO ) - RETURN - END IF - IF( INFOL.NE.0 ) THEN - INFO = 100*INFOL - RETURN - END IF - IF( IWARNL.NE.0 ) - $ IWARN = 100*IWARNL - WRKOPT = MAX( WRKOPT, INT( DWORK(JWORK) ) + JWORK - 1 ) - IRCNDB = 4 - IF ( LSAME( JOBCK, 'K' ) ) - $ IRCNDB = IRCNDB + 8 - CALL DCOPY( IRCNDB, DWORK(JWORK+1), 1, RCND(IRCND+1), 1 ) - IRCND = IRCND + IRCNDB -C -C Copy the system matrices to the beginning of DWORK, to save -C space, and redefine the pointers. -C - CALL DCOPY( ISAD, DWORK(IA), 1, DWORK, 1 ) - IA = 1 - IB = IA + LDAC*N - IX0 = IB + LDAC*M - IV = IX0 + N -C -C Compute the initial condition of the system. On normal exit, -C DWORK(i), i = JWORK+2:JWORK+1+N*N, -C DWORK(j), j = JWORK+2+N*N:JWORK+1+N*N+L*N, and -C DWORK(k), k = JWORK+2+N*N+L*N:JWORK+1+N*N+L*N+N*M, -C contain the transformed system matrices At, Ct, and Bt, -C respectively, corresponding to the real Schur form of the -C estimated system state matrix A. The transformation matrix is -C stored in DWORK(IV:IV+N*N-1). -C The workspace needed is defined for the options set above -C in the PARAMETER statements. -C Workspace: -C need: (N+L)*(N+M) + N + N*N + 2 + N*( N + M + L ) + -C max( 5*N, 2, min( LDW1, LDW2 ) ), where, -C LDW1 = NSMP*L*(N + 1) + 2*N + max( 2*N*N, 4*N), -C LDW2 = N*(N + 1) + 2*N + -C max( N*L*(N + 1) + 2*N*N + L*N, 4*N); -C prefer: larger. -C Integer workspace: N. -C - JWORK = IV + N2 - CALL IB01CD( 'X needed', COMUSE, JOBXD, N, M, L, NSMP, - $ DWORK(IA), LDAC, DWORK(IB), LDAC, DWORK(IA+N), - $ LDAC, DWORK(IB+N), LDAC, U, LDU, Y, LDY, - $ DWORK(IX0), DWORK(IV), N, RCOND, IWORK, - $ DWORK(JWORK), LDWORK-JWORK+1, IWARNL, INFOL ) -C - IF( INFOL.EQ.-26 ) THEN - INFO = -21 - DWORK(1) = DWORK(JWORK) - CALL XERBLA( 'IB03BD', -INFO ) - RETURN - END IF - IF( INFOL.EQ.1 ) - $ INFOL = 10 - IF( INFOL.NE.0 ) THEN - INFO = 100*INFOL - RETURN - END IF - IF( IWARNL.NE.0 ) - $ IWARN = 100*IWARNL - WRKOPT = MAX( WRKOPT, INT( DWORK(JWORK) ) + JWORK - 1 ) - IRCND = IRCND + 1 - RCND(IRCND) = DWORK(JWORK+1) -C -C Now, save the system matrices and x0 in the final location. -C - IF ( IV.LT.AC ) THEN - CALL DCOPY( ISAD+N, DWORK(IA), 1, DWORK(AC), 1 ) - ELSE - DO 10 J = AC + ISAD + N - 1, AC, -1 - DWORK(J) = DWORK(IA+J-AC) - 10 CONTINUE - END IF -C -C Compute the output of the linear part. -C Workspace: need NSMP*L + (N + L)*(N + M) + 3*N + M + L, -C if M > 0; -C NSMP*L + (N + L)*N + 2*N + L, if M = 0; -C prefer larger. -C - JWORK = IX + N - CALL DCOPY( N, DWORK(IX), 1, X(NTHS+1), 1 ) - CALL TF01MX( N, M, L, NSMP, DWORK(AC), LDAC, U, LDU, X(NTHS+1), - $ DWORK(Z), NSMP, DWORK(JWORK), LDWORK-JWORK+1, - $ INFO ) -C -C Convert the state-space representation to output normal form. -C Workspace: -C need: NSMP*L + (N + L)*(N + M) + N + -C MAX(1, N*N*L + N*L + N, N*N + -C MAX(N*N + N*MAX(N,L) + 6*N + MIN(N,L), N*M)); -C prefer: larger. -C - CALL TB01VD( 'Apply', N, M, L, DWORK(AC), LDAC, DWORK(BD), - $ LDAC, DWORK(AC+N), LDAC, DWORK(BD+N), LDAC, - $ DWORK(IX), X(NTHS+1), LTHS, DWORK(JWORK), - $ LDWORK-JWORK+1, INFOL ) -C - IF( INFOL.GT.0 ) THEN - INFO = INFOL + 4 - RETURN - END IF - WRKOPT = MAX( WRKOPT, INT( DWORK(JWORK) ) + JWORK - 1 ) -C - END IF -C - LIPAR = 7 - IW1 = 0 - IW2 = 0 - IDIAG = AC -C - IF ( INIT2 ) THEN -C -C Initialize the nonlinear part. -C - IF ( .NOT.INIT1 ) THEN - BD = AC + LDAC*N - IX = BD + LDAC*M -C -C Convert the output normal form to state-space model. -C Workspace: need NSMP*L + (N + L)*(2*N + M) + 2*N. -C (NSMP*L locations are reserved for the output of the linear -C part.) -C - JWORK = IX + N - CALL TB01VY( 'Apply', N, M, L, X(NTHS+1), LTHS, DWORK(AC), - $ LDAC, DWORK(BD), LDAC, DWORK(AC+N), LDAC, - $ DWORK(BD+N), LDAC, DWORK(IX), DWORK(JWORK), - $ LDWORK-JWORK+1, INFO ) -C -C Compute the output of the linear part. -C Workspace: need NSMP*L + (N + L)*(N + M) + 3*N + M + L, -C if M > 0; -C NSMP*L + (N + L)*N + 2*N + L, if M = 0; -C prefer larger. -C - CALL TF01MX( N, M, L, NSMP, DWORK(AC), LDAC, U, LDU, - $ DWORK(IX), DWORK(Z), NSMP, DWORK(JWORK), - $ LDWORK-JWORK+1, INFO ) - END IF -C -C Optimize the parameters of the nonlinear part. -C Workspace: -C need NSMP*L + BSN + -C MAX( 4, NSMP + -C MAX( NSMP*BSN + MAX( 2*NN, 5*BSN + 1 ), -C BSN**2 + BSN + MAX( NSMP + 2*NN, 5*BSN ) )); -C prefer larger. -C Integer workspace: NN*(L + 2) + 2. -C - WORK(1) = ZERO - CALL DCOPY( 3, WORK(1), 0, WORK(2), 1 ) -C -C Set the integer parameters needed, including the number of -C neurons. -C - IPAR(1) = NSMP - IPAR(2) = L - IPAR(3) = NN - JWORK = IDIAG + BSN -C - DO 30 I = 0, L - 1 - CALL DCOPY( 4, SEED, 1, DWORK(JWORK), 1 ) - CALL MD03BD( 'Random initialization', SCALE, COND, NF01BE, - $ MD03BA, MD03BB, NSMP, BSN, ITMAX1, FACTOR, - $ NPRINT, IPAR, LIPAR, DWORK(Z), NSMP, Y(1,I+1), - $ LDY, X(I*BSN+1), DWORK(IDIAG), NFEV, NJEV, - $ TOL1, TOL1, GTOL, TOL, IWORK, DWORK(JWORK), - $ LDWORK-JWORK+1, IWARNL, INFOL ) - IF( INFOL.NE.0 ) THEN - INFO = 10*INFOL - RETURN - END IF - IF ( IWARNL.LT.0 ) THEN - INFO = INFOL - IWARN = IWARNL - GO TO 50 - ELSEIF ( IWARNL.GT.0 ) THEN - IF ( IWARN.GT.100 ) THEN - IWARN = MAX( IWARN, ( IWARN/100 )*100 + 10*IWARNL ) - ELSE - IWARN = MAX( IWARN, 10*IWARNL ) - END IF - END IF - WORK(1) = MAX( WORK(1), DWORK(JWORK) ) - WORK(2) = MAX( WORK(2), DWORK(JWORK+1) ) - WORK(4) = MAX( WORK(4), DWORK(JWORK+3) ) - WORK(3) = WORK(3) + DWORK(JWORK+2) - IW1 = NFEV + IW1 - IW2 = NJEV + IW2 - 30 CONTINUE -C - END IF -C -C Main iteration. -C Workspace: -C need NSMP*L + NX + -C MAX( 4, NSMP*L + -C MAX( NSMP*L*( BSN + LTHS ) + -C MAX( NSMP*L + LDW1, LDW2 + NX ), -C NX*( BSN + LTHS ) + NX + -C MAX( NSMP*L + LDW1, NX + LDW3 ) ) ), -C LDW0 = MAX( N*(N+L), N+M+L ), if M > 0; -C LDW0 = MAX( N*(N+L), L ), if M = 0; -C LDW1 = NSMP*L + MAX( 2*NN, (N + L)*(N + M) + 2*N + LDW0); -C LDW2 = 4*NX + 1, if L <= 1 or BSN = 0; otherwise, -C LDW2 = BSN + MAX(3*BSN+1,LTHS); -C LDW2 = MAX(LDW2, 4*LTHS+1), if NSMP > BSN; -C LDW2 = MAX(LDW2, (NSMP-BSN)*(L-1)), if BSN < NSMP < 2*BSN; -C LDW3 = 4*NX, if L <= 1 or BSN = 0; -C LDW3 = LTHS*BSN + 2*NX + 2*MAX(BSN,LTHS), -C if L > 1 and BSN > 0; -C prefer larger. -C Integer workspace: NX+L. -C -C Set the integer parameters describing the Jacobian structure -C and the number of neurons. -C - IPAR(1) = LTHS - IPAR(2) = L - IPAR(3) = NSMP - IPAR(4) = BSN - IPAR(5) = M - IPAR(6) = N - IPAR(7) = NN - JWORK = IDIAG + NX -C - CALL MD03BD( 'Given initialization', SCALE, COND, NF01BF, - $ NF01BS, NF01BP, NSML, NX, ITMAX2, FACTOR, NPRINT, - $ IPAR, LIPAR, U, LDU, Y, LDY, X, DWORK(IDIAG), NFEV, - $ NJEV, TOL2, TOL2, GTOL, TOL, IWORK, DWORK(JWORK), - $ LDWORK-JWORK+1, IWARNL, INFO ) - IF( INFO.NE.0 ) - $ RETURN -C - DO 40 I = 1, NX + L - IWORK(I+3) = IWORK(I) - 40 CONTINUE -C - 50 CONTINUE - IWORK(1) = IW1 + NFEV - IWORK(2) = IW2 + NJEV - IF ( IWARNL.LT.0 ) THEN - IWARN = IWARNL - ELSE - IWARN = IWARN + IWARNL - END IF - CALL DCOPY( 4, DWORK(JWORK), 1, DWORK, 1 ) - IF ( INIT2 ) - $ CALL DCOPY( 4, WORK, 1, DWORK(5), 1 ) - IF ( INIT1 ) THEN - IWORK(3) = IRCND - CALL DCOPY( IRCND, RCND, 1, DWORK(9), 1 ) - ELSE - IWORK(3) = 0 - END IF -C - RETURN -C -C *** Last line of IB03BD *** - END diff --git a/mex/sources/libslicot/MA01AD.f b/mex/sources/libslicot/MA01AD.f deleted file mode 100644 index eab214d03..000000000 --- a/mex/sources/libslicot/MA01AD.f +++ /dev/null @@ -1,95 +0,0 @@ - SUBROUTINE MA01AD( XR, XI, YR, YI ) -C -C SLICOT RELEASE 5.0. -C -C Copyright (c) 2002-2009 NICONET e.V. -C -C This program is free software: you can redistribute it and/or -C modify it under the terms of the GNU General Public License as -C published by the Free Software Foundation, either version 2 of -C the License, or (at your option) any later version. -C -C This program is distributed in the hope that it will be useful, -C but WITHOUT ANY WARRANTY; without even the implied warranty of -C MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the -C GNU General Public License for more details. -C -C You should have received a copy of the GNU General Public License -C along with this program. If not, see -C . -C -C PURPOSE -C -C To compute the complex square root YR + i*YI of a complex number -C XR + i*XI in real arithmetic. The returned result is so that -C YR >= 0.0 and SIGN(YI) = SIGN(XI). -C -C ARGUMENTS -C -C Input/Output Parameters -C -C XR (input) DOUBLE PRECISION -C XI (input) DOUBLE PRECISION -C These scalars define the real and imaginary part of the -C complex number of which the square root is sought. -C -C YR (output) DOUBLE PRECISION -C YI (output) DOUBLE PRECISION -C These scalars define the real and imaginary part of the -C complex square root. -C -C METHOD -C -C The complex square root YR + i*YI of the complex number XR + i*XI -C is computed in real arithmetic, taking care to avoid overflow. -C -C REFERENCES -C -C Adapted from EISPACK subroutine CSROOT. -C -C CONTRIBUTOR -C -C P. Benner, Universitaet Bremen, Germany, and -C R. Byers, University of Kansas, Lawrence, USA, -C Aug. 1998, routine DCROOT. -C V. Sima, Research Institute for Informatics, Bucharest, Romania, -C Oct. 1998, SLICOT Library version. -C -C REVISIONS -C -C - -C -C ****************************************************************** -C -C .. Parameters .. - DOUBLE PRECISION ZERO, HALF - PARAMETER ( ZERO = 0.0D0, HALF = 1.0D0/2.0D0 ) -C .. -C .. Scalar Arguments .. - DOUBLE PRECISION XR, XI, YR, YI -C .. -C .. Local Scalars .. - DOUBLE PRECISION S -C .. -C .. External Functions .. - DOUBLE PRECISION DLAPY2 - EXTERNAL DLAPY2 -C -C .. Intrinsic functions .. - INTRINSIC ABS, SQRT -C .. -C .. Executable Statements .. -C - S = SQRT( HALF*( DLAPY2( XR, XI ) + ABS( XR ) ) ) - IF ( XR.GE.ZERO ) YR = S - IF ( XI.LT.ZERO ) S = -S - IF ( XR.LE.ZERO ) THEN - YI = S - IF ( XR.LT.ZERO ) YR = HALF*( XI/S ) - ELSE - YI = HALF*( XI/YR ) - END IF -C - RETURN -C *** Last line of MA01AD *** - END diff --git a/mex/sources/libslicot/MA02AD.f b/mex/sources/libslicot/MA02AD.f deleted file mode 100644 index a3cec4e40..000000000 --- a/mex/sources/libslicot/MA02AD.f +++ /dev/null @@ -1,108 +0,0 @@ - SUBROUTINE MA02AD( JOB, M, N, A, LDA, B, LDB ) -C -C SLICOT RELEASE 5.0. -C -C Copyright (c) 2002-2009 NICONET e.V. -C -C This program is free software: you can redistribute it and/or -C modify it under the terms of the GNU General Public License as -C published by the Free Software Foundation, either version 2 of -C the License, or (at your option) any later version. -C -C This program is distributed in the hope that it will be useful, -C but WITHOUT ANY WARRANTY; without even the implied warranty of -C MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the -C GNU General Public License for more details. -C -C You should have received a copy of the GNU General Public License -C along with this program. If not, see -C . -C -C PURPOSE -C -C To transpose all or part of a two-dimensional matrix A into -C another matrix B. -C -C ARGUMENTS -C -C Mode Parameters -C -C JOB CHARACTER*1 -C Specifies the part of the matrix A to be transposed into B -C as follows: -C = 'U': Upper triangular part; -C = 'L': Lower triangular part; -C Otherwise: All of the matrix A. -C -C Input/Output Parameters -C -C M (input) INTEGER -C The number of rows of the matrix A. M >= 0. -C -C N (input) INTEGER -C The number of columns of the matrix A. N >= 0. -C -C A (input) DOUBLE PRECISION array, dimension (LDA,N) -C The m-by-n matrix A. If JOB = 'U', only the upper -C triangle or trapezoid is accessed; if JOB = 'L', only the -C lower triangle or trapezoid is accessed. -C -C LDA INTEGER -C The leading dimension of the array A. LDA >= max(1,M). -C -C B (output) DOUBLE PRECISION array, dimension (LDB,M) -C B = A' in the locations specified by JOB. -C -C LDB INTEGER -C The leading dimension of the array B. LDB >= max(1,N). -C -C CONTRIBUTOR -C -C A. Varga, German Aerospace Center, -C DLR Oberpfaffenhofen, March 1998. -C Based on the RASP routine DMTRA. -C -C REVISIONS -C -C - -C -C ****************************************************************** -C -C .. Scalar Arguments .. - CHARACTER JOB - INTEGER LDA, LDB, M, N -C .. Array Arguments .. - DOUBLE PRECISION A(LDA,*), B(LDB,*) -C .. Local Scalars .. - INTEGER I, J -C .. External Functions .. - LOGICAL LSAME - EXTERNAL LSAME -C .. Intrinsic Functions .. - INTRINSIC MIN -C -C .. Executable Statements .. -C - IF( LSAME( JOB, 'U' ) ) THEN - DO 20 J = 1, N - DO 10 I = 1, MIN( J, M ) - B(J,I) = A(I,J) - 10 CONTINUE - 20 CONTINUE - ELSE IF( LSAME( JOB, 'L' ) ) THEN - DO 40 J = 1, N - DO 30 I = J, M - B(J,I) = A(I,J) - 30 CONTINUE - 40 CONTINUE - ELSE - DO 60 J = 1, N - DO 50 I = 1, M - B(J,I) = A(I,J) - 50 CONTINUE - 60 CONTINUE - END IF -C - RETURN -C *** Last line of MA02AD *** - END diff --git a/mex/sources/libslicot/MA02BD.f b/mex/sources/libslicot/MA02BD.f deleted file mode 100644 index 38e713734..000000000 --- a/mex/sources/libslicot/MA02BD.f +++ /dev/null @@ -1,113 +0,0 @@ - SUBROUTINE MA02BD( SIDE, M, N, A, LDA ) -C -C SLICOT RELEASE 5.0. -C -C Copyright (c) 2002-2009 NICONET e.V. -C -C This program is free software: you can redistribute it and/or -C modify it under the terms of the GNU General Public License as -C published by the Free Software Foundation, either version 2 of -C the License, or (at your option) any later version. -C -C This program is distributed in the hope that it will be useful, -C but WITHOUT ANY WARRANTY; without even the implied warranty of -C MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the -C GNU General Public License for more details. -C -C You should have received a copy of the GNU General Public License -C along with this program. If not, see -C . -C -C PURPOSE -C -C To reverse the order of rows and/or columns of a given matrix A -C by pre-multiplying and/or post-multiplying it, respectively, with -C a permutation matrix P, where P is a square matrix of appropriate -C order, with ones down the secondary diagonal. -C -C ARGUMENTS -C -C Mode Parameters -C -C SIDE CHARACTER*1 -C Specifies the operation to be performed, as follows: -C = 'L': the order of rows of A is to be reversed by -C pre-multiplying A with P; -C = 'R': the order of columns of A is to be reversed by -C post-multiplying A with P; -C = 'B': both the order of rows and the order of columns -C of A is to be reversed by pre-multiplying and -C post-multiplying A with P. -C -C Input/Output Parameters -C -C M (input) INTEGER -C The number of rows of the matrix A. M >= 0. -C -C N (input) INTEGER -C The number of columns of the matrix A. N >= 0. -C -C A (input/output) DOUBLE PRECISION array, dimension (LDA,N) -C On entry, the leading M-by-N part of this array must -C contain the given matrix whose rows and/or columns are to -C be permuted. -C On exit, the leading M-by-N part of this array contains -C the matrix P*A if SIDE = 'L', or A*P if SIDE = 'R', or -C P*A*P if SIDE = 'B'. -C -C LDA INTEGER -C The leading dimension of the array A. LDA >= max(1,M). -C -C CONTRIBUTOR -C -C A. Varga, German Aerospace Center, -C DLR Oberpfaffenhofen, March 1998. -C Based on the RASP routine PAP. -C -C REVISIONS -C -C - -C -C ****************************************************************** -C -C .. Scalar Arguments .. - CHARACTER SIDE - INTEGER LDA, M, N -C .. Array Arguments .. - DOUBLE PRECISION A(LDA,*) -C .. Local Scalars .. - LOGICAL BSIDES - INTEGER I, J, K, M2, N2 -C .. External Functions .. - LOGICAL LSAME - EXTERNAL LSAME -C .. External Subroutines .. - EXTERNAL DSWAP -C .. Executable Statements .. -C - BSIDES = LSAME( SIDE, 'B' ) -C - IF( ( LSAME( SIDE, 'L' ) .OR. BSIDES ) .AND. M.GT.1 ) THEN -C -C Compute P*A. -C - M2 = M/2 - K = M - M2 + 1 - DO 10 J = 1, N - CALL DSWAP( M2, A(1,J), -1, A(K,J), 1 ) - 10 CONTINUE - END IF - IF( ( LSAME( SIDE, 'R' ) .OR. BSIDES ) .AND. N.GT.1 ) THEN -C -C Compute A*P. -C - N2 = N/2 - K = N - N2 + 1 - DO 20 I = 1, M - CALL DSWAP( N2, A(I,1), -LDA, A(I,K), LDA ) - 20 CONTINUE - END IF -C - RETURN -C *** Last line of MA02BD *** - END diff --git a/mex/sources/libslicot/MA02BZ.f b/mex/sources/libslicot/MA02BZ.f deleted file mode 100644 index b2a699bf1..000000000 --- a/mex/sources/libslicot/MA02BZ.f +++ /dev/null @@ -1,114 +0,0 @@ - SUBROUTINE MA02BZ( SIDE, M, N, A, LDA ) -C -C SLICOT RELEASE 5.0. -C -C Copyright (c) 2002-2009 NICONET e.V. -C -C This program is free software: you can redistribute it and/or -C modify it under the terms of the GNU General Public License as -C published by the Free Software Foundation, either version 2 of -C the License, or (at your option) any later version. -C -C This program is distributed in the hope that it will be useful, -C but WITHOUT ANY WARRANTY; without even the implied warranty of -C MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the -C GNU General Public License for more details. -C -C You should have received a copy of the GNU General Public License -C along with this program. If not, see -C . -C -C PURPOSE -C -C To reverse the order of rows and/or columns of a given matrix A -C by pre-multiplying and/or post-multiplying it, respectively, with -C a permutation matrix P, where P is a square matrix of appropriate -C order, with ones down the secondary diagonal. -C -C ARGUMENTS -C -C Mode Parameters -C -C SIDE CHARACTER*1 -C Specifies the operation to be performed, as follows: -C = 'L': the order of rows of A is to be reversed by -C pre-multiplying A with P; -C = 'R': the order of columns of A is to be reversed by -C post-multiplying A with P; -C = 'B': both the order of rows and the order of columns -C of A is to be reversed by pre-multiplying and -C post-multiplying A with P. -C -C Input/Output Parameters -C -C M (input) INTEGER -C The number of rows of the matrix A. M >= 0. -C -C N (input) INTEGER -C The number of columns of the matrix A. N >= 0. -C -C A (input/output) COMPLEX*16 array, dimension (LDA,N) -C On entry, the leading M-by-N part of this array must -C contain the given matrix whose rows and/or columns are to -C be permuted. -C On exit, the leading M-by-N part of this array contains -C the matrix P*A if SIDE = 'L', or A*P if SIDE = 'R', or -C P*A*P if SIDE = 'B'. -C -C LDA INTEGER -C The leading dimension of the array A. LDA >= max(1,M). -C -C CONTRIBUTOR -C -C A. Varga, German Aerospace Center, -C DLR Oberpfaffenhofen, March 1998. -C Complex version: V. Sima, Research Institute for Informatics, -C Bucharest, Nov. 2008. -C -C REVISIONS -C -C - -C -C ****************************************************************** -C -C .. Scalar Arguments .. - CHARACTER SIDE - INTEGER LDA, M, N -C .. Array Arguments .. - COMPLEX*16 A(LDA,*) -C .. Local Scalars .. - LOGICAL BSIDES - INTEGER I, J, K, M2, N2 -C .. External Functions .. - LOGICAL LSAME - EXTERNAL LSAME -C .. External Subroutines .. - EXTERNAL ZSWAP -C .. Executable Statements .. -C - BSIDES = LSAME( SIDE, 'B' ) -C - IF( ( LSAME( SIDE, 'L' ) .OR. BSIDES ) .AND. M.GT.1 ) THEN -C -C Compute P*A. -C - M2 = M/2 - K = M - M2 + 1 - DO 10 J = 1, N - CALL ZSWAP( M2, A(1,J), -1, A(K,J), 1 ) - 10 CONTINUE - END IF - IF( ( LSAME( SIDE, 'R' ) .OR. BSIDES ) .AND. N.GT.1 ) THEN -C -C Compute A*P. -C - N2 = N/2 - K = N - N2 + 1 - DO 20 I = 1, M - CALL ZSWAP( N2, A(I,1), -LDA, A(I,K), LDA ) - 20 CONTINUE - END IF -C - RETURN -C *** Last line of MA02BZ *** - END diff --git a/mex/sources/libslicot/MA02CD.f b/mex/sources/libslicot/MA02CD.f deleted file mode 100644 index e4948b891..000000000 --- a/mex/sources/libslicot/MA02CD.f +++ /dev/null @@ -1,113 +0,0 @@ - SUBROUTINE MA02CD( N, KL, KU, A, LDA ) -C -C SLICOT RELEASE 5.0. -C -C Copyright (c) 2002-2009 NICONET e.V. -C -C This program is free software: you can redistribute it and/or -C modify it under the terms of the GNU General Public License as -C published by the Free Software Foundation, either version 2 of -C the License, or (at your option) any later version. -C -C This program is distributed in the hope that it will be useful, -C but WITHOUT ANY WARRANTY; without even the implied warranty of -C MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the -C GNU General Public License for more details. -C -C You should have received a copy of the GNU General Public License -C along with this program. If not, see -C . -C -C PURPOSE -C -C To compute the pertranspose of a central band of a square matrix. -C -C ARGUMENTS -C -C Input/Output Parameters -C -C N (input) INTEGER -C The order of the square matrix A. N >= 0. -C -C KL (input) INTEGER -C The number of subdiagonals of A to be pertransposed. -C 0 <= KL <= N-1. -C -C KU (input) INTEGER -C The number of superdiagonals of A to be pertransposed. -C 0 <= KU <= N-1. -C -C A (input/output) DOUBLE PRECISION array, dimension (LDA,N) -C On entry, the leading N-by-N part of this array must -C contain a square matrix whose central band formed from -C the KL subdiagonals, the main diagonal and the KU -C superdiagonals will be pertransposed. -C On exit, the leading N-by-N part of this array contains -C the matrix A with its central band (the KL subdiagonals, -C the main diagonal and the KU superdiagonals) pertransposed -C (that is the elements of each antidiagonal appear in -C reversed order). This is equivalent to forming P*B'*P, -C where B is the matrix formed from the central band of A -C and P is a permutation matrix with ones down the secondary -C diagonal. -C -C LDA INTEGER -C The leading dimension of the array A. LDA >= max(1,N). -C -C CONTRIBUTOR -C -C A. Varga, German Aerospace Center, -C DLR Oberpfaffenhofen, March 1998. -C Based on the RASP routine DMPTR. -C -C REVISIONS -C -C A. Varga, December 2001. -C V. Sima, March 2004. -C -C ****************************************************************** -C -C .. Scalar Arguments .. - INTEGER KL, KU, LDA, N -C .. Array Arguments .. - DOUBLE PRECISION A(LDA,*) -C .. Local Scalars .. - INTEGER I, I1, LDA1 -C .. External Subroutines .. - EXTERNAL DSWAP -C .. Intrinsic Functions .. - INTRINSIC MIN -C .. Executable Statements .. -C -C Quick return if possible. -C - IF( N.LE.1 ) - $ RETURN -C - LDA1 = LDA + 1 -C -C Pertranspose the KL subdiagonals. -C - DO 10 I = 1, MIN( KL, N-2 ) - I1 = (N-I) / 2 - IF( I1.GT.0 ) - $ CALL DSWAP( I1, A(I+1,1), LDA1, A(N-I1+1,N-I1+1-I), -LDA1 ) - 10 CONTINUE -C -C Pertranspose the KU superdiagonals. -C - DO 20 I = 1, MIN( KU, N-2 ) - I1 = (N-I) / 2 - IF( I1.GT.0 ) - $ CALL DSWAP( I1, A(1,I+1), LDA1, A(N-I1+1-I,N-I1+1), -LDA1 ) - 20 CONTINUE -C -C Pertranspose the diagonal. -C - I1 = N / 2 - IF( I1.GT.0 ) - $ CALL DSWAP( I1, A(1,1), LDA1, A(N-I1+1,N-I1+1), -LDA1 ) -C - RETURN -C *** Last line of MA02CD *** - END diff --git a/mex/sources/libslicot/MA02CZ.f b/mex/sources/libslicot/MA02CZ.f deleted file mode 100644 index 5bb85b5ed..000000000 --- a/mex/sources/libslicot/MA02CZ.f +++ /dev/null @@ -1,113 +0,0 @@ - SUBROUTINE MA02CZ( N, KL, KU, A, LDA ) -C -C SLICOT RELEASE 5.0. -C -C Copyright (c) 2002-2009 NICONET e.V. -C -C This program is free software: you can redistribute it and/or -C modify it under the terms of the GNU General Public License as -C published by the Free Software Foundation, either version 2 of -C the License, or (at your option) any later version. -C -C This program is distributed in the hope that it will be useful, -C but WITHOUT ANY WARRANTY; without even the implied warranty of -C MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the -C GNU General Public License for more details. -C -C You should have received a copy of the GNU General Public License -C along with this program. If not, see -C . -C -C PURPOSE -C -C To compute the pertranspose of a central band of a square matrix. -C -C ARGUMENTS -C -C Input/Output Parameters -C -C N (input) INTEGER -C The order of the square matrix A. N >= 0. -C -C KL (input) INTEGER -C The number of subdiagonals of A to be pertransposed. -C 0 <= KL <= N-1. -C -C KU (input) INTEGER -C The number of superdiagonals of A to be pertransposed. -C 0 <= KU <= N-1. -C -C A (input/output) COMPLEX*16 array, dimension (LDA,N) -C On entry, the leading N-by-N part of this array must -C contain a square matrix whose central band formed from -C the KL subdiagonals, the main diagonal and the KU -C superdiagonals will be pertransposed. -C On exit, the leading N-by-N part of this array contains -C the matrix A with its central band (the KL subdiagonals, -C the main diagonal and the KU superdiagonals) pertransposed -C (that is the elements of each antidiagonal appear in -C reversed order). This is equivalent to forming P*B'*P, -C where B is the matrix formed from the central band of A -C and P is a permutation matrix with ones down the secondary -C diagonal. -C -C LDA INTEGER -C The leading dimension of the array A. LDA >= max(1,N). -C -C CONTRIBUTOR -C -C A. Varga, German Aerospace Center, -C DLR Oberpfaffenhofen, March 1998. -C Complex version: V. Sima, Research Institute for Informatics, -C Bucharest, Nov. 2008. -C -C REVISIONS -C -C - -C -C ****************************************************************** -C -C .. Scalar Arguments .. - INTEGER KL, KU, LDA, N -C .. Array Arguments .. - COMPLEX*16 A(LDA,*) -C .. Local Scalars .. - INTEGER I, I1, LDA1 -C .. External Subroutines .. - EXTERNAL ZSWAP -C .. Intrinsic Functions .. - INTRINSIC MIN -C .. Executable Statements .. -C -C Quick return if possible. -C - IF( N.LE.1 ) - $ RETURN -C - LDA1 = LDA + 1 -C -C Pertranspose the KL subdiagonals. -C - DO 10 I = 1, MIN( KL, N-2 ) - I1 = (N-I) / 2 - IF( I1.GT.0 ) - $ CALL ZSWAP( I1, A(I+1,1), LDA1, A(N-I1+1,N-I1+1-I), -LDA1 ) - 10 CONTINUE -C -C Pertranspose the KU superdiagonals. -C - DO 20 I = 1, MIN( KU, N-2 ) - I1 = (N-I) / 2 - IF( I1.GT.0 ) - $ CALL ZSWAP( I1, A(1,I+1), LDA1, A(N-I1+1-I,N-I1+1), -LDA1 ) - 20 CONTINUE -C -C Pertranspose the diagonal. -C - I1 = N / 2 - IF( I1.GT.0 ) - $ CALL ZSWAP( I1, A(1,1), LDA1, A(N-I1+1,N-I1+1), -LDA1 ) -C - RETURN -C *** Last line of MA02CZ *** - END diff --git a/mex/sources/libslicot/MA02DD.f b/mex/sources/libslicot/MA02DD.f deleted file mode 100644 index ef7967e73..000000000 --- a/mex/sources/libslicot/MA02DD.f +++ /dev/null @@ -1,157 +0,0 @@ - SUBROUTINE MA02DD( JOB, UPLO, N, A, LDA, AP ) -C -C SLICOT RELEASE 5.0. -C -C Copyright (c) 2002-2009 NICONET e.V. -C -C This program is free software: you can redistribute it and/or -C modify it under the terms of the GNU General Public License as -C published by the Free Software Foundation, either version 2 of -C the License, or (at your option) any later version. -C -C This program is distributed in the hope that it will be useful, -C but WITHOUT ANY WARRANTY; without even the implied warranty of -C MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the -C GNU General Public License for more details. -C -C You should have received a copy of the GNU General Public License -C along with this program. If not, see -C . -C -C PURPOSE -C -C To pack/unpack the upper or lower triangle of a symmetric matrix. -C The packed matrix is stored column-wise in the one-dimensional -C array AP. -C -C ARGUMENTS -C -C Mode Parameters -C -C JOB CHARACTER*1 -C Specifies whether the matrix should be packed or unpacked, -C as follows: -C = 'P': The matrix should be packed; -C = 'U': The matrix should be unpacked. -C -C UPLO CHARACTER*1 -C Specifies the part of the matrix to be packed/unpacked, -C as follows: -C = 'U': Upper triangular part; -C = 'L': Lower triangular part. -C -C Input/Output Parameters -C -C N (input) INTEGER -C The order of the matrix A. N >= 0. -C -C A (input or output) DOUBLE PRECISION array, dimension -C (LDA,N) -C This array is an input parameter if JOB = 'P', and an -C output parameter if JOB = 'U'. -C On entry, if JOB = 'P', the leading N-by-N upper -C triangular part (if UPLO = 'U'), or lower triangular part -C (if UPLO = 'L'), of this array must contain the -C corresponding upper or lower triangle of the symmetric -C matrix A, and the other strictly triangular part is not -C referenced. -C On exit, if JOB = 'U', the leading N-by-N upper triangular -C part (if UPLO = 'U'), or lower triangular part (if -C UPLO = 'L'), of this array contains the corresponding -C upper or lower triangle of the symmetric matrix A; the -C other strictly triangular part is not referenced. -C -C LDA INTEGER -C The leading dimension of the array A. LDA >= max(1,N). -C -C AP (output or input) DOUBLE PRECISION array, dimension -C (N*(N+1)/2) -C This array is an output parameter if JOB = 'P', and an -C input parameter if JOB = 'U'. -C On entry, if JOB = 'U', the leading N*(N+1)/2 elements of -C this array must contain the upper (if UPLO = 'U') or lower -C (if UPLO = 'L') triangle of the symmetric matrix A, packed -C column-wise. That is, the elements are stored in the order -C 11, 12, 22, ..., 1n, 2n, 3n, ..., nn, if UPLO = 'U'; -C 11, 21, 31, ..., n1, 22, 32, ..., n2, ..., if UPLO = 'L'. -C On exit, if JOB = 'P', the leading N*(N+1)/2 elements of -C this array contain the upper (if UPLO = 'U') or lower -C (if UPLO = 'L') triangle of the symmetric matrix A, packed -C column-wise, as described above. -C -C CONTRIBUTOR -C -C V. Sima, Research Institute for Informatics, Bucharest, Romania, -C Oct. 1998. -C -C REVISIONS -C -C - -C -C ****************************************************************** -C -C .. Scalar Arguments .. - CHARACTER JOB, UPLO - INTEGER LDA, N -C .. Array Arguments .. - DOUBLE PRECISION A(LDA,*), AP(*) -C .. Local Scalars .. - LOGICAL LUPLO - INTEGER IJ, J -C .. External Functions .. - LOGICAL LSAME - EXTERNAL LSAME -C .. External Subroutines .. - EXTERNAL DCOPY -C -C .. Executable Statements .. -C -C For efficiency reasons, the parameters are not checked for errors. -C - LUPLO = LSAME( UPLO, 'L' ) - IJ = 1 - IF( LSAME( JOB, 'P' ) ) THEN - IF( LUPLO ) THEN -C -C Pack the lower triangle of A. -C - DO 20 J = 1, N - CALL DCOPY( N-J+1, A(J,J), 1, AP(IJ), 1 ) - IJ = IJ + N - J + 1 - 20 CONTINUE -C - ELSE -C -C Pack the upper triangle of A. -C - DO 40 J = 1, N - CALL DCOPY( J, A(1,J), 1, AP(IJ), 1 ) - IJ = IJ + J - 40 CONTINUE -C - END IF - ELSE - IF( LUPLO ) THEN -C -C Unpack the lower triangle of A. -C - DO 60 J = 1, N - CALL DCOPY( N-J+1, AP(IJ), 1, A(J,J), 1 ) - IJ = IJ + N - J + 1 - 60 CONTINUE -C - ELSE -C -C Unpack the upper triangle of A. -C - DO 80 J = 1, N - CALL DCOPY( J, AP(IJ), 1, A(1,J), 1 ) - IJ = IJ + J - 80 CONTINUE -C - END IF - END IF -C - RETURN -C *** Last line of MA02DD *** - END diff --git a/mex/sources/libslicot/MA02ED.f b/mex/sources/libslicot/MA02ED.f deleted file mode 100644 index 79ce82f7c..000000000 --- a/mex/sources/libslicot/MA02ED.f +++ /dev/null @@ -1,99 +0,0 @@ - SUBROUTINE MA02ED( UPLO, N, A, LDA ) -C -C SLICOT RELEASE 5.0. -C -C Copyright (c) 2002-2009 NICONET e.V. -C -C This program is free software: you can redistribute it and/or -C modify it under the terms of the GNU General Public License as -C published by the Free Software Foundation, either version 2 of -C the License, or (at your option) any later version. -C -C This program is distributed in the hope that it will be useful, -C but WITHOUT ANY WARRANTY; without even the implied warranty of -C MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the -C GNU General Public License for more details. -C -C You should have received a copy of the GNU General Public License -C along with this program. If not, see -C . -C -C PURPOSE -C -C To store by symmetry the upper or lower triangle of a symmetric -C matrix, given the other triangle. -C -C ARGUMENTS -C -C Mode Parameters -C -C UPLO CHARACTER*1 -C Specifies which part of the matrix is given as follows: -C = 'U': Upper triangular part; -C = 'L': Lower triangular part. -C For all other values, the array A is not referenced. -C -C Input/Output Parameters -C -C N (input) INTEGER -C The order of the matrix A. N >= 0. -C -C A (input/output) DOUBLE PRECISION array, dimension (LDA,N) -C On entry, the leading N-by-N upper triangular part -C (if UPLO = 'U'), or lower triangular part (if UPLO = 'L'), -C of this array must contain the corresponding upper or -C lower triangle of the symmetric matrix A. -C On exit, the leading N-by-N part of this array contains -C the symmetric matrix A with all elements stored. -C -C LDA INTEGER -C The leading dimension of the array A. LDA >= max(1,N). -C -C CONTRIBUTOR -C -C V. Sima, Research Institute for Informatics, Bucharest, Romania, -C Oct. 1998. -C -C REVISIONS -C -C - -C -C ****************************************************************** -C -C .. Scalar Arguments .. - CHARACTER UPLO - INTEGER LDA, N -C .. Array Arguments .. - DOUBLE PRECISION A(LDA,*) -C .. Local Scalars .. - INTEGER J -C .. External Functions .. - LOGICAL LSAME - EXTERNAL LSAME -C .. External Subroutines .. - EXTERNAL DCOPY -C -C .. Executable Statements .. -C -C For efficiency reasons, the parameters are not checked for errors. -C - IF( LSAME( UPLO, 'L' ) ) THEN -C -C Construct the upper triangle of A. -C - DO 20 J = 2, N - CALL DCOPY( J-1, A(J,1), LDA, A(1,J), 1 ) - 20 CONTINUE -C - ELSE IF( LSAME( UPLO, 'U' ) ) THEN -C -C Construct the lower triangle of A. -C - DO 40 J = 2, N - CALL DCOPY( J-1, A(1,J), 1, A(J,1), LDA ) - 40 CONTINUE -C - END IF - RETURN -C *** Last line of MA02ED *** - END diff --git a/mex/sources/libslicot/MA02FD.f b/mex/sources/libslicot/MA02FD.f deleted file mode 100644 index f2ec4350b..000000000 --- a/mex/sources/libslicot/MA02FD.f +++ /dev/null @@ -1,104 +0,0 @@ - SUBROUTINE MA02FD( X1, X2, C, S, INFO ) -C -C SLICOT RELEASE 5.0. -C -C Copyright (c) 2002-2009 NICONET e.V. -C -C This program is free software: you can redistribute it and/or -C modify it under the terms of the GNU General Public License as -C published by the Free Software Foundation, either version 2 of -C the License, or (at your option) any later version. -C -C This program is distributed in the hope that it will be useful, -C but WITHOUT ANY WARRANTY; without even the implied warranty of -C MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the -C GNU General Public License for more details. -C -C You should have received a copy of the GNU General Public License -C along with this program. If not, see -C . -C -C PURPOSE -C -C To compute the coefficients c and s (c^2 + s^2 = 1) for a modified -C hyperbolic plane rotation, such that, -C -C y1 := 1/c * x1 - s/c * x2 = sqrt(x1^2 - x2^2), -C y2 := -s * y1 + c * x2 = 0, -C -C given two real numbers x1 and x2, satisfying either x1 = x2 = 0, -C or abs(x2) < abs(x1). -C -C ARGUMENTS -C -C Input/Output Parameters -C -C X1 (input/output) DOUBLE PRECISION -C On entry, the real number x1. -C On exit, the real number y1. -C -C X2 (input) DOUBLE PRECISION -C The real number x2. -C The values x1 and x2 should satisfy either x1 = x2 = 0, or -C abs(x2) < abs(x1). -C -C C (output) DOUBLE PRECISION -C The cosines c of the modified hyperbolic plane rotation. -C -C S (output) DOUBLE PRECISION -C The sines s of the modified hyperbolic plane rotation. -C -C Error Indicator -C -C INFO INTEGER -C = 0: succesful exit; -C = 1: if abs(x2) >= abs(x1) and either x1 <> 0 or x2 <> 0. -C -C CONTRIBUTOR -C -C D. Kressner, Technical Univ. Chemnitz, Germany, June 2000. -C -C REVISIONS -C -C V. Sima, Katholieke Univ. Leuven, Belgium, June 2000. -C -C KEYWORDS -C -C Orthogonal transformation, plane rotation. -C -C ***************************************************************** -C -C .. Parameters .. - DOUBLE PRECISION ONE, ZERO - PARAMETER ( ONE = 1.0D0, ZERO = 0.0D0 ) -C .. Scalar Arguments .. - DOUBLE PRECISION X1, X2, C, S - INTEGER INFO -C .. Intrinsic Functions .. - INTRINSIC ABS, SIGN, SQRT -C .. Executable Statements .. -C - IF ( ( X1.NE.ZERO .OR. X2.NE.ZERO ) .AND. - $ ABS( X2 ).GE.ABS( X1 ) ) THEN - INFO = 1 - ELSE - INFO = 0 - IF ( X1.EQ.ZERO ) THEN - S = ZERO - C = ONE - ELSE - S = X2 / X1 -C -C No overflows could appear in the next statement; underflows -C are possible if X2 is tiny and X1 is huge, but then -C abs(C) = ONE - delta, -C where delta is much less than machine precision. -C - C = SIGN( SQRT( ONE - S ) * SQRT( ONE + S ), X1 ) - X1 = C * X1 - END IF - END IF -C - RETURN -C *** Last line of MA02FD *** - END diff --git a/mex/sources/libslicot/MA02GD.f b/mex/sources/libslicot/MA02GD.f deleted file mode 100644 index 90cda2ed4..000000000 --- a/mex/sources/libslicot/MA02GD.f +++ /dev/null @@ -1,158 +0,0 @@ - SUBROUTINE MA02GD( N, A, LDA, K1, K2, IPIV, INCX ) -C -C SLICOT RELEASE 5.0. -C -C Copyright (c) 2002-2009 NICONET e.V. -C -C This program is free software: you can redistribute it and/or -C modify it under the terms of the GNU General Public License as -C published by the Free Software Foundation, either version 2 of -C the License, or (at your option) any later version. -C -C This program is distributed in the hope that it will be useful, -C but WITHOUT ANY WARRANTY; without even the implied warranty of -C MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the -C GNU General Public License for more details. -C -C You should have received a copy of the GNU General Public License -C along with this program. If not, see -C . -C -C PURPOSE -C -C To perform a series of column interchanges on the matrix A. -C One column interchange is initiated for each of columns K1 through -C K2 of A. This is useful for solving linear systems X*A = B, when -C the matrix A has already been factored by LAPACK Library routine -C DGETRF. -C -C ARGUMENTS -C -C Input/Output Parameters -C -C N (input) INTEGER -C The number of rows of the matrix A. N >= 0. -C -C A (input/output) DOUBLE PRECISION array, dimension (LDA,*) -C On entry, the leading N-by-M part of this array must -C contain the matrix A to which the column interchanges will -C be applied, where M is the largest element of IPIV(K), for -C K = K1, ..., K2. -C On exit, the leading N-by-M part of this array contains -C the permuted matrix. -C -C LDA INTEGER -C The leading dimension of the array A. LDA >= MAX(1,N). -C -C K1 (input) INTEGER -C The first element of IPIV for which a column interchange -C will be done. -C -C K2 (input) INTEGER -C The last element of IPIV for which a column interchange -C will be done. -C -C IPIV (input) INTEGER array, dimension (K1+(K2-K1)*abs(INCX)) -C The vector of interchanging (pivot) indices. Only the -C elements in positions K1 through K2 of IPIV are accessed. -C IPIV(K) = L implies columns K and L are to be -C interchanged. -C -C INCX (input) INTEGER -C The increment between successive values of IPIV. -C If INCX is negative, the interchanges are applied in -C reverse order. -C -C METHOD -C -C The columns IPIV(K) and K are swapped for K = K1, ..., K2, for -C INCX = 1 (and similarly, for INCX <> 1). -C -C FURTHER COMMENTS -C -C This routine is the column-oriented counterpart of the LAPACK -C Library routine DLASWP. The LAPACK Library routine DLAPMT cannot -C be used in this context. To solve the system X*A = B, where A and -C B are N-by-N and M-by-N, respectively, the following statements -C can be used: -C -C CALL DGETRF( N, N, A, LDA, IPIV, INFO ) -C CALL DTRSM( 'R', 'U', 'N', 'N', M, N, ONE, A, LDA, B, LDB ) -C CALL DTRSM( 'R', 'L', 'N', 'U', M, N, ONE, A, LDA, B, LDB ) -C CALL MA02GD( M, B, LDB, 1, N, IPIV, -1 ) -C -C CONTRIBUTOR -C -C V. Sima, Research Institute for Informatics, Bucharest, Mar. 2000. -C -C REVISIONS -C -C V. Sima, Research Institute for Informatics, Bucharest, Apr. 2008. -C -C KEYWORDS -C -C Elementary matrix operations, linear algebra. -C -C ****************************************************************** -C -C .. Scalar Arguments .. - INTEGER INCX, K1, K2, LDA, N -C .. -C .. Array Arguments .. - INTEGER IPIV( * ) - DOUBLE PRECISION A( LDA, * ) -C .. -C .. Local Scalars .. - INTEGER J, JP, JX -C .. -C .. External Subroutines .. - EXTERNAL DSWAP -C .. -C .. Executable Statements .. -C -C Quick return if possible. -C - IF( INCX.EQ.0 .OR. N.EQ.0 ) - $ RETURN -C -C Interchange column J with column IPIV(J) for each of columns K1 -C through K2. -C - IF( INCX.GT.0 ) THEN - JX = K1 - ELSE - JX = 1 + ( 1-K2 )*INCX - END IF -C - IF( INCX.EQ.1 ) THEN -C - DO 10 J = K1, K2 - JP = IPIV( J ) - IF( JP.NE.J ) - $ CALL DSWAP( N, A( 1, J ), 1, A( 1, JP ), 1 ) - 10 CONTINUE -C - ELSE IF( INCX.GT.1 ) THEN -C - DO 20 J = K1, K2 - JP = IPIV( JX ) - IF( JP.NE.J ) - $ CALL DSWAP( N, A( 1, J ), 1, A( 1, JP ), 1 ) - JX = JX + INCX - 20 CONTINUE -C - ELSE IF( INCX.LT.0 ) THEN -C - DO 30 J = K2, K1, -1 - JP = IPIV( JX ) - IF( JP.NE.J ) - $ CALL DSWAP( N, A( 1, J ), 1, A( 1, JP ), 1 ) - JX = JX + INCX - 30 CONTINUE -C - END IF -C - RETURN -C -C *** Last line of MA02GD *** - END diff --git a/mex/sources/libslicot/MA02HD.f b/mex/sources/libslicot/MA02HD.f deleted file mode 100644 index 2017da866..000000000 --- a/mex/sources/libslicot/MA02HD.f +++ /dev/null @@ -1,180 +0,0 @@ - LOGICAL FUNCTION MA02HD( JOB, M, N, DIAG, A, LDA ) -C -C SLICOT RELEASE 5.0. -C -C Copyright (c) 2002-2009 NICONET e.V. -C -C This program is free software: you can redistribute it and/or -C modify it under the terms of the GNU General Public License as -C published by the Free Software Foundation, either version 2 of -C the License, or (at your option) any later version. -C -C This program is distributed in the hope that it will be useful, -C but WITHOUT ANY WARRANTY; without even the implied warranty of -C MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the -C GNU General Public License for more details. -C -C You should have received a copy of the GNU General Public License -C along with this program. If not, see -C . -C -C PURPOSE -C -C To check if A = DIAG*I, where I is an M-by-N matrix with ones on -C the diagonal and zeros elsewhere. -C -C FUNCTION VALUE -C -C MA02HD LOGICAL -C The function value is set to .TRUE. if A = DIAG*I, and to -C .FALSE., otherwise. -C -C ARGUMENTS -C -C Mode Parameters -C -C JOB CHARACTER*1 -C Specifies the part of the matrix A to be checked out, -C as follows: -C = 'U': Upper triangular/trapezoidal part; -C = 'L': Lower triangular/trapezoidal part. -C Otherwise: All of the matrix A. -C -C Input/Output Parameters -C -C M (input) INTEGER -C The number of rows of the matrix A. M >= 0. -C -C N (input) INTEGER -C The number of columns of the matrix A. N >= 0. -C -C DIAG (input) DOUBLE PRECISION -C The scalar DIAG. -C -C A (input) DOUBLE PRECISION array, dimension (LDA,N) -C The leading M-by-N part of this array must contain the -C matrix A. If JOB = 'U', only the upper triangle or -C trapezoid is accessed; if JOB = 'L', only the lower -C triangle or trapezoid is accessed. -C -C LDA INTEGER -C The leading dimension of the array A. LDA >= max(1,M). -C -C METHOD -C -C The routine returns immediately after detecting a diagonal element -C which differs from DIAG, or a nonzero off-diagonal element in the -C searched part of A. -C -C CONTRIBUTORS -C -C V. Sima, Research Institute for Informatics, Bucharest, May 2001. -C A. Varga, German Aerospace Center, Oberpfaffenhofen, May 2001. -C -C REVISIONS -C -C V. Sima, Research Institute for Informatics, Bucharest, Jan. 2003. -C -C KEYWORDS -C -C Elementary operations. -C -C ****************************************************************** -C -C .. Parameters .. - DOUBLE PRECISION ZERO - PARAMETER ( ZERO = 0.0D0 ) -C .. Scalar Arguments .. - CHARACTER JOB - INTEGER LDA, M, N - DOUBLE PRECISION DIAG -C .. Array Arguments .. - DOUBLE PRECISION A(LDA,*) -C .. Local Scalars .. - INTEGER I, J -C .. External Functions - LOGICAL LSAME - EXTERNAL LSAME -C .. Intrinsic Functions .. - INTRINSIC MIN -C -C .. Executable Statements .. -C -C Do not check parameters, for efficiency. -C - IF( LSAME( JOB, 'U' ) ) THEN -C - DO 20 J = 1, N -C - DO 10 I = 1, MIN( J-1, M ) - IF( A(I,J).NE.ZERO ) THEN - MA02HD = .FALSE. - RETURN - END IF - 10 CONTINUE -C - IF( J.LE.M ) THEN - IF( A(J,J).NE.DIAG ) THEN - MA02HD = .FALSE. - RETURN - END IF - END IF - 20 CONTINUE -C - ELSE IF( LSAME( JOB, 'L' ) ) THEN -C - DO 40 J = 1, MIN( M, N ) - IF( A(J,J).NE.DIAG ) THEN - MA02HD = .FALSE. - RETURN - END IF -C - IF ( J.NE.M ) THEN -C - DO 30 I = MIN( J+1, M ), M - IF( A(I,J).NE.ZERO ) THEN - MA02HD = .FALSE. - RETURN - END IF - 30 CONTINUE -C - END IF - 40 CONTINUE -C - ELSE -C - DO 70 J = 1, N -C - DO 50 I = 1, MIN( J-1, M ) - IF( A(I,J).NE.ZERO ) THEN - MA02HD = .FALSE. - RETURN - END IF - 50 CONTINUE -C - IF( J.LE.M ) THEN - IF( A(J,J).NE.DIAG ) THEN - MA02HD = .FALSE. - RETURN - END IF - END IF -C - IF ( J.LT.M ) THEN -C - DO 60 I = MIN( J+1, M ), M - IF( A(I,J).NE.ZERO ) THEN - MA02HD = .FALSE. - RETURN - END IF - 60 CONTINUE -C - END IF - 70 CONTINUE -C - END IF -C - MA02HD = .TRUE. -C - RETURN -C *** Last line of MA02HD *** - END diff --git a/mex/sources/libslicot/MA02ID.f b/mex/sources/libslicot/MA02ID.f deleted file mode 100644 index 8b822bb55..000000000 --- a/mex/sources/libslicot/MA02ID.f +++ /dev/null @@ -1,293 +0,0 @@ - DOUBLE PRECISION FUNCTION MA02ID( TYP, NORM, N, A, LDA, QG, - $ LDQG, DWORK ) -C -C SLICOT RELEASE 5.0. -C -C Copyright (c) 2002-2009 NICONET e.V. -C -C This program is free software: you can redistribute it and/or -C modify it under the terms of the GNU General Public License as -C published by the Free Software Foundation, either version 2 of -C the License, or (at your option) any later version. -C -C This program is distributed in the hope that it will be useful, -C but WITHOUT ANY WARRANTY; without even the implied warranty of -C MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the -C GNU General Public License for more details. -C -C You should have received a copy of the GNU General Public License -C along with this program. If not, see -C . -C -C PURPOSE -C -C To compute the value of the one norm, or the Frobenius norm, or -C the infinity norm, or the element of largest absolute value -C of a real skew-Hamiltonian matrix -C -C [ A G ] T T -C X = [ T ], G = -G, Q = -Q, -C [ Q A ] -C -C or of a real Hamiltonian matrix -C -C [ A G ] T T -C X = [ T ], G = G, Q = Q, -C [ Q -A ] -C -C where A, G and Q are real n-by-n matrices. -C -C Note that for this kind of matrices the infinity norm is equal -C to the one norm. -C -C FUNCTION VALUE -C -C MA02ID DOUBLE PRECISION -C The computed norm. -C -C ARGUMENTS -C -C Mode Parameters -C -C TYP CHARACTER*1 -C Specifies the type of the input matrix X: -C = 'S': X is skew-Hamiltonian; -C = 'H': X is Hamiltonian. -C -C NORM CHARACTER*1 -C Specifies the value to be returned in MA02ID: -C = '1' or 'O': one norm of X; -C = 'F' or 'E': Frobenius norm of X; -C = 'I': infinity norm of X; -C = 'M': max(abs(X(i,j)). -C -C Input/Output Parameters -C -C N (input) INTEGER -C The order of the matrix A. N >= 0. -C -C A (input) DOUBLE PRECISION array, dimension (LDA,N) -C On entry, the leading N-by-N part of this array must -C contain the matrix A. -C -C LDA INTEGER -C The leading dimension of the array A. LDA >= MAX(1,N). -C -C QG (input) DOUBLE PRECISION array, dimension (LDQG,N+1) -C On entry, the leading N-by-N+1 part of this array must -C contain in columns 1:N the lower triangular part of the -C matrix Q and in columns 2:N+1 the upper triangular part -C of the matrix G. If TYP = 'S', the parts containing the -C diagonal and the first supdiagonal of this array are not -C referenced. -C -C LDQG INTEGER -C The leading dimension of the array QG. LDQG >= MAX(1,N). -C -C Workspace -C -C -C DWORK DOUBLE PRECISION array, dimension (LDWORK) -C where LDWORK >= 2*N when NORM = '1', NORM = 'I' or -C NORM = 'O'; otherwise, DWORK is not referenced. -C -C CONTRIBUTORS -C -C D. Kressner, Technical Univ. Berlin, Germany, and -C P. Benner, Technical Univ. Chemnitz, Germany, December 2003. -C -C REVISIONS -C -C V. Sima, June 2008 (SLICOT version of the HAPACK routine DLANHA). -C -C KEYWORDS -C -C Elementary matrix operations, Hamiltonian matrix, skew-Hamiltonian -C matrix. -C -C ****************************************************************** -C -C .. Parameters .. - DOUBLE PRECISION ONE, TWO, ZERO - PARAMETER ( ONE = 1.0D+0, TWO = 2.0D+0, ZERO = 0.0D+0 ) -C .. Scalar Arguments .. - CHARACTER NORM, TYP - INTEGER LDA, LDQG, N -C .. Array Arguments .. - DOUBLE PRECISION A(LDA,*), DWORK(*), QG(LDQG,*) -C .. Local Scalars .. - LOGICAL LSH - INTEGER I, J - DOUBLE PRECISION DSCL, DSUM, SCALE, SUM, TEMP, VALUE -C .. External Functions .. - LOGICAL LSAME - DOUBLE PRECISION DLANGE, DLAPY2 - EXTERNAL DLANGE, DLAPY2, LSAME -C .. External Subroutines .. - EXTERNAL DLASSQ -C .. Intrinsic Functions .. - INTRINSIC ABS, MAX, SQRT -C -C .. Executable Statements .. -C - LSH = LSAME( TYP, 'S' ) -C - IF ( N.EQ.0 ) THEN - VALUE = ZERO -C - ELSE IF ( LSAME( NORM, 'M' ) .AND. LSH ) THEN -C -C Find max(abs(A(i,j))). -C - VALUE = DLANGE( 'MaxElement', N, N, A, LDA, DWORK ) - IF ( N.GT.1 ) THEN - DO 30 J = 1, N+1 - DO 10 I = 1, J-2 - VALUE = MAX( VALUE, ABS( QG(I,J) ) ) - 10 CONTINUE - DO 20 I = J+1, N - VALUE = MAX( VALUE, ABS( QG(I,J) ) ) - 20 CONTINUE - 30 CONTINUE - END IF -C - ELSE IF ( LSAME( NORM, 'M' ) ) THEN -C -C Find max( abs( A(i,j) ), abs( QG(i,j) ) ). -C - VALUE = MAX( DLANGE( 'MaxElement', N, N, A, LDA, DWORK ), - $ DLANGE( 'MaxElement', N, N+1, QG, LDQG, - $ DWORK ) ) -C - ELSE IF ( ( LSAME( NORM, 'O' ) .OR. ( NORM.EQ.'1' ) .OR. - $ LSAME( NORM, 'I' ) ) .AND. LSH ) THEN -C -C Find the column and row sums of A (in one pass). -C - VALUE = ZERO - DO 40 I = 1, N - DWORK(I) = ZERO - 40 CONTINUE -C - DO 60 J = 1, N - SUM = ZERO - DO 50 I = 1, N - TEMP = ABS( A(I,J) ) - SUM = SUM + TEMP - DWORK(I) = DWORK(I) + TEMP - 50 CONTINUE - DWORK(N+J) = SUM - 60 CONTINUE -C -C Compute the maximal absolute column sum. -C - DO 90 J = 1, N+1 - DO 70 I = 1, J-2 - TEMP = ABS( QG(I,J) ) - DWORK(I) = DWORK(I) + TEMP - DWORK(J-1) = DWORK(J-1) + TEMP - 70 CONTINUE - IF ( J.LT.N+1 ) THEN - SUM = DWORK(N+J) - DO 80 I = J+1, N - TEMP = ABS( QG(I,J) ) - SUM = SUM + TEMP - DWORK(N+I) = DWORK(N+I) + TEMP - 80 CONTINUE - VALUE = MAX( VALUE, SUM ) - END IF - 90 CONTINUE - DO 100 I = 1, N - VALUE = MAX( VALUE, DWORK(I) ) - 100 CONTINUE -C - ELSE IF ( LSAME( NORM, 'O' ) .OR. ( NORM.EQ.'1' ) .OR. - $ LSAME( NORM, 'I' ) ) THEN -C -C Find the column and row sums of A (in one pass). -C - VALUE = ZERO - DO 110 I = 1, N - DWORK(I) = ZERO - 110 CONTINUE -C - DO 130 J = 1, N - SUM = ZERO - DO 120 I = 1, N - TEMP = ABS( A(I,J) ) - SUM = SUM + TEMP - DWORK(I) = DWORK(I) + TEMP - 120 CONTINUE - DWORK(N+J) = SUM - 130 CONTINUE -C -C Compute the maximal absolute column sum. -C - DO 160 J = 1, N+1 - DO 140 I = 1, J-2 - TEMP = ABS( QG(I,J) ) - DWORK(I) = DWORK(I) + TEMP - DWORK(J-1) = DWORK(J-1) + TEMP - 140 CONTINUE - IF ( J.GT.1 ) - $ DWORK(J-1) = DWORK(J-1) + ABS( QG(J-1,J) ) - IF ( J.LT.N+1 ) THEN - SUM = DWORK(N+J) + ABS( QG(J,J) ) - DO 150 I = J+1, N - TEMP = ABS( QG(I,J) ) - SUM = SUM + TEMP - DWORK(N+I) = DWORK(N+I) + TEMP - 150 CONTINUE - VALUE = MAX( VALUE, SUM ) - END IF - 160 CONTINUE - DO 170 I = 1, N - VALUE = MAX( VALUE, DWORK(I) ) - 170 CONTINUE -C - ELSE IF ( ( LSAME( NORM, 'F' ) .OR. - $ LSAME( NORM, 'E' ) ) .AND. LSH ) THEN -C -C Find normF(A). -C - SCALE = ZERO - SUM = ONE - DO 180 J = 1, N - CALL DLASSQ( N, A(1,J), 1, SCALE, SUM ) - 180 CONTINUE -C -C Add normF(G) and normF(Q). -C - DO 190 J = 1, N+1 - IF ( J.GT.2 ) - $ CALL DLASSQ( J-2, QG(1,J), 1, SCALE, SUM ) - IF ( J.LT.N ) - $ CALL DLASSQ( N-J, QG(J+1,J), 1, SCALE, SUM ) - 190 CONTINUE - VALUE = SQRT( TWO )*SCALE*SQRT( SUM ) - ELSE IF ( LSAME( NORM, 'F' ) .OR. LSAME( NORM, 'E' ) ) THEN - SCALE = ZERO - SUM = ONE - DO 200 J = 1, N - CALL DLASSQ( N, A(1,J), 1, SCALE, SUM ) - 200 CONTINUE - DSCL = ZERO - DSUM = ONE - DO 210 J = 1, N+1 - IF ( J.GT.1 ) THEN - CALL DLASSQ( J-2, QG(1,J), 1, SCALE, SUM ) - CALL DLASSQ( 1, QG(J-1,J), 1, DSCL, DSUM ) - END IF - IF ( J.LT.N+1 ) THEN - CALL DLASSQ( 1, QG(J,J), 1, DSCL, DSUM ) - CALL DLASSQ( N-J, QG(J+1,J), 1, SCALE, SUM ) - END IF - 210 CONTINUE - VALUE = DLAPY2( SQRT( TWO )*SCALE*SQRT( SUM ), - $ DSCL*SQRT( DSUM ) ) - END IF -C - MA02ID = VALUE - RETURN -C *** Last line of MA02ID *** - END diff --git a/mex/sources/libslicot/MA02JD.f b/mex/sources/libslicot/MA02JD.f deleted file mode 100644 index ebf75d0a2..000000000 --- a/mex/sources/libslicot/MA02JD.f +++ /dev/null @@ -1,164 +0,0 @@ - DOUBLE PRECISION FUNCTION MA02JD( LTRAN1, LTRAN2, N, Q1, LDQ1, Q2, - $ LDQ2, RES, LDRES ) -C -C SLICOT RELEASE 5.0. -C -C Copyright (c) 2002-2009 NICONET e.V. -C -C This program is free software: you can redistribute it and/or -C modify it under the terms of the GNU General Public License as -C published by the Free Software Foundation, either version 2 of -C the License, or (at your option) any later version. -C -C This program is distributed in the hope that it will be useful, -C but WITHOUT ANY WARRANTY; without even the implied warranty of -C MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the -C GNU General Public License for more details. -C -C You should have received a copy of the GNU General Public License -C along with this program. If not, see -C . -C -C PURPOSE -C -C To compute || Q^T Q - I ||_F for a matrix of the form -C -C [ op( Q1 ) op( Q2 ) ] -C Q = [ ], -C [ -op( Q2 ) op( Q1 ) ] -C -C where Q1 and Q2 are N-by-N matrices. This residual can be used to -C test wether Q is numerically an orthogonal symplectic matrix. -C -C FUNCTION VALUE -C -C MA02JD DOUBLE PRECISION -C The computed residual. -C -C ARGUMENTS -C -C Mode Parameters -C -C LTRAN1 LOGICAL -C Specifies the form of op( Q1 ) as follows: -C = .FALSE.: op( Q1 ) = Q1; -C = .TRUE. : op( Q1 ) = Q1'. -C -C LTRAN2 LOGICAL -C Specifies the form of op( Q2 ) as follows: -C = .FALSE.: op( Q2 ) = Q2; -C = .TRUE. : op( Q2 ) = Q2'. -C -C Input/Output Parameters -C -C N (input) INTEGER -C The order of the matrices Q1 and Q2. N >= 0. -C -C Q1 (input) DOUBLE PRECISION array, dimension (LDQ1,N) -C On entry, the leading N-by-N part of this array must -C contain the matrix op( Q1 ). -C -C LDQ1 INTEGER -C The leading dimension of the array Q1. LDQ1 >= MAX(1,N). -C -C Q2 (input) DOUBLE PRECISION array, dimension (LDQ2,N) -C On entry, the leading N-by-N part of this array must -C contain the matrix op( Q2 ). -C -C LDQ2 INTEGER -C The leading dimension of the array Q2. LDQ2 >= MAX(1,N). -C -C Workspace -C -C RES DOUBLE PRECISION array, dimension (LDRES,N) -C -C LDRES INTEGER -C The leading dimension of the array RES. LDRES >= MAX(1,N). -C -C METHOD -C -C The routine computes the residual by simple elementary operations. -C -C CONTRIBUTORS -C -C D. Kressner, Technical Univ. Berlin, Germany, and -C P. Benner, Technical Univ. Chemnitz, Germany, December 2003. -C -C REVISIONS -C -C V. Sima, June 2008 (SLICOT version of the HAPACK routine DLAORS). -C -C KEYWORDS -C -C Elementary operations. -C -C ****************************************************************** -C -C .. Parameters .. - DOUBLE PRECISION ZERO, ONE, TWO - PARAMETER ( ZERO = 0.0D0, ONE = 1.0D0, TWO = 2.0D0 ) -C .. Scalar Arguments .. - LOGICAL LTRAN1, LTRAN2 - INTEGER LDQ1, LDQ2, LDRES, N -C .. Array Arguments .. - DOUBLE PRECISION Q1(LDQ1,*), Q2(LDQ2,*), RES(LDRES,*) -C .. Local Scalars .. - INTEGER I - DOUBLE PRECISION TEMP -C .. Local Arrays .. - DOUBLE PRECISION DUMMY(1) -C .. External Subroutines .. - EXTERNAL DGEMM -C .. External Functions .. - DOUBLE PRECISION DLANGE, DLAPY2 - EXTERNAL DLANGE, DLAPY2 -C .. Intrinsic Functions .. - INTRINSIC SQRT -C -C .. Executable Statements .. -C - IF ( LTRAN1 ) THEN - CALL DGEMM( 'No Transpose', 'Transpose', N, N, N, ONE, Q1, - $ LDQ1, Q1, LDQ1, ZERO, RES, LDRES ) - ELSE - CALL DGEMM( 'Transpose', 'No Transpose', N, N, N, ONE, Q1, - $ LDQ1, Q1, LDQ1, ZERO, RES, LDRES ) - END IF - IF ( LTRAN2 ) THEN - CALL DGEMM( 'No Transpose', 'Transpose', N, N, N, ONE, Q2, - $ LDQ2, Q2, LDQ2, ONE, RES, LDRES ) - ELSE - CALL DGEMM( 'Transpose', 'No Transpose', N, N, N, ONE, Q2, - $ LDQ2, Q2, LDQ2, ONE, RES, LDRES ) - END IF - DO 10 I = 1, N - RES(I,I) = RES(I,I) - ONE - 10 CONTINUE - TEMP = DLANGE( 'Frobenius', N, N, RES, LDRES, DUMMY ) - IF ( LTRAN1 .AND. LTRAN2 ) THEN - CALL DGEMM( 'No Transpose', 'Transpose', N, N, N, ONE, Q2, - $ LDQ2, Q1, LDQ1, ZERO, RES, LDRES ) - CALL DGEMM( 'No Transpose', 'Transpose', N, N, N, ONE, Q1, - $ LDQ1, Q2, LDQ2, -ONE, RES, LDRES ) - ELSE IF ( LTRAN1 ) THEN - CALL DGEMM( 'Transpose', 'Transpose', N, N, N, ONE, Q2, - $ LDQ2, Q1, LDQ1, ZERO, RES, LDRES ) - CALL DGEMM( 'No Transpose', 'No Transpose', N, N, N, ONE, Q1, - $ LDQ1, Q2, LDQ2, -ONE, RES, LDRES ) - ELSE IF ( LTRAN2 ) THEN - CALL DGEMM( 'No Transpose', 'No Transpose', N, N, N, ONE, Q2, - $ LDQ2, Q1, LDQ1, ZERO, RES, LDRES ) - CALL DGEMM( 'Transpose', 'Transpose', N, N, N, ONE, Q1, - $ LDQ1, Q2, LDQ2, -ONE, RES, LDRES ) - ELSE - CALL DGEMM( 'Transpose', 'No Transpose', N, N, N, ONE, Q2, - $ LDQ2, Q1, LDQ1, ZERO, RES, LDRES ) - CALL DGEMM( 'Transpose', 'No Transpose', N, N, N, ONE, Q1, - $ LDQ1, Q2, LDQ2, -ONE, RES, LDRES ) - END IF - TEMP = DLAPY2( TEMP, DLANGE( 'Frobenius', N, N, RES, LDRES, - $ DUMMY ) ) - MA02JD = SQRT( TWO )*TEMP - RETURN -C *** Last line of MA02JD *** - END diff --git a/mex/sources/libslicot/MB01MD.f b/mex/sources/libslicot/MB01MD.f deleted file mode 100644 index 94f99f57a..000000000 --- a/mex/sources/libslicot/MB01MD.f +++ /dev/null @@ -1,279 +0,0 @@ - SUBROUTINE MB01MD( UPLO, N, ALPHA, A, LDA, X, INCX, BETA, Y, - $ INCY ) -C -C SLICOT RELEASE 5.0. -C -C Copyright (c) 2002-2009 NICONET e.V. -C -C This program is free software: you can redistribute it and/or -C modify it under the terms of the GNU General Public License as -C published by the Free Software Foundation, either version 2 of -C the License, or (at your option) any later version. -C -C This program is distributed in the hope that it will be useful, -C but WITHOUT ANY WARRANTY; without even the implied warranty of -C MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the -C GNU General Public License for more details. -C -C You should have received a copy of the GNU General Public License -C along with this program. If not, see -C . -C -C PURPOSE -C -C To perform the matrix-vector operation -C -C y := alpha*A*x + beta*y, -C -C where alpha and beta are scalars, x and y are vectors of length -C n and A is an n-by-n skew-symmetric matrix. -C -C This is a modified version of the vanilla implemented BLAS -C routine DSYMV written by Jack Dongarra, Jeremy Du Croz, -C Sven Hammarling, and Richard Hanson. -C -C ARGUMENTS -C -C Mode Parameters -C -C UPLO CHARACTER*1 -C Specifies whether the upper or lower triangular part of -C the array A is to be referenced as follows: -C = 'U': only the strictly upper triangular part of A is to -C be referenced; -C = 'L': only the strictly lower triangular part of A is to -C be referenced. -C -C Input/Output Parameters -C -C N (input) INTEGER -C The order of the matrix A. N >= 0. -C -C ALPHA (input) DOUBLE PRECISION -C The scalar alpha. If alpha is zero the array A is not -C referenced. -C -C A (input) DOUBLE PRECISION array, dimension (LDA,N) -C On entry with UPLO = 'U', the leading N-by-N part of this -C array must contain the strictly upper triangular part of -C the matrix A. The lower triangular part of this array is -C not referenced. -C On entry with UPLO = 'L', the leading N-by-N part of this -C array must contain the strictly lower triangular part of -C the matrix A. The upper triangular part of this array is -C not referenced. -C -C LDA INTEGER -C The leading dimension of the array A. LDA >= MAX(1,N) -C -C X (input) DOUBLE PRECISION array, dimension -C ( 1 + ( N - 1 )*abs( INCX ) ). -C On entry, elements 1, INCX+1, .., ( N - 1 )*INCX + 1 of -C this array must contain the elements of the vector X. -C -C INCX (input) INTEGER -C The increment for the elements of X. IF INCX < 0 then the -C elements of X are accessed in reversed order. INCX <> 0. -C -C BETA (input) DOUBLE PRECISION -C The scalar beta. If beta is zero then Y need not be set on -C input. -C -C Y (input/output) DOUBLE PRECISION array, dimension -C ( 1 + ( N - 1 )*abs( INCY ) ). -C On entry, elements 1, INCY+1, .., ( N - 1 )*INCY + 1 of -C this array must contain the elements of the vector Y. -C On exit, elements 1, INCY+1, .., ( N - 1 )*INCY + 1 of -C this array contain the updated elements of the vector Y. -C -C INCY (input) INTEGER -C The increment for the elements of Y. IF INCY < 0 then the -C elements of Y are accessed in reversed order. INCY <> 0. -C -C NUMERICAL ASPECTS -C -C Though being almost identical with the vanilla implementation -C of the BLAS routine DSYMV the performance of this routine could -C be significantly lower in the case of vendor supplied, highly -C optimized BLAS. -C -C CONTRIBUTORS -C -C D. Kressner, Technical Univ. Berlin, Germany, and -C P. Benner, Technical Univ. Chemnitz, Germany, December 2003. -C -C REVISIONS -C -C V. Sima, May 2008 (SLICOT version of the HAPACK routine DSKMV). -C -C KEYWORDS -C -C Elementary matrix operations. -C -C ****************************************************************** -C -C .. Parameters .. - DOUBLE PRECISION ONE, ZERO - PARAMETER ( ONE = 1.0D+0, ZERO = 0.0D+0 ) -C .. Scalar Arguments .. - DOUBLE PRECISION ALPHA, BETA - INTEGER INCX, INCY, LDA, N - CHARACTER UPLO -C .. Array Arguments .. - DOUBLE PRECISION A(LDA,*), X(*), Y(*) -C .. Local Scalars .. - DOUBLE PRECISION TEMP1, TEMP2 - INTEGER I, INFO, IX, IY, J, JX, JY, KX, KY -C .. External Functions .. - LOGICAL LSAME - EXTERNAL LSAME -C .. External Subroutines .. - EXTERNAL XERBLA -C .. Intrinsic Functions .. - INTRINSIC MAX -C -C .. Executable Statements .. -C -C Test the input parameters. -C - INFO = 0 - IF ( .NOT.LSAME( UPLO, 'U' ) .AND. .NOT.LSAME( UPLO, 'L' ) ) THEN - INFO = 1 - ELSE IF ( N.LT.0 )THEN - INFO = 2 - ELSE IF ( LDA.LT.MAX( 1, N ) )THEN - INFO = 5 - ELSE IF ( INCX.EQ.0 )THEN - INFO = 7 - ELSE IF ( INCY.EQ.0 )THEN - INFO = 10 - END IF - IF ( INFO.NE.0 )THEN - CALL XERBLA( 'MB01MD', INFO ) - RETURN - END IF -C -C Quick return if possible. -C - IF ( ( N.EQ.0 ).OR.( ( ALPHA.EQ.ZERO ).AND.( BETA.EQ.ONE ) ) ) - $ RETURN -C -C Set up the start points in X and Y. -C - IF ( INCX.GT.0 )THEN - KX = 1 - ELSE - KX = 1 - ( N - 1 )*INCX - END IF - IF ( INCY.GT.0 )THEN - KY = 1 - ELSE - KY = 1 - ( N - 1 )*INCY - END IF -C -C Start the operations. In this version the elements of A are -C accessed sequentially with one pass through the triangular part -C of A. -C -C First form y := beta*y. -C - IF ( BETA.NE.ONE )THEN - IF ( INCY.EQ.1 )THEN - IF ( BETA.EQ.ZERO )THEN - DO 10 I = 1, N - Y(I) = ZERO - 10 CONTINUE - ELSE - DO 20 I = 1, N - Y(I) = BETA*Y(I) - 20 CONTINUE - END IF - ELSE - IY = KY - IF ( BETA.EQ.ZERO )THEN - DO 30 I = 1, N - Y(IY) = ZERO - IY = IY + INCY - 30 CONTINUE - ELSE - DO 40 I = 1, N - Y(IY) = BETA*Y(IY) - IY = IY + INCY - 40 CONTINUE - END IF - END IF - END IF -C -C Quick return if possible. -C - IF ( ALPHA.EQ.ZERO ) - $ RETURN - IF ( LSAME( UPLO, 'U' ) )THEN -C -C Form y when A is stored in upper triangle. -C - IF ( ( INCX.EQ.1 ).AND.( INCY.EQ.1 ) )THEN - DO 60 J = 2, N - TEMP1 = ALPHA*X(J) - TEMP2 = ZERO - DO 50, I = 1, J - 1 - Y(I) = Y(I) + TEMP1*A(I,J) - TEMP2 = TEMP2 + A(I,J)*X(I) - 50 CONTINUE - Y(J) = Y(J) - ALPHA*TEMP2 - 60 CONTINUE - ELSE - JX = KX + INCX - JY = KY + INCY - DO 80 J = 2, N - TEMP1 = ALPHA*X(JX) - TEMP2 = ZERO - IX = KX - IY = KY - DO 70 I = 1, J - 1 - Y(IY) = Y(IY) + TEMP1*A(I,J) - TEMP2 = TEMP2 + A(I,J)*X(IX) - IX = IX + INCX - IY = IY + INCY - 70 CONTINUE - Y(JY) = Y(JY) - ALPHA*TEMP2 - JX = JX + INCX - JY = JY + INCY - 80 CONTINUE - END IF - ELSE -C -C Form y when A is stored in lower triangle. -C - IF ( ( INCX.EQ.1 ) .AND. ( INCY.EQ.1 ) )THEN - DO 100 J = 1, N - 1 - TEMP1 = ALPHA*X(J) - TEMP2 = ZERO - DO 90 I = J + 1, N - Y(I) = Y(I) + TEMP1*A(I,J) - TEMP2 = TEMP2 + A(I,J)*X(I) - 90 CONTINUE - Y(J) = Y(J) - ALPHA*TEMP2 - 100 CONTINUE - ELSE - JX = KX - JY = KY - DO 120 J = 1, N - 1 - TEMP1 = ALPHA*X(JX) - TEMP2 = ZERO - IX = JX - IY = JY - DO 110 I = J + 1, N - IX = IX + INCX - IY = IY + INCY - Y(IY ) = Y(IY) + TEMP1*A(I,J) - TEMP2 = TEMP2 + A(I,J)*X(IX) - 110 CONTINUE - Y(JY) = Y(JY) - ALPHA*TEMP2 - JX = JX + INCX - JY = JY + INCY - 120 CONTINUE - END IF - END IF -C *** Last line of MB01MD *** - END diff --git a/mex/sources/libslicot/MB01ND.f b/mex/sources/libslicot/MB01ND.f deleted file mode 100644 index 036facf71..000000000 --- a/mex/sources/libslicot/MB01ND.f +++ /dev/null @@ -1,249 +0,0 @@ - SUBROUTINE MB01ND( UPLO, N, ALPHA, X, INCX, Y, INCY, A, LDA ) -C -C SLICOT RELEASE 5.0. -C -C Copyright (c) 2002-2009 NICONET e.V. -C -C This program is free software: you can redistribute it and/or -C modify it under the terms of the GNU General Public License as -C published by the Free Software Foundation, either version 2 of -C the License, or (at your option) any later version. -C -C This program is distributed in the hope that it will be useful, -C but WITHOUT ANY WARRANTY; without even the implied warranty of -C MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the -C GNU General Public License for more details. -C -C You should have received a copy of the GNU General Public License -C along with this program. If not, see -C . -C -C PURPOSE -C -C To perform the skew-symmetric rank 2 operation -C -C A := alpha*x*y' - alpha*y*x' + A, -C -C where alpha is a scalar, x and y are vectors of length n and A is -C an n-by-n skew-symmetric matrix. -C -C This is a modified version of the vanilla implemented BLAS -C routine DSYR2 written by Jack Dongarra, Jeremy Du Croz, -C Sven Hammarling, and Richard Hanson. -C -C ARGUMENTS -C -C Mode Parameters -C -C UPLO CHARACTER*1 -C Specifies whether the upper or lower triangular part of -C the array A is to be referenced as follows: -C = 'U': only the strictly upper triangular part of A is to -C be referenced; -C = 'L': only the strictly lower triangular part of A is to -C be referenced. -C -C Input/Output Parameters -C -C N (input) INTEGER -C The order of the matrix A. N >= 0. -C -C ALPHA (input) DOUBLE PRECISION -C The scalar alpha. If alpha is zero X and Y are not -C referenced. -C -C X (input) DOUBLE PRECISION array, dimension -C ( 1 + ( N - 1 )*abs( INCX ) ). -C On entry, elements 1, INCX+1, .., ( N - 1 )*INCX + 1 of -C this array must contain the elements of the vector X. -C -C INCX (input) INTEGER -C The increment for the elements of X. IF INCX < 0 then the -C elements of X are accessed in reversed order. INCX <> 0. -C -C Y (input) DOUBLE PRECISION array, dimension -C ( 1 + ( N - 1 )*abs( INCY ) ). -C On entry, elements 1, INCY+1, .., ( N - 1 )*INCY + 1 of -C this array must contain the elements of the vector Y. -C -C INCY (input) INTEGER -C The increment for the elements of Y. IF INCY < 0 then the -C elements of Y are accessed in reversed order. INCY <> 0. -C -C A (input/output) DOUBLE PRECISION array, dimension (LDA,N) -C On entry with UPLO = 'U', the leading N-by-N part of this -C array must contain the strictly upper triangular part of -C the matrix A. The lower triangular part of this array is -C not referenced. -C On entry with UPLO = 'L', the leading N-by-N part of this -C array must contain the strictly lower triangular part of -C the matrix A. The upper triangular part of this array is -C not referenced. -C On exit with UPLO = 'U', the leading N-by-N part of this -C array contains the strictly upper triangular part of the -C updated matrix A. -C On exit with UPLO = 'L', the leading N-by-N part of this -C array contains the strictly lower triangular part of the -C updated matrix A. -C -C LDA INTEGER -C The leading dimension of the array A. LDA >= MAX(1,N) -C -C NUMERICAL ASPECTS -C -C Though being almost identical with the vanilla implementation -C of the BLAS routine DSYR2 the performance of this routine could -C be significantly lower in the case of vendor supplied, highly -C optimized BLAS. -C -C CONTRIBUTORS -C -C D. Kressner, Technical Univ. Berlin, Germany, and -C P. Benner, Technical Univ. Chemnitz, Germany, December 2003. -C -C REVISIONS -C -C V. Sima, May 2008 (SLICOT version of the HAPACK routine DSKR2). -C -C KEYWORDS -C -C Elementary matrix operations. -C -C ****************************************************************** -C -C .. Parameters .. - DOUBLE PRECISION ZERO - PARAMETER ( ZERO = 0.0D+0 ) -C .. Scalar Arguments .. - DOUBLE PRECISION ALPHA - INTEGER INCX, INCY, LDA, N - CHARACTER UPLO -C .. Array Arguments .. - DOUBLE PRECISION A( LDA, * ), X( * ), Y( * ) -C .. Local Scalars .. - DOUBLE PRECISION TEMP1, TEMP2 - INTEGER I, INFO, IX, IY, J, JX, JY, KX, KY -C .. External Functions .. - LOGICAL LSAME - EXTERNAL LSAME -C .. External Subroutines .. - EXTERNAL XERBLA -C .. Intrinsic Functions .. - INTRINSIC MAX -C -C .. Executable Statements .. -C -C Test the input parameters. -C - INFO = 0 - IF ( .NOT.LSAME( UPLO, 'U' ).AND. - $ .NOT.LSAME( UPLO, 'L' ) )THEN - INFO = 1 - ELSE IF ( N.LT.0 )THEN - INFO = 2 - ELSE IF ( INCX.EQ.0 )THEN - INFO = 5 - ELSE IF ( INCY.EQ.0 )THEN - INFO = 7 - ELSE IF ( LDA.LT.MAX( 1, N ) )THEN - INFO = 9 - END IF -C - IF ( INFO.NE.0 )THEN - CALL XERBLA( 'MB01ND', INFO ) - RETURN - END IF -C -C Quick return if possible. -C - IF ( ( N.EQ.0 ).OR.( ALPHA.EQ.ZERO ) ) - $ RETURN -C -C Set up the start points in X and Y if the increments are not both -C unity. -C - IF ( ( INCX.NE.1 ).OR.( INCY.NE.1 ) )THEN - IF ( INCX.GT.0 )THEN - KX = 1 - ELSE - KX = 1 - ( N - 1 )*INCX - END IF - IF ( INCY.GT.0 )THEN - KY = 1 - ELSE - KY = 1 - ( N - 1 )*INCY - END IF - JX = KX - JY = KY - END IF -C -C Start the operations. In this version the elements of A are -C accessed sequentially with one pass through the triangular part -C of A. -C - IF ( LSAME( UPLO, 'U' ) )THEN -C -C Form A when A is stored in the upper triangle. -C - IF ( ( INCX.EQ.1 ).AND.( INCY.EQ.1 ) )THEN - DO 20 J = 2, N - IF ( ( X(J).NE.ZERO ).OR.( Y(J).NE.ZERO ) )THEN - TEMP1 = ALPHA*Y(J) - TEMP2 = ALPHA*X(J) - DO 10 I = 1, J-1 - A(I,J) = A(I,J) + X(I)*TEMP1 - Y(I)*TEMP2 - 10 CONTINUE - END IF - 20 CONTINUE - ELSE - DO 40 J = 2, N - IF ( ( X(JX).NE.ZERO ).OR.( Y(JY).NE.ZERO ) )THEN - TEMP1 = ALPHA*Y(JY) - TEMP2 = ALPHA*X(JX) - IX = KX - IY = KY - DO 30 I = 1, J-1 - A(I,J) = A(I,J) + X(IX)*TEMP1 - Y(IY)*TEMP2 - IX = IX + INCX - IY = IY + INCY - 30 CONTINUE - END IF - JX = JX + INCX - JY = JY + INCY - 40 CONTINUE - END IF - ELSE -C -C Form A when A is stored in the lower triangle. -C - IF ( ( INCX.EQ.1 ).AND.( INCY.EQ.1 ) )THEN - DO 60 J = 1, N-1 - IF ( ( X(J).NE.ZERO ).OR.( Y(J).NE.ZERO ) )THEN - TEMP1 = ALPHA*Y(J) - TEMP2 = ALPHA*X(J) - DO 50 I = J+1, N - A(I,J) = A(I,J) + X(I)*TEMP1 - Y(I)*TEMP2 - 50 CONTINUE - END IF - 60 CONTINUE - ELSE - DO 80 J = 1, N-1 - IF ( ( X(JX).NE.ZERO ).OR.( Y(JY).NE.ZERO ) )THEN - TEMP1 = ALPHA*Y(JY) - TEMP2 = ALPHA*X(JX) - IX = JX - IY = JY - DO 70 I = J+1, N - A(I,J) = A(I,J) + X(IX)*TEMP1 - Y(IY)*TEMP2 - IX = IX + INCX - IY = IY + INCY - 70 CONTINUE - END IF - JX = JX + INCX - JY = JY + INCY - 80 CONTINUE - END IF - END IF - RETURN -C *** Last line of MB01ND *** - END diff --git a/mex/sources/libslicot/MB01PD.f b/mex/sources/libslicot/MB01PD.f deleted file mode 100644 index 1845ab8a8..000000000 --- a/mex/sources/libslicot/MB01PD.f +++ /dev/null @@ -1,271 +0,0 @@ - SUBROUTINE MB01PD( SCUN, TYPE, M, N, KL, KU, ANRM, NBL, NROWS, A, - $ LDA, INFO ) -C -C SLICOT RELEASE 5.0. -C -C Copyright (c) 2002-2009 NICONET e.V. -C -C This program is free software: you can redistribute it and/or -C modify it under the terms of the GNU General Public License as -C published by the Free Software Foundation, either version 2 of -C the License, or (at your option) any later version. -C -C This program is distributed in the hope that it will be useful, -C but WITHOUT ANY WARRANTY; without even the implied warranty of -C MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the -C GNU General Public License for more details. -C -C You should have received a copy of the GNU General Public License -C along with this program. If not, see -C . -C -C PURPOSE -C -C To scale a matrix or undo scaling. Scaling is performed, if -C necessary, so that the matrix norm will be in a safe range of -C representable numbers. -C -C ARGUMENTS -C -C Mode Parameters -C -C SCUN CHARACTER*1 -C SCUN indicates the operation to be performed. -C = 'S': scale the matrix. -C = 'U': undo scaling of the matrix. -C -C TYPE CHARACTER*1 -C TYPE indicates the storage type of the input matrix. -C = 'G': A is a full matrix. -C = 'L': A is a (block) lower triangular matrix. -C = 'U': A is an (block) upper triangular matrix. -C = 'H': A is an (block) upper Hessenberg matrix. -C = 'B': A is a symmetric band matrix with lower bandwidth -C KL and upper bandwidth KU and with the only the -C lower half stored. -C = 'Q': A is a symmetric band matrix with lower bandwidth -C KL and upper bandwidth KU and with the only the -C upper half stored. -C = 'Z': A is a band matrix with lower bandwidth KL and -C upper bandwidth KU. -C -C Input/Output Parameters -C -C M (input) INTEGER -C The number of rows of the matrix A. M >= 0. -C -C N (input) INTEGER -C The number of columns of the matrix A. N >= 0. -C -C KL (input) INTEGER -C The lower bandwidth of A. Referenced only if TYPE = 'B', -C 'Q' or 'Z'. -C -C KU (input) INTEGER -C The upper bandwidth of A. Referenced only if TYPE = 'B', -C 'Q' or 'Z'. -C -C ANRM (input) DOUBLE PRECISION -C The norm of the initial matrix A. ANRM >= 0. -C When ANRM = 0 then an immediate return is effected. -C ANRM should be preserved between the call of the routine -C with SCUN = 'S' and the corresponding one with SCUN = 'U'. -C -C NBL (input) INTEGER -C The number of diagonal blocks of the matrix A, if it has a -C block structure. To specify that matrix A has no block -C structure, set NBL = 0. NBL >= 0. -C -C NROWS (input) INTEGER array, dimension max(1,NBL) -C NROWS(i) contains the number of rows and columns of the -C i-th diagonal block of matrix A. The sum of the values -C NROWS(i), for i = 1: NBL, should be equal to min(M,N). -C The elements of the array NROWS are not referenced if -C NBL = 0. -C -C A (input/output) DOUBLE PRECISION array, dimension (LDA,N) -C On entry, the leading M by N part of this array must -C contain the matrix to be scaled/unscaled. -C On exit, the leading M by N part of A will contain -C the modified matrix. -C The storage mode of A is specified by TYPE. -C -C LDA (input) INTEGER -C The leading dimension of the array A. LDA >= max(1,M). -C -C Error Indicator -C -C INFO (output) INTEGER -C = 0: successful exit -C < 0: if INFO = -i, the i-th argument had an illegal -C value. -C -C METHOD -C -C Denote by ANRM the norm of the matrix, and by SMLNUM and BIGNUM, -C two positive numbers near the smallest and largest safely -C representable numbers, respectively. The matrix is scaled, if -C needed, such that the norm of the result is in the range -C [SMLNUM, BIGNUM]. The scaling factor is represented as a ratio -C of two numbers, one of them being ANRM, and the other one either -C SMLNUM or BIGNUM, depending on ANRM being less than SMLNUM or -C larger than BIGNUM, respectively. For undoing the scaling, the -C norm is again compared with SMLNUM or BIGNUM, and the reciprocal -C of the previous scaling factor is used. -C -C CONTRIBUTOR -C -C V. Sima, Katholieke Univ. Leuven, Belgium, Nov. 1996. -C -C REVISIONS -C -C Oct. 2001, V. Sima, Research Institute for Informatics, Bucharest. -C -C ****************************************************************** -C -C .. Parameters .. - DOUBLE PRECISION ZERO, ONE - PARAMETER ( ZERO = 0.0D0, ONE = 1.0D0 ) -C .. Scalar Arguments .. - CHARACTER SCUN, TYPE - INTEGER INFO, KL, KU, LDA, M, MN, N, NBL - DOUBLE PRECISION ANRM -C .. Array Arguments .. - INTEGER NROWS ( * ) - DOUBLE PRECISION A( LDA, * ) -C .. Local Scalars .. - LOGICAL FIRST, LSCALE - INTEGER I, ISUM, ITYPE - DOUBLE PRECISION BIGNUM, SMLNUM -C .. External Functions .. - LOGICAL LSAME - DOUBLE PRECISION DLAMCH - EXTERNAL DLAMCH, LSAME -C .. -C .. External Subroutines .. - EXTERNAL DLABAD, MB01QD, XERBLA -C .. Intrinsic Functions .. - INTRINSIC MAX, MIN -C .. Save statement .. - SAVE BIGNUM, FIRST, SMLNUM -C .. Data statements .. - DATA FIRST/.TRUE./ -C .. -C .. Executable Statements .. -C -C Test the input scalar arguments. -C - INFO = 0 - LSCALE = LSAME( SCUN, 'S' ) - IF( LSAME( TYPE, 'G' ) ) THEN - ITYPE = 0 - ELSE IF( LSAME( TYPE, 'L' ) ) THEN - ITYPE = 1 - ELSE IF( LSAME( TYPE, 'U' ) ) THEN - ITYPE = 2 - ELSE IF( LSAME( TYPE, 'H' ) ) THEN - ITYPE = 3 - ELSE IF( LSAME( TYPE, 'B' ) ) THEN - ITYPE = 4 - ELSE IF( LSAME( TYPE, 'Q' ) ) THEN - ITYPE = 5 - ELSE IF( LSAME( TYPE, 'Z' ) ) THEN - ITYPE = 6 - ELSE - ITYPE = -1 - END IF -C - MN = MIN( M, N ) -C - ISUM = 0 - IF( NBL.GT.0 ) THEN - DO 10 I = 1, NBL - ISUM = ISUM + NROWS(I) - 10 CONTINUE - END IF -C - IF( .NOT.LSCALE .AND. .NOT.LSAME( SCUN, 'U' ) ) THEN - INFO = -1 - ELSE IF( ITYPE.EQ.-1 ) THEN - INFO = -2 - ELSE IF( M.LT.0 ) THEN - INFO = -3 - ELSE IF( N.LT.0 .OR. - $ ( ( ITYPE.EQ.4 .OR. ITYPE.EQ.5 ) .AND. N.NE.M ) ) THEN - INFO = -4 - ELSE IF( ANRM.LT.ZERO ) THEN - INFO = -7 - ELSE IF( NBL.LT.0 ) THEN - INFO = -8 - ELSE IF( NBL.GT.0 .AND. ISUM.NE.MN ) THEN - INFO = -9 - ELSE IF( ITYPE.LE.3 .AND. LDA.LT.MAX( 1, M ) ) THEN - INFO = -11 - ELSE IF( ITYPE.GE.4 ) THEN - IF( KL.LT.0 .OR. KL.GT.MAX( M-1, 0 ) ) THEN - INFO = -5 - ELSE IF( KU.LT.0 .OR. KU.GT.MAX( N-1, 0 ) .OR. - $ ( ( ITYPE.EQ.4 .OR. ITYPE.EQ.5 ) .AND. KL.NE.KU ) ) - $ THEN - INFO = -6 - ELSE IF( ( ITYPE.EQ.4 .AND. LDA.LT.KL+1 ) .OR. - $ ( ITYPE.EQ.5 .AND. LDA.LT.KU+1 ) .OR. - $ ( ITYPE.EQ.6 .AND. LDA.LT.2*KL+KU+1 ) ) THEN - INFO = -11 - END IF - END IF -C - IF( INFO.NE.0 ) THEN - CALL XERBLA( 'MB01PD', -INFO ) - RETURN - END IF -C -C Quick return if possible. -C - IF( MN.EQ.0 .OR. ANRM.EQ.ZERO ) - $ RETURN -C - IF ( FIRST ) THEN -C -C Get machine parameters. -C - SMLNUM = DLAMCH( 'S' ) / DLAMCH( 'P' ) - BIGNUM = ONE / SMLNUM - CALL DLABAD( SMLNUM, BIGNUM ) - FIRST = .FALSE. - END IF -C - IF ( LSCALE ) THEN -C -C Scale A, if its norm is outside range [SMLNUM,BIGNUM]. -C - IF( ANRM.LT.SMLNUM ) THEN -C -C Scale matrix norm up to SMLNUM. -C - CALL MB01QD( TYPE, M, N, KL, KU, ANRM, SMLNUM, NBL, NROWS, - $ A, LDA, INFO ) - ELSE IF( ANRM.GT.BIGNUM ) THEN -C -C Scale matrix norm down to BIGNUM. -C - CALL MB01QD( TYPE, M, N, KL, KU, ANRM, BIGNUM, NBL, NROWS, - $ A, LDA, INFO ) - END IF -C - ELSE -C -C Undo scaling. -C - IF( ANRM.LT.SMLNUM ) THEN - CALL MB01QD( TYPE, M, N, KL, KU, SMLNUM, ANRM, NBL, NROWS, - $ A, LDA, INFO ) - ELSE IF( ANRM.GT.BIGNUM ) THEN - CALL MB01QD( TYPE, M, N, KL, KU, BIGNUM, ANRM, NBL, NROWS, - $ A, LDA, INFO ) - END IF - END IF -C - RETURN -C *** Last line of MB01PD *** - END diff --git a/mex/sources/libslicot/MB01QD.f b/mex/sources/libslicot/MB01QD.f deleted file mode 100644 index 61befc51a..000000000 --- a/mex/sources/libslicot/MB01QD.f +++ /dev/null @@ -1,334 +0,0 @@ - SUBROUTINE MB01QD( TYPE, M, N, KL, KU, CFROM, CTO, NBL, NROWS, A, - $ LDA, INFO ) -C -C SLICOT RELEASE 5.0. -C -C Copyright (c) 2002-2009 NICONET e.V. -C -C This program is free software: you can redistribute it and/or -C modify it under the terms of the GNU General Public License as -C published by the Free Software Foundation, either version 2 of -C the License, or (at your option) any later version. -C -C This program is distributed in the hope that it will be useful, -C but WITHOUT ANY WARRANTY; without even the implied warranty of -C MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the -C GNU General Public License for more details. -C -C You should have received a copy of the GNU General Public License -C along with this program. If not, see -C . -C -C PURPOSE -C -C To multiply the M by N real matrix A by the real scalar CTO/CFROM. -C This is done without over/underflow as long as the final result -C CTO*A(I,J)/CFROM does not over/underflow. TYPE specifies that -C A may be full, (block) upper triangular, (block) lower triangular, -C (block) upper Hessenberg, or banded. -C -C ARGUMENTS -C -C Mode Parameters -C -C TYPE CHARACTER*1 -C TYPE indices the storage type of the input matrix. -C = 'G': A is a full matrix. -C = 'L': A is a (block) lower triangular matrix. -C = 'U': A is a (block) upper triangular matrix. -C = 'H': A is a (block) upper Hessenberg matrix. -C = 'B': A is a symmetric band matrix with lower bandwidth -C KL and upper bandwidth KU and with the only the -C lower half stored. -C = 'Q': A is a symmetric band matrix with lower bandwidth -C KL and upper bandwidth KU and with the only the -C upper half stored. -C = 'Z': A is a band matrix with lower bandwidth KL and -C upper bandwidth KU. -C -C Input/Output Parameters -C -C M (input) INTEGER -C The number of rows of the matrix A. M >= 0. -C -C N (input) INTEGER -C The number of columns of the matrix A. N >= 0. -C -C KL (input) INTEGER -C The lower bandwidth of A. Referenced only if TYPE = 'B', -C 'Q' or 'Z'. -C -C KU (input) INTEGER -C The upper bandwidth of A. Referenced only if TYPE = 'B', -C 'Q' or 'Z'. -C -C CFROM (input) DOUBLE PRECISION -C CTO (input) DOUBLE PRECISION -C The matrix A is multiplied by CTO/CFROM. A(I,J) is -C computed without over/underflow if the final result -C CTO*A(I,J)/CFROM can be represented without over/ -C underflow. CFROM must be nonzero. -C -C NBL (input) INTEGER -C The number of diagonal blocks of the matrix A, if it has a -C block structure. To specify that matrix A has no block -C structure, set NBL = 0. NBL >= 0. -C -C NROWS (input) INTEGER array, dimension max(1,NBL) -C NROWS(i) contains the number of rows and columns of the -C i-th diagonal block of matrix A. The sum of the values -C NROWS(i), for i = 1: NBL, should be equal to min(M,N). -C The array NROWS is not referenced if NBL = 0. -C -C A (input/output) DOUBLE PRECISION array, dimension (LDA,N) -C The matrix to be multiplied by CTO/CFROM. See TYPE for -C the storage type. -C -C LDA (input) INTEGER -C The leading dimension of the array A. LDA >= max(1,M). -C -C Error Indicator -C -C INFO INTEGER -C Not used in this implementation. -C -C METHOD -C -C Matrix A is multiplied by the real scalar CTO/CFROM, taking into -C account the specified storage mode of the matrix. -C MB01QD is a version of the LAPACK routine DLASCL, modified for -C dealing with block triangular, or block Hessenberg matrices. -C For efficiency, no tests of the input scalar parameters are -C performed. -C -C CONTRIBUTOR -C -C V. Sima, Katholieke Univ. Leuven, Belgium, Nov. 1996. -C -C ****************************************************************** -C -C .. Parameters .. - DOUBLE PRECISION ZERO, ONE - PARAMETER ( ZERO = 0.0D0, ONE = 1.0D0 ) -C .. -C .. Scalar Arguments .. - CHARACTER TYPE - INTEGER INFO, KL, KU, LDA, M, N, NBL - DOUBLE PRECISION CFROM, CTO -C .. -C .. Array Arguments .. - INTEGER NROWS ( * ) - DOUBLE PRECISION A( LDA, * ) -C .. -C .. Local Scalars .. - LOGICAL DONE, NOBLC - INTEGER I, IFIN, ITYPE, J, JFIN, JINI, K, K1, K2, K3, - $ K4 - DOUBLE PRECISION BIGNUM, CFROM1, CFROMC, CTO1, CTOC, MUL, SMLNUM -C .. -C .. External Functions .. - LOGICAL LSAME - DOUBLE PRECISION DLAMCH - EXTERNAL LSAME, DLAMCH -C .. -C .. Intrinsic Functions .. - INTRINSIC ABS, MAX, MIN -C .. -C .. Executable Statements .. -C - IF( LSAME( TYPE, 'G' ) ) THEN - ITYPE = 0 - ELSE IF( LSAME( TYPE, 'L' ) ) THEN - ITYPE = 1 - ELSE IF( LSAME( TYPE, 'U' ) ) THEN - ITYPE = 2 - ELSE IF( LSAME( TYPE, 'H' ) ) THEN - ITYPE = 3 - ELSE IF( LSAME( TYPE, 'B' ) ) THEN - ITYPE = 4 - ELSE IF( LSAME( TYPE, 'Q' ) ) THEN - ITYPE = 5 - ELSE - ITYPE = 6 - END IF -C -C Quick return if possible. -C - IF( MIN( M, N ).EQ.0 ) - $ RETURN -C -C Get machine parameters. -C - SMLNUM = DLAMCH( 'S' ) - BIGNUM = ONE / SMLNUM -C - CFROMC = CFROM - CTOC = CTO -C - 10 CONTINUE - CFROM1 = CFROMC*SMLNUM - CTO1 = CTOC / BIGNUM - IF( ABS( CFROM1 ).GT.ABS( CTOC ) .AND. CTOC.NE.ZERO ) THEN - MUL = SMLNUM - DONE = .FALSE. - CFROMC = CFROM1 - ELSE IF( ABS( CTO1 ).GT.ABS( CFROMC ) ) THEN - MUL = BIGNUM - DONE = .FALSE. - CTOC = CTO1 - ELSE - MUL = CTOC / CFROMC - DONE = .TRUE. - END IF -C - NOBLC = NBL.EQ.0 -C - IF( ITYPE.EQ.0 ) THEN -C -C Full matrix -C - DO 30 J = 1, N - DO 20 I = 1, M - A( I, J ) = A( I, J )*MUL - 20 CONTINUE - 30 CONTINUE -C - ELSE IF( ITYPE.EQ.1 ) THEN -C - IF ( NOBLC ) THEN -C -C Lower triangular matrix -C - DO 50 J = 1, N - DO 40 I = J, M - A( I, J ) = A( I, J )*MUL - 40 CONTINUE - 50 CONTINUE -C - ELSE -C -C Block lower triangular matrix -C - JFIN = 0 - DO 80 K = 1, NBL - JINI = JFIN + 1 - JFIN = JFIN + NROWS( K ) - DO 70 J = JINI, JFIN - DO 60 I = JINI, M - A( I, J ) = A( I, J )*MUL - 60 CONTINUE - 70 CONTINUE - 80 CONTINUE - END IF -C - ELSE IF( ITYPE.EQ.2 ) THEN -C - IF ( NOBLC ) THEN -C -C Upper triangular matrix -C - DO 100 J = 1, N - DO 90 I = 1, MIN( J, M ) - A( I, J ) = A( I, J )*MUL - 90 CONTINUE - 100 CONTINUE -C - ELSE -C -C Block upper triangular matrix -C - JFIN = 0 - DO 130 K = 1, NBL - JINI = JFIN + 1 - JFIN = JFIN + NROWS( K ) - IF ( K.EQ.NBL ) JFIN = N - DO 120 J = JINI, JFIN - DO 110 I = 1, MIN( JFIN, M ) - A( I, J ) = A( I, J )*MUL - 110 CONTINUE - 120 CONTINUE - 130 CONTINUE - END IF -C - ELSE IF( ITYPE.EQ.3 ) THEN -C - IF ( NOBLC ) THEN -C -C Upper Hessenberg matrix -C - DO 150 J = 1, N - DO 140 I = 1, MIN( J+1, M ) - A( I, J ) = A( I, J )*MUL - 140 CONTINUE - 150 CONTINUE -C - ELSE -C -C Block upper Hessenberg matrix -C - JFIN = 0 - DO 180 K = 1, NBL - JINI = JFIN + 1 - JFIN = JFIN + NROWS( K ) -C - IF ( K.EQ.NBL ) THEN - JFIN = N - IFIN = N - ELSE - IFIN = JFIN + NROWS( K+1 ) - END IF -C - DO 170 J = JINI, JFIN - DO 160 I = 1, MIN( IFIN, M ) - A( I, J ) = A( I, J )*MUL - 160 CONTINUE - 170 CONTINUE - 180 CONTINUE - END IF -C - ELSE IF( ITYPE.EQ.4 ) THEN -C -C Lower half of a symmetric band matrix -C - K3 = KL + 1 - K4 = N + 1 - DO 200 J = 1, N - DO 190 I = 1, MIN( K3, K4-J ) - A( I, J ) = A( I, J )*MUL - 190 CONTINUE - 200 CONTINUE -C - ELSE IF( ITYPE.EQ.5 ) THEN -C -C Upper half of a symmetric band matrix -C - K1 = KU + 2 - K3 = KU + 1 - DO 220 J = 1, N - DO 210 I = MAX( K1-J, 1 ), K3 - A( I, J ) = A( I, J )*MUL - 210 CONTINUE - 220 CONTINUE -C - ELSE IF( ITYPE.EQ.6 ) THEN -C -C Band matrix -C - K1 = KL + KU + 2 - K2 = KL + 1 - K3 = 2*KL + KU + 1 - K4 = KL + KU + 1 + M - DO 240 J = 1, N - DO 230 I = MAX( K1-J, K2 ), MIN( K3, K4-J ) - A( I, J ) = A( I, J )*MUL - 230 CONTINUE - 240 CONTINUE -C - END IF -C - IF( .NOT.DONE ) - $ GO TO 10 -C - RETURN -C *** Last line of MB01QD *** - END diff --git a/mex/sources/libslicot/MB01RD.f b/mex/sources/libslicot/MB01RD.f deleted file mode 100644 index 2c53070de..000000000 --- a/mex/sources/libslicot/MB01RD.f +++ /dev/null @@ -1,345 +0,0 @@ - SUBROUTINE MB01RD( UPLO, TRANS, M, N, ALPHA, BETA, R, LDR, A, LDA, - $ X, LDX, DWORK, LDWORK, INFO ) -C -C SLICOT RELEASE 5.0. -C -C Copyright (c) 2002-2009 NICONET e.V. -C -C This program is free software: you can redistribute it and/or -C modify it under the terms of the GNU General Public License as -C published by the Free Software Foundation, either version 2 of -C the License, or (at your option) any later version. -C -C This program is distributed in the hope that it will be useful, -C but WITHOUT ANY WARRANTY; without even the implied warranty of -C MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the -C GNU General Public License for more details. -C -C You should have received a copy of the GNU General Public License -C along with this program. If not, see -C . -C -C PURPOSE -C -C To compute the matrix formula -C _ -C R = alpha*R + beta*op( A )*X*op( A )', -C _ -C where alpha and beta are scalars, R, X, and R are symmetric -C matrices, A is a general matrix, and op( A ) is one of -C -C op( A ) = A or op( A ) = A'. -C -C The result is overwritten on R. -C -C ARGUMENTS -C -C Mode Parameters -C -C UPLO CHARACTER*1 _ -C Specifies which triangles of the symmetric matrices R, R, -C and X are given as follows: -C = 'U': the upper triangular part is given; -C = 'L': the lower triangular part is given. -C -C TRANS CHARACTER*1 -C Specifies the form of op( A ) to be used in the matrix -C multiplication as follows: -C = 'N': op( A ) = A; -C = 'T': op( A ) = A'; -C = 'C': op( A ) = A'. -C -C Input/Output Parameters -C -C M (input) INTEGER _ -C The order of the matrices R and R and the number of rows -C of the matrix op( A ). M >= 0. -C -C N (input) INTEGER -C The order of the matrix X and the number of columns of the -C the matrix op( A ). N >= 0. -C -C ALPHA (input) DOUBLE PRECISION -C The scalar alpha. When alpha is zero then R need not be -C set before entry, except when R is identified with X in -C the call (which is possible only in this case). -C -C BETA (input) DOUBLE PRECISION -C The scalar beta. When beta is zero then A and X are not -C referenced. -C -C R (input/output) DOUBLE PRECISION array, dimension (LDR,M) -C On entry with UPLO = 'U', the leading M-by-M upper -C triangular part of this array must contain the upper -C triangular part of the symmetric matrix R; the strictly -C lower triangular part of the array is used as workspace. -C On entry with UPLO = 'L', the leading M-by-M lower -C triangular part of this array must contain the lower -C triangular part of the symmetric matrix R; the strictly -C upper triangular part of the array is used as workspace. -C On exit, the leading M-by-M upper triangular part (if -C UPLO = 'U'), or lower triangular part (if UPLO = 'L'), of -C this array contains the corresponding triangular part of -C _ -C the computed matrix R. If beta <> 0, the remaining -C strictly triangular part of this array contains the -C corresponding part of the matrix expression -C beta*op( A )*T*op( A )', where T is the triangular matrix -C defined in the Method section. -C -C LDR INTEGER -C The leading dimension of array R. LDR >= MAX(1,M). -C -C A (input) DOUBLE PRECISION array, dimension (LDA,k) -C where k is N when TRANS = 'N' and is M when TRANS = 'T' or -C TRANS = 'C'. -C On entry with TRANS = 'N', the leading M-by-N part of this -C array must contain the matrix A. -C On entry with TRANS = 'T' or TRANS = 'C', the leading -C N-by-M part of this array must contain the matrix A. -C -C LDA INTEGER -C The leading dimension of array A. LDA >= MAX(1,l), -C where l is M when TRANS = 'N' and is N when TRANS = 'T' or -C TRANS = 'C'. -C -C X (input/output) DOUBLE PRECISION array, dimension (LDX,N) -C On entry, if UPLO = 'U', the leading N-by-N upper -C triangular part of this array must contain the upper -C triangular part of the symmetric matrix X and the strictly -C lower triangular part of the array is not referenced. -C On entry, if UPLO = 'L', the leading N-by-N lower -C triangular part of this array must contain the lower -C triangular part of the symmetric matrix X and the strictly -C upper triangular part of the array is not referenced. -C On exit, each diagonal element of this array has half its -C input value, but the other elements are not modified. -C -C LDX INTEGER -C The leading dimension of array X. LDX >= MAX(1,N). -C -C Workspace -C -C DWORK DOUBLE PRECISION array, dimension (LDWORK) -C On exit, if INFO = 0, the leading M-by-N part of this -C array (with the leading dimension MAX(1,M)) returns the -C matrix product beta*op( A )*T, where T is the triangular -C matrix defined in the Method section. -C This array is not referenced when beta = 0. -C -C LDWORK The length of the array DWORK. -C LDWORK >= MAX(1,M*N), if beta <> 0; -C LDWORK >= 1, if beta = 0. -C -C Error Indicator -C -C INFO INTEGER -C = 0: successful exit; -C < 0: if INFO = -k, the k-th argument had an illegal -C value. -C -C METHOD -C -C The matrix expression is efficiently evaluated taking the symmetry -C into account. Specifically, let X = T + T', with T an upper or -C lower triangular matrix, defined by -C -C T = triu( X ) - (1/2)*diag( X ), if UPLO = 'U', -C T = tril( X ) - (1/2)*diag( X ), if UPLO = 'L', -C -C where triu, tril, and diag denote the upper triangular part, lower -C triangular part, and diagonal part of X, respectively. Then, -C -C op( A )*X*op( A )' = B + B', -C -C where B := op( A )*T*op( A )'. Matrix B is not symmetric, but it -C can be written as tri( B ) + stri( B ), where tri denotes the -C triangular part specified by UPLO, and stri denotes the remaining -C strictly triangular part. Let R = V + V', with V defined as T -C above. Then, the required triangular part of the result can be -C written as -C -C alpha*V + beta*tri( B ) + beta*(stri( B ))' + -C alpha*diag( V ) + beta*diag( tri( B ) ). -C -C REFERENCES -C -C None. -C -C NUMERICAL ASPECTS -C -C The algorithm requires approximately -C -C 2 2 -C 3/2 x M x N + 1/2 x M -C -C operations. -C -C CONTRIBUTORS -C -C V. Sima, Katholieke Univ. Leuven, Belgium, Feb. 1997. -C -C REVISIONS -C -C V. Sima, Research Institute for Informatics, Bucharest, Mar. 2004, -C Apr. 2004. -C -C KEYWORDS -C -C Elementary matrix operations, matrix algebra, matrix operations. -C -C ****************************************************************** -C -C .. Parameters .. - DOUBLE PRECISION ZERO, ONE, HALF - PARAMETER ( ZERO = 0.0D0, ONE = 1.0D0, HALF = 0.5D0 ) -C .. Scalar Arguments .. - CHARACTER TRANS, UPLO - INTEGER INFO, LDA, LDR, LDWORK, LDX, M, N - DOUBLE PRECISION ALPHA, BETA -C .. Array Arguments .. - DOUBLE PRECISION A(LDA,*), DWORK(*), R(LDR,*), X(LDX,*) -C .. Local Scalars .. - CHARACTER*12 NTRAN - LOGICAL LTRANS, LUPLO - INTEGER J, JWORK, LDW, NROWA -C .. External Functions .. - LOGICAL LSAME - EXTERNAL LSAME -C .. External Subroutines .. - EXTERNAL DAXPY, DCOPY, DGEMM, DLACPY, DLASCL, DLASET, - $ DSCAL, DTRMM, XERBLA -C .. Intrinsic Functions .. - INTRINSIC MAX -C .. Executable Statements .. -C -C Test the input scalar arguments. -C - INFO = 0 - LUPLO = LSAME( UPLO, 'U' ) - LTRANS = LSAME( TRANS, 'T' ) .OR. LSAME( TRANS, 'C' ) -C - IF ( LTRANS ) THEN - NROWA = N - NTRAN = 'No transpose' - ELSE - NROWA = M - NTRAN = 'Transpose' - END IF -C - LDW = MAX( 1, M ) -C - IF( ( .NOT.LUPLO ).AND.( .NOT.LSAME( UPLO, 'L' ) ) )THEN - INFO = -1 - ELSE IF( ( .NOT.LTRANS ).AND.( .NOT.LSAME( TRANS, 'N' ) ) )THEN - INFO = -2 - ELSE IF( M.LT.0 ) THEN - INFO = -3 - ELSE IF( N.LT.0 ) THEN - INFO = -4 - ELSE IF( LDR.LT.LDW ) THEN - INFO = -8 - ELSE IF( LDA.LT.MAX( 1, NROWA ) ) THEN - INFO = -10 - ELSE IF( LDX.LT.MAX( 1, N ) ) THEN - INFO = -12 - ELSE IF( ( BETA.NE.ZERO .AND. LDWORK.LT.MAX( 1, M*N ) ) - $ .OR.( BETA.EQ.ZERO .AND. LDWORK.LT.1 ) ) THEN - INFO = -14 - END IF -C - IF ( INFO.NE.0 ) THEN -C -C Error return. -C - CALL XERBLA( 'MB01RD', -INFO ) - RETURN - END IF -C -C Quick return if possible. -C - CALL DSCAL( N, HALF, X, LDX+1 ) - IF ( M.EQ.0 ) - $ RETURN -C - IF ( BETA.EQ.ZERO .OR. N.EQ.0 ) THEN - IF ( ALPHA.EQ.ZERO ) THEN -C -C Special case alpha = 0. -C - CALL DLASET( UPLO, M, M, ZERO, ZERO, R, LDR ) - ELSE -C -C Special case beta = 0 or N = 0. -C - IF ( ALPHA.NE.ONE ) - $ CALL DLASCL( UPLO, 0, 0, ONE, ALPHA, M, M, R, LDR, INFO ) - END IF - RETURN - END IF -C -C General case: beta <> 0. Efficiently compute -C _ -C R = alpha*R + beta*op( A )*X*op( A )', -C -C as described in the Method section. -C -C Compute W = beta*op( A )*T in DWORK. -C Workspace: need M*N. -C -C (Note: Comments in the code beginning "Workspace:" describe the -C minimal amount of real workspace needed at that point in the -C code.) -C - IF( LTRANS ) THEN - JWORK = 1 -C - DO 10 J = 1, N - CALL DCOPY( M, A(J,1), LDA, DWORK(JWORK), 1 ) - JWORK = JWORK + LDW - 10 CONTINUE -C - ELSE - CALL DLACPY( 'Full', M, N, A, LDA, DWORK, LDW ) - END IF -C - CALL DTRMM( 'Right', UPLO, 'No transpose', 'Non-unit', M, N, BETA, - $ X, LDX, DWORK, LDW ) -C -C Compute Y = alpha*V + W*op( A )' in R. First, set to zero the -C strictly triangular part of R not specified by UPLO. That part -C will then contain beta*stri( B ). -C - IF ( ALPHA.NE.ZERO ) THEN - IF ( M.GT.1 ) THEN - IF ( LUPLO ) THEN - CALL DLASET( 'Lower', M-1, M-1, ZERO, ZERO, R(2,1), LDR ) - ELSE - CALL DLASET( 'Upper', M-1, M-1, ZERO, ZERO, R(1,2), LDR ) - END IF - END IF - CALL DSCAL( M, HALF, R, LDR+1 ) - END IF -C - CALL DGEMM( 'No transpose', NTRAN, M, M, N, ONE, DWORK, LDW, A, - $ LDA, ALPHA, R, LDR ) -C -C Add the term corresponding to B', with B = op( A )*T*op( A )'. -C - IF( LUPLO ) THEN -C - DO 20 J = 1, M - CALL DAXPY( J, ONE, R(J,1), LDR, R(1,J), 1 ) - 20 CONTINUE -C - ELSE -C - DO 30 J = 1, M - CALL DAXPY( J, ONE, R(1,J), 1, R(J,1), LDR ) - 30 CONTINUE -C - END IF -C - RETURN -C *** Last line of MB01RD *** - END diff --git a/mex/sources/libslicot/MB01RU.f b/mex/sources/libslicot/MB01RU.f deleted file mode 100644 index c22549cc7..000000000 --- a/mex/sources/libslicot/MB01RU.f +++ /dev/null @@ -1,282 +0,0 @@ - SUBROUTINE MB01RU( UPLO, TRANS, M, N, ALPHA, BETA, R, LDR, A, LDA, - $ X, LDX, DWORK, LDWORK, INFO ) -C -C SLICOT RELEASE 5.0. -C -C Copyright (c) 2002-2009 NICONET e.V. -C -C This program is free software: you can redistribute it and/or -C modify it under the terms of the GNU General Public License as -C published by the Free Software Foundation, either version 2 of -C the License, or (at your option) any later version. -C -C This program is distributed in the hope that it will be useful, -C but WITHOUT ANY WARRANTY; without even the implied warranty of -C MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the -C GNU General Public License for more details. -C -C You should have received a copy of the GNU General Public License -C along with this program. If not, see -C . -C -C PURPOSE -C -C To compute the matrix formula -C _ -C R = alpha*R + beta*op( A )*X*op( A )', -C _ -C where alpha and beta are scalars, R, X, and R are symmetric -C matrices, A is a general matrix, and op( A ) is one of -C -C op( A ) = A or op( A ) = A'. -C -C The result is overwritten on R. -C -C ARGUMENTS -C -C Mode Parameters -C -C UPLO CHARACTER*1 -C Specifies which triangles of the symmetric matrices R -C and X are given as follows: -C = 'U': the upper triangular part is given; -C = 'L': the lower triangular part is given. -C -C TRANS CHARACTER*1 -C Specifies the form of op( A ) to be used in the matrix -C multiplication as follows: -C = 'N': op( A ) = A; -C = 'T': op( A ) = A'; -C = 'C': op( A ) = A'. -C -C Input/Output Parameters -C -C M (input) INTEGER _ -C The order of the matrices R and R and the number of rows -C of the matrix op( A ). M >= 0. -C -C N (input) INTEGER -C The order of the matrix X and the number of columns of the -C the matrix op( A ). N >= 0. -C -C ALPHA (input) DOUBLE PRECISION -C The scalar alpha. When alpha is zero then R need not be -C set before entry, except when R is identified with X in -C the call. -C -C BETA (input) DOUBLE PRECISION -C The scalar beta. When beta is zero then A and X are not -C referenced. -C -C R (input/output) DOUBLE PRECISION array, dimension (LDR,M) -C On entry with UPLO = 'U', the leading M-by-M upper -C triangular part of this array must contain the upper -C triangular part of the symmetric matrix R. -C On entry with UPLO = 'L', the leading M-by-M lower -C triangular part of this array must contain the lower -C triangular part of the symmetric matrix R. -C On exit, the leading M-by-M upper triangular part (if -C UPLO = 'U'), or lower triangular part (if UPLO = 'L'), of -C this array contains the corresponding triangular part of -C _ -C the computed matrix R. -C -C LDR INTEGER -C The leading dimension of array R. LDR >= MAX(1,M). -C -C A (input) DOUBLE PRECISION array, dimension (LDA,k) -C where k is N when TRANS = 'N' and is M when TRANS = 'T' or -C TRANS = 'C'. -C On entry with TRANS = 'N', the leading M-by-N part of this -C array must contain the matrix A. -C On entry with TRANS = 'T' or TRANS = 'C', the leading -C N-by-M part of this array must contain the matrix A. -C -C LDA INTEGER -C The leading dimension of array A. LDA >= MAX(1,k), -C where k is M when TRANS = 'N' and is N when TRANS = 'T' or -C TRANS = 'C'. -C -C X (input) DOUBLE PRECISION array, dimension (LDX,N) -C On entry, if UPLO = 'U', the leading N-by-N upper -C triangular part of this array must contain the upper -C triangular part of the symmetric matrix X and the strictly -C lower triangular part of the array is not referenced. -C On entry, if UPLO = 'L', the leading N-by-N lower -C triangular part of this array must contain the lower -C triangular part of the symmetric matrix X and the strictly -C upper triangular part of the array is not referenced. -C The diagonal elements of this array are modified -C internally, but are restored on exit. -C -C LDX INTEGER -C The leading dimension of array X. LDX >= MAX(1,N). -C -C Workspace -C -C DWORK DOUBLE PRECISION array, dimension (LDWORK) -C This array is not referenced when beta = 0, or M*N = 0. -C -C LDWORK The length of the array DWORK. -C LDWORK >= M*N, if beta <> 0; -C LDWORK >= 0, if beta = 0. -C -C Error Indicator -C -C INFO INTEGER -C = 0: successful exit; -C < 0: if INFO = -k, the k-th argument had an illegal -C value. -C -C METHOD -C -C The matrix expression is efficiently evaluated taking the symmetry -C into account. Specifically, let X = T + T', with T an upper or -C lower triangular matrix, defined by -C -C T = triu( X ) - (1/2)*diag( X ), if UPLO = 'U', -C T = tril( X ) - (1/2)*diag( X ), if UPLO = 'L', -C -C where triu, tril, and diag denote the upper triangular part, lower -C triangular part, and diagonal part of X, respectively. Then, -C -C A*X*A' = ( A*T )*A' + A*( A*T )', for TRANS = 'N', -C A'*X*A = A'*( T*A ) + ( T*A )'*A, for TRANS = 'T', or 'C', -C -C which involve BLAS 3 operations (DTRMM and DSYR2K). -C -C NUMERICAL ASPECTS -C -C The algorithm requires approximately -C -C 2 2 -C 3/2 x M x N + 1/2 x M -C -C operations. -C -C FURTHER COMMENTS -C -C This is a simpler version for MB01RD. -C -C CONTRIBUTORS -C -C V. Sima, Katholieke Univ. Leuven, Belgium, Jan. 1999. -C -C REVISIONS -C -C A. Varga, German Aerospace Center, Oberpfaffenhofen, March 2004. -C V. Sima, Research Institute for Informatics, Bucharest, Mar. 2004. -C -C KEYWORDS -C -C Elementary matrix operations, matrix algebra, matrix operations. -C -C ****************************************************************** -C -C .. Parameters .. - DOUBLE PRECISION ZERO, ONE, TWO, HALF - PARAMETER ( ZERO = 0.0D0, ONE = 1.0D0, TWO = 2.0D0, - $ HALF = 0.5D0 ) -C .. Scalar Arguments .. - CHARACTER TRANS, UPLO - INTEGER INFO, LDA, LDR, LDWORK, LDX, M, N - DOUBLE PRECISION ALPHA, BETA -C .. Array Arguments .. - DOUBLE PRECISION A(LDA,*), DWORK(*), R(LDR,*), X(LDX,*) -C .. Local Scalars .. - LOGICAL LTRANS, LUPLO -C .. External Functions .. - LOGICAL LSAME - EXTERNAL LSAME -C .. External Subroutines .. - EXTERNAL DLACPY, DLASCL, DLASET, DSCAL, DSYR2K, DTRMM, - $ XERBLA -C .. Intrinsic Functions .. - INTRINSIC MAX -C .. Executable Statements .. -C -C Test the input scalar arguments. -C - INFO = 0 - LUPLO = LSAME( UPLO, 'U' ) - LTRANS = LSAME( TRANS, 'T' ) .OR. LSAME( TRANS, 'C' ) -C - IF( ( .NOT.LUPLO ).AND.( .NOT.LSAME( UPLO, 'L' ) ) )THEN - INFO = -1 - ELSE IF( ( .NOT.LTRANS ).AND.( .NOT.LSAME( TRANS, 'N' ) ) )THEN - INFO = -2 - ELSE IF( M.LT.0 ) THEN - INFO = -3 - ELSE IF( N.LT.0 ) THEN - INFO = -4 - ELSE IF( LDR.LT.MAX( 1, M ) ) THEN - INFO = -8 - ELSE IF( LDA.LT.1 .OR. ( LTRANS .AND. LDA.LT.N ) .OR. - $ ( .NOT.LTRANS .AND. LDA.LT.M ) ) THEN - INFO = -10 - ELSE IF( LDX.LT.MAX( 1, N ) ) THEN - INFO = -12 - ELSE IF( ( BETA.NE.ZERO .AND. LDWORK.LT.M*N ) - $ .OR.( BETA.EQ.ZERO .AND. LDWORK.LT.0 ) ) THEN - INFO = -14 - END IF -C - IF ( INFO.NE.0 ) THEN -C -C Error return. -C - CALL XERBLA( 'MB01RU', -INFO ) - RETURN - END IF -C -C Quick return if possible. -C - IF ( M.EQ.0 ) - $ RETURN -C - IF ( BETA.EQ.ZERO .OR. N.EQ.0 ) THEN - IF ( ALPHA.EQ.ZERO ) THEN -C -C Special case alpha = 0. -C - CALL DLASET( UPLO, M, M, ZERO, ZERO, R, LDR ) - ELSE -C -C Special case beta = 0 or N = 0. -C - IF ( ALPHA.NE.ONE ) - $ CALL DLASCL( UPLO, 0, 0, ONE, ALPHA, M, M, R, LDR, INFO ) - END IF - RETURN - END IF -C -C General case: beta <> 0. -C Compute W = op( A )*T or W = T*op( A ) in DWORK, and apply the -C updating formula (see METHOD section). -C Workspace: need M*N. -C - CALL DSCAL( N, HALF, X, LDX+1 ) -C - IF( LTRANS ) THEN -C - CALL DLACPY( 'Full', N, M, A, LDA, DWORK, N ) - CALL DTRMM( 'Left', UPLO, 'NoTranspose', 'Non-unit', N, M, - $ ONE, X, LDX, DWORK, N ) - CALL DSYR2K( UPLO, TRANS, M, N, BETA, DWORK, N, A, LDA, ALPHA, - $ R, LDR ) -C - ELSE -C - CALL DLACPY( 'Full', M, N, A, LDA, DWORK, M ) - CALL DTRMM( 'Right', UPLO, 'NoTranspose', 'Non-unit', M, N, - $ ONE, X, LDX, DWORK, M ) - CALL DSYR2K( UPLO, TRANS, M, N, BETA, DWORK, M, A, LDA, ALPHA, - $ R, LDR ) -C - END IF -C - CALL DSCAL( N, TWO, X, LDX+1 ) -C - RETURN -C *** Last line of MB01RU *** - END diff --git a/mex/sources/libslicot/MB01RW.f b/mex/sources/libslicot/MB01RW.f deleted file mode 100644 index 1305d3ed4..000000000 --- a/mex/sources/libslicot/MB01RW.f +++ /dev/null @@ -1,249 +0,0 @@ - SUBROUTINE MB01RW( UPLO, TRANS, M, N, A, LDA, Z, LDZ, DWORK, - $ INFO ) -C -C SLICOT RELEASE 5.0. -C -C Copyright (c) 2002-2009 NICONET e.V. -C -C This program is free software: you can redistribute it and/or -C modify it under the terms of the GNU General Public License as -C published by the Free Software Foundation, either version 2 of -C the License, or (at your option) any later version. -C -C This program is distributed in the hope that it will be useful, -C but WITHOUT ANY WARRANTY; without even the implied warranty of -C MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the -C GNU General Public License for more details. -C -C You should have received a copy of the GNU General Public License -C along with this program. If not, see -C . -C -C PURPOSE -C -C To compute the transformation of the symmetric matrix A by the -C matrix Z in the form -C -C A := op(Z)*A*op(Z)', -C -C where op(Z) is either Z or its transpose, Z'. -C -C ARGUMENTS -C -C Mode Parameters -C -C UPLO CHARACTER*1 -C Specifies whether the upper or lower triangle of A -C is stored: -C = 'U': Upper triangle of A is stored; -C = 'L': Lower triangle of A is stored. -C -C TRANS CHARACTER*1 -C Specifies whether op(Z) is Z or its transpose Z': -C = 'N': op(Z) = Z; -C = 'T': op(Z) = Z'. -C -C Input/Output Parameters -C -C M (input) INTEGER -C The order of the resulting symmetric matrix op(Z)*A*op(Z)' -C and the number of rows of the matrix Z, if TRANS = 'N', -C or the number of columns of the matrix Z, if TRANS = 'T'. -C M >= 0. -C -C N (input) INTEGER -C The order of the symmetric matrix A and the number of -C columns of the matrix Z, if TRANS = 'N', or the number of -C rows of the matrix Z, if TRANS = 'T'. N >= 0. -C -C A (input/output) DOUBLE PRECISION array, dimension -C (LDA,MAX(M,N)) -C On entry, the leading N-by-N upper or lower triangular -C part of this array must contain the upper (UPLO = 'U') -C or lower (UPLO = 'L') triangular part of the symmetric -C matrix A. -C On exit, the leading M-by-M upper or lower triangular -C part of this array contains the upper (UPLO = 'U') or -C lower (UPLO = 'L') triangular part of the symmetric -C matrix op(Z)*A*op(Z)'. -C -C LDA INTEGER -C The leading dimension of the array A. LDA >= MAX(1,M,N). -C -C Z (input) DOUBLE PRECISION array, dimension (LDQ,K) -C where K = N if TRANS = 'N' and K = M if TRANS = 'T'. -C The leading M-by-N part, if TRANS = 'N', or N-by-M part, -C if TRANS = 'T', of this array contains the matrix Z. -C -C LDZ INTEGER -C The leading dimension of the array Z. -C LDZ >= MAX(1,M) if TRANS = 'N' and -C LDZ >= MAX(1,N) if TRANS = 'T'. -C -C Workspace -C -C DWORK DOUBLE PRECISION array, dimension (N) -C -C Error Indicator -C -C INFO INTEGER -C = 0: successful exit; -C < 0: if INFO = -i, the i-th argument had an illegal -C value. -C -C FURTHER COMMENTS -C -C This is a simpler, BLAS 2 version for MB01RD. -C -C CONTRIBUTOR -C -C A. Varga, DLR, Feb. 1995. -C -C REVISIONS -C -C April 1998 (T. Penzl). -C Sep. 1998 (V. Sima). -C -C ****************************************************************** -C -C .. Parameters .. - DOUBLE PRECISION ZERO, ONE - PARAMETER ( ZERO = 0.0D0, ONE = 1.0D0 ) -C .. Scalar Arguments .. - CHARACTER TRANS, UPLO - INTEGER INFO, LDA, LDZ, M, N -C .. Array Arguments .. - DOUBLE PRECISION A(LDA,*), DWORK(*), Z(LDZ,*) -C .. Local Scalars .. - LOGICAL NOTTRA, UPPER - INTEGER I, J -C .. External Functions .. - LOGICAL LSAME - EXTERNAL LSAME -C .. External Subroutines .. - EXTERNAL DCOPY, DGEMV, XERBLA -C .. Intrinsic Functions .. - INTRINSIC MAX -C -C .. Executable Statements -C - NOTTRA = LSAME( TRANS, 'N' ) - UPPER = LSAME( UPLO, 'U' ) -C - INFO = 0 - IF( .NOT.( UPPER .OR. LSAME( UPLO, 'L') ) ) THEN - INFO = -1 - ELSE IF( .NOT.( NOTTRA .OR. LSAME( TRANS, 'T') ) ) THEN - INFO = -2 - ELSE IF( M.LT.0 ) THEN - INFO = -3 - ELSE IF( N.LT.0 ) THEN - INFO = -4 - ELSE IF( LDA.LT.MAX( 1, M, N ) ) THEN - INFO = -6 - ELSE IF( ( NOTTRA .AND. LDZ.LT.MAX( 1, M ) ) .OR. - $ ( .NOT.NOTTRA .AND. LDZ.LT.MAX( 1, N ) ) ) THEN - INFO = -8 - END IF -C - IF ( INFO.NE.0 ) THEN - CALL XERBLA( 'MB01RW', -INFO ) - RETURN - END IF -C -C Quick return if possible. -C - IF( N.EQ.0 .OR. M.EQ.0 ) - $ RETURN -C - IF ( NOTTRA ) THEN -C -C Compute Z*A*Z'. -C - IF ( UPPER ) THEN -C -C Compute Z*A in A (M-by-N). -C - DO 10 J = 1, N - CALL DCOPY( J-1, A(1,J), 1, DWORK, 1 ) - CALL DCOPY( N-J+1, A(J,J), LDA, DWORK(J), 1 ) - CALL DGEMV( TRANS, M, N, ONE, Z, LDZ, DWORK, 1, ZERO, - $ A(1,J), 1 ) - 10 CONTINUE -C -C Compute A*Z' in the upper triangular part of A. -C - DO 20 I = 1, M - CALL DCOPY( N, A(I,1), LDA, DWORK, 1 ) - CALL DGEMV( TRANS, M-I+1, N, ONE, Z(I,1), LDZ, DWORK, 1, - $ ZERO, A(I,I), LDA ) - 20 CONTINUE -C - ELSE -C -C Compute A*Z' in A (N-by-M). -C - DO 30 I = 1, N - CALL DCOPY( I-1, A(I,1), LDA, DWORK, 1 ) - CALL DCOPY( N-I+1, A(I,I), 1, DWORK(I), 1 ) - CALL DGEMV( TRANS, M, N, ONE, Z, LDZ, DWORK, 1, ZERO, - $ A(I,1), LDA ) - 30 CONTINUE -C -C Compute Z*A in the lower triangular part of A. -C - DO 40 J = 1, M - CALL DCOPY( N, A(1,J), 1, DWORK, 1 ) - CALL DGEMV( TRANS, M-J+1, N, ONE, Z(J,1), LDZ, DWORK, 1, - $ ZERO, A(J,J), 1 ) - 40 CONTINUE -C - END IF - ELSE -C -C Compute Z'*A*Z. -C - IF ( UPPER ) THEN -C -C Compute Z'*A in A (M-by-N). -C - DO 50 J = 1, N - CALL DCOPY( J-1, A(1,J), 1, DWORK, 1 ) - CALL DCOPY( N-J+1, A(J,J), LDA, DWORK(J), 1 ) - CALL DGEMV( TRANS, N, M, ONE, Z, LDZ, DWORK, 1, ZERO, - $ A(1,J), 1 ) - 50 CONTINUE -C -C Compute A*Z in the upper triangular part of A. -C - DO 60 I = 1, M - CALL DCOPY( N, A(I,1), LDA, DWORK, 1 ) - CALL DGEMV( TRANS, N, M-I+1, ONE, Z(1,I), LDZ, DWORK, 1, - $ ZERO, A(I,I), LDA ) - 60 CONTINUE -C - ELSE -C -C Compute A*Z in A (N-by-M). -C - DO 70 I = 1, N - CALL DCOPY( I-1, A(I,1), LDA, DWORK, 1 ) - CALL DCOPY( N-I+1, A(I,I), 1, DWORK(I), 1 ) - CALL DGEMV( TRANS, N, M, ONE, Z, LDZ, DWORK, 1, ZERO, - $ A(I,1), LDA ) - 70 CONTINUE -C -C Compute Z'*A in the lower triangular part of A. -C - DO 80 J = 1, M - CALL DCOPY( N, A(1,J), 1, DWORK, 1 ) - CALL DGEMV( TRANS, N, M-J+1, ONE, Z(1,J), LDZ, DWORK, 1, - $ ZERO, A(J,J), 1 ) - 80 CONTINUE -C - END IF - END IF -C - RETURN -C *** Last line of MB01RW *** - END diff --git a/mex/sources/libslicot/MB01RX.f b/mex/sources/libslicot/MB01RX.f deleted file mode 100644 index 64abe3901..000000000 --- a/mex/sources/libslicot/MB01RX.f +++ /dev/null @@ -1,315 +0,0 @@ - SUBROUTINE MB01RX( SIDE, UPLO, TRANS, M, N, ALPHA, BETA, R, LDR, - $ A, LDA, B, LDB, INFO ) -C -C SLICOT RELEASE 5.0. -C -C Copyright (c) 2002-2009 NICONET e.V. -C -C This program is free software: you can redistribute it and/or -C modify it under the terms of the GNU General Public License as -C published by the Free Software Foundation, either version 2 of -C the License, or (at your option) any later version. -C -C This program is distributed in the hope that it will be useful, -C but WITHOUT ANY WARRANTY; without even the implied warranty of -C MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the -C GNU General Public License for more details. -C -C You should have received a copy of the GNU General Public License -C along with this program. If not, see -C . -C -C PURPOSE -C -C To compute either the upper or lower triangular part of one of the -C matrix formulas -C _ -C R = alpha*R + beta*op( A )*B, (1) -C _ -C R = alpha*R + beta*B*op( A ), (2) -C _ -C where alpha and beta are scalars, R and R are m-by-m matrices, -C op( A ) and B are m-by-n and n-by-m matrices for (1), or n-by-m -C and m-by-n matrices for (2), respectively, and op( A ) is one of -C -C op( A ) = A or op( A ) = A', the transpose of A. -C -C The result is overwritten on R. -C -C ARGUMENTS -C -C Mode Parameters -C -C SIDE CHARACTER*1 -C Specifies whether the matrix A appears on the left or -C right in the matrix product as follows: -C _ -C = 'L': R = alpha*R + beta*op( A )*B; -C _ -C = 'R': R = alpha*R + beta*B*op( A ). -C -C UPLO CHARACTER*1 _ -C Specifies which triangles of the matrices R and R are -C computed and given, respectively, as follows: -C = 'U': the upper triangular part; -C = 'L': the lower triangular part. -C -C TRANS CHARACTER*1 -C Specifies the form of op( A ) to be used in the matrix -C multiplication as follows: -C = 'N': op( A ) = A; -C = 'T': op( A ) = A'; -C = 'C': op( A ) = A'. -C -C Input/Output Parameters -C -C M (input) INTEGER _ -C The order of the matrices R and R, the number of rows of -C the matrix op( A ) and the number of columns of the -C matrix B, for SIDE = 'L', or the number of rows of the -C matrix B and the number of columns of the matrix op( A ), -C for SIDE = 'R'. M >= 0. -C -C N (input) INTEGER -C The number of rows of the matrix B and the number of -C columns of the matrix op( A ), for SIDE = 'L', or the -C number of rows of the matrix op( A ) and the number of -C columns of the matrix B, for SIDE = 'R'. N >= 0. -C -C ALPHA (input) DOUBLE PRECISION -C The scalar alpha. When alpha is zero then R need not be -C set before entry. -C -C BETA (input) DOUBLE PRECISION -C The scalar beta. When beta is zero then A and B are not -C referenced. -C -C R (input/output) DOUBLE PRECISION array, dimension (LDR,M) -C On entry with UPLO = 'U', the leading M-by-M upper -C triangular part of this array must contain the upper -C triangular part of the matrix R; the strictly lower -C triangular part of the array is not referenced. -C On entry with UPLO = 'L', the leading M-by-M lower -C triangular part of this array must contain the lower -C triangular part of the matrix R; the strictly upper -C triangular part of the array is not referenced. -C On exit, the leading M-by-M upper triangular part (if -C UPLO = 'U'), or lower triangular part (if UPLO = 'L') of -C this array contains the corresponding triangular part of -C _ -C the computed matrix R. -C -C LDR INTEGER -C The leading dimension of array R. LDR >= MAX(1,M). -C -C A (input) DOUBLE PRECISION array, dimension (LDA,k), where -C k = N when SIDE = 'L', and TRANS = 'N', or -C SIDE = 'R', and TRANS = 'T'; -C k = M when SIDE = 'R', and TRANS = 'N', or -C SIDE = 'L', and TRANS = 'T'. -C On entry, if SIDE = 'L', and TRANS = 'N', or -C SIDE = 'R', and TRANS = 'T', -C the leading M-by-N part of this array must contain the -C matrix A. -C On entry, if SIDE = 'R', and TRANS = 'N', or -C SIDE = 'L', and TRANS = 'T', -C the leading N-by-M part of this array must contain the -C matrix A. -C -C LDA INTEGER -C The leading dimension of array A. LDA >= MAX(1,l), where -C l = M when SIDE = 'L', and TRANS = 'N', or -C SIDE = 'R', and TRANS = 'T'; -C l = N when SIDE = 'R', and TRANS = 'N', or -C SIDE = 'L', and TRANS = 'T'. -C -C B (input) DOUBLE PRECISION array, dimension (LDB,p), where -C p = M when SIDE = 'L'; -C p = N when SIDE = 'R'. -C On entry, the leading N-by-M part, if SIDE = 'L', or -C M-by-N part, if SIDE = 'R', of this array must contain the -C matrix B. -C -C LDB INTEGER -C The leading dimension of array B. -C LDB >= MAX(1,N), if SIDE = 'L'; -C LDB >= MAX(1,M), if SIDE = 'R'. -C -C Error Indicator -C -C INFO INTEGER -C = 0: successful exit; -C < 0: if INFO = -i, the i-th argument had an illegal -C value. -C -C METHOD -C -C The matrix expression is evaluated taking the triangular -C structure into account. BLAS 2 operations are used. A block -C algorithm can be easily constructed; it can use BLAS 3 GEMM -C operations for most computations, and calls of this BLAS 2 -C algorithm for computing the triangles. -C -C FURTHER COMMENTS -C -C The main application of this routine is when the result should -C be a symmetric matrix, e.g., when B = X*op( A )', for (1), or -C B = op( A )'*X, for (2), where B is already available and X = X'. -C -C CONTRIBUTORS -C -C V. Sima, Katholieke Univ. Leuven, Belgium, Feb. 1999. -C -C REVISIONS -C -C V. Sima, Research Institute for Informatics, Bucharest, Mar. 2004. -C -C KEYWORDS -C -C Elementary matrix operations, matrix algebra, matrix operations. -C -C ****************************************************************** -C -C .. Parameters .. - DOUBLE PRECISION ZERO, ONE - PARAMETER ( ZERO = 0.0D0, ONE = 1.0D0 ) -C .. Scalar Arguments .. - CHARACTER SIDE, TRANS, UPLO - INTEGER INFO, LDA, LDB, LDR, M, N - DOUBLE PRECISION ALPHA, BETA -C .. Array Arguments .. - DOUBLE PRECISION A(LDA,*), B(LDB,*), R(LDR,*) -C .. Local Scalars .. - LOGICAL LSIDE, LTRANS, LUPLO - INTEGER J -C .. External Functions .. - LOGICAL LSAME - EXTERNAL LSAME -C .. External Subroutines .. - EXTERNAL DGEMV, DLASCL, DLASET, XERBLA -C .. Intrinsic Functions .. - INTRINSIC MAX -C .. Executable Statements .. -C -C Test the input scalar arguments. -C - INFO = 0 - LSIDE = LSAME( SIDE, 'L' ) - LUPLO = LSAME( UPLO, 'U' ) - LTRANS = LSAME( TRANS, 'T' ) .OR. LSAME( TRANS, 'C' ) -C - IF( ( .NOT.LSIDE ).AND.( .NOT.LSAME( SIDE, 'R' ) ) )THEN - INFO = -1 - ELSE IF( ( .NOT.LUPLO ).AND.( .NOT.LSAME( UPLO, 'L' ) ) )THEN - INFO = -2 - ELSE IF( ( .NOT.LTRANS ).AND.( .NOT.LSAME( TRANS, 'N' ) ) )THEN - INFO = -3 - ELSE IF( M.LT.0 ) THEN - INFO = -4 - ELSE IF( N.LT.0 ) THEN - INFO = -5 - ELSE IF( LDR.LT.MAX( 1, M ) ) THEN - INFO = -9 - ELSE IF( LDA.LT.1 .OR. - $ ( ( ( LSIDE .AND. .NOT.LTRANS ) .OR. - $ ( .NOT.LSIDE .AND. LTRANS ) ) .AND. LDA.LT.M ) .OR. - $ ( ( ( LSIDE .AND. LTRANS ) .OR. - $ ( .NOT.LSIDE .AND. .NOT.LTRANS ) ) .AND. LDA.LT.N ) ) THEN - INFO = -11 - ELSE IF( LDB.LT.1 .OR. - $ ( LSIDE .AND. LDB.LT.N ) .OR. - $ ( .NOT.LSIDE .AND. LDB.LT.M ) ) THEN - INFO = -13 - END IF -C - IF ( INFO.NE.0 ) THEN -C -C Error return. -C - CALL XERBLA( 'MB01RX', -INFO ) - RETURN - END IF -C -C Quick return if possible. -C - IF ( M.EQ.0 ) - $ RETURN -C - IF ( BETA.EQ.ZERO .OR. N.EQ.0 ) THEN - IF ( ALPHA.EQ.ZERO ) THEN -C -C Special case alpha = 0. -C - CALL DLASET( UPLO, M, M, ZERO, ZERO, R, LDR ) - ELSE -C -C Special case beta = 0 or N = 0. -C - IF ( ALPHA.NE.ONE ) - $ CALL DLASCL( UPLO, 0, 0, ONE, ALPHA, M, M, R, LDR, INFO ) - END IF - RETURN - END IF -C -C General case: beta <> 0. -C Compute the required triangle of (1) or (2) using BLAS 2 -C operations. -C - IF( LSIDE ) THEN - IF( LUPLO ) THEN - IF ( LTRANS ) THEN - DO 10 J = 1, M - CALL DGEMV( TRANS, N, J, BETA, A, LDA, B(1,J), 1, - $ ALPHA, R(1,J), 1 ) - 10 CONTINUE - ELSE - DO 20 J = 1, M - CALL DGEMV( TRANS, J, N, BETA, A, LDA, B(1,J), 1, - $ ALPHA, R(1,J), 1 ) - 20 CONTINUE - END IF - ELSE - IF ( LTRANS ) THEN - DO 30 J = 1, M - CALL DGEMV( TRANS, N, M-J+1, BETA, A(1,J), LDA, - $ B(1,J), 1, ALPHA, R(J,J), 1 ) - 30 CONTINUE - ELSE - DO 40 J = 1, M - CALL DGEMV( TRANS, M-J+1, N, BETA, A(J,1), LDA, - $ B(1,J), 1, ALPHA, R(J,J), 1 ) - 40 CONTINUE - END IF - END IF -C - ELSE - IF( LUPLO ) THEN - IF( LTRANS ) THEN - DO 50 J = 1, M - CALL DGEMV( 'NoTranspose', J, N, BETA, B, LDB, A(J,1), - $ LDA, ALPHA, R(1,J), 1 ) - 50 CONTINUE - ELSE - DO 60 J = 1, M - CALL DGEMV( 'NoTranspose', J, N, BETA, B, LDB, A(1,J), - $ 1, ALPHA, R(1,J), 1 ) - 60 CONTINUE - END IF - ELSE - IF( LTRANS ) THEN - DO 70 J = 1, M - CALL DGEMV( 'NoTranspose', M-J+1, N, BETA, B(J,1), - $ LDB, A(J,1), LDA, ALPHA, R(J,J), 1 ) - 70 CONTINUE - ELSE - DO 80 J = 1, M - CALL DGEMV( 'NoTranspose', M-J+1, N, BETA, B(J,1), - $ LDB, A(1,J), 1, ALPHA, R(J,J), 1 ) - 80 CONTINUE - END IF - END IF - END IF -C - RETURN -C *** Last line of MB01RX *** - END diff --git a/mex/sources/libslicot/MB01RY.f b/mex/sources/libslicot/MB01RY.f deleted file mode 100644 index af32cfe63..000000000 --- a/mex/sources/libslicot/MB01RY.f +++ /dev/null @@ -1,429 +0,0 @@ - SUBROUTINE MB01RY( SIDE, UPLO, TRANS, M, ALPHA, BETA, R, LDR, H, - $ LDH, B, LDB, DWORK, INFO ) -C -C SLICOT RELEASE 5.0. -C -C Copyright (c) 2002-2009 NICONET e.V. -C -C This program is free software: you can redistribute it and/or -C modify it under the terms of the GNU General Public License as -C published by the Free Software Foundation, either version 2 of -C the License, or (at your option) any later version. -C -C This program is distributed in the hope that it will be useful, -C but WITHOUT ANY WARRANTY; without even the implied warranty of -C MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the -C GNU General Public License for more details. -C -C You should have received a copy of the GNU General Public License -C along with this program. If not, see -C . -C -C PURPOSE -C -C To compute either the upper or lower triangular part of one of the -C matrix formulas -C _ -C R = alpha*R + beta*op( H )*B, (1) -C _ -C R = alpha*R + beta*B*op( H ), (2) -C _ -C where alpha and beta are scalars, H, B, R, and R are m-by-m -C matrices, H is an upper Hessenberg matrix, and op( H ) is one of -C -C op( H ) = H or op( H ) = H', the transpose of H. -C -C The result is overwritten on R. -C -C ARGUMENTS -C -C Mode Parameters -C -C SIDE CHARACTER*1 -C Specifies whether the Hessenberg matrix H appears on the -C left or right in the matrix product as follows: -C _ -C = 'L': R = alpha*R + beta*op( H )*B; -C _ -C = 'R': R = alpha*R + beta*B*op( H ). -C -C UPLO CHARACTER*1 _ -C Specifies which triangles of the matrices R and R are -C computed and given, respectively, as follows: -C = 'U': the upper triangular part; -C = 'L': the lower triangular part. -C -C TRANS CHARACTER*1 -C Specifies the form of op( H ) to be used in the matrix -C multiplication as follows: -C = 'N': op( H ) = H; -C = 'T': op( H ) = H'; -C = 'C': op( H ) = H'. -C -C Input/Output Parameters -C -C M (input) INTEGER _ -C The order of the matrices R, R, H and B. M >= 0. -C -C ALPHA (input) DOUBLE PRECISION -C The scalar alpha. When alpha is zero then R need not be -C set before entry. -C -C BETA (input) DOUBLE PRECISION -C The scalar beta. When beta is zero then H and B are not -C referenced. -C -C R (input/output) DOUBLE PRECISION array, dimension (LDR,M) -C On entry with UPLO = 'U', the leading M-by-M upper -C triangular part of this array must contain the upper -C triangular part of the matrix R; the strictly lower -C triangular part of the array is not referenced. -C On entry with UPLO = 'L', the leading M-by-M lower -C triangular part of this array must contain the lower -C triangular part of the matrix R; the strictly upper -C triangular part of the array is not referenced. -C On exit, the leading M-by-M upper triangular part (if -C UPLO = 'U'), or lower triangular part (if UPLO = 'L') of -C this array contains the corresponding triangular part of -C _ -C the computed matrix R. -C -C LDR INTEGER -C The leading dimension of array R. LDR >= MAX(1,M). -C -C H (input) DOUBLE PRECISION array, dimension (LDH,M) -C On entry, the leading M-by-M upper Hessenberg part of -C this array must contain the upper Hessenberg part of the -C matrix H. -C The elements below the subdiagonal are not referenced, -C except possibly for those in the first column, which -C could be overwritten, but are restored on exit. -C -C LDH INTEGER -C The leading dimension of array H. LDH >= MAX(1,M). -C -C B (input) DOUBLE PRECISION array, dimension (LDB,M) -C On entry, the leading M-by-M part of this array must -C contain the matrix B. -C -C LDB INTEGER -C The leading dimension of array B. LDB >= MAX(1,M). -C -C Workspace -C -C DWORK DOUBLE PRECISION array, dimension (LDWORK) -C LDWORK >= M, if beta <> 0 and SIDE = 'L'; -C LDWORK >= 0, if beta = 0 or SIDE = 'R'. -C This array is not referenced when beta = 0 or SIDE = 'R'. -C -C Error Indicator -C -C INFO INTEGER -C = 0: successful exit; -C < 0: if INFO = -i, the i-th argument had an illegal -C value. -C -C METHOD -C -C The matrix expression is efficiently evaluated taking the -C Hessenberg/triangular structure into account. BLAS 2 operations -C are used. A block algorithm can be constructed; it can use BLAS 3 -C GEMM operations for most computations, and calls of this BLAS 2 -C algorithm for computing the triangles. -C -C FURTHER COMMENTS -C -C The main application of this routine is when the result should -C be a symmetric matrix, e.g., when B = X*op( H )', for (1), or -C B = op( H )'*X, for (2), where B is already available and X = X'. -C -C CONTRIBUTORS -C -C V. Sima, Katholieke Univ. Leuven, Belgium, Feb. 1999. -C -C REVISIONS -C -C - -C -C KEYWORDS -C -C Elementary matrix operations, matrix algebra, matrix operations. -C -C ****************************************************************** -C -C .. Parameters .. - DOUBLE PRECISION ZERO, ONE - PARAMETER ( ZERO = 0.0D0, ONE = 1.0D0 ) -C .. Scalar Arguments .. - CHARACTER SIDE, TRANS, UPLO - INTEGER INFO, LDB, LDH, LDR, M - DOUBLE PRECISION ALPHA, BETA -C .. Array Arguments .. - DOUBLE PRECISION B(LDB,*), DWORK(*), H(LDH,*), R(LDR,*) -C .. Local Scalars .. - LOGICAL LSIDE, LTRANS, LUPLO - INTEGER I, J -C .. External Functions .. - LOGICAL LSAME - DOUBLE PRECISION DDOT - EXTERNAL DDOT, LSAME -C .. External Subroutines .. - EXTERNAL DCOPY, DGEMV, DLASCL, DLASET, DSCAL, DSWAP, - $ DTRMV, XERBLA -C .. Intrinsic Functions .. - INTRINSIC MAX, MIN -C .. Executable Statements .. -C -C Test the input scalar arguments. -C - INFO = 0 - LSIDE = LSAME( SIDE, 'L' ) - LUPLO = LSAME( UPLO, 'U' ) - LTRANS = LSAME( TRANS, 'T' ) .OR. LSAME( TRANS, 'C' ) -C - IF( ( .NOT.LSIDE ).AND.( .NOT.LSAME( SIDE, 'R' ) ) )THEN - INFO = -1 - ELSE IF( ( .NOT.LUPLO ).AND.( .NOT.LSAME( UPLO, 'L' ) ) )THEN - INFO = -2 - ELSE IF( ( .NOT.LTRANS ).AND.( .NOT.LSAME( TRANS, 'N' ) ) )THEN - INFO = -3 - ELSE IF( M.LT.0 ) THEN - INFO = -4 - ELSE IF( LDR.LT.MAX( 1, M ) ) THEN - INFO = -8 - ELSE IF( LDH.LT.MAX( 1, M ) ) THEN - INFO = -10 - ELSE IF( LDB.LT.MAX( 1, M ) ) THEN - INFO = -12 - END IF -C - IF ( INFO.NE.0 ) THEN -C -C Error return. -C - CALL XERBLA( 'MB01RY', -INFO ) - RETURN - END IF -C -C Quick return if possible. -C - IF ( M.EQ.0 ) - $ RETURN -C - IF ( BETA.EQ.ZERO ) THEN - IF ( ALPHA.EQ.ZERO ) THEN -C -C Special case when both alpha = 0 and beta = 0. -C - CALL DLASET( UPLO, M, M, ZERO, ZERO, R, LDR ) - ELSE -C -C Special case beta = 0. -C - IF ( ALPHA.NE.ONE ) - $ CALL DLASCL( UPLO, 0, 0, ONE, ALPHA, M, M, R, LDR, INFO ) - END IF - RETURN - END IF -C -C General case: beta <> 0. -C Compute the required triangle of (1) or (2) using BLAS 2 -C operations. -C - IF( LSIDE ) THEN -C -C To avoid repeated references to the subdiagonal elements of H, -C these are swapped with the corresponding elements of H in the -C first column, and are finally restored. -C - IF( M.GT.2 ) - $ CALL DSWAP( M-2, H( 3, 2 ), LDH+1, H( 3, 1 ), 1 ) -C - IF( LUPLO ) THEN - IF ( LTRANS ) THEN -C - DO 20 J = 1, M -C -C Multiply the transposed upper triangle of the leading -C j-by-j submatrix of H by the leading part of the j-th -C column of B. -C - CALL DCOPY( J, B( 1, J ), 1, DWORK, 1 ) - CALL DTRMV( 'Upper', TRANS, 'Non-unit', J, H, LDH, - $ DWORK, 1 ) -C -C Add the contribution of the subdiagonal of H to -C the j-th column of the product. -C - DO 10 I = 1, MIN( J, M - 1 ) - R( I, J ) = ALPHA*R( I, J ) + BETA*( DWORK( I ) + - $ H( I+1, 1 )*B( I+1, J ) ) - 10 CONTINUE -C - 20 CONTINUE -C - R( M, M ) = ALPHA*R( M, M ) + BETA*DWORK( M ) -C - ELSE -C - DO 40 J = 1, M -C -C Multiply the upper triangle of the leading j-by-j -C submatrix of H by the leading part of the j-th column -C of B. -C - CALL DCOPY( J, B( 1, J ), 1, DWORK, 1 ) - CALL DTRMV( 'Upper', TRANS, 'Non-unit', J, H, LDH, - $ DWORK, 1 ) - IF( J.LT.M ) THEN -C -C Multiply the remaining right part of the leading -C j-by-M submatrix of H by the trailing part of the -C j-th column of B. -C - CALL DGEMV( TRANS, J, M-J, BETA, H( 1, J+1 ), LDH, - $ B( J+1, J ), 1, ALPHA, R( 1, J ), 1 ) - ELSE - CALL DSCAL( M, ALPHA, R( 1, M ), 1 ) - END IF -C -C Add the contribution of the subdiagonal of H to -C the j-th column of the product. -C - R( 1, J ) = R( 1, J ) + BETA*DWORK( 1 ) -C - DO 30 I = 2, J - R( I, J ) = R( I, J ) + BETA*( DWORK( I ) + - $ H( I, 1 )*B( I-1, J ) ) - 30 CONTINUE -C - 40 CONTINUE -C - END IF -C - ELSE -C - IF ( LTRANS ) THEN -C - DO 60 J = M, 1, -1 -C -C Multiply the transposed upper triangle of the trailing -C (M-j+1)-by-(M-j+1) submatrix of H by the trailing part -C of the j-th column of B. -C - CALL DCOPY( M-J+1, B( J, J ), 1, DWORK( J ), 1 ) - CALL DTRMV( 'Upper', TRANS, 'Non-unit', M-J+1, - $ H( J, J ), LDH, DWORK( J ), 1 ) - IF( J.GT.1 ) THEN -C -C Multiply the remaining left part of the trailing -C (M-j+1)-by-(j-1) submatrix of H' by the leading -C part of the j-th column of B. -C - CALL DGEMV( TRANS, J-1, M-J+1, BETA, H( 1, J ), - $ LDH, B( 1, J ), 1, ALPHA, R( J, J ), - $ 1 ) - ELSE - CALL DSCAL( M, ALPHA, R( 1, 1 ), 1 ) - END IF -C -C Add the contribution of the subdiagonal of H to -C the j-th column of the product. -C - DO 50 I = J, M - 1 - R( I, J ) = R( I, J ) + BETA*( DWORK( I ) + - $ H( I+1, 1 )*B( I+1, J ) ) - 50 CONTINUE -C - R( M, J ) = R( M, J ) + BETA*DWORK( M ) - 60 CONTINUE -C - ELSE -C - DO 80 J = M, 1, -1 -C -C Multiply the upper triangle of the trailing -C (M-j+1)-by-(M-j+1) submatrix of H by the trailing -C part of the j-th column of B. -C - CALL DCOPY( M-J+1, B( J, J ), 1, DWORK( J ), 1 ) - CALL DTRMV( 'Upper', TRANS, 'Non-unit', M-J+1, - $ H( J, J ), LDH, DWORK( J ), 1 ) -C -C Add the contribution of the subdiagonal of H to -C the j-th column of the product. -C - DO 70 I = MAX( J, 2 ), M - R( I, J ) = ALPHA*R( I, J ) + BETA*( DWORK( I ) - $ + H( I, 1 )*B( I-1, J ) ) - 70 CONTINUE -C - 80 CONTINUE -C - R( 1, 1 ) = ALPHA*R( 1, 1 ) + BETA*DWORK( 1 ) -C - END IF - END IF -C - IF( M.GT.2 ) - $ CALL DSWAP( M-2, H( 3, 2 ), LDH+1, H( 3, 1 ), 1 ) -C - ELSE -C -C Row-wise calculations are used for H, if SIDE = 'R' and -C TRANS = 'T'. -C - IF( LUPLO ) THEN - IF( LTRANS ) THEN - R( 1, 1 ) = ALPHA*R( 1, 1 ) + - $ BETA*DDOT( M, B, LDB, H, LDH ) -C - DO 90 J = 2, M - CALL DGEMV( 'NoTranspose', J, M-J+2, BETA, - $ B( 1, J-1 ), LDB, H( J, J-1 ), LDH, - $ ALPHA, R( 1, J ), 1 ) - 90 CONTINUE -C - ELSE -C - DO 100 J = 1, M - 1 - CALL DGEMV( 'NoTranspose', J, J+1, BETA, B, LDB, - $ H( 1, J ), 1, ALPHA, R( 1, J ), 1 ) - 100 CONTINUE -C - CALL DGEMV( 'NoTranspose', M, M, BETA, B, LDB, - $ H( 1, M ), 1, ALPHA, R( 1, M ), 1 ) -C - END IF -C - ELSE -C - IF( LTRANS ) THEN -C - CALL DGEMV( 'NoTranspose', M, M, BETA, B, LDB, H, LDH, - $ ALPHA, R( 1, 1 ), 1 ) -C - DO 110 J = 2, M - CALL DGEMV( 'NoTranspose', M-J+1, M-J+2, BETA, - $ B( J, J-1 ), LDB, H( J, J-1 ), LDH, ALPHA, - $ R( J, J ), 1 ) - 110 CONTINUE -C - ELSE -C - DO 120 J = 1, M - 1 - CALL DGEMV( 'NoTranspose', M-J+1, J+1, BETA, - $ B( J, 1 ), LDB, H( 1, J ), 1, ALPHA, - $ R( J, J ), 1 ) - 120 CONTINUE -C - R( M, M ) = ALPHA*R( M, M ) + - $ BETA*DDOT( M, B( M, 1 ), LDB, H( 1, M ), 1 ) -C - END IF - END IF - END IF -C - RETURN -C *** Last line of MB01RY *** - END diff --git a/mex/sources/libslicot/MB01SD.f b/mex/sources/libslicot/MB01SD.f deleted file mode 100644 index b29437379..000000000 --- a/mex/sources/libslicot/MB01SD.f +++ /dev/null @@ -1,123 +0,0 @@ - SUBROUTINE MB01SD( JOBS, M, N, A, LDA, R, C ) -C -C SLICOT RELEASE 5.0. -C -C Copyright (c) 2002-2009 NICONET e.V. -C -C This program is free software: you can redistribute it and/or -C modify it under the terms of the GNU General Public License as -C published by the Free Software Foundation, either version 2 of -C the License, or (at your option) any later version. -C -C This program is distributed in the hope that it will be useful, -C but WITHOUT ANY WARRANTY; without even the implied warranty of -C MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the -C GNU General Public License for more details. -C -C You should have received a copy of the GNU General Public License -C along with this program. If not, see -C . -C -C PURPOSE -C -C To scale a general M-by-N matrix A using the row and column -C scaling factors in the vectors R and C. -C -C ARGUMENTS -C -C Mode Parameters -C -C JOBS CHARACTER*1 -C Specifies the scaling operation to be done, as follows: -C = 'R': row scaling, i.e., A will be premultiplied -C by diag(R); -C = 'C': column scaling, i.e., A will be postmultiplied -C by diag(C); -C = 'B': both row and column scaling, i.e., A will be -C replaced by diag(R) * A * diag(C). -C -C Input/Output Parameters -C -C M (input) INTEGER -C The number of rows of the matrix A. M >= 0. -C -C N (input) INTEGER -C The number of columns of the matrix A. N >= 0. -C -C A (input/output) DOUBLE PRECISION array, dimension (LDA,N) -C On entry, the M-by-N matrix A. -C On exit, the scaled matrix. See JOBS for the form of the -C scaled matrix. -C -C LDA INTEGER -C The leading dimension of the array A. LDA >= max(1,M). -C -C R (input) DOUBLE PRECISION array, dimension (M) -C The row scale factors for A. -C R is not referenced if JOBS = 'C'. -C -C C (input) DOUBLE PRECISION array, dimension (N) -C The column scale factors for A. -C C is not referenced if JOBS = 'R'. -C -C -C CONTRIBUTOR -C -C A. Varga, German Aerospace Center, -C DLR Oberpfaffenhofen, April 1998. -C Based on the RASP routine DMSCAL. -C -C ****************************************************************** -C -C .. Scalar Arguments .. - CHARACTER JOBS - INTEGER LDA, M, N -C .. Array Arguments .. - DOUBLE PRECISION A(LDA,*), C(*), R(*) -C .. Local Scalars .. - INTEGER I, J - DOUBLE PRECISION CJ -C .. External Functions .. - LOGICAL LSAME - EXTERNAL LSAME -C .. Executable Statements .. -C -C Quick return if possible. -C - IF( M.EQ.0 .OR. N.EQ.0 ) - $ RETURN -C - IF( LSAME( JOBS, 'C' ) ) THEN -C -C Column scaling, no row scaling. -C - DO 20 J = 1, N - CJ = C(J) - DO 10 I = 1, M - A(I,J) = CJ*A(I,J) - 10 CONTINUE - 20 CONTINUE - ELSE IF( LSAME( JOBS, 'R' ) ) THEN -C -C Row scaling, no column scaling. -C - DO 40 J = 1, N - DO 30 I = 1, M - A(I,J) = R(I)*A(I,J) - 30 CONTINUE - 40 CONTINUE - ELSE IF( LSAME( JOBS, 'B' ) ) THEN -C -C Row and column scaling. -C - DO 60 J = 1, N - CJ = C(J) - DO 50 I = 1, M - A(I,J) = CJ*R(I)*A(I,J) - 50 CONTINUE - 60 CONTINUE - END IF -C - RETURN -C *** Last line of MB01SD *** - END diff --git a/mex/sources/libslicot/MB01TD.f b/mex/sources/libslicot/MB01TD.f deleted file mode 100644 index d4e06e626..000000000 --- a/mex/sources/libslicot/MB01TD.f +++ /dev/null @@ -1,173 +0,0 @@ - SUBROUTINE MB01TD( N, A, LDA, B, LDB, DWORK, INFO ) -C -C SLICOT RELEASE 5.0. -C -C Copyright (c) 2002-2009 NICONET e.V. -C -C This program is free software: you can redistribute it and/or -C modify it under the terms of the GNU General Public License as -C published by the Free Software Foundation, either version 2 of -C the License, or (at your option) any later version. -C -C This program is distributed in the hope that it will be useful, -C but WITHOUT ANY WARRANTY; without even the implied warranty of -C MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the -C GNU General Public License for more details. -C -C You should have received a copy of the GNU General Public License -C along with this program. If not, see -C . -C -C PURPOSE -C -C To compute the matrix product A * B, where A and B are upper -C quasi-triangular matrices (that is, block upper triangular with -C 1-by-1 or 2-by-2 diagonal blocks) with the same structure. -C The result is returned in the array B. -C -C ARGUMENTS -C -C Input/Output Parameters -C -C N (input) INTEGER -C The order of the matrices A and B. N >= 0. -C -C A (input) DOUBLE PRECISION array, dimension (LDA,N) -C The leading N-by-N part of this array must contain the -C upper quasi-triangular matrix A. The elements below the -C subdiagonal are not referenced. -C -C LDA INTEGER -C The leading dimension of the array A. LDA >= max(1,N). -C -C B (input/output) DOUBLE PRECISION array, dimension (LDB,N) -C On entry, the leading N-by-N part of this array must -C contain the upper quasi-triangular matrix B, with the same -C structure as matrix A. -C On exit, the leading N-by-N part of this array contains -C the computed product A * B, with the same structure as -C on entry. -C The elements below the subdiagonal are not referenced. -C -C LDB INTEGER -C The leading dimension of the array B. LDB >= max(1,N). -C -C Workspace -C -C DWORK DOUBLE PRECISION array, dimension (N-1) -C -C Error Indicator -C -C INFO INTEGER -C = 0: successful exit; -C < 0: if INFO = -i, the i-th argument had an illegal -C value; -C = 1: if the matrices A and B have not the same structure, -C and/or A and B are not upper quasi-triangular. -C -C METHOD -C -C The matrix product A * B is computed column by column, using -C BLAS 2 and BLAS 1 operations. -C -C FURTHER COMMENTS -C -C This routine can be used, for instance, for computing powers of -C a real Schur form matrix. -C -C CONTRIBUTOR -C -C V. Sima, Katholieke Univ. Leuven, Belgium, June 1998. -C -C REVISIONS -C -C V. Sima, Feb. 2000. -C -C KEYWORDS -C -C Elementary matrix operations, matrix operations. -C -C ****************************************************************** -C -C .. Parameters .. - DOUBLE PRECISION ZERO, ONE - PARAMETER ( ZERO = 0.0D0, ONE = 1.0D0 ) -C .. Scalar Arguments .. - INTEGER INFO, LDA, LDB, N -C .. Array Arguments .. - DOUBLE PRECISION A(LDA,*), B(LDB,*), DWORK(*) -C .. Local Scalars .. - INTEGER I, J, JMIN, JMNM -C .. External Subroutines .. - EXTERNAL DAXPY, DTRMV, XERBLA -C .. Intrinsic Functions .. - INTRINSIC MAX, MIN -C -C .. Executable Statements .. -C -C Test the input scalar arguments. -C - INFO = 0 - IF( N.LT.0 ) THEN - INFO = -1 - ELSE IF( LDA.LT.MAX( 1, N ) ) THEN - INFO = -3 - ELSE IF( LDB.LT.MAX( 1, N ) ) THEN - INFO = -5 - END IF -C - IF ( INFO.NE.0 ) THEN -C -C Error return. -C - CALL XERBLA( 'MB01TD', -INFO ) - RETURN - END IF -C -C Quick return, if possible. -C - IF ( N.EQ.0 ) THEN - RETURN - ELSE IF ( N.EQ.1 ) THEN - B(1,1) = A(1,1)*B(1,1) - RETURN - END IF -C -C Test the upper quasi-triangular structure of A and B for identity. -C - DO 10 I = 1, N - 1 - IF ( A(I+1,I).EQ.ZERO ) THEN - IF ( B(I+1,I).NE.ZERO ) THEN - INFO = 1 - RETURN - END IF - ELSE IF ( I.LT.N-1 ) THEN - IF ( A(I+2,I+1).NE.ZERO ) THEN - INFO = 1 - RETURN - END IF - END IF - 10 CONTINUE -C - DO 30 J = 1, N - JMIN = MIN( J+1, N ) - JMNM = MIN( JMIN, N-1 ) -C -C Compute the contribution of the subdiagonal of A to the -C j-th column of the product. -C - DO 20 I = 1, JMNM - DWORK(I) = A(I+1,I)*B(I,J) - 20 CONTINUE -C -C Multiply the upper triangle of A by the j-th column of B, -C and add to the above result. -C - CALL DTRMV( 'Upper', 'No transpose', 'Non-unit', JMIN, A, LDA, - $ B(1,J), 1 ) - CALL DAXPY( JMNM, ONE, DWORK, 1, B(2,J), 1 ) - 30 CONTINUE -C - RETURN -C *** Last line of MB01TD *** - END diff --git a/mex/sources/libslicot/MB01UD.f b/mex/sources/libslicot/MB01UD.f deleted file mode 100644 index 0bdacadf5..000000000 --- a/mex/sources/libslicot/MB01UD.f +++ /dev/null @@ -1,238 +0,0 @@ - SUBROUTINE MB01UD( SIDE, TRANS, M, N, ALPHA, H, LDH, A, LDA, B, - $ LDB, INFO ) -C -C SLICOT RELEASE 5.0. -C -C Copyright (c) 2002-2009 NICONET e.V. -C -C This program is free software: you can redistribute it and/or -C modify it under the terms of the GNU General Public License as -C published by the Free Software Foundation, either version 2 of -C the License, or (at your option) any later version. -C -C This program is distributed in the hope that it will be useful, -C but WITHOUT ANY WARRANTY; without even the implied warranty of -C MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the -C GNU General Public License for more details. -C -C You should have received a copy of the GNU General Public License -C along with this program. If not, see -C . -C -C PURPOSE -C -C To compute one of the matrix products -C -C B = alpha*op( H ) * A, or B = alpha*A * op( H ), -C -C where alpha is a scalar, A and B are m-by-n matrices, H is an -C upper Hessenberg matrix, and op( H ) is one of -C -C op( H ) = H or op( H ) = H', the transpose of H. -C -C ARGUMENTS -C -C Mode Parameters -C -C SIDE CHARACTER*1 -C Specifies whether the Hessenberg matrix H appears on the -C left or right in the matrix product as follows: -C = 'L': B = alpha*op( H ) * A; -C = 'R': B = alpha*A * op( H ). -C -C TRANS CHARACTER*1 -C Specifies the form of op( H ) to be used in the matrix -C multiplication as follows: -C = 'N': op( H ) = H; -C = 'T': op( H ) = H'; -C = 'C': op( H ) = H'. -C -C Input/Output Parameters -C -C M (input) INTEGER -C The number of rows of the matrices A and B. M >= 0. -C -C N (input) INTEGER -C The number of columns of the matrices A and B. N >= 0. -C -C ALPHA (input) DOUBLE PRECISION -C The scalar alpha. When alpha is zero then H is not -C referenced and A need not be set before entry. -C -C H (input) DOUBLE PRECISION array, dimension (LDH,k) -C where k is M when SIDE = 'L' and is N when SIDE = 'R'. -C On entry with SIDE = 'L', the leading M-by-M upper -C Hessenberg part of this array must contain the upper -C Hessenberg matrix H. -C On entry with SIDE = 'R', the leading N-by-N upper -C Hessenberg part of this array must contain the upper -C Hessenberg matrix H. -C The elements below the subdiagonal are not referenced, -C except possibly for those in the first column, which -C could be overwritten, but are restored on exit. -C -C LDH INTEGER -C The leading dimension of the array H. LDH >= max(1,k), -C where k is M when SIDE = 'L' and is N when SIDE = 'R'. -C -C A (input) DOUBLE PRECISION array, dimension (LDA,N) -C The leading M-by-N part of this array must contain the -C matrix A. -C -C LDA INTEGER -C The leading dimension of the array A. LDA >= max(1,M). -C -C B (output) DOUBLE PRECISION array, dimension (LDB,N) -C The leading M-by-N part of this array contains the -C computed product. -C -C LDB INTEGER -C The leading dimension of the array B. LDB >= max(1,M). -C -C Error Indicator -C -C INFO INTEGER -C = 0: successful exit; -C < 0: if INFO = -i, the i-th argument had an illegal -C value. -C -C METHOD -C -C The required matrix product is computed in two steps. In the first -C step, the upper triangle of H is used; in the second step, the -C contribution of the subdiagonal is added. A fast BLAS 3 DTRMM -C operation is used in the first step. -C -C CONTRIBUTOR -C -C V. Sima, Katholieke Univ. Leuven, Belgium, January 1999. -C -C REVISIONS -C -C - -C -C KEYWORDS -C -C Elementary matrix operations, matrix operations. -C -C ****************************************************************** -C -C .. Parameters .. - DOUBLE PRECISION ZERO, ONE - PARAMETER ( ZERO = 0.0D0, ONE = 1.0D0 ) -C .. Scalar Arguments .. - CHARACTER SIDE, TRANS - INTEGER INFO, LDA, LDB, LDH, M, N - DOUBLE PRECISION ALPHA -C .. Array Arguments .. - DOUBLE PRECISION A(LDA,*), B(LDB,*), H(LDH,*) -C .. Local Scalars .. - LOGICAL LSIDE, LTRANS - INTEGER I, J -C .. External Functions .. - LOGICAL LSAME - EXTERNAL LSAME -C .. External Subroutines .. - EXTERNAL DAXPY, DLACPY, DLASET, DSWAP, DTRMM, XERBLA -C .. Intrinsic Functions .. - INTRINSIC MAX, MIN -C -C .. Executable Statements .. -C -C Test the input scalar arguments. -C - INFO = 0 - LSIDE = LSAME( SIDE, 'L' ) - LTRANS = LSAME( TRANS, 'T' ) .OR. LSAME( TRANS, 'C' ) -C - IF( ( .NOT.LSIDE ).AND.( .NOT.LSAME( SIDE, 'R' ) ) )THEN - INFO = -1 - ELSE IF( ( .NOT.LTRANS ).AND.( .NOT.LSAME( TRANS, 'N' ) ) )THEN - INFO = -2 - ELSE IF( M.LT.0 ) THEN - INFO = -3 - ELSE IF( N.LT.0 ) THEN - INFO = -4 - ELSE IF( LDH.LT.1 .OR. ( LSIDE .AND. LDH.LT.M ) .OR. - $ ( .NOT.LSIDE .AND. LDH.LT.N ) ) THEN - INFO = -7 - ELSE IF( LDA.LT.MAX( 1, M ) ) THEN - INFO = -9 - ELSE IF( LDB.LT.MAX( 1, M ) ) THEN - INFO = -11 - END IF -C - IF ( INFO.NE.0 ) THEN -C -C Error return. -C - CALL XERBLA( 'MB01UD', -INFO ) - RETURN - END IF -C -C Quick return, if possible. -C - IF ( MIN( M, N ).EQ.0 ) - $ RETURN -C - IF( ALPHA.EQ.ZERO ) THEN -C -C Set B to zero and return. -C - CALL DLASET( 'Full', M, N, ZERO, ZERO, B, LDB ) - RETURN - END IF -C -C Copy A in B and compute one of the matrix products -C B = alpha*op( triu( H ) ) * A, or -C B = alpha*A * op( triu( H ) ), -C involving the upper triangle of H. -C - CALL DLACPY( 'Full', M, N, A, LDA, B, LDB ) - CALL DTRMM( SIDE, 'Upper', TRANS, 'Non-unit', M, N, ALPHA, H, - $ LDH, B, LDB ) -C -C Add the contribution of the subdiagonal of H. -C If SIDE = 'L', the subdiagonal of H is swapped with the -C corresponding elements in the first column of H, and the -C calculations are organized for column operations. -C - IF( LSIDE ) THEN - IF( M.GT.2 ) - $ CALL DSWAP( M-2, H( 3, 2 ), LDH+1, H( 3, 1 ), 1 ) - IF( LTRANS ) THEN - DO 20 J = 1, N - DO 10 I = 1, M - 1 - B( I, J ) = B( I, J ) + ALPHA*H( I+1, 1 )*A( I+1, J ) - 10 CONTINUE - 20 CONTINUE - ELSE - DO 40 J = 1, N - DO 30 I = 2, M - B( I, J ) = B( I, J ) + ALPHA*H( I, 1 )*A( I-1, J ) - 30 CONTINUE - 40 CONTINUE - END IF - IF( M.GT.2 ) - $ CALL DSWAP( M-2, H( 3, 2 ), LDH+1, H( 3, 1 ), 1 ) -C - ELSE -C - IF( LTRANS ) THEN - DO 50 J = 1, N - 1 - IF ( H( J+1, J ).NE.ZERO ) - $ CALL DAXPY( M, ALPHA*H( J+1, J ), A( 1, J ), 1, - $ B( 1, J+1 ), 1 ) - 50 CONTINUE - ELSE - DO 60 J = 1, N - 1 - IF ( H( J+1, J ).NE.ZERO ) - $ CALL DAXPY( M, ALPHA*H( J+1, J ), A( 1, J+1 ), 1, - $ B( 1, J ), 1 ) - 60 CONTINUE - END IF - END IF -C - RETURN -C *** Last line of MB01UD *** - END diff --git a/mex/sources/libslicot/MB01UW.f b/mex/sources/libslicot/MB01UW.f deleted file mode 100644 index ff8489636..000000000 --- a/mex/sources/libslicot/MB01UW.f +++ /dev/null @@ -1,377 +0,0 @@ - SUBROUTINE MB01UW( SIDE, TRANS, M, N, ALPHA, H, LDH, A, LDA, - $ DWORK, LDWORK, INFO ) -C -C SLICOT RELEASE 5.0. -C -C Copyright (c) 2002-2009 NICONET e.V. -C -C This program is free software: you can redistribute it and/or -C modify it under the terms of the GNU General Public License as -C published by the Free Software Foundation, either version 2 of -C the License, or (at your option) any later version. -C -C This program is distributed in the hope that it will be useful, -C but WITHOUT ANY WARRANTY; without even the implied warranty of -C MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the -C GNU General Public License for more details. -C -C You should have received a copy of the GNU General Public License -C along with this program. If not, see -C . -C -C PURPOSE -C -C To compute one of the matrix products -C -C A : = alpha*op( H ) * A, or A : = alpha*A * op( H ), -C -C where alpha is a scalar, A is an m-by-n matrix, H is an upper -C Hessenberg matrix, and op( H ) is one of -C -C op( H ) = H or op( H ) = H', the transpose of H. -C -C ARGUMENTS -C -C Mode Parameters -C -C SIDE CHARACTER*1 -C Specifies whether the Hessenberg matrix H appears on the -C left or right in the matrix product as follows: -C = 'L': A := alpha*op( H ) * A; -C = 'R': A := alpha*A * op( H ). -C -C TRANS CHARACTER*1 -C Specifies the form of op( H ) to be used in the matrix -C multiplication as follows: -C = 'N': op( H ) = H; -C = 'T': op( H ) = H'; -C = 'C': op( H ) = H'. -C -C Input/Output Parameters -C -C M (input) INTEGER -C The number of rows of the matrix A. M >= 0. -C -C N (input) INTEGER -C The number of columns of the matrix A. N >= 0. -C -C ALPHA (input) DOUBLE PRECISION -C The scalar alpha. When alpha is zero then H is not -C referenced and A need not be set before entry. -C -C H (input) DOUBLE PRECISION array, dimension (LDH,k) -C where k is M when SIDE = 'L' and is N when SIDE = 'R'. -C On entry with SIDE = 'L', the leading M-by-M upper -C Hessenberg part of this array must contain the upper -C Hessenberg matrix H. -C On entry with SIDE = 'R', the leading N-by-N upper -C Hessenberg part of this array must contain the upper -C Hessenberg matrix H. -C The elements below the subdiagonal are not referenced, -C except possibly for those in the first column, which -C could be overwritten, but are restored on exit. -C -C LDH INTEGER -C The leading dimension of the array H. LDH >= max(1,k), -C where k is M when SIDE = 'L' and is N when SIDE = 'R'. -C -C A (input/output) DOUBLE PRECISION array, dimension (LDA,N) -C On entry, the leading M-by-N part of this array must -C contain the matrix A. -C On exit, the leading M-by-N part of this array contains -C the computed product. -C -C LDA INTEGER -C The leading dimension of the array A. LDA >= max(1,M). -C -C Workspace -C -C DWORK DOUBLE PRECISION array, dimension (LDWORK) -C On exit, if INFO = 0, alpha <> 0, and LDWORK >= M*N > 0, -C DWORK contains a copy of the matrix A, having the leading -C dimension M. -C This array is not referenced when alpha = 0. -C -C LDWORK The length of the array DWORK. -C LDWORK >= 0, if alpha = 0 or MIN(M,N) = 0; -C LDWORK >= M-1, if SIDE = 'L'; -C LDWORK >= N-1, if SIDE = 'R'. -C For maximal efficiency LDWORK should be at least M*N. -C -C Error Indicator -C -C INFO INTEGER -C = 0: successful exit; -C < 0: if INFO = -i, the i-th argument had an illegal -C value. -C -C METHOD -C -C The required matrix product is computed in two steps. In the first -C step, the upper triangle of H is used; in the second step, the -C contribution of the subdiagonal is added. If the workspace can -C accomodate a copy of A, a fast BLAS 3 DTRMM operation is used in -C the first step. -C -C CONTRIBUTOR -C -C V. Sima, Katholieke Univ. Leuven, Belgium, January 1999. -C -C REVISIONS -C -C V. Sima, Research Institute for Informatics, Bucharest, Feb. 2004. -C -C KEYWORDS -C -C Elementary matrix operations, matrix operations. -C -C ****************************************************************** -C -C .. Parameters .. - DOUBLE PRECISION ZERO, ONE - PARAMETER ( ZERO = 0.0D0, ONE = 1.0D0 ) -C .. Scalar Arguments .. - CHARACTER SIDE, TRANS - INTEGER INFO, LDA, LDH, LDWORK, M, N - DOUBLE PRECISION ALPHA -C .. Array Arguments .. - DOUBLE PRECISION A(LDA,*), DWORK(*), H(LDH,*) -C .. Local Scalars .. - LOGICAL LSIDE, LTRANS - INTEGER I, J, JW -C .. External Functions .. - LOGICAL LSAME - EXTERNAL LSAME -C .. External Subroutines .. - EXTERNAL DAXPY, DLACPY, DLASCL, DLASET, DSCAL, DSWAP, - $ DTRMM, DTRMV, XERBLA -C .. Intrinsic Functions .. - INTRINSIC MAX, MIN -C -C .. Executable Statements .. -C -C Test the input scalar arguments. -C - INFO = 0 - LSIDE = LSAME( SIDE, 'L' ) - LTRANS = LSAME( TRANS, 'T' ) .OR. LSAME( TRANS, 'C' ) -C - IF( ( .NOT.LSIDE ).AND.( .NOT.LSAME( SIDE, 'R' ) ) )THEN - INFO = -1 - ELSE IF( ( .NOT.LTRANS ).AND.( .NOT.LSAME( TRANS, 'N' ) ) )THEN - INFO = -2 - ELSE IF( M.LT.0 ) THEN - INFO = -3 - ELSE IF( N.LT.0 ) THEN - INFO = -4 - ELSE IF( LDH.LT.1 .OR. ( LSIDE .AND. LDH.LT.M ) .OR. - $ ( .NOT.LSIDE .AND. LDH.LT.N ) ) THEN - INFO = -7 - ELSE IF( LDA.LT.MAX( 1, M ) ) THEN - INFO = -9 - ELSE IF( LDWORK.LT.0 .OR. - $ ( ALPHA.NE.ZERO .AND. MIN( M, N ).GT.0 .AND. - $ ( ( LSIDE .AND. LDWORK.LT.M-1 ) .OR. - $ ( .NOT.LSIDE .AND. LDWORK.LT.N-1 ) ) ) ) THEN - INFO = -11 - END IF -C - IF ( INFO.NE.0 ) THEN -C -C Error return. -C - CALL XERBLA( 'MB01UW', -INFO ) - RETURN - END IF -C -C Quick return, if possible. -C - IF ( MIN( M, N ).EQ.0 ) THEN - RETURN - ELSE IF ( LSIDE ) THEN - IF ( M.EQ.1 ) THEN - CALL DSCAL( N, ALPHA*H(1,1), A, LDA ) - RETURN - END IF - ELSE - IF ( N.EQ.1 ) THEN - CALL DSCAL( M, ALPHA*H(1,1), A, 1 ) - RETURN - END IF - END IF -C - IF( ALPHA.EQ.ZERO ) THEN -C -C Set A to zero and return. -C - CALL DLASET( 'Full', M, N, ZERO, ZERO, A, LDA ) - RETURN - END IF -C - IF( LDWORK.GE.M*N ) THEN -C -C Enough workspace for a fast BLAS 3 calculation. -C Save A in the workspace and compute one of the matrix products -C A : = alpha*op( triu( H ) ) * A, or -C A : = alpha*A * op( triu( H ) ), -C involving the upper triangle of H. -C - CALL DLACPY( 'Full', M, N, A, LDA, DWORK, M ) - CALL DTRMM( SIDE, 'Upper', TRANS, 'Non-unit', M, N, ALPHA, H, - $ LDH, A, LDA ) -C -C Add the contribution of the subdiagonal of H. -C If SIDE = 'L', the subdiagonal of H is swapped with the -C corresponding elements in the first column of H, and the -C calculations are organized for column operations. -C - IF( LSIDE ) THEN - IF( M.GT.2 ) - $ CALL DSWAP( M-2, H( 3, 2 ), LDH+1, H( 3, 1 ), 1 ) - IF( LTRANS ) THEN - JW = 1 - DO 20 J = 1, N - JW = JW + 1 - DO 10 I = 1, M - 1 - A( I, J ) = A( I, J ) + - $ ALPHA*H( I+1, 1 )*DWORK( JW ) - JW = JW + 1 - 10 CONTINUE - 20 CONTINUE - ELSE - JW = 0 - DO 40 J = 1, N - JW = JW + 1 - DO 30 I = 2, M - A( I, J ) = A( I, J ) + - $ ALPHA*H( I, 1 )*DWORK( JW ) - JW = JW + 1 - 30 CONTINUE - 40 CONTINUE - END IF - IF( M.GT.2 ) - $ CALL DSWAP( M-2, H( 3, 2 ), LDH+1, H( 3, 1 ), 1 ) -C - ELSE -C - IF( LTRANS ) THEN - JW = 1 - DO 50 J = 1, N - 1 - IF ( H( J+1, J ).NE.ZERO ) - $ CALL DAXPY( M, ALPHA*H( J+1, J ), DWORK( JW ), 1, - $ A( 1, J+1 ), 1 ) - JW = JW + M - 50 CONTINUE - ELSE - JW = M + 1 - DO 60 J = 1, N - 1 - IF ( H( J+1, J ).NE.ZERO ) - $ CALL DAXPY( M, ALPHA*H( J+1, J ), DWORK( JW ), 1, - $ A( 1, J ), 1 ) - JW = JW + M - 60 CONTINUE - END IF - END IF -C - ELSE -C -C Use a BLAS 2 calculation. -C - IF( LSIDE ) THEN - IF( M.GT.2 ) - $ CALL DSWAP( M-2, H( 3, 2 ), LDH+1, H( 3, 1 ), 1 ) - IF( LTRANS ) THEN - DO 80 J = 1, N -C -C Compute the contribution of the subdiagonal of H to -C the j-th column of the product. -C - DO 70 I = 1, M - 1 - DWORK( I ) = H( I+1, 1 )*A( I+1, J ) - 70 CONTINUE -C -C Multiply the upper triangle of H by the j-th column -C of A, and add to the above result. -C - CALL DTRMV( 'Upper', TRANS, 'Non-unit', M, H, LDH, - $ A( 1, J ), 1 ) - CALL DAXPY( M-1, ONE, DWORK, 1, A( 1, J ), 1 ) - 80 CONTINUE -C - ELSE - DO 100 J = 1, N -C -C Compute the contribution of the subdiagonal of H to -C the j-th column of the product. -C - DO 90 I = 1, M - 1 - DWORK( I ) = H( I+1, 1 )*A( I, J ) - 90 CONTINUE -C -C Multiply the upper triangle of H by the j-th column -C of A, and add to the above result. -C - CALL DTRMV( 'Upper', TRANS, 'Non-unit', M, H, LDH, - $ A( 1, J ), 1 ) - CALL DAXPY( M-1, ONE, DWORK, 1, A( 2, J ), 1 ) - 100 CONTINUE - END IF - IF( M.GT.2 ) - $ CALL DSWAP( M-2, H( 3, 2 ), LDH+1, H( 3, 1 ), 1 ) -C - ELSE -C -C Below, row-wise calculations are used for A. -C - IF( N.GT.2 ) - $ CALL DSWAP( N-2, H( 3, 2 ), LDH+1, H( 3, 1 ), 1 ) - IF( LTRANS ) THEN - DO 120 I = 1, M -C -C Compute the contribution of the subdiagonal of H to -C the i-th row of the product. -C - DO 110 J = 1, N - 1 - DWORK( J ) = A( I, J )*H( J+1, 1 ) - 110 CONTINUE -C -C Multiply the i-th row of A by the upper triangle of H, -C and add to the above result. -C - CALL DTRMV( 'Upper', 'NoTranspose', 'Non-unit', N, H, - $ LDH, A( I, 1 ), LDA ) - CALL DAXPY( N-1, ONE, DWORK, 1, A( I, 2 ), LDA ) - 120 CONTINUE -C - ELSE - DO 140 I = 1, M -C -C Compute the contribution of the subdiagonal of H to -C the i-th row of the product. -C - DO 130 J = 1, N - 1 - DWORK( J ) = A( I, J+1 )*H( J+1, 1 ) - 130 CONTINUE -C -C Multiply the i-th row of A by the upper triangle of H, -C and add to the above result. -C - CALL DTRMV( 'Upper', 'Transpose', 'Non-unit', N, H, - $ LDH, A( I, 1 ), LDA ) - CALL DAXPY( N-1, ONE, DWORK, 1, A( I, 1 ), LDA ) - 140 CONTINUE - END IF - IF( N.GT.2 ) - $ CALL DSWAP( N-2, H( 3, 2 ), LDH+1, H( 3, 1 ), 1 ) -C - END IF -C -C Scale the result by alpha. -C - IF ( ALPHA.NE.ONE ) - $ CALL DLASCL( 'General', 0, 0, ONE, ALPHA, M, N, A, LDA, - $ INFO ) - END IF - RETURN -C *** Last line of MB01UW *** - END diff --git a/mex/sources/libslicot/MB01UX.f b/mex/sources/libslicot/MB01UX.f deleted file mode 100644 index 166c23c44..000000000 --- a/mex/sources/libslicot/MB01UX.f +++ /dev/null @@ -1,373 +0,0 @@ - SUBROUTINE MB01UX( SIDE, UPLO, TRANS, M, N, ALPHA, T, LDT, A, LDA, - $ DWORK, LDWORK, INFO ) -C -C SLICOT RELEASE 5.0. -C -C Copyright (c) 2002-2009 NICONET e.V. -C -C This program is free software: you can redistribute it and/or -C modify it under the terms of the GNU General Public License as -C published by the Free Software Foundation, either version 2 of -C the License, or (at your option) any later version. -C -C This program is distributed in the hope that it will be useful, -C but WITHOUT ANY WARRANTY; without even the implied warranty of -C MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the -C GNU General Public License for more details. -C -C You should have received a copy of the GNU General Public License -C along with this program. If not, see -C . -C -C PURPOSE -C -C To compute one of the matrix products -C -C A : = alpha*op( T ) * A, or A : = alpha*A * op( T ), -C -C where alpha is a scalar, A is an m-by-n matrix, T is a quasi- -C triangular matrix, and op( T ) is one of -C -C op( T ) = T or op( T ) = T', the transpose of T. -C -C ARGUMENTS -C -C Mode Parameters -C -C SIDE CHARACTER*1 -C Specifies whether the upper quasi-triangular matrix H -C appears on the left or right in the matrix product as -C follows: -C = 'L': A := alpha*op( T ) * A; -C = 'R': A := alpha*A * op( T ). -C -C UPLO CHARACTER*1. -C Specifies whether the matrix T is an upper or lower -C quasi-triangular matrix as follows: -C = 'U': T is an upper quasi-triangular matrix; -C = 'L': T is a lower quasi-triangular matrix. -C -C TRANS CHARACTER*1 -C Specifies the form of op( T ) to be used in the matrix -C multiplication as follows: -C = 'N': op( T ) = T; -C = 'T': op( T ) = T'; -C = 'C': op( T ) = T'. -C -C Input/Output Parameters -C -C M (input) INTEGER -C The number of rows of the matrix A. M >= 0. -C -C N (input) INTEGER -C The number of columns of the matrix A. N >= 0. -C -C ALPHA (input) DOUBLE PRECISION -C The scalar alpha. When alpha is zero then T is not -C referenced and A need not be set before entry. -C -C T (input) DOUBLE PRECISION array, dimension (LDT,k) -C where k is M when SIDE = 'L' and is N when SIDE = 'R'. -C On entry with UPLO = 'U', the leading k-by-k upper -C Hessenberg part of this array must contain the upper -C quasi-triangular matrix T. The elements below the -C subdiagonal are not referenced. -C On entry with UPLO = 'L', the leading k-by-k lower -C Hessenberg part of this array must contain the lower -C quasi-triangular matrix T. The elements above the -C supdiagonal are not referenced. -C -C LDT INTEGER -C The leading dimension of the array T. LDT >= max(1,k), -C where k is M when SIDE = 'L' and is N when SIDE = 'R'. -C -C A (input/output) DOUBLE PRECISION array, dimension (LDA,N) -C On entry, the leading M-by-N part of this array must -C contain the matrix A. -C On exit, the leading M-by-N part of this array contains -C the computed product. -C -C LDA INTEGER -C The leading dimension of the array A. LDA >= max(1,M). -C -C Workspace -C -C DWORK DOUBLE PRECISION array, dimension (LDWORK) -C On exit, if INFO = 0 and ALPHA<>0, DWORK(1) returns the -C optimal value of LDWORK. -C On exit, if INFO = -12, DWORK(1) returns the minimum -C value of LDWORK. -C This array is not referenced when alpha = 0. -C -C LDWORK The length of the array DWORK. -C LDWORK >= 1, if alpha = 0 or MIN(M,N) = 0; -C LDWORK >= 2*(M-1), if SIDE = 'L'; -C LDWORK >= 2*(N-1), if SIDE = 'R'. -C For maximal efficiency LDWORK should be at least -C NOFF*N + M - 1, if SIDE = 'L'; -C NOFF*M + N - 1, if SIDE = 'R'; -C where NOFF is the number of nonzero elements on the -C subdiagonal (if UPLO = 'U') or supdiagonal (if UPLO = 'L') -C of T. -C -C Error Indicator -C -C INFO INTEGER -C = 0: successful exit; -C < 0: if INFO = -i, the i-th argument had an illegal -C value. -C -C METHOD -C -C The technique used in this routine is similiar to the technique -C used in the SLICOT [1] subroutine MB01UW developed by Vasile Sima. -C The required matrix product is computed in two steps. In the first -C step, the triangle of T specified by UPLO is used; in the second -C step, the contribution of the sub-/supdiagonal is added. If the -C workspace can accommodate parts of A, a fast BLAS 3 DTRMM -C operation is used in the first step. -C -C REFERENCES -C -C [1] Benner, P., Mehrmann, V., Sima, V., Van Huffel, S., and -C Varga, A. -C SLICOT - A subroutine library in systems and control theory. -C In: Applied and computational control, signals, and circuits, -C Vol. 1, pp. 499-539, Birkhauser, Boston, 1999. -C -C CONTRIBUTORS -C -C D. Kressner, Technical Univ. Berlin, Germany, and -C P. Benner, Technical Univ. Chemnitz, Germany, December 2003. -C -C REVISIONS -C -C V. Sima, May 2008 (SLICOT version of the HAPACK routine DTRQML). -C -C KEYWORDS -C -C Elementary matrix operations. -C -C ****************************************************************** -C -C .. Parameters .. - DOUBLE PRECISION ZERO, ONE - PARAMETER ( ZERO = 0.0D0, ONE = 1.0D0 ) -C .. Scalar Arguments .. - CHARACTER SIDE, TRANS, UPLO - INTEGER INFO, LDA, LDT, LDWORK, M, N - DOUBLE PRECISION ALPHA -C .. Array Arguments .. - DOUBLE PRECISION A(LDA,*), DWORK(*), T(LDT,*) -C .. Local Scalars .. - LOGICAL LSIDE, LTRAN, LUP - CHARACTER ATRAN - INTEGER I, IERR, J, K, NOFF, PDW, PSAV, WRKMIN, WRKOPT, - $ XDIF - DOUBLE PRECISION TEMP -C .. External Functions .. - LOGICAL LSAME - EXTERNAL LSAME -C .. External Subroutines .. - EXTERNAL DAXPY, DCOPY, DLASCL, DLASET, DTRMM, DTRMV, - $ XERBLA -C .. Intrinsic Functions .. - INTRINSIC MAX, MIN -C -C .. Executable Statements .. -C -C Decode and test the input scalar arguments. -C - INFO = 0 - LSIDE = LSAME( SIDE, 'L' ) - LUP = LSAME( UPLO, 'U' ) - LTRAN = LSAME( TRANS, 'T' ) .OR. LSAME( TRANS, 'C' ) - IF ( LSIDE ) THEN - K = M - ELSE - K = N - END IF - WRKMIN = 2*( K - 1 ) -C - IF ( ( .NOT.LSIDE ).AND.( .NOT.LSAME( SIDE, 'R' ) ) ) THEN - INFO = -1 - ELSE IF ( ( .NOT.LUP ).AND.( .NOT.LSAME( UPLO, 'L' ) ) ) THEN - INFO = -2 - ELSE IF ( ( .NOT.LTRAN ).AND.( .NOT.LSAME( TRANS, 'N' ) ) ) THEN - INFO = -3 - ELSE IF ( M.LT.0 ) THEN - INFO = -4 - ELSE IF ( N.LT.0 ) THEN - INFO = -5 - ELSE IF ( LDT.LT.MAX( 1, K ) ) THEN - INFO = -8 - ELSE IF ( LDA.LT.MAX( 1, M ) ) THEN - INFO = -10 - ELSE IF ( LDWORK.LT.0 .OR. - $ ( ALPHA.NE.ZERO .AND. MIN( M, N ).GT.0 .AND. - $ LDWORK.LT.WRKMIN ) ) THEN - DWORK(1) = DBLE( WRKMIN ) - INFO = -12 - END IF -C - IF ( INFO.NE.0 ) THEN -C -C Error return. -C - CALL XERBLA( 'MB01UX', -INFO ) - RETURN - END IF -C -C Quick return, if possible. -C - IF ( MIN( M, N ).EQ.0 ) - $ RETURN -C - IF ( ALPHA.EQ.ZERO ) THEN -C -C Set A to zero and return. -C - CALL DLASET( 'Full', M, N, ZERO, ZERO, A, LDA ) - RETURN - END IF -C -C Save and count off-diagonal entries of T. -C - IF ( LUP ) THEN - CALL DCOPY( K-1, T(2,1), LDT+1, DWORK, 1 ) - ELSE - CALL DCOPY( K-1, T(1,2), LDT+1, DWORK, 1 ) - END IF - NOFF = 0 - DO 5 I = 1, K-1 - IF ( DWORK(I).NE.ZERO ) - $ NOFF = NOFF + 1 - 5 CONTINUE -C -C Compute optimal workspace. -C - IF ( LSIDE ) THEN - WRKOPT = NOFF*N + M - 1 - ELSE - WRKOPT = NOFF*M + N - 1 - END IF - PSAV = K - IF ( .NOT.LTRAN ) THEN - XDIF = 0 - ELSE - XDIF = 1 - END IF - IF ( .NOT.LUP ) - $ XDIF = 1 - XDIF - IF ( .NOT.LSIDE ) - $ XDIF = 1 - XDIF -C - IF ( LDWORK.GE.WRKOPT ) THEN -C -C Enough workspace for a fast BLAS 3 calculation. -C Save relevant parts of A in the workspace and compute one of -C the matrix products -C A : = alpha*op( triu( T ) ) * A, or -C A : = alpha*A * op( triu( T ) ), -C involving the upper/lower triangle of T. -C - PDW = PSAV - IF ( LSIDE ) THEN - DO 20 J = 1, N - DO 10 I = 1, M-1 - IF ( DWORK(I).NE.ZERO ) THEN - DWORK(PDW) = A(I+XDIF,J) - PDW = PDW + 1 - END IF - 10 CONTINUE - 20 CONTINUE - ELSE - DO 30 J = 1, N-1 - IF ( DWORK(J).NE.ZERO ) THEN - CALL DCOPY( M, A(1,J+XDIF), 1, DWORK(PDW), 1 ) - PDW = PDW + M - END IF - 30 CONTINUE - END IF - CALL DTRMM( SIDE, UPLO, TRANS, 'Non-unit', M, N, ALPHA, T, - $ LDT, A, LDA ) -C -C Add the contribution of the offdiagonal of T. -C - PDW = PSAV - XDIF = 1 - XDIF - IF( LSIDE ) THEN - DO 50 J = 1, N - DO 40 I = 1, M-1 - TEMP = DWORK(I) - IF ( TEMP.NE.ZERO ) THEN - A(I+XDIF,J) = A(I+XDIF,J) + ALPHA * TEMP * - $ DWORK(PDW) - PDW = PDW + 1 - END IF - 40 CONTINUE - 50 CONTINUE - ELSE - DO 60 J = 1, N-1 - TEMP = DWORK(J)*ALPHA - IF ( TEMP.NE.ZERO ) THEN - CALL DAXPY( M, TEMP, DWORK(PDW), 1, A(1,J+XDIF), 1 ) - PDW = PDW + M - END IF - 60 CONTINUE - END IF - ELSE -C -C Use a BLAS 2 calculation. -C - IF ( LSIDE ) THEN - DO 80 J = 1, N -C -C Compute the contribution of the offdiagonal of T to -C the j-th column of the product. -C - DO 70 I = 1, M - 1 - DWORK(PSAV+I-1) = DWORK(I)*A(I+XDIF,J) - 70 CONTINUE -C -C Multiply the triangle of T by the j-th column of A, -C and add to the above result. -C - CALL DTRMV( UPLO, TRANS, 'Non-unit', M, T, LDT, A(1,J), - $ 1 ) - CALL DAXPY( M-1, ONE, DWORK(PSAV), 1, A(2-XDIF,J), 1 ) - 80 CONTINUE - ELSE - IF ( LTRAN ) THEN - ATRAN = 'N' - ELSE - ATRAN = 'T' - END IF - DO 100 I = 1, M -C -C Compute the contribution of the offdiagonal of T to -C the i-th row of the product. -C - DO 90 J = 1, N - 1 - DWORK(PSAV+J-1) = A(I,J+XDIF)*DWORK(J) - 90 CONTINUE -C -C Multiply the i-th row of A by the triangle of T, -C and add to the above result. -C - CALL DTRMV( UPLO, ATRAN, 'Non-unit', N, T, LDT, A(I,1), - $ LDA ) - CALL DAXPY( N-1, ONE, DWORK(PSAV), 1, A(I,2-XDIF), LDA ) - 100 CONTINUE - END IF -C -C Scale the result by alpha. -C - IF ( ALPHA.NE.ONE ) - $ CALL DLASCL( 'General', 0, 0, ONE, ALPHA, M, N, A, LDA, - $ IERR ) - END IF - DWORK(1) = DBLE( MAX( WRKMIN, WRKOPT ) ) - RETURN -C *** Last line of MB01UX *** - END diff --git a/mex/sources/libslicot/MB01VD.f b/mex/sources/libslicot/MB01VD.f deleted file mode 100644 index bcd924d68..000000000 --- a/mex/sources/libslicot/MB01VD.f +++ /dev/null @@ -1,1693 +0,0 @@ - SUBROUTINE MB01VD( TRANA, TRANB, MA, NA, MB, NB, ALPHA, BETA, - $ A, LDA, B, LDB, C, LDC, MC, NC, INFO ) -C -C SLICOT RELEASE 5.0. -C -C Copyright (c) 2002-2009 NICONET e.V. -C -C This program is free software: you can redistribute it and/or -C modify it under the terms of the GNU General Public License as -C published by the Free Software Foundation, either version 2 of -C the License, or (at your option) any later version. -C -C This program is distributed in the hope that it will be useful, -C but WITHOUT ANY WARRANTY; without even the implied warranty of -C MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the -C GNU General Public License for more details. -C -C You should have received a copy of the GNU General Public License -C along with this program. If not, see -C . -C -C PURPOSE -C -C To perform the following matrix operation -C -C C = alpha*kron( op(A), op(B) ) + beta*C, -C -C where alpha and beta are real scalars, op(M) is either matrix M or -C its transpose, M', and kron( X, Y ) denotes the Kronecker product -C of the matrices X and Y. -C -C ARGUMENTS -C -C Mode Parameters -C -C TRANA CHARACTER*1 -C Specifies the form of op(A) to be used as follows: -C = 'N': op(A) = A; -C = 'T': op(A) = A'; -C = 'C': op(A) = A'. -C -C TRANB CHARACTER*1 -C Specifies the form of op(B) to be used as follows: -C = 'N': op(B) = B; -C = 'T': op(B) = B'; -C = 'C': op(B) = B'. -C -C Input/Output Parameters -C -C MA (input) INTEGER -C The number of rows of the matrix op(A). MA >= 0. -C -C NA (input) INTEGER -C The number of columns of the matrix op(A). NA >= 0. -C -C MB (input) INTEGER -C The number of rows of the matrix op(B). MB >= 0. -C -C NB (input) INTEGER -C The number of columns of the matrix op(B). NB >= 0. -C -C ALPHA (input) DOUBLE PRECISION -C The scalar alpha. When alpha is zero then A and B need not -C be set before entry. -C -C BETA (input) DOUBLE PRECISION -C The scalar beta. When beta is zero then C need not be -C set before entry. -C -C A (input) DOUBLE PRECISION array, dimension (LDA,ka), -C where ka is NA when TRANA = 'N', and is MA otherwise. -C If TRANA = 'N', the leading MA-by-NA part of this array -C must contain the matrix A; otherwise, the leading NA-by-MA -C part of this array must contain the matrix A. -C -C LDA INTEGER -C The leading dimension of the array A. -C LDA >= max(1,MA), if TRANA = 'N'; -C LDA >= max(1,NA), if TRANA = 'T' or 'C'. -C -C B (input) DOUBLE PRECISION array, dimension (LDB,kb) -C where kb is NB when TRANB = 'N', and is MB otherwise. -C If TRANB = 'N', the leading MB-by-NB part of this array -C must contain the matrix B; otherwise, the leading NB-by-MB -C part of this array must contain the matrix B. -C -C LDB INTEGER -C The leading dimension of the array B. -C LDB >= max(1,MB), if TRANB = 'N'; -C LDB >= max(1,NB), if TRANB = 'T' or 'C'. -C -C C (input/output) DOUBLE PRECISION array, dimension (LDC,NC) -C On entry, if beta is nonzero, the leading MC-by-NC part of -C this array must contain the given matric C, where -C MC = MA*MB and NC = NA*NB. -C On exit, the leading MC-by-NC part of this array contains -C the computed matrix expression -C C = alpha*kron( op(A), op(B) ) + beta*C. -C -C LDC INTEGER -C The leading dimension of the array C. -C LDC >= max(1,MC). -C -C MC (output) INTEGER -C The number of rows of the matrix C. MC = MA*MB. -C -C NC (output) INTEGER -C The number of columns of the matrix C. NC = NA*NB. -C -C Error Indicator -C -C INFO INTEGER -C = 0: successful exit; -C < 0: if INFO = -i, the i-th argument had an illegal -C value. -C -C METHOD -C -C The Kronecker product of the matrices op(A) and op(B) is computed -C column by column. -C -C FURTHER COMMENTS -C -C The multiplications by zero elements in A are avoided, if the -C matrix A is considered to be sparse, i.e., if -C (number of zeros in A)/(MA*NA) >= SPARST = 0.8. The code makes -C NB+1 passes through the matrix A, and MA*NA passes through the -C matrix B. If LDA and/or LDB are very large, and op(A) = A' and/or -C op(B) = B', it could be more efficient to transpose A and/or B -C before calling this routine, and use the 'N' values for TRANA -C and/or TRANB. -C -C CONTRIBUTOR -C -C V. Sima, Katholieke Univ. Leuven, Belgium, February 2000. -C -C REVISIONS -C -C - -C -C KEYWORDS -C -C Elementary matrix operations, matrix operations. -C -C ****************************************************************** -C -C .. Parameters .. - DOUBLE PRECISION ZERO, ONE - PARAMETER ( ZERO = 0.0D0, ONE = 1.0D0 ) - DOUBLE PRECISION SPARST - PARAMETER ( SPARST = 0.8D0 ) -C .. Scalar Arguments .. - CHARACTER TRANA, TRANB - INTEGER INFO, LDA, LDB, LDC, MA, MB, MC, NA, NB, NC - DOUBLE PRECISION ALPHA, BETA -C .. Array Arguments .. - DOUBLE PRECISION A(LDA,*), B(LDB,*), C(LDC,*) -C .. Local Scalars .. - LOGICAL SPARSE, TRANSA, TRANSB - INTEGER I, IC, J, JC, K, L, LC, NZ - DOUBLE PRECISION AIJ -C .. Local Arrays .. - DOUBLE PRECISION DUM(1) -C .. External Functions .. - LOGICAL LSAME - EXTERNAL LSAME -C .. External Subroutines .. - EXTERNAL DCOPY, DLASET, DSCAL, XERBLA -C .. Intrinsic Functions .. - INTRINSIC DBLE, MAX -C -C .. Executable Statements .. -C -C Test the input scalar arguments. -C - TRANSA = LSAME( TRANA, 'T' ) .OR. LSAME( TRANA, 'C' ) - TRANSB = LSAME( TRANB, 'T' ) .OR. LSAME( TRANB, 'C' ) - MC = MA*MB - INFO = 0 - IF( .NOT.( TRANSA .OR. LSAME( TRANA, 'N' ) ) ) THEN - INFO = -1 - ELSE IF( .NOT.( TRANSB .OR. LSAME( TRANB, 'N' ) ) ) THEN - INFO = -2 - ELSE IF( MA.LT.0 ) THEN - INFO = -3 - ELSE IF( NA.LT.0 ) THEN - INFO = -4 - ELSE IF( MB.LT.0 ) THEN - INFO = -5 - ELSE IF( NB.LT.0 ) THEN - INFO = -6 - ELSE IF( ( TRANSA .AND. LDA.LT.NA ) .OR. LDA.LT.1 .OR. - $ ( .NOT.TRANSA .AND. LDA.LT.MA ) ) THEN - INFO = -10 - ELSE IF( ( TRANSB .AND. LDB.LT.NB ) .OR. LDB.LT.1 .OR. - $ ( .NOT.TRANSB .AND. LDB.LT.MB ) ) THEN - INFO = -12 - ELSE IF( LDC.LT.MAX( 1, MC ) ) THEN - INFO = -14 - END IF -C - IF ( INFO.NE.0 ) THEN -C -C Error return. -C - CALL XERBLA( 'MB01VD', -INFO ) - RETURN - END IF -C -C Quick return, if possible. -C - NC = NA*NB - IF ( MC.EQ.0 .OR. NC.EQ.0 ) - $ RETURN -C - IF ( ALPHA.EQ.ZERO ) THEN - IF ( BETA.EQ.ZERO ) THEN - CALL DLASET( 'Full', MC, NC, ZERO, ZERO, C, LDC ) - ELSE IF ( BETA.NE.ONE ) THEN -C - DO 10 J = 1, NC - CALL DSCAL( MC, BETA, C(1,J), 1 ) - 10 CONTINUE -C - END IF - RETURN - END IF -C - DUM(1) = ZERO - JC = 1 - NZ = 0 -C -C Compute the Kronecker product of the matrices op(A) and op(B), -C C = alpha*kron( op(A), op(B) ) + beta*C. -C First, check if A is sparse. Here, A is considered as being sparse -C if (number of zeros in A)/(MA*NA) >= SPARST. -C - DO 30 J = 1, NA -C - DO 20 I = 1, MA - IF ( TRANSA ) THEN - IF ( A(J,I).EQ.ZERO ) - $ NZ = NZ + 1 - ELSE - IF ( A(I,J).EQ.ZERO ) - $ NZ = NZ + 1 - END IF - 20 CONTINUE -C - 30 CONTINUE -C - SPARSE = DBLE( NZ )/DBLE( MA*NA ).GE.SPARST -C - IF ( .NOT.TRANSA .AND. .NOT.TRANSB ) THEN -C -C Case op(A) = A and op(B) = B. -C - IF ( BETA.EQ.ZERO ) THEN - IF ( ALPHA.EQ.ONE ) THEN - IF ( SPARSE ) THEN -C -C Case beta = 0, alpha = 1, A sparse. -C - DO 80 J = 1, NA -C - DO 70 K = 1, NB - IC = 1 -C - DO 60 I = 1, MA - AIJ = A(I,J) - IF ( AIJ.EQ.ZERO ) THEN - CALL DCOPY( MB, DUM(1), 0, C(IC,JC), 1 ) - ELSE IF ( AIJ.EQ.ONE ) THEN - CALL DCOPY( MB, B(1,K), 1, C(IC,JC), 1 ) - ELSE - LC = IC -C - DO 50 L = 1, MB - C(LC,JC) = AIJ*B(L,K) - LC = LC + 1 - 50 CONTINUE -C - END IF - IC = IC + MB - 60 CONTINUE -C - JC = JC + 1 - 70 CONTINUE -C - 80 CONTINUE -C - ELSE -C -C Case beta = 0, alpha = 1, A not sparse. -C - DO 120 J = 1, NA -C - DO 110 K = 1, NB - IC = 1 -C - DO 100 I = 1, MA - AIJ = A(I,J) - LC = IC -C - DO 90 L = 1, MB - C(LC,JC) = AIJ*B(L,K) - LC = LC + 1 - 90 CONTINUE -C - IC = IC + MB - 100 CONTINUE -C - JC = JC + 1 - 110 CONTINUE -C - 120 CONTINUE -C - END IF - ELSE - IF ( SPARSE ) THEN -C -C Case beta = 0, alpha <> 1, A sparse. -C - DO 160 J = 1, NA -C - DO 150 K = 1, NB - IC = 1 -C - DO 140 I = 1, MA - AIJ = ALPHA*A(I,J) - IF ( AIJ.EQ.ZERO ) THEN - CALL DCOPY( MB, DUM(1), 0, C(IC,JC), 1 ) - ELSE - LC = IC -C - DO 130 L = 1, MB - C(LC,JC) = AIJ*B(L,K) - LC = LC + 1 - 130 CONTINUE -C - END IF - IC = IC + MB - 140 CONTINUE -C - JC = JC + 1 - 150 CONTINUE -C - 160 CONTINUE -C - ELSE -C -C Case beta = 0, alpha <> 1, A not sparse. -C - DO 200 J = 1, NA -C - DO 190 K = 1, NB - IC = 1 -C - DO 180 I = 1, MA - AIJ = ALPHA*A(I,J) - LC = IC -C - DO 170 L = 1, MB - C(LC,JC) = AIJ*B(L,K) - LC = LC + 1 - 170 CONTINUE -C - IC = IC + MB - 180 CONTINUE -C - JC = JC + 1 - 190 CONTINUE -C - 200 CONTINUE -C - END IF - END IF - ELSE IF ( BETA.EQ.ONE ) THEN - IF ( ALPHA.EQ.ONE ) THEN - IF ( SPARSE ) THEN -C -C Case beta = 1, alpha = 1, A sparse. -C - DO 240 J = 1, NA -C - DO 230 K = 1, NB - IC = 1 -C - DO 220 I = 1, MA - AIJ = A(I,J) - IF ( AIJ.NE.ZERO ) THEN - LC = IC -C - DO 210 L = 1, MB - C(LC,JC) = C(LC,JC) + AIJ*B(L,K) - LC = LC + 1 - 210 CONTINUE -C - END IF - IC = IC + MB - 220 CONTINUE -C - JC = JC + 1 - 230 CONTINUE -C - 240 CONTINUE -C - ELSE -C -C Case beta = 1, alpha = 1, A not sparse. -C - DO 280 J = 1, NA -C - DO 270 K = 1, NB - IC = 1 -C - DO 260 I = 1, MA - AIJ = A(I,J) - LC = IC -C - DO 250 L = 1, MB - C(LC,JC) = C(LC,JC) + AIJ*B(L,K) - LC = LC + 1 - 250 CONTINUE -C - IC = IC + MB - 260 CONTINUE -C - JC = JC + 1 - 270 CONTINUE -C - 280 CONTINUE -C - END IF - ELSE - IF ( SPARSE ) THEN -C -C Case beta = 1, alpha <> 1, A sparse. -C - DO 320 J = 1, NA -C - DO 310 K = 1, NB - IC = 1 -C - DO 300 I = 1, MA - AIJ = ALPHA*A(I,J) - IF ( AIJ.NE.ZERO ) THEN - LC = IC -C - DO 290 L = 1, MB - C(LC,JC) = C(LC,JC) + AIJ*B(L,K) - LC = LC + 1 - 290 CONTINUE -C - END IF - IC = IC + MB - 300 CONTINUE -C - JC = JC + 1 - 310 CONTINUE -C - 320 CONTINUE -C - ELSE -C -C Case beta = 1, alpha <> 1, A not sparse. -C - DO 360 J = 1, NA -C - DO 350 K = 1, NB - IC = 1 -C - DO 340 I = 1, MA - AIJ = ALPHA*A(I,J) - LC = IC -C - DO 330 L = 1, MB - C(LC,JC) = C(LC,JC) + AIJ*B(L,K) - LC = LC + 1 - 330 CONTINUE -C - IC = IC + MB - 340 CONTINUE -C - JC = JC + 1 - 350 CONTINUE -C - 360 CONTINUE -C - END IF - END IF - ELSE - IF ( ALPHA.EQ.ONE ) THEN - IF ( SPARSE ) THEN -C -C Case beta <> 0 or 1, alpha = 1, A sparse. -C - DO 400 J = 1, NA -C - DO 390 K = 1, NB - IC = 1 -C - DO 380 I = 1, MA - AIJ = A(I,J) -C - IF ( AIJ.EQ.ZERO ) THEN - CALL DSCAL( MB, BETA, C(IC,JC), 1 ) - ELSE - LC = IC -C - DO 370 L = 1, MB - C(LC,JC) = BETA*C(LC,JC) + AIJ*B(L,K) - LC = LC + 1 - 370 CONTINUE -C - END IF - IC = IC + MB - 380 CONTINUE -C - JC = JC + 1 - 390 CONTINUE -C - 400 CONTINUE -C - ELSE -C -C Case beta <> 0 or 1, alpha = 1, A not sparse. -C - DO 440 J = 1, NA -C - DO 430 K = 1, NB - IC = 1 -C - DO 420 I = 1, MA - AIJ = A(I,J) - LC = IC -C - DO 410 L = 1, MB - C(LC,JC) = BETA*C(LC,JC) + AIJ*B(L,K) - LC = LC + 1 - 410 CONTINUE -C - IC = IC + MB - 420 CONTINUE -C - JC = JC + 1 - 430 CONTINUE -C - 440 CONTINUE -C - END IF - ELSE - IF ( SPARSE ) THEN -C -C Case beta <> 0 or 1, alpha <> 1, A sparse. -C - DO 480 J = 1, NA -C - DO 470 K = 1, NB - IC = 1 -C - DO 460 I = 1, MA - AIJ = ALPHA*A(I,J) -C - IF ( AIJ.EQ.ZERO ) THEN - CALL DSCAL( MB, BETA, C(IC,JC), 1 ) - ELSE - LC = IC -C - DO 450 L = 1, MB - C(LC,JC) = BETA*C(LC,JC) + AIJ*B(L,K) - LC = LC + 1 - 450 CONTINUE -C - END IF - IC = IC + MB - 460 CONTINUE -C - JC = JC + 1 - 470 CONTINUE -C - 480 CONTINUE -C - ELSE -C -C Case beta <> 0 or 1, alpha <> 1, A not sparse. -C - DO 520 J = 1, NA -C - DO 510 K = 1, NB - IC = 1 -C - DO 500 I = 1, MA - AIJ = ALPHA*A(I,J) - LC = IC -C - DO 490 L = 1, MB - C(LC,JC) = BETA*C(LC,JC) + AIJ*B(L,K) - LC = LC + 1 - 490 CONTINUE -C - IC = IC + MB - 500 CONTINUE -C - JC = JC + 1 - 510 CONTINUE -C - 520 CONTINUE -C - END IF - END IF - END IF - ELSE IF ( TRANSA .AND. .NOT.TRANSB ) THEN -C -C Case op(A) = A' and op(B) = B. -C - IF ( BETA.EQ.ZERO ) THEN - IF ( ALPHA.EQ.ONE ) THEN - IF ( SPARSE ) THEN -C -C Case beta = 0, alpha = 1, A sparse. -C - DO 560 J = 1, NA -C - DO 550 K = 1, NB - IC = 1 -C - DO 540 I = 1, MA - AIJ = A(J,I) - IF ( AIJ.EQ.ZERO ) THEN - CALL DCOPY( MB, DUM(1), 0, C(IC,JC), 1 ) - ELSE IF ( AIJ.EQ.ONE ) THEN - CALL DCOPY( MB, B(1,K), 1, C(IC,JC), 1 ) - ELSE - LC = IC -C - DO 530 L = 1, MB - C(LC,JC) = AIJ*B(L,K) - LC = LC + 1 - 530 CONTINUE -C - END IF - IC = IC + MB - 540 CONTINUE -C - JC = JC + 1 - 550 CONTINUE -C - 560 CONTINUE -C - ELSE -C -C Case beta = 0, alpha = 1, A not sparse. -C - DO 600 J = 1, NA -C - DO 590 K = 1, NB - IC = 1 -C - DO 580 I = 1, MA - AIJ = A(J,I) - LC = IC -C - DO 570 L = 1, MB - C(LC,JC) = AIJ*B(L,K) - LC = LC + 1 - 570 CONTINUE -C - IC = IC + MB - 580 CONTINUE -C - JC = JC + 1 - 590 CONTINUE -C - 600 CONTINUE -C - END IF - ELSE - IF ( SPARSE ) THEN -C -C Case beta = 0, alpha <> 1, A sparse. -C - DO 640 J = 1, NA -C - DO 630 K = 1, NB - IC = 1 -C - DO 620 I = 1, MA - AIJ = ALPHA*A(J,I) - IF ( AIJ.EQ.ZERO ) THEN - CALL DCOPY( MB, DUM(1), 0, C(IC,JC), 1 ) - ELSE - LC = IC -C - DO 610 L = 1, MB - C(LC,JC) = AIJ*B(L,K) - LC = LC + 1 - 610 CONTINUE -C - END IF - IC = IC + MB - 620 CONTINUE -C - JC = JC + 1 - 630 CONTINUE -C - 640 CONTINUE -C - ELSE -C -C Case beta = 0, alpha <> 1, A not sparse. -C - DO 680 J = 1, NA -C - DO 670 K = 1, NB - IC = 1 -C - DO 660 I = 1, MA - AIJ = ALPHA*A(J,I) - LC = IC -C - DO 650 L = 1, MB - C(LC,JC) = AIJ*B(L,K) - LC = LC + 1 - 650 CONTINUE -C - IC = IC + MB - 660 CONTINUE -C - JC = JC + 1 - 670 CONTINUE -C - 680 CONTINUE -C - END IF - END IF - ELSE IF ( BETA.EQ.ONE ) THEN - IF ( ALPHA.EQ.ONE ) THEN - IF ( SPARSE ) THEN -C -C Case beta = 1, alpha = 1, A sparse. -C - DO 720 J = 1, NA -C - DO 710 K = 1, NB - IC = 1 -C - DO 700 I = 1, MA - AIJ = A(J,I) - IF ( AIJ.NE.ZERO ) THEN - LC = IC -C - DO 690 L = 1, MB - C(LC,JC) = C(LC,JC) + AIJ*B(L,K) - LC = LC + 1 - 690 CONTINUE -C - END IF - IC = IC + MB - 700 CONTINUE -C - JC = JC + 1 - 710 CONTINUE -C - 720 CONTINUE -C - ELSE -C -C Case beta = 1, alpha = 1, A not sparse. -C - DO 760 J = 1, NA -C - DO 750 K = 1, NB - IC = 1 -C - DO 740 I = 1, MA - AIJ = A(J,I) - LC = IC -C - DO 730 L = 1, MB - C(LC,JC) = C(LC,JC) + AIJ*B(L,K) - LC = LC + 1 - 730 CONTINUE -C - IC = IC + MB - 740 CONTINUE -C - JC = JC + 1 - 750 CONTINUE -C - 760 CONTINUE -C - END IF - ELSE - IF ( SPARSE ) THEN -C -C Case beta = 1, alpha <> 1, A sparse. -C - DO 800 J = 1, NA -C - DO 790 K = 1, NB - IC = 1 -C - DO 780 I = 1, MA - AIJ = ALPHA*A(J,I) - IF ( AIJ.NE.ZERO ) THEN - LC = IC -C - DO 770 L = 1, MB - C(LC,JC) = C(LC,JC) + AIJ*B(L,K) - LC = LC + 1 - 770 CONTINUE -C - END IF - IC = IC + MB - 780 CONTINUE -C - JC = JC + 1 - 790 CONTINUE -C - 800 CONTINUE -C - ELSE -C -C Case beta = 1, alpha <> 1, A not sparse. -C - DO 840 J = 1, NA -C - DO 830 K = 1, NB - IC = 1 -C - DO 820 I = 1, MA - AIJ = ALPHA*A(J,I) - LC = IC -C - DO 810 L = 1, MB - C(LC,JC) = C(LC,JC) + AIJ*B(L,K) - LC = LC + 1 - 810 CONTINUE -C - IC = IC + MB - 820 CONTINUE -C - JC = JC + 1 - 830 CONTINUE -C - 840 CONTINUE -C - END IF - END IF - ELSE - IF ( ALPHA.EQ.ONE ) THEN - IF ( SPARSE ) THEN -C -C Case beta <> 0 or 1, alpha = 1, A sparse. -C - DO 880 J = 1, NA -C - DO 870 K = 1, NB - IC = 1 -C - DO 860 I = 1, MA - AIJ = A(J,I) -C - IF ( AIJ.EQ.ZERO ) THEN - CALL DSCAL( MB, BETA, C(IC,JC), 1 ) - ELSE - LC = IC -C - DO 850 L = 1, MB - C(LC,JC) = BETA*C(LC,JC) + AIJ*B(L,K) - LC = LC + 1 - 850 CONTINUE -C - END IF - IC = IC + MB - 860 CONTINUE -C - JC = JC + 1 - 870 CONTINUE -C - 880 CONTINUE -C - ELSE -C -C Case beta <> 0 or 1, alpha = 1, A not sparse. -C - DO 920 J = 1, NA -C - DO 910 K = 1, NB - IC = 1 -C - DO 900 I = 1, MA - AIJ = A(J,I) - LC = IC -C - DO 890 L = 1, MB - C(LC,JC) = BETA*C(LC,JC) + AIJ*B(L,K) - LC = LC + 1 - 890 CONTINUE -C - IC = IC + MB - 900 CONTINUE -C - JC = JC + 1 - 910 CONTINUE -C - 920 CONTINUE -C - END IF - ELSE - IF ( SPARSE ) THEN -C -C Case beta <> 0 or 1, alpha <> 1, A sparse. -C - DO 960 J = 1, NA -C - DO 950 K = 1, NB - IC = 1 -C - DO 940 I = 1, MA - AIJ = ALPHA*A(J,I) -C - IF ( AIJ.EQ.ZERO ) THEN - CALL DSCAL( MB, BETA, C(IC,JC), 1 ) - ELSE - LC = IC -C - DO 930 L = 1, MB - C(LC,JC) = BETA*C(LC,JC) + AIJ*B(L,K) - LC = LC + 1 - 930 CONTINUE -C - END IF - IC = IC + MB - 940 CONTINUE -C - JC = JC + 1 - 950 CONTINUE -C - 960 CONTINUE -C - ELSE -C -C Case beta <> 0 or 1, alpha <> 1, A not sparse. -C - DO 1000 J = 1, NA -C - DO 990 K = 1, NB - IC = 1 -C - DO 980 I = 1, MA - AIJ = ALPHA*A(J,I) - LC = IC -C - DO 970 L = 1, MB - C(LC,JC) = BETA*C(LC,JC) + AIJ*B(L,K) - LC = LC + 1 - 970 CONTINUE -C - IC = IC + MB - 980 CONTINUE -C - JC = JC + 1 - 990 CONTINUE -C - 1000 CONTINUE -C - END IF - END IF - END IF - ELSE IF ( TRANSB .AND. .NOT.TRANSA ) THEN -C -C Case op(A) = A and op(B) = B'. -C - IF ( BETA.EQ.ZERO ) THEN - IF ( ALPHA.EQ.ONE ) THEN - IF ( SPARSE ) THEN -C -C Case beta = 0, alpha = 1, A sparse. -C - DO 1080 J = 1, NA -C - DO 1070 K = 1, NB - IC = 1 -C - DO 1060 I = 1, MA - AIJ = A(I,J) - IF ( AIJ.EQ.ZERO ) THEN - CALL DCOPY( MB, DUM(1), 0, C(IC,JC), 1 ) - ELSE IF ( AIJ.EQ.ONE ) THEN - CALL DCOPY( MB, B(K,1), LDB, C(IC,JC), 1 ) - ELSE - LC = IC -C - DO 1050 L = 1, MB - C(LC,JC) = AIJ*B(K,L) - LC = LC + 1 - 1050 CONTINUE -C - END IF - IC = IC + MB - 1060 CONTINUE -C - JC = JC + 1 - 1070 CONTINUE -C - 1080 CONTINUE -C - ELSE -C -C Case beta = 0, alpha = 1, A not sparse. -C - DO 1120 J = 1, NA -C - DO 1110 K = 1, NB - IC = 1 -C - DO 1100 I = 1, MA - AIJ = A(I,J) - LC = IC -C - DO 1090 L = 1, MB - C(LC,JC) = AIJ*B(K,L) - LC = LC + 1 - 1090 CONTINUE -C - IC = IC + MB - 1100 CONTINUE -C - JC = JC + 1 - 1110 CONTINUE -C - 1120 CONTINUE -C - END IF - ELSE - IF ( SPARSE ) THEN -C -C Case beta = 0, alpha <> 1, A sparse. -C - DO 1160 J = 1, NA -C - DO 1150 K = 1, NB - IC = 1 -C - DO 1140 I = 1, MA - AIJ = ALPHA*A(I,J) - IF ( AIJ.EQ.ZERO ) THEN - CALL DCOPY( MB, DUM(1), 0, C(IC,JC), 1 ) - ELSE - LC = IC -C - DO 1130 L = 1, MB - C(LC,JC) = AIJ*B(K,L) - LC = LC + 1 - 1130 CONTINUE -C - END IF - IC = IC + MB - 1140 CONTINUE -C - JC = JC + 1 - 1150 CONTINUE -C - 1160 CONTINUE -C - ELSE -C -C Case beta = 0, alpha <> 1, A not sparse. -C - DO 1200 J = 1, NA -C - DO 1190 K = 1, NB - IC = 1 -C - DO 1180 I = 1, MA - AIJ = ALPHA*A(I,J) - LC = IC -C - DO 1170 L = 1, MB - C(LC,JC) = AIJ*B(K,L) - LC = LC + 1 - 1170 CONTINUE -C - IC = IC + MB - 1180 CONTINUE -C - JC = JC + 1 - 1190 CONTINUE -C - 1200 CONTINUE -C - END IF - END IF - ELSE IF ( BETA.EQ.ONE ) THEN - IF ( ALPHA.EQ.ONE ) THEN - IF ( SPARSE ) THEN -C -C Case beta = 1, alpha = 1, A sparse. -C - DO 1240 J = 1, NA -C - DO 1230 K = 1, NB - IC = 1 -C - DO 1220 I = 1, MA - AIJ = A(I,J) - IF ( AIJ.NE.ZERO ) THEN - LC = IC -C - DO 1210 L = 1, MB - C(LC,JC) = C(LC,JC) + AIJ*B(K,L) - LC = LC + 1 - 1210 CONTINUE -C - END IF - IC = IC + MB - 1220 CONTINUE -C - JC = JC + 1 - 1230 CONTINUE -C - 1240 CONTINUE -C - ELSE -C -C Case beta = 1, alpha = 1, A not sparse. -C - DO 1280 J = 1, NA -C - DO 1270 K = 1, NB - IC = 1 -C - DO 1260 I = 1, MA - AIJ = A(I,J) - LC = IC -C - DO 1250 L = 1, MB - C(LC,JC) = C(LC,JC) + AIJ*B(K,L) - LC = LC + 1 - 1250 CONTINUE -C - IC = IC + MB - 1260 CONTINUE -C - JC = JC + 1 - 1270 CONTINUE -C - 1280 CONTINUE -C - END IF - ELSE - IF ( SPARSE ) THEN -C -C Case beta = 1, alpha <> 1, A sparse. -C - DO 1320 J = 1, NA -C - DO 1310 K = 1, NB - IC = 1 -C - DO 1300 I = 1, MA - AIJ = ALPHA*A(I,J) - IF ( AIJ.NE.ZERO ) THEN - LC = IC -C - DO 1290 L = 1, MB - C(LC,JC) = C(LC,JC) + AIJ*B(K,L) - LC = LC + 1 - 1290 CONTINUE -C - END IF - IC = IC + MB - 1300 CONTINUE -C - JC = JC + 1 - 1310 CONTINUE -C - 1320 CONTINUE -C - ELSE -C -C Case beta = 1, alpha <> 1, A not sparse. -C - DO 1360 J = 1, NA -C - DO 1350 K = 1, NB - IC = 1 -C - DO 1340 I = 1, MA - AIJ = ALPHA*A(I,J) - LC = IC -C - DO 1330 L = 1, MB - C(LC,JC) = C(LC,JC) + AIJ*B(K,L) - LC = LC + 1 - 1330 CONTINUE -C - IC = IC + MB - 1340 CONTINUE -C - JC = JC + 1 - 1350 CONTINUE -C - 1360 CONTINUE -C - END IF - END IF - ELSE - IF ( ALPHA.EQ.ONE ) THEN - IF ( SPARSE ) THEN -C -C Case beta <> 0 or 1, alpha = 1, A sparse. -C - DO 1400 J = 1, NA -C - DO 1390 K = 1, NB - IC = 1 -C - DO 1380 I = 1, MA - AIJ = A(I,J) -C - IF ( AIJ.EQ.ZERO ) THEN - CALL DSCAL( MB, BETA, C(IC,JC), 1 ) - ELSE - LC = IC -C - DO 1370 L = 1, MB - C(LC,JC) = BETA*C(LC,JC) + AIJ*B(K,L) - LC = LC + 1 - 1370 CONTINUE -C - END IF - IC = IC + MB - 1380 CONTINUE -C - JC = JC + 1 - 1390 CONTINUE -C - 1400 CONTINUE -C - ELSE -C -C Case beta <> 0 or 1, alpha = 1, A not sparse. -C - DO 1440 J = 1, NA -C - DO 1430 K = 1, NB - IC = 1 -C - DO 1420 I = 1, MA - AIJ = A(I,J) - LC = IC -C - DO 1410 L = 1, MB - C(LC,JC) = BETA*C(LC,JC) + AIJ*B(K,L) - LC = LC + 1 - 1410 CONTINUE -C - IC = IC + MB - 1420 CONTINUE -C - JC = JC + 1 - 1430 CONTINUE -C - 1440 CONTINUE -C - END IF - ELSE - IF ( SPARSE ) THEN -C -C Case beta <> 0 or 1, alpha <> 1, A sparse. -C - DO 1480 J = 1, NA -C - DO 1470 K = 1, NB - IC = 1 -C - DO 1460 I = 1, MA - AIJ = ALPHA*A(I,J) -C - IF ( AIJ.EQ.ZERO ) THEN - CALL DSCAL( MB, BETA, C(IC,JC), 1 ) - ELSE - LC = IC -C - DO 1450 L = 1, MB - C(LC,JC) = BETA*C(LC,JC) + AIJ*B(K,L) - LC = LC + 1 - 1450 CONTINUE -C - END IF - IC = IC + MB - 1460 CONTINUE -C - JC = JC + 1 - 1470 CONTINUE -C - 1480 CONTINUE -C - ELSE -C -C Case beta <> 0 or 1, alpha <> 1, A not sparse. -C - DO 1520 J = 1, NA -C - DO 1510 K = 1, NB - IC = 1 -C - DO 1500 I = 1, MA - AIJ = ALPHA*A(I,J) - LC = IC -C - DO 1490 L = 1, MB - C(LC,JC) = BETA*C(LC,JC) + AIJ*B(K,L) - LC = LC + 1 - 1490 CONTINUE -C - IC = IC + MB - 1500 CONTINUE -C - JC = JC + 1 - 1510 CONTINUE -C - 1520 CONTINUE -C - END IF - END IF - END IF - ELSE -C -C Case op(A) = A' and op(B) = B'. -C - IF ( BETA.EQ.ZERO ) THEN - IF ( ALPHA.EQ.ONE ) THEN - IF ( SPARSE ) THEN -C -C Case beta = 0, alpha = 1, A sparse. -C - DO 1580 J = 1, NA -C - DO 1570 K = 1, NB - IC = 1 -C - DO 1560 I = 1, MA - AIJ = A(J,I) - IF ( AIJ.EQ.ZERO ) THEN - CALL DCOPY( MB, DUM(1), 0, C(IC,JC), 1 ) - ELSE IF ( AIJ.EQ.ONE ) THEN - CALL DCOPY( MB, B(K,1), LDB, C(IC,JC), 1 ) - ELSE - LC = IC -C - DO 1550 L = 1, MB - C(LC,JC) = AIJ*B(K,L) - LC = LC + 1 - 1550 CONTINUE -C - END IF - IC = IC + MB - 1560 CONTINUE -C - JC = JC + 1 - 1570 CONTINUE -C - 1580 CONTINUE -C - ELSE -C -C Case beta = 0, alpha = 1, A not sparse. -C - DO 1620 J = 1, NA -C - DO 1610 K = 1, NB - IC = 1 -C - DO 1600 I = 1, MA - AIJ = A(J,I) - LC = IC -C - DO 1590 L = 1, MB - C(LC,JC) = AIJ*B(K,L) - LC = LC + 1 - 1590 CONTINUE -C - IC = IC + MB - 1600 CONTINUE -C - JC = JC + 1 - 1610 CONTINUE -C - 1620 CONTINUE -C - END IF - ELSE - IF ( SPARSE ) THEN -C -C Case beta = 0, alpha <> 1, A sparse. -C - DO 1660 J = 1, NA -C - DO 1650 K = 1, NB - IC = 1 -C - DO 1640 I = 1, MA - AIJ = ALPHA*A(J,I) - IF ( AIJ.EQ.ZERO ) THEN - CALL DCOPY( MB, DUM(1), 0, C(IC,JC), 1 ) - ELSE - LC = IC -C - DO 1630 L = 1, MB - C(LC,JC) = AIJ*B(K,L) - LC = LC + 1 - 1630 CONTINUE -C - END IF - IC = IC + MB - 1640 CONTINUE -C - JC = JC + 1 - 1650 CONTINUE -C - 1660 CONTINUE -C - ELSE -C -C Case beta = 0, alpha <> 1, A not sparse. -C - DO 1700 J = 1, NA -C - DO 1690 K = 1, NB - IC = 1 -C - DO 1680 I = 1, MA - AIJ = ALPHA*A(J,I) - LC = IC -C - DO 1670 L = 1, MB - C(LC,JC) = AIJ*B(K,L) - LC = LC + 1 - 1670 CONTINUE -C - IC = IC + MB - 1680 CONTINUE -C - JC = JC + 1 - 1690 CONTINUE -C - 1700 CONTINUE -C - END IF - END IF - ELSE IF ( BETA.EQ.ONE ) THEN - IF ( ALPHA.EQ.ONE ) THEN - IF ( SPARSE ) THEN -C -C Case beta = 1, alpha = 1, A sparse. -C - DO 1740 J = 1, NA -C - DO 1730 K = 1, NB - IC = 1 -C - DO 1720 I = 1, MA - AIJ = A(J,I) - IF ( AIJ.NE.ZERO ) THEN - LC = IC -C - DO 1710 L = 1, MB - C(LC,JC) = C(LC,JC) + AIJ*B(K,L) - LC = LC + 1 - 1710 CONTINUE -C - END IF - IC = IC + MB - 1720 CONTINUE -C - JC = JC + 1 - 1730 CONTINUE -C - 1740 CONTINUE -C - ELSE -C -C Case beta = 1, alpha = 1, A not sparse. -C - DO 1780 J = 1, NA -C - DO 1770 K = 1, NB - IC = 1 -C - DO 1760 I = 1, MA - AIJ = A(J,I) - LC = IC -C - DO 1750 L = 1, MB - C(LC,JC) = C(LC,JC) + AIJ*B(K,L) - LC = LC + 1 - 1750 CONTINUE -C - IC = IC + MB - 1760 CONTINUE -C - JC = JC + 1 - 1770 CONTINUE -C - 1780 CONTINUE -C - END IF - ELSE - IF ( SPARSE ) THEN -C -C Case beta = 1, alpha <> 1, A sparse. -C - DO 1820 J = 1, NA -C - DO 1810 K = 1, NB - IC = 1 -C - DO 1800 I = 1, MA - AIJ = ALPHA*A(J,I) - IF ( AIJ.NE.ZERO ) THEN - LC = IC -C - DO 1790 L = 1, MB - C(LC,JC) = C(LC,JC) + AIJ*B(K,L) - LC = LC + 1 - 1790 CONTINUE -C - END IF - IC = IC + MB - 1800 CONTINUE -C - JC = JC + 1 - 1810 CONTINUE -C - 1820 CONTINUE -C - ELSE -C -C Case beta = 1, alpha <> 1, A not sparse. -C - DO 1860 J = 1, NA -C - DO 1850 K = 1, NB - IC = 1 -C - DO 1840 I = 1, MA - AIJ = ALPHA*A(J,I) - LC = IC -C - DO 1830 L = 1, MB - C(LC,JC) = C(LC,JC) + AIJ*B(K,L) - LC = LC + 1 - 1830 CONTINUE -C - IC = IC + MB - 1840 CONTINUE -C - JC = JC + 1 - 1850 CONTINUE -C - 1860 CONTINUE -C - END IF - END IF - ELSE - IF ( ALPHA.EQ.ONE ) THEN - IF ( SPARSE ) THEN -C -C Case beta <> 0 or 1, alpha = 1, A sparse. -C - DO 1900 J = 1, NA -C - DO 1890 K = 1, NB - IC = 1 -C - DO 1880 I = 1, MA - AIJ = A(J,I) -C - IF ( AIJ.EQ.ZERO ) THEN - CALL DSCAL( MB, BETA, C(IC,JC), 1 ) - ELSE - LC = IC -C - DO 1870 L = 1, MB - C(LC,JC) = BETA*C(LC,JC) + AIJ*B(K,L) - LC = LC + 1 - 1870 CONTINUE -C - END IF - IC = IC + MB - 1880 CONTINUE -C - JC = JC + 1 - 1890 CONTINUE -C - 1900 CONTINUE -C - ELSE -C -C Case beta <> 0 or 1, alpha = 1, A not sparse. -C - DO 1940 J = 1, NA -C - DO 1930 K = 1, NB - IC = 1 -C - DO 1920 I = 1, MA - AIJ = A(J,I) - LC = IC -C - DO 1910 L = 1, MB - C(LC,JC) = BETA*C(LC,JC) + AIJ*B(K,L) - LC = LC + 1 - 1910 CONTINUE -C - IC = IC + MB - 1920 CONTINUE -C - JC = JC + 1 - 1930 CONTINUE -C - 1940 CONTINUE -C - END IF - ELSE - IF ( SPARSE ) THEN -C -C Case beta <> 0 or 1, alpha <> 1, A sparse. -C - DO 1980 J = 1, NA -C - DO 1970 K = 1, NB - IC = 1 -C - DO 1960 I = 1, MA - AIJ = ALPHA*A(J,I) -C - IF ( AIJ.EQ.ZERO ) THEN - CALL DSCAL( MB, BETA, C(IC,JC), 1 ) - ELSE - LC = IC -C - DO 1950 L = 1, MB - C(LC,JC) = BETA*C(LC,JC) + AIJ*B(K,L) - LC = LC + 1 - 1950 CONTINUE -C - END IF - IC = IC + MB - 1960 CONTINUE -C - JC = JC + 1 - 1970 CONTINUE -C - 1980 CONTINUE -C - ELSE -C -C Case beta <> 0 or 1, alpha <> 1, A not sparse. -C - DO 2020 J = 1, NA -C - DO 2010 K = 1, NB - IC = 1 -C - DO 2000 I = 1, MA - AIJ = ALPHA*A(J,I) - LC = IC -C - DO 1990 L = 1, MB - C(LC,JC) = BETA*C(LC,JC) + AIJ*B(K,L) - LC = LC + 1 - 1990 CONTINUE -C - IC = IC + MB - 2000 CONTINUE -C - JC = JC + 1 - 2010 CONTINUE -C - 2020 CONTINUE -C - END IF - END IF - END IF - END IF - RETURN -C *** Last line of MB01VD *** - END diff --git a/mex/sources/libslicot/MB01WD.f b/mex/sources/libslicot/MB01WD.f deleted file mode 100644 index 53c85f9da..000000000 --- a/mex/sources/libslicot/MB01WD.f +++ /dev/null @@ -1,343 +0,0 @@ - SUBROUTINE MB01WD( DICO, UPLO, TRANS, HESS, N, ALPHA, BETA, R, - $ LDR, A, LDA, T, LDT, INFO ) -C -C SLICOT RELEASE 5.0. -C -C Copyright (c) 2002-2009 NICONET e.V. -C -C This program is free software: you can redistribute it and/or -C modify it under the terms of the GNU General Public License as -C published by the Free Software Foundation, either version 2 of -C the License, or (at your option) any later version. -C -C This program is distributed in the hope that it will be useful, -C but WITHOUT ANY WARRANTY; without even the implied warranty of -C MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the -C GNU General Public License for more details. -C -C You should have received a copy of the GNU General Public License -C along with this program. If not, see -C . -C -C PURPOSE -C -C To compute the matrix formula -C _ -C R = alpha*( op( A )'*op( T )'*op( T ) + op( T )'*op( T )*op( A ) ) -C + beta*R, (1) -C -C if DICO = 'C', or -C _ -C R = alpha*( op( A )'*op( T )'*op( T )*op( A ) - op( T )'*op( T )) -C + beta*R, (2) -C _ -C if DICO = 'D', where alpha and beta are scalars, R, and R are -C symmetric matrices, T is a triangular matrix, A is a general or -C Hessenberg matrix, and op( M ) is one of -C -C op( M ) = M or op( M ) = M'. -C -C The result is overwritten on R. -C -C ARGUMENTS -C -C Mode Parameters -C -C DICO CHARACTER*1 -C Specifies the formula to be evaluated, as follows: -C = 'C': formula (1), "continuous-time" case; -C = 'D': formula (2), "discrete-time" case. -C -C UPLO CHARACTER*1 -C Specifies which triangles of the symmetric matrix R and -C triangular matrix T are given, as follows: -C = 'U': the upper triangular parts of R and T are given; -C = 'L': the lower triangular parts of R and T are given; -C -C TRANS CHARACTER*1 -C Specifies the form of op( M ) to be used, as follows: -C = 'N': op( M ) = M; -C = 'T': op( M ) = M'; -C = 'C': op( M ) = M'. -C -C HESS CHARACTER*1 -C Specifies the form of the matrix A, as follows: -C = 'F': matrix A is full; -C = 'H': matrix A is Hessenberg (or Schur), either upper -C (if UPLO = 'U'), or lower (if UPLO = 'L'). -C -C Input/Output Parameters -C -C N (input) INTEGER -C The order of the matrices R, A, and T. N >= 0. -C -C ALPHA (input) DOUBLE PRECISION -C The scalar alpha. When alpha is zero then the arrays A -C and T are not referenced. -C -C BETA (input) DOUBLE PRECISION -C The scalar beta. When beta is zero then the array R need -C not be set before entry. -C -C R (input/output) DOUBLE PRECISION array, dimension (LDR,N) -C On entry with UPLO = 'U', the leading N-by-N upper -C triangular part of this array must contain the upper -C triangular part of the symmetric matrix R. -C On entry with UPLO = 'L', the leading N-by-N lower -C triangular part of this array must contain the lower -C triangular part of the symmetric matrix R. -C On exit, the leading N-by-N upper triangular part (if -C UPLO = 'U'), or lower triangular part (if UPLO = 'L'), of -C this array contains the corresponding triangular part of -C _ -C the computed matrix R. -C -C LDR INTEGER -C The leading dimension of array R. LDR >= MAX(1,N). -C -C A (input/output) DOUBLE PRECISION array, dimension (LDA,N) -C On entry, the leading N-by-N part of this array must -C contain the matrix A. If HESS = 'H' the elements below the -C first subdiagonal, if UPLO = 'U', or above the first -C superdiagonal, if UPLO = 'L', need not be set to zero, -C and are not referenced if DICO = 'D'. -C On exit, the leading N-by-N part of this array contains -C the following matrix product -C alpha*T'*T*A, if TRANS = 'N', or -C alpha*A*T*T', otherwise, -C if DICO = 'C', or -C T*A, if TRANS = 'N', or -C A*T, otherwise, -C if DICO = 'D' (and in this case, these products have a -C Hessenberg form, if HESS = 'H'). -C -C LDA INTEGER -C The leading dimension of array A. LDA >= MAX(1,N). -C -C T (input) DOUBLE PRECISION array, dimension (LDT,N) -C If UPLO = 'U', the leading N-by-N upper triangular part of -C this array must contain the upper triangular matrix T and -C the strictly lower triangular part need not be set to zero -C (and it is not referenced). -C If UPLO = 'L', the leading N-by-N lower triangular part of -C this array must contain the lower triangular matrix T and -C the strictly upper triangular part need not be set to zero -C (and it is not referenced). -C -C LDT INTEGER -C The leading dimension of array T. LDT >= MAX(1,N). -C -C Error Indicator -C -C INFO INTEGER -C = 0: successful exit; -C < 0: if INFO = -k, the k-th argument had an illegal -C value. -C -C METHOD -C -C The matrix expression (1) or (2) is efficiently evaluated taking -C the structure into account. BLAS 3 operations (DTRMM, DSYRK and -C their specializations) are used throughout. -C -C NUMERICAL ASPECTS -C -C If A is a full matrix, the algorithm requires approximately -C 3 -C N operations, if DICO = 'C'; -C 3 -C 7/6 x N operations, if DICO = 'D'. -C -C CONTRIBUTORS -C -C V. Sima, Research Institute for Informatics, Bucharest, Nov. 2000. -C -C REVISIONS -C -C - -C -C KEYWORDS -C -C Elementary matrix operations, matrix algebra, matrix operations. -C -C ****************************************************************** -C -C .. Parameters .. - DOUBLE PRECISION ZERO, ONE - PARAMETER ( ZERO = 0.0D0, ONE = 1.0D0 ) -C .. Scalar Arguments .. - CHARACTER DICO, HESS, TRANS, UPLO - INTEGER INFO, LDA, LDR, LDT, N - DOUBLE PRECISION ALPHA, BETA -C .. Array Arguments .. - DOUBLE PRECISION A(LDA,*), R(LDR,*), T(LDT,*) -C .. Local Scalars .. - LOGICAL DISCR, REDUC, TRANSP, UPPER - CHARACTER NEGTRA, SIDE - INTEGER I, INFO2, J -C .. External Functions .. - LOGICAL LSAME - EXTERNAL LSAME -C .. External Subroutines .. - EXTERNAL DLASCL, DLASET, DSYRK, DTRMM, MB01YD, MB01ZD, - $ XERBLA -C .. Intrinsic Functions .. - INTRINSIC MAX -C .. Executable Statements .. -C -C Test the input scalar arguments. -C - INFO = 0 - DISCR = LSAME( DICO, 'D' ) - UPPER = LSAME( UPLO, 'U' ) - TRANSP = LSAME( TRANS, 'T' ) .OR. LSAME( TRANS, 'C' ) - REDUC = LSAME( HESS, 'H' ) -C - IF( .NOT.( DISCR .OR. LSAME( DICO, 'C' ) ) )THEN - INFO = -1 - ELSE IF( .NOT.( UPPER .OR. LSAME( UPLO, 'L' ) ) )THEN - INFO = -2 - ELSE IF( .NOT.( TRANSP .OR. LSAME( TRANS, 'N' ) ) )THEN - INFO = -3 - ELSE IF( .NOT.( REDUC .OR. LSAME( HESS, 'F' ) ) )THEN - INFO = -4 - ELSE IF( N.LT.0 ) THEN - INFO = -5 - ELSE IF( LDR.LT.MAX( 1, N ) ) THEN - INFO = -9 - ELSE IF( LDA.LT.MAX( 1, N ) ) THEN - INFO = -11 - ELSE IF( LDT.LT.MAX( 1, N ) ) THEN - INFO = -13 - END IF -C - IF ( INFO.NE.0 ) THEN -C -C Error return. -C - CALL XERBLA( 'MB01WD', -INFO ) - RETURN - END IF -C -C Quick return if possible. -C - IF ( N.EQ.0 ) - $ RETURN -C - IF ( ALPHA.EQ.ZERO ) THEN - IF ( BETA.EQ.ZERO ) THEN -C -C Special case when both alpha = 0 and beta = 0. -C - CALL DLASET( UPLO, N, N, ZERO, ZERO, R, LDR ) - ELSE -C -C Special case alpha = 0. -C - IF ( BETA.NE.ONE ) - $ CALL DLASCL( UPLO, 0, 0, ONE, BETA, N, N, R, LDR, INFO2 ) - END IF - RETURN - END IF -C -C General case: alpha <> 0. -C -C Compute (in A) T*A, if TRANS = 'N', or -C A*T, otherwise. -C - IF ( TRANSP ) THEN - SIDE = 'R' - NEGTRA = 'N' - ELSE - SIDE = 'L' - NEGTRA = 'T' - END IF -C - IF ( REDUC .AND. N.GT.2 ) THEN - CALL MB01ZD( SIDE, UPLO, 'NoTranspose', 'Non-unit', N, N, 1, - $ ONE, T, LDT, A, LDA, INFO2 ) - ELSE - CALL DTRMM( SIDE, UPLO, 'NoTranspose', 'Non-unit', N, N, ONE, - $ T, LDT, A, LDA ) - END IF -C - IF( .NOT.DISCR ) THEN -C -C Compute (in A) alpha*T'*T*A, if TRANS = 'N', or -C alpha*A*T*T', otherwise. -C - IF ( REDUC .AND. N.GT.2 ) THEN - CALL MB01ZD( SIDE, UPLO, 'Transpose', 'Non-unit', N, N, 1, - $ ALPHA, T, LDT, A, LDA, INFO2 ) - ELSE - CALL DTRMM( SIDE, UPLO, 'Transpose', 'Non-unit', N, N, - $ ALPHA, T, LDT, A, LDA ) - END IF -C -C Compute the required triangle of the result, using symmetry. -C - IF ( UPPER ) THEN - IF ( BETA.EQ.ZERO ) THEN -C - DO 20 J = 1, N - DO 10 I = 1, J - R( I, J ) = A( I, J ) + A( J, I ) - 10 CONTINUE - 20 CONTINUE -C - ELSE -C - DO 40 J = 1, N - DO 30 I = 1, J - R( I, J ) = A( I, J ) + A( J, I ) + BETA*R( I, J ) - 30 CONTINUE - 40 CONTINUE -C - END IF -C - ELSE -C - IF ( BETA.EQ.ZERO ) THEN -C - DO 60 J = 1, N - DO 50 I = J, N - R( I, J ) = A( I, J ) + A( J, I ) - 50 CONTINUE - 60 CONTINUE -C - ELSE -C - DO 80 J = 1, N - DO 70 I = J, N - R( I, J ) = A( I, J ) + A( J, I ) + BETA*R( I, J ) - 70 CONTINUE - 80 CONTINUE -C - END IF -C - END IF -C - ELSE -C -C Compute (in R) alpha*A'*T'*T*A + beta*R, if TRANS = 'N', or -C alpha*A*T*T'*A' + beta*R, otherwise. -C - IF ( REDUC .AND. N.GT.2 ) THEN - CALL MB01YD( UPLO, NEGTRA, N, N, 1, ALPHA, BETA, A, LDA, R, - $ LDR, INFO2 ) - ELSE - CALL DSYRK( UPLO, NEGTRA, N, N, ALPHA, A, LDA, BETA, R, - $ LDR ) - END IF -C -C Compute (in R) -alpha*T'*T + R, if TRANS = 'N', or -C -alpha*T*T' + R, otherwise. -C - CALL MB01YD( UPLO, NEGTRA, N, N, 0, -ALPHA, ONE, T, LDT, R, - $ LDR, INFO2 ) -C - END IF -C - RETURN -C *** Last line of MB01WD *** - END diff --git a/mex/sources/libslicot/MB01XD.f b/mex/sources/libslicot/MB01XD.f deleted file mode 100644 index 3a54a2e2a..000000000 --- a/mex/sources/libslicot/MB01XD.f +++ /dev/null @@ -1,207 +0,0 @@ - SUBROUTINE MB01XD( UPLO, N, A, LDA, INFO ) -C -C SLICOT RELEASE 5.0. -C -C Copyright (c) 2002-2009 NICONET e.V. -C -C This program is free software: you can redistribute it and/or -C modify it under the terms of the GNU General Public License as -C published by the Free Software Foundation, either version 2 of -C the License, or (at your option) any later version. -C -C This program is distributed in the hope that it will be useful, -C but WITHOUT ANY WARRANTY; without even the implied warranty of -C MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the -C GNU General Public License for more details. -C -C You should have received a copy of the GNU General Public License -C along with this program. If not, see -C . -C -C PURPOSE -C -C To compute the matrix product U' * U or L * L', where U and L are -C upper and lower triangular matrices, respectively, stored in the -C corresponding upper or lower triangular part of the array A. -C -C If UPLO = 'U' then the upper triangle of the result is stored, -C overwriting the matrix U in A. -C If UPLO = 'L' then the lower triangle of the result is stored, -C overwriting the matrix L in A. -C -C ARGUMENTS -C -C Mode Parameters -C -C UPLO CHARACTER*1 -C Specifies which triangle (U or L) is given in the array A, -C as follows: -C = 'U': the upper triangular part U is given; -C = 'L': the lower triangular part L is given. -C -C Input/Output Parameters -C -C N (input) INTEGER -C The order of the triangular matrices U or L. N >= 0. -C -C A (input/output) DOUBLE PRECISION array, dimension (LDA,N) -C On entry, if UPLO = 'U', the leading N-by-N upper -C triangular part of this array must contain the upper -C triangular matrix U. -C On entry, if UPLO = 'L', the leading N-by-N lower -C triangular part of this array must contain the lower -C triangular matrix L. -C On exit, if UPLO = 'U', the leading N-by-N upper -C triangular part of this array contains the upper -C triangular part of the product U' * U. The strictly lower -C triangular part is not referenced. -C On exit, if UPLO = 'L', the leading N-by-N lower -C triangular part of this array contains the lower -C triangular part of the product L * L'. The strictly upper -C triangular part is not referenced. -C -C LDA INTEGER -C The leading dimension of array A. LDA >= max(1,N). -C -C Error Indicator -C -C INFO INTEGER -C = 0: successful exit; -C < 0: if INFO = -i, the i-th argument had an illegal -C value. -C -C METHOD -C -C The matrix product U' * U or L * L' is computed using BLAS 3 -C operations as much as possible (a block algorithm). -C -C FURTHER COMMENTS -C -C This routine is a counterpart of LAPACK Library routine DLAUUM, -C which computes the matrix product U * U' or L' * L. -C -C CONTRIBUTOR -C -C V. Sima, Research Institute for Informatics, Bucharest, Nov. 2000. -C -C REVISIONS -C -C - -C -C KEYWORDS -C -C Elementary matrix operations, matrix operations. -C -C ****************************************************************** -C -C .. Parameters .. - DOUBLE PRECISION ONE - PARAMETER ( ONE = 1.0D0 ) -C .. -C .. Scalar Arguments .. - CHARACTER UPLO - INTEGER INFO, LDA, N -C .. -C .. Array Arguments .. - DOUBLE PRECISION A( LDA, * ) -C .. -C .. Local Scalars .. - LOGICAL UPPER - INTEGER I, IB, II, NB -C .. -C .. External Functions .. - LOGICAL LSAME - INTEGER ILAENV - EXTERNAL LSAME, ILAENV -C .. -C .. External Subroutines .. - EXTERNAL DGEMM, DSYRK, DTRMM, MB01XY, XERBLA -C .. -C .. Intrinsic Functions .. - INTRINSIC MAX, MIN -C .. -C .. Executable Statements .. -C -C Test the input scalar arguments. -C - INFO = 0 - UPPER = LSAME( UPLO, 'U' ) - IF( .NOT.UPPER .AND. .NOT.LSAME( UPLO, 'L' ) ) THEN - INFO = -1 - ELSE IF( N.LT.0 ) THEN - INFO = -2 - ELSE IF( LDA.LT.MAX( 1, N ) ) THEN - INFO = -4 - END IF -C - IF( INFO.NE.0 ) THEN -C -C Error return. -C - CALL XERBLA( 'MB01XD', -INFO ) - RETURN - END IF -C -C Quick return, if possible. -C - IF( N.EQ.0 ) - $ RETURN -C -C Determine the block size for this environment (as for DLAUUM). -C - NB = ILAENV( 1, 'DLAUUM', UPLO, N, -1, -1, -1 ) -C - IF( NB.LE.1 .OR. NB.GE.N ) THEN -C -C Use unblocked code. -C - CALL MB01XY( UPLO, N, A, LDA, INFO ) - ELSE -C -C Use blocked code. -C - IF( UPPER ) THEN -C -C Compute the product U' * U. -C - DO 10 I = N, 1, -NB - IB = MIN( NB, I ) - II = I - IB + 1 - IF( I.LT.N ) THEN - CALL DTRMM( 'Left', 'Upper', 'Transpose', 'Non-unit', - $ IB, N-I, ONE, A( II, II ), LDA, - $ A( II, II+IB ), LDA ) - CALL DGEMM( 'Transpose', 'No transpose', IB, N-I, - $ I-IB, ONE, A( 1, II ), LDA, A( 1, II+IB ), - $ LDA, ONE, A( II, II+IB ), LDA ) - END IF - CALL MB01XY( 'Upper', IB, A( II, II ), LDA, INFO ) - CALL DSYRK( 'Upper', 'Transpose', IB, II-1, ONE, - $ A( 1, II ), LDA, ONE, A( II, II ), LDA ) - 10 CONTINUE - ELSE -C -C Compute the product L * L'. -C - DO 20 I = N, 1, -NB - IB = MIN( NB, I ) - II = I - IB + 1 - IF( I.LT.N ) THEN - CALL DTRMM( 'Right', 'Lower', 'Transpose', 'Non-unit', - $ N-I, IB, ONE, A( II, II ), LDA, - $ A( II+IB, II ), LDA ) - CALL DGEMM( 'No transpose', 'Transpose', N-I, IB, - $ I-IB, ONE, A( II+IB, 1 ), LDA, A( II, 1 ), - $ LDA, ONE, A( II+IB, II ), LDA ) - END IF - CALL MB01XY( 'Lower', IB, A( II, II ), LDA, INFO ) - CALL DSYRK( 'Lower', 'No Transpose', IB, II-1, ONE, - $ A( II, 1 ), LDA, ONE, A( II, II ), LDA ) - 20 CONTINUE - END IF - END IF -C - RETURN -C -C *** Last line of MB01XD *** - END diff --git a/mex/sources/libslicot/MB01XY.f b/mex/sources/libslicot/MB01XY.f deleted file mode 100644 index 6af6275cd..000000000 --- a/mex/sources/libslicot/MB01XY.f +++ /dev/null @@ -1,191 +0,0 @@ - SUBROUTINE MB01XY( UPLO, N, A, LDA, INFO ) -C -C SLICOT RELEASE 5.0. -C -C Copyright (c) 2002-2009 NICONET e.V. -C -C This program is free software: you can redistribute it and/or -C modify it under the terms of the GNU General Public License as -C published by the Free Software Foundation, either version 2 of -C the License, or (at your option) any later version. -C -C This program is distributed in the hope that it will be useful, -C but WITHOUT ANY WARRANTY; without even the implied warranty of -C MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the -C GNU General Public License for more details. -C -C You should have received a copy of the GNU General Public License -C along with this program. If not, see -C . -C -C PURPOSE -C -C To compute the matrix product U' * U or L * L', where U and L are -C upper and lower triangular matrices, respectively, stored in the -C corresponding upper or lower triangular part of the array A. -C -C If UPLO = 'U' then the upper triangle of the result is stored, -C overwriting the matrix U in A. -C If UPLO = 'L' then the lower triangle of the result is stored, -C overwriting the matrix L in A. -C -C ARGUMENTS -C -C Mode Parameters -C -C UPLO CHARACTER*1 -C Specifies which triangle (U or L) is given in the array A, -C as follows: -C = 'U': the upper triangular part U is given; -C = 'L': the lower triangular part L is given. -C -C Input/Output Parameters -C -C N (input) INTEGER -C The order of the triangular matrices U or L. N >= 0. -C -C A (input/output) DOUBLE PRECISION array, dimension (LDA,N) -C On entry, if UPLO = 'U', the leading N-by-N upper -C triangular part of this array must contain the upper -C triangular matrix U. -C On entry, if UPLO = 'L', the leading N-by-N lower -C triangular part of this array must contain the lower -C triangular matrix L. -C On exit, if UPLO = 'U', the leading N-by-N upper -C triangular part of this array contains the upper -C triangular part of the product U' * U. The strictly lower -C triangular part is not referenced. -C On exit, if UPLO = 'L', the leading N-by-N lower -C triangular part of this array contains the lower -C triangular part of the product L * L'. The strictly upper -C triangular part is not referenced. -C -C LDA INTEGER -C The leading dimension of array A. LDA >= max(1,N). -C -C Error Indicator -C -C INFO INTEGER -C = 0: successful exit; -C < 0: if INFO = -i, the i-th argument had an illegal -C value. -C -C METHOD -C -C The matrix product U' * U or L * L' is computed using BLAS 2 and -C BLAS 1 operations (an unblocked algorithm). -C -C FURTHER COMMENTS -C -C This routine is a counterpart of LAPACK Library routine DLAUU2, -C which computes the matrix product U * U' or L' * L. -C -C CONTRIBUTOR -C -C V. Sima, Research Institute for Informatics, Bucharest, Nov. 2000. -C -C REVISIONS -C -C - -C -C KEYWORDS -C -C Elementary matrix operations, matrix operations. -C -C ****************************************************************** -C -C .. Parameters .. - DOUBLE PRECISION ONE - PARAMETER ( ONE = 1.0D0 ) -C .. -C .. Scalar Arguments .. - CHARACTER UPLO - INTEGER INFO, LDA, N -C .. -C .. Array Arguments .. - DOUBLE PRECISION A( LDA, * ) -C .. -C .. Local Scalars .. - LOGICAL UPPER - INTEGER I - DOUBLE PRECISION AII -C .. -C .. External Functions .. - LOGICAL LSAME - DOUBLE PRECISION DDOT - EXTERNAL DDOT, LSAME -C .. -C .. External Subroutines .. - EXTERNAL DGEMV, DSCAL, XERBLA -C .. -C .. Intrinsic Functions .. - INTRINSIC MAX -C .. -C .. Executable Statements .. -C -C Test the input scalar arguments. -C - INFO = 0 - UPPER = LSAME( UPLO, 'U' ) - IF( .NOT.UPPER .AND. .NOT.LSAME( UPLO, 'L' ) ) THEN - INFO = -1 - ELSE IF( N.LT.0 ) THEN - INFO = -2 - ELSE IF( LDA.LT.MAX( 1, N ) ) THEN - INFO = -4 - END IF -C - IF( INFO.NE.0 ) THEN -C -C Error return. -C - CALL XERBLA( 'MB01XY', -INFO ) - RETURN - END IF -C -C Quick return, if possible. -C - IF( N.EQ.0 ) - $ RETURN -C - IF( UPPER ) THEN -C -C Compute the product U' * U. -C - A( N, N ) = DDOT( N, A( 1, N ), 1, A( 1, N ), 1 ) -C - DO 10 I = N-1, 2, -1 - AII = A( I, I ) - A( I, I ) = DDOT( I, A( 1, I ), 1, A( 1, I ), 1 ) - CALL DGEMV( 'Transpose', I-1, N-I, ONE, A( 1, I+1 ), LDA, - $ A( 1, I ), 1, AII, A( I, I+1 ), LDA ) - 10 CONTINUE -C - IF( N.GT.1 ) THEN - AII = A( 1, 1 ) - CALL DSCAL( N, AII, A( 1, 1 ), LDA ) - END IF -C - ELSE -C -C Compute the product L * L'. -C - A( N, N ) = DDOT( N, A( N, 1 ), LDA, A( N, 1 ), LDA ) -C - DO 20 I = N-1, 2, -1 - AII = A( I, I ) - A( I, I ) = DDOT( I, A( I, 1 ), LDA, A( I, 1 ), LDA ) - CALL DGEMV( 'No Transpose', N-I, I-1, ONE, A( I+1, 1 ), - $ LDA, A( I, 1 ), LDA, AII, A( I+1, I ), 1 ) - 20 CONTINUE -C - IF( N.GT.1 ) THEN - AII = A( 1, 1 ) - CALL DSCAL( N, AII, A( 1, 1 ), 1 ) - END IF - END IF -C - RETURN -C -C *** Last line of MB01XY *** - END diff --git a/mex/sources/libslicot/MB01YD.f b/mex/sources/libslicot/MB01YD.f deleted file mode 100644 index 6d5c2a0fe..000000000 --- a/mex/sources/libslicot/MB01YD.f +++ /dev/null @@ -1,352 +0,0 @@ - SUBROUTINE MB01YD( UPLO, TRANS, N, K, L, ALPHA, BETA, A, LDA, C, - $ LDC, INFO ) -C -C SLICOT RELEASE 5.0. -C -C Copyright (c) 2002-2009 NICONET e.V. -C -C This program is free software: you can redistribute it and/or -C modify it under the terms of the GNU General Public License as -C published by the Free Software Foundation, either version 2 of -C the License, or (at your option) any later version. -C -C This program is distributed in the hope that it will be useful, -C but WITHOUT ANY WARRANTY; without even the implied warranty of -C MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the -C GNU General Public License for more details. -C -C You should have received a copy of the GNU General Public License -C along with this program. If not, see -C . -C -C PURPOSE -C -C To perform the symmetric rank k operations -C -C C := alpha*op( A )*op( A )' + beta*C, -C -C where alpha and beta are scalars, C is an n-by-n symmetric matrix, -C op( A ) is an n-by-k matrix, and op( A ) is one of -C -C op( A ) = A or op( A ) = A'. -C -C The matrix A has l nonzero codiagonals, either upper or lower. -C -C ARGUMENTS -C -C Mode Parameters -C -C UPLO CHARACTER*1 -C Specifies which triangle of the symmetric matrix C -C is given and computed, as follows: -C = 'U': the upper triangular part is given/computed; -C = 'L': the lower triangular part is given/computed. -C UPLO also defines the pattern of the matrix A (see below). -C -C TRANS CHARACTER*1 -C Specifies the form of op( A ) to be used, as follows: -C = 'N': op( A ) = A; -C = 'T': op( A ) = A'; -C = 'C': op( A ) = A'. -C -C Input/Output Parameters -C -C N (input) INTEGER -C The order of the matrix C. N >= 0. -C -C K (input) INTEGER -C The number of columns of the matrix op( A ). K >= 0. -C -C L (input) INTEGER -C If UPLO = 'U', matrix A has L nonzero subdiagonals. -C If UPLO = 'L', matrix A has L nonzero superdiagonals. -C MAX(0,NR-1) >= L >= 0, if UPLO = 'U', -C MAX(0,NC-1) >= L >= 0, if UPLO = 'L', -C where NR and NC are the numbers of rows and columns of the -C matrix A, respectively. -C -C ALPHA (input) DOUBLE PRECISION -C The scalar alpha. When alpha is zero then the array A is -C not referenced. -C -C BETA (input) DOUBLE PRECISION -C The scalar beta. When beta is zero then the array C need -C not be set before entry. -C -C A (input) DOUBLE PRECISION array, dimension (LDA,NC), where -C NC is K when TRANS = 'N', and is N otherwise. -C If TRANS = 'N', the leading N-by-K part of this array must -C contain the matrix A, otherwise the leading K-by-N part of -C this array must contain the matrix A. -C If UPLO = 'U', only the upper triangular part and the -C first L subdiagonals are referenced, and the remaining -C subdiagonals are assumed to be zero. -C If UPLO = 'L', only the lower triangular part and the -C first L superdiagonals are referenced, and the remaining -C superdiagonals are assumed to be zero. -C -C LDA INTEGER -C The leading dimension of array A. LDA >= max(1,NR), -C where NR = N, if TRANS = 'N', and NR = K, otherwise. -C -C C (input/output) DOUBLE PRECISION array, dimension (LDC,N) -C On entry with UPLO = 'U', the leading N-by-N upper -C triangular part of this array must contain the upper -C triangular part of the symmetric matrix C. -C On entry with UPLO = 'L', the leading N-by-N lower -C triangular part of this array must contain the lower -C triangular part of the symmetric matrix C. -C On exit, the leading N-by-N upper triangular part (if -C UPLO = 'U'), or lower triangular part (if UPLO = 'L'), of -C this array contains the corresponding triangular part of -C the updated matrix C. -C -C LDC INTEGER -C The leading dimension of array C. LDC >= MAX(1,N). -C -C Error Indicator -C -C INFO INTEGER -C = 0: successful exit; -C < 0: if INFO = -i, the i-th argument had an illegal -C value. -C -C METHOD -C -C The calculations are efficiently performed taking the symmetry -C and structure into account. -C -C FURTHER COMMENTS -C -C The matrix A may have the following patterns, when n = 7, k = 5, -C and l = 2 are used for illustration: -C -C UPLO = 'U', TRANS = 'N' UPLO = 'L', TRANS = 'N' -C -C [ x x x x x ] [ x x x 0 0 ] -C [ x x x x x ] [ x x x x 0 ] -C [ x x x x x ] [ x x x x x ] -C A = [ 0 x x x x ], A = [ x x x x x ], -C [ 0 0 x x x ] [ x x x x x ] -C [ 0 0 0 x x ] [ x x x x x ] -C [ 0 0 0 0 x ] [ x x x x x ] -C -C UPLO = 'U', TRANS = 'T' UPLO = 'L', TRANS = 'T' -C -C [ x x x x x x x ] [ x x x 0 0 0 0 ] -C [ x x x x x x x ] [ x x x x 0 0 0 ] -C A = [ x x x x x x x ], A = [ x x x x x 0 0 ]. -C [ 0 x x x x x x ] [ x x x x x x 0 ] -C [ 0 0 x x x x x ] [ x x x x x x x ] -C -C If N = K, the matrix A is upper or lower triangular, for L = 0, -C and upper or lower Hessenberg, for L = 1. -C -C This routine is a specialization of the BLAS 3 routine DSYRK. -C BLAS 1 calls are used when appropriate, instead of in-line code, -C in order to increase the efficiency. If the matrix A is full, or -C its zero triangle has small order, an optimized DSYRK code could -C be faster than MB01YD. -C -C CONTRIBUTOR -C -C V. Sima, Research Institute for Informatics, Bucharest, Nov. 2000. -C -C REVISIONS -C -C - -C -C KEYWORDS -C -C Elementary matrix operations, matrix operations. -C -C ****************************************************************** -C -C .. Parameters .. - DOUBLE PRECISION ZERO, ONE - PARAMETER ( ZERO = 0.0D0, ONE = 1.0D0 ) -C .. -C .. Scalar Arguments .. - CHARACTER TRANS, UPLO - INTEGER INFO, LDA, LDC, K, L, N - DOUBLE PRECISION ALPHA, BETA -C .. -C .. Array Arguments .. - DOUBLE PRECISION A( LDA, * ), C( LDC, * ) -C .. -C .. Local Scalars .. - LOGICAL TRANSP, UPPER - INTEGER I, J, M, NCOLA, NROWA - DOUBLE PRECISION TEMP -C .. -C .. External Functions .. - LOGICAL LSAME - DOUBLE PRECISION DDOT - EXTERNAL DDOT, LSAME -C .. -C .. External Subroutines .. - EXTERNAL DAXPY, DLASCL, DLASET, DSCAL, XERBLA -C .. -C .. Intrinsic Functions .. - INTRINSIC MAX, MIN -C .. -C .. Executable Statements .. -C -C Test the input scalar arguments. -C - INFO = 0 - UPPER = LSAME( UPLO, 'U' ) - TRANSP = LSAME( TRANS, 'T' ) .OR. LSAME( TRANS, 'C' ) -C - IF( TRANSP )THEN - NROWA = K - NCOLA = N - ELSE - NROWA = N - NCOLA = K - END IF -C - IF( UPPER )THEN - M = NROWA - ELSE - M = NCOLA - END IF -C - IF( .NOT.( UPPER .OR. LSAME( UPLO, 'L' ) ) ) THEN - INFO = -1 - ELSE IF( .NOT.( TRANSP .OR. LSAME( TRANS, 'N' ) ) ) THEN - INFO = -2 - ELSE IF( N.LT.0 ) THEN - INFO = -3 - ELSE IF( K.LT.0 ) THEN - INFO = -4 - ELSE IF( L.LT.0 .OR. L.GT.MAX( 0, M-1 ) ) THEN - INFO = -5 - ELSE IF( LDA.LT.MAX( 1, NROWA ) ) THEN - INFO = -9 - ELSE IF( LDC.LT.MAX( 1, N ) ) THEN - INFO = -11 - END IF -C - IF( INFO.NE.0 ) THEN -C -C Error return. -C - CALL XERBLA( 'MB01YD', -INFO ) - RETURN - END IF -C -C Quick return, if possible. -C - IF( ( N.EQ.0 ).OR. - $ ( ( ( ALPHA.EQ.ZERO ).OR.( K.EQ.0 ) ).AND.( BETA.EQ.ONE ) ) ) - $ RETURN -C - IF ( ALPHA.EQ.ZERO ) THEN - IF ( BETA.EQ.ZERO ) THEN -C -C Special case when both alpha = 0 and beta = 0. -C - CALL DLASET( UPLO, N, N, ZERO, ZERO, C, LDC ) - ELSE -C -C Special case alpha = 0. -C - CALL DLASCL( UPLO, 0, 0, ONE, BETA, N, N, C, LDC, INFO ) - END IF - RETURN - END IF -C -C General case: alpha <> 0. -C - IF ( .NOT.TRANSP ) THEN -C -C Form C := alpha*A*A' + beta*C. -C - IF ( UPPER ) THEN -C - DO 30 J = 1, N - IF ( BETA.EQ.ZERO ) THEN -C - DO 10 I = 1, J - C( I, J ) = ZERO - 10 CONTINUE -C - ELSE IF ( BETA.NE.ONE ) THEN - CALL DSCAL ( J, BETA, C( 1, J ), 1 ) - END IF -C - DO 20 M = MAX( 1, J-L ), K - CALL DAXPY ( MIN( J, L+M ), ALPHA*A( J, M ), - $ A( 1, M ), 1, C( 1, J ), 1 ) - 20 CONTINUE -C - 30 CONTINUE -C - ELSE -C - DO 60 J = 1, N - IF ( BETA.EQ.ZERO ) THEN -C - DO 40 I = J, N - C( I, J ) = ZERO - 40 CONTINUE -C - ELSE IF ( BETA.NE.ONE ) THEN - CALL DSCAL ( N-J+1, BETA, C( J, J ), 1 ) - END IF -C - DO 50 M = 1, MIN( J+L, K ) - CALL DAXPY ( N-J+1, ALPHA*A( J, M ), A( J, M ), 1, - $ C( J, J ), 1 ) - 50 CONTINUE -C - 60 CONTINUE -C - END IF -C - ELSE -C -C Form C := alpha*A'*A + beta*C. -C - IF ( UPPER ) THEN -C - DO 80 J = 1, N -C - DO 70 I = 1, J - TEMP = ALPHA*DDOT ( MIN( J+L, K ), A( 1, I ), 1, - $ A( 1, J ), 1 ) - IF ( BETA.EQ.ZERO ) THEN - C( I, J ) = TEMP - ELSE - C( I, J ) = TEMP + BETA*C( I, J ) - END IF - 70 CONTINUE -C - 80 CONTINUE -C - ELSE -C - DO 100 J = 1, N -C - DO 90 I = J, N - M = MAX( 1, I-L ) - TEMP = ALPHA*DDOT ( K-M+1, A( M, I ), 1, A( M, J ), - $ 1 ) - IF ( BETA.EQ.ZERO ) THEN - C( I, J ) = TEMP - ELSE - C( I, J ) = TEMP + BETA*C( I, J ) - END IF - 90 CONTINUE -C - 100 CONTINUE -C - END IF -C - END IF -C - RETURN -C -C *** Last line of MB01YD *** - END diff --git a/mex/sources/libslicot/MB01ZD.f b/mex/sources/libslicot/MB01ZD.f deleted file mode 100644 index abdbbf473..000000000 --- a/mex/sources/libslicot/MB01ZD.f +++ /dev/null @@ -1,475 +0,0 @@ - SUBROUTINE MB01ZD( SIDE, UPLO, TRANST, DIAG, M, N, L, ALPHA, T, - $ LDT, H, LDH, INFO ) -C -C SLICOT RELEASE 5.0. -C -C Copyright (c) 2002-2009 NICONET e.V. -C -C This program is free software: you can redistribute it and/or -C modify it under the terms of the GNU General Public License as -C published by the Free Software Foundation, either version 2 of -C the License, or (at your option) any later version. -C -C This program is distributed in the hope that it will be useful, -C but WITHOUT ANY WARRANTY; without even the implied warranty of -C MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the -C GNU General Public License for more details. -C -C You should have received a copy of the GNU General Public License -C along with this program. If not, see -C . -C -C PURPOSE -C -C To compute the matrix product -C -C H := alpha*op( T )*H, or H := alpha*H*op( T ), -C -C where alpha is a scalar, H is an m-by-n upper or lower -C Hessenberg-like matrix (with l nonzero subdiagonals or -C superdiagonals, respectively), T is a unit, or non-unit, -C upper or lower triangular matrix, and op( T ) is one of -C -C op( T ) = T or op( T ) = T'. -C -C ARGUMENTS -C -C Mode Parameters -C -C SIDE CHARACTER*1 -C Specifies whether the triangular matrix T appears on the -C left or right in the matrix product, as follows: -C = 'L': the product alpha*op( T )*H is computed; -C = 'R': the product alpha*H*op( T ) is computed. -C -C UPLO CHARACTER*1 -C Specifies the form of the matrices T and H, as follows: -C = 'U': the matrix T is upper triangular and the matrix H -C is upper Hessenberg-like; -C = 'L': the matrix T is lower triangular and the matrix H -C is lower Hessenberg-like. -C -C TRANST CHARACTER*1 -C Specifies the form of op( T ) to be used, as follows: -C = 'N': op( T ) = T; -C = 'T': op( T ) = T'; -C = 'C': op( T ) = T'. -C -C DIAG CHARACTER*1. -C Specifies whether or not T is unit triangular, as follows: -C = 'U': the matrix T is assumed to be unit triangular; -C = 'N': the matrix T is not assumed to be unit triangular. -C -C Input/Output Parameters -C -C M (input) INTEGER -C The number of rows of H. M >= 0. -C -C N (input) INTEGER -C The number of columns of H. N >= 0. -C -C L (input) INTEGER -C If UPLO = 'U', matrix H has L nonzero subdiagonals. -C If UPLO = 'L', matrix H has L nonzero superdiagonals. -C MAX(0,M-1) >= L >= 0, if UPLO = 'U'; -C MAX(0,N-1) >= L >= 0, if UPLO = 'L'. -C -C ALPHA (input) DOUBLE PRECISION -C The scalar alpha. When alpha is zero then T is not -C referenced and H need not be set before entry. -C -C T (input) DOUBLE PRECISION array, dimension (LDT,k), where -C k is m when SIDE = 'L' and is n when SIDE = 'R'. -C If UPLO = 'U', the leading k-by-k upper triangular part -C of this array must contain the upper triangular matrix T -C and the strictly lower triangular part is not referenced. -C If UPLO = 'L', the leading k-by-k lower triangular part -C of this array must contain the lower triangular matrix T -C and the strictly upper triangular part is not referenced. -C Note that when DIAG = 'U', the diagonal elements of T are -C not referenced either, but are assumed to be unity. -C -C LDT INTEGER -C The leading dimension of array T. -C LDT >= MAX(1,M), if SIDE = 'L'; -C LDT >= MAX(1,N), if SIDE = 'R'. -C -C H (input/output) DOUBLE PRECISION array, dimension (LDH,N) -C On entry, if UPLO = 'U', the leading M-by-N upper -C Hessenberg part of this array must contain the upper -C Hessenberg-like matrix H. -C On entry, if UPLO = 'L', the leading M-by-N lower -C Hessenberg part of this array must contain the lower -C Hessenberg-like matrix H. -C On exit, the leading M-by-N part of this array contains -C the matrix product alpha*op( T )*H, if SIDE = 'L', -C or alpha*H*op( T ), if SIDE = 'R'. If TRANST = 'N', this -C product has the same pattern as the given matrix H; -C the elements below the L-th subdiagonal (if UPLO = 'U'), -C or above the L-th superdiagonal (if UPLO = 'L'), are not -C referenced in this case. If TRANST = 'T', the elements -C below the (N+L)-th row (if UPLO = 'U', SIDE = 'R', and -C M > N+L), or at the right of the (M+L)-th column -C (if UPLO = 'L', SIDE = 'L', and N > M+L), are not set to -C zero nor referenced. -C -C LDH INTEGER -C The leading dimension of array H. LDH >= max(1,M). -C -C Error Indicator -C -C INFO INTEGER -C = 0: successful exit; -C < 0: if INFO = -i, the i-th argument had an illegal -C value. -C -C METHOD -C -C The calculations are efficiently performed taking the problem -C structure into account. -C -C FURTHER COMMENTS -C -C The matrix H may have the following patterns, when m = 7, n = 6, -C and l = 2 are used for illustration: -C -C UPLO = 'U' UPLO = 'L' -C -C [ x x x x x x ] [ x x x 0 0 0 ] -C [ x x x x x x ] [ x x x x 0 0 ] -C [ x x x x x x ] [ x x x x x 0 ] -C H = [ 0 x x x x x ], H = [ x x x x x x ]. -C [ 0 0 x x x x ] [ x x x x x x ] -C [ 0 0 0 x x x ] [ x x x x x x ] -C [ 0 0 0 0 x x ] [ x x x x x x ] -C -C The products T*H or H*T have the same pattern as H, but the -C products T'*H or H*T' may be full matrices. -C -C If m = n, the matrix H is upper or lower triangular, for l = 0, -C and upper or lower Hessenberg, for l = 1. -C -C This routine is a specialization of the BLAS 3 routine DTRMM. -C BLAS 1 calls are used when appropriate, instead of in-line code, -C in order to increase the efficiency. If the matrix H is full, or -C its zero triangle has small order, an optimized DTRMM code could -C be faster than MB01ZD. -C -C CONTRIBUTOR -C -C V. Sima, Research Institute for Informatics, Bucharest, Nov. 2000. -C -C REVISIONS -C -C - -C -C KEYWORDS -C -C Elementary matrix operations, matrix operations. -C -C ****************************************************************** -C -C .. Parameters .. - DOUBLE PRECISION ONE, ZERO - PARAMETER ( ONE = 1.0D0, ZERO = 0.0D0 ) -C .. -C .. Scalar Arguments .. - CHARACTER DIAG, SIDE, TRANST, UPLO - INTEGER INFO, L, LDH, LDT, M, N - DOUBLE PRECISION ALPHA -C .. -C .. Array Arguments .. - DOUBLE PRECISION H( LDH, * ), T( LDT, * ) -C .. -C .. Local Scalars .. - LOGICAL LSIDE, NOUNIT, TRANS, UPPER - INTEGER I, I1, I2, J, K, M2, NROWT - DOUBLE PRECISION TEMP -C .. -C .. External Functions .. - LOGICAL LSAME - DOUBLE PRECISION DDOT - EXTERNAL DDOT, LSAME -C .. -C .. External Subroutines .. - EXTERNAL DAXPY, DSCAL, XERBLA -C .. -C .. Intrinsic Functions .. - INTRINSIC MAX, MIN -C .. -C .. Executable Statements .. -C -C Test the input scalar arguments. -C - LSIDE = LSAME( SIDE, 'L' ) - UPPER = LSAME( UPLO, 'U' ) - TRANS = LSAME( TRANST, 'T' ) .OR. LSAME( TRANST, 'C' ) - NOUNIT = LSAME( DIAG, 'N' ) - IF( LSIDE )THEN - NROWT = M - ELSE - NROWT = N - END IF -C - IF( UPPER )THEN - M2 = M - ELSE - M2 = N - END IF -C - INFO = 0 - IF( .NOT.( LSIDE .OR. LSAME( SIDE, 'R' ) ) ) THEN - INFO = -1 - ELSE IF( .NOT.( UPPER .OR. LSAME( UPLO, 'L' ) ) ) THEN - INFO = -2 - ELSE IF( .NOT.( TRANS .OR. LSAME( TRANST, 'N' ) ) ) THEN - INFO = -3 - ELSE IF( .NOT.( NOUNIT .OR. LSAME( DIAG, 'U' ) ) ) THEN - INFO = -4 - ELSE IF( M.LT.0 ) THEN - INFO = -5 - ELSE IF( N.LT.0 ) THEN - INFO = -6 - ELSE IF( L.LT.0 .OR. L.GT.MAX( 0, M2-1 ) ) THEN - INFO = -7 - ELSE IF( LDT.LT.MAX( 1, NROWT ) ) THEN - INFO = -10 - ELSE IF( LDH.LT.MAX( 1, M ) )THEN - INFO = -12 - END IF -C - IF( INFO.NE.0 ) THEN -C -C Error return. -C - CALL XERBLA( 'MB01ZD', -INFO ) - RETURN - END IF -C -C Quick return, if possible. -C - IF( MIN( M, N ).EQ.0 ) - $ RETURN -C -C Also, when alpha = 0. -C - IF( ALPHA.EQ.ZERO ) THEN -C - DO 20, J = 1, N - IF( UPPER ) THEN - I1 = 1 - I2 = MIN( J+L, M ) - ELSE - I1 = MAX( 1, J-L ) - I2 = M - END IF -C - DO 10, I = I1, I2 - H( I, J ) = ZERO - 10 CONTINUE -C - 20 CONTINUE -C - RETURN - END IF -C -C Start the operations. -C - IF( LSIDE )THEN - IF( .NOT.TRANS ) THEN -C -C Form H := alpha*T*H. -C - IF( UPPER ) THEN -C - DO 40, J = 1, N -C - DO 30, K = 1, MIN( J+L, M ) - IF( H( K, J ).NE.ZERO ) THEN - TEMP = ALPHA*H( K, J ) - CALL DAXPY ( K-1, TEMP, T( 1, K ), 1, H( 1, J ), - $ 1 ) - IF( NOUNIT ) - $ TEMP = TEMP*T( K, K ) - H( K, J ) = TEMP - END IF - 30 CONTINUE -C - 40 CONTINUE -C - ELSE -C - DO 60, J = 1, N -C - DO 50 K = M, MAX( 1, J-L ), -1 - IF( H( K, J ).NE.ZERO ) THEN - TEMP = ALPHA*H( K, J ) - H( K, J ) = TEMP - IF( NOUNIT ) - $ H( K, J ) = H( K, J )*T( K, K ) - CALL DAXPY ( M-K, TEMP, T( K+1, K ), 1, - $ H( K+1, J ), 1 ) - END IF - 50 CONTINUE -C - 60 CONTINUE -C - END IF -C - ELSE -C -C Form H := alpha*T'*H. -C - IF( UPPER ) THEN -C - DO 80, J = 1, N - I1 = J + L -C - DO 70, I = M, 1, -1 - IF( I.GT.I1 ) THEN - TEMP = DDOT( I1, T( 1, I ), 1, H( 1, J ), 1 ) - ELSE - TEMP = H( I, J ) - IF( NOUNIT ) - $ TEMP = TEMP*T( I, I ) - TEMP = TEMP + DDOT( I-1, T( 1, I ), 1, - $ H( 1, J ), 1 ) - END IF - H( I, J ) = ALPHA*TEMP - 70 CONTINUE -C - 80 CONTINUE -C - ELSE -C - DO 100, J = 1, MIN( M+L, N ) - I1 = J - L -C - DO 90, I = 1, M - IF( I.LT.I1 ) THEN - TEMP = DDOT( M-I1+1, T( I1, I ), 1, H( I1, J ), - $ 1 ) - ELSE - TEMP = H( I, J ) - IF( NOUNIT ) - $ TEMP = TEMP*T( I, I ) - TEMP = TEMP + DDOT( M-I, T( I+1, I ), 1, - $ H( I+1, J ), 1 ) - END IF - H( I, J ) = ALPHA*TEMP - 90 CONTINUE -C - 100 CONTINUE -C - END IF -C - END IF -C - ELSE -C - IF( .NOT.TRANS ) THEN -C -C Form H := alpha*H*T. -C - IF( UPPER ) THEN -C - DO 120, J = N, 1, -1 - I2 = MIN( J+L, M ) - TEMP = ALPHA - IF( NOUNIT ) - $ TEMP = TEMP*T( J, J ) - CALL DSCAL ( I2, TEMP, H( 1, J ), 1 ) -C - DO 110, K = 1, J - 1 - CALL DAXPY ( I2, ALPHA*T( K, J ), H( 1, K ), 1, - $ H( 1, J ), 1 ) - 110 CONTINUE -C - 120 CONTINUE -C - ELSE -C - DO 140, J = 1, N - I1 = MAX( 1, J-L ) - TEMP = ALPHA - IF( NOUNIT ) - $ TEMP = TEMP*T( J, J ) - CALL DSCAL ( M-I1+1, TEMP, H( I1, J ), 1 ) -C - DO 130, K = J + 1, N - CALL DAXPY ( M-I1+1, ALPHA*T( K, J ), H( I1, K ), - $ 1, H( I1, J ), 1 ) - 130 CONTINUE -C - 140 CONTINUE -C - END IF -C - ELSE -C -C Form H := alpha*H*T'. -C - IF( UPPER ) THEN - M2 = MIN( N+L, M ) -C - DO 170, K = 1, N - I1 = MIN( K+L, M ) - I2 = MIN( K+L, M2 ) -C - DO 160, J = 1, K - 1 - IF( T( J, K ).NE.ZERO ) THEN - TEMP = ALPHA*T( J, K ) - CALL DAXPY ( I1, TEMP, H( 1, K ), 1, H( 1, J ), - $ 1 ) -C - DO 150, I = I1 + 1, I2 - H( I, J ) = TEMP*H( I, K ) - 150 CONTINUE -C - END IF - 160 CONTINUE -C - TEMP = ALPHA - IF( NOUNIT ) - $ TEMP = TEMP*T( K, K ) - IF( TEMP.NE.ONE ) - $ CALL DSCAL( I2, TEMP, H( 1, K ), 1 ) - 170 CONTINUE -C - ELSE -C - DO 200, K = N, 1, -1 - I1 = MAX( 1, K-L ) - I2 = MAX( 1, K-L+1 ) - M2 = MIN( M, I2-1 ) -C - DO 190, J = K + 1, N - IF( T( J, K ).NE.ZERO ) THEN - TEMP = ALPHA*T( J, K ) - CALL DAXPY ( M-I2+1, TEMP, H( I2, K ), 1, - $ H( I2, J ), 1 ) -C - DO 180, I = I1, M2 - H( I, J ) = TEMP*H( I, K ) - 180 CONTINUE -C - END IF - 190 CONTINUE -C - TEMP = ALPHA - IF( NOUNIT ) - $ TEMP = TEMP*T( K, K ) - IF( TEMP.NE.ONE ) - $ CALL DSCAL( M-I1+1, TEMP, H( I1, K ), 1 ) - 200 CONTINUE -C - END IF -C - END IF -C - END IF -C - RETURN -C -C *** Last line of MB01ZD *** - END diff --git a/mex/sources/libslicot/MB02CD.f b/mex/sources/libslicot/MB02CD.f deleted file mode 100644 index 2c878db9d..000000000 --- a/mex/sources/libslicot/MB02CD.f +++ /dev/null @@ -1,597 +0,0 @@ - SUBROUTINE MB02CD( JOB, TYPET, K, N, T, LDT, G, LDG, R, LDR, L, - $ LDL, CS, LCS, DWORK, LDWORK, INFO ) -C -C SLICOT RELEASE 5.0. -C -C Copyright (c) 2002-2009 NICONET e.V. -C -C This program is free software: you can redistribute it and/or -C modify it under the terms of the GNU General Public License as -C published by the Free Software Foundation, either version 2 of -C the License, or (at your option) any later version. -C -C This program is distributed in the hope that it will be useful, -C but WITHOUT ANY WARRANTY; without even the implied warranty of -C MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the -C GNU General Public License for more details. -C -C You should have received a copy of the GNU General Public License -C along with this program. If not, see -C . -C -C PURPOSE -C -C To compute the Cholesky factor and the generator and/or the -C Cholesky factor of the inverse of a symmetric positive definite -C (s.p.d.) block Toeplitz matrix T, defined by either its first -C block row, or its first block column, depending on the routine -C parameter TYPET. Transformation information is stored. -C -C ARGUMENTS -C -C Mode Parameters -C -C JOB CHARACTER*1 -C Specifies the output of the routine, as follows: -C = 'G': only computes the generator G of the inverse; -C = 'R': computes the generator G of the inverse and the -C Cholesky factor R of T, i.e., if TYPET = 'R', -C then R'*R = T, and if TYPET = 'C', then R*R' = T; -C = 'L': computes the generator G and the Cholesky factor L -C of the inverse, i.e., if TYPET = 'R', then -C L'*L = inv(T), and if TYPET = 'C', then -C L*L' = inv(T); -C = 'A': computes the generator G, the Cholesky factor L -C of the inverse and the Cholesky factor R of T; -C = 'O': only computes the Cholesky factor R of T. -C -C TYPET CHARACTER*1 -C Specifies the type of T, as follows: -C = 'R': T contains the first block row of an s.p.d. block -C Toeplitz matrix; if demanded, the Cholesky factors -C R and L are upper and lower triangular, -C respectively, and G contains the transposed -C generator of the inverse; -C = 'C': T contains the first block column of an s.p.d. -C block Toeplitz matrix; if demanded, the Cholesky -C factors R and L are lower and upper triangular, -C respectively, and G contains the generator of the -C inverse. This choice results in a column oriented -C algorithm which is usually faster. -C Note: in the sequel, the notation x / y means that -C x corresponds to TYPET = 'R' and y corresponds to -C TYPET = 'C'. -C -C Input/Output Parameters -C -C K (input) INTEGER -C The number of rows / columns in T, which should be equal -C to the blocksize. K >= 0. -C -C N (input) INTEGER -C The number of blocks in T. N >= 0. -C -C T (input/output) DOUBLE PRECISION array, dimension -C (LDT,N*K) / (LDT,K) -C On entry, the leading K-by-N*K / N*K-by-K part of this -C array must contain the first block row / column of an -C s.p.d. block Toeplitz matrix. -C On exit, if INFO = 0, then the leading K-by-N*K / N*K-by-K -C part of this array contains, in the first K-by-K block, -C the upper / lower Cholesky factor of T(1:K,1:K), and in -C the remaining part, the Householder transformations -C applied during the process. -C -C LDT INTEGER -C The leading dimension of the array T. -C LDT >= MAX(1,K), if TYPET = 'R'; -C LDT >= MAX(1,N*K), if TYPET = 'C'. -C -C G (output) DOUBLE PRECISION array, dimension -C (LDG,N*K) / (LDG,2*K) -C If INFO = 0 and JOB = 'G', 'R', 'L', or 'A', the leading -C 2*K-by-N*K / N*K-by-2*K part of this array contains, in -C the first K-by-K block of the second block row / column, -C the lower right block of L (necessary for updating -C factorizations in SLICOT Library routine MB02DD), and -C in the remaining part, the generator of the inverse of T. -C Actually, to obtain a generator one has to set -C G(K+1:2*K, 1:K) = 0, if TYPET = 'R'; -C G(1:K, K+1:2*K) = 0, if TYPET = 'C'. -C -C LDG INTEGER -C The leading dimension of the array G. -C LDG >= MAX(1,2*K), if TYPET = 'R' and -C JOB = 'G', 'R', 'L', or 'A'; -C LDG >= MAX(1,N*K), if TYPET = 'C' and -C JOB = 'G', 'R', 'L', or 'A'; -C LDG >= 1, if JOB = 'O'. -C -C R (output) DOUBLE PRECISION array, dimension (LDR,N*K) -C If INFO = 0 and JOB = 'R', 'A', or 'O', then the leading -C N*K-by-N*K part of this array contains the upper / lower -C Cholesky factor of T. -C The elements in the strictly lower / upper triangular part -C are not referenced. -C -C LDR INTEGER -C The leading dimension of the array R. -C LDR >= MAX(1,N*K), if JOB = 'R', 'A', or 'O'; -C LDR >= 1, if JOB = 'G', or 'L'. -C -C L (output) DOUBLE PRECISION array, dimension (LDL,N*K) -C If INFO = 0 and JOB = 'L', or 'A', then the leading -C N*K-by-N*K part of this array contains the lower / upper -C Cholesky factor of the inverse of T. -C The elements in the strictly upper / lower triangular part -C are not referenced. -C -C LDL INTEGER -C The leading dimension of the array L. -C LDL >= MAX(1,N*K), if JOB = 'L', or 'A'; -C LDL >= 1, if JOB = 'G', 'R', or 'O'. -C -C CS (output) DOUBLE PRECISION array, dimension (LCS) -C If INFO = 0, then the leading 3*(N-1)*K part of this -C array contains information about the hyperbolic rotations -C and Householder transformations applied during the -C process. This information is needed for updating the -C factorizations in SLICOT Library routine MB02DD. -C -C LCS INTEGER -C The length of the array CS. LCS >= 3*(N-1)*K. -C -C Workspace -C -C DWORK DOUBLE PRECISION array, dimension (LDWORK) -C On exit, if INFO = 0, DWORK(1) returns the optimal -C value of LDWORK. -C On exit, if INFO = -16, DWORK(1) returns the minimum -C value of LDWORK. -C -C LDWORK INTEGER -C The length of the array DWORK. -C LDWORK >= MAX(1,(N-1)*K). -C For optimum performance LDWORK should be larger. -C -C Error Indicator -C -C INFO INTEGER -C = 0: successful exit; -C < 0: if INFO = -i, the i-th argument had an illegal -C value; -C = 1: the reduction algorithm failed. The Toeplitz matrix -C associated with T is not (numerically) positive -C definite. -C -C METHOD -C -C Householder transformations and modified hyperbolic rotations -C are used in the Schur algorithm [1], [2]. -C -C REFERENCES -C -C [1] Kailath, T. and Sayed, A. -C Fast Reliable Algorithms for Matrices with Structure. -C SIAM Publications, Philadelphia, 1999. -C -C [2] Kressner, D. and Van Dooren, P. -C Factorizations and linear system solvers for matrices with -C Toeplitz structure. -C SLICOT Working Note 2000-2, 2000. -C -C NUMERICAL ASPECTS -C -C The implemented method is numerically stable. -C 3 2 -C The algorithm requires 0(K N ) floating point operations. -C -C CONTRIBUTOR -C -C D. Kressner, Technical Univ. Chemnitz, Germany, June 2000. -C -C REVISIONS -C -C V. Sima, Research Institute for Informatics, Bucharest, July 2000, -C February 2004. -C -C KEYWORDS -C -C Elementary matrix operations, Householder transformation, matrix -C operations, Toeplitz matrix. -C -C ****************************************************************** -C -C .. Parameters .. - DOUBLE PRECISION ZERO, ONE - PARAMETER ( ZERO = 0.0D0, ONE = 1.0D0 ) -C .. Scalar Arguments .. - CHARACTER JOB, TYPET - INTEGER INFO, K, LCS, LDG, LDL, LDR, LDT, LDWORK, N -C .. Array Arguments .. - DOUBLE PRECISION CS(*), DWORK(*), G(LDG, *), L(LDL,*), R(LDR,*), - $ T(LDT,*) -C .. Local Scalars .. - INTEGER I, IERR, MAXWRK, STARTI, STARTR, STARTT - LOGICAL COMPG, COMPL, COMPR, ISROW -C .. External Functions .. - LOGICAL LSAME - EXTERNAL LSAME -C .. External Subroutines .. - EXTERNAL DLACPY, DLASET, DPOTRF, DTRSM, MB02CX, MB02CY, - $ XERBLA -C .. Intrinsic Functions .. - INTRINSIC INT, MAX, MIN -C -C .. Executable Statements .. -C -C Decode the scalar input parameters. -C - INFO = 0 - COMPL = LSAME( JOB, 'L' ) .OR. LSAME( JOB, 'A' ) - COMPG = LSAME( JOB, 'G' ) .OR. LSAME( JOB, 'R' ) .OR. COMPL - COMPR = LSAME( JOB, 'R' ) .OR. LSAME( JOB, 'A' ) .OR. - $ LSAME( JOB, 'O' ) - ISROW = LSAME( TYPET, 'R' ) -C -C Check the scalar input parameters. -C - IF ( .NOT.( COMPG .OR. COMPR ) ) THEN - INFO = -1 - ELSE IF ( .NOT.( ISROW .OR. LSAME( TYPET, 'C' ) ) ) THEN - INFO = -2 - ELSE IF ( K.LT.0 ) THEN - INFO = -3 - ELSE IF ( N.LT.0 ) THEN - INFO = -4 - ELSE IF ( LDT.LT.1 .OR. ( ISROW .AND. LDT.LT.K ) .OR. - $ ( .NOT.ISROW .AND. LDT.LT.N*K ) ) THEN - INFO = -6 - ELSE IF ( LDG.LT.1 .OR. - $ ( COMPG .AND. ( ( ISROW .AND. LDG.LT.2*K ) - $ .OR. ( .NOT.ISROW .AND. LDG.LT.N*K ) ) ) ) THEN - INFO = -8 - ELSE IF ( LDR.LT.1 .OR. ( COMPR .AND. ( LDR.LT.N*K ) ) ) THEN - INFO = -10 - ELSE IF ( LDL.LT.1 .OR. ( COMPL .AND. ( LDL.LT.N*K ) ) ) THEN - INFO = -12 - ELSE IF ( LCS.LT.3*( N - 1 )*K ) THEN - INFO = -14 - ELSE IF ( LDWORK.LT.MAX( 1, ( N - 1 )*K ) ) THEN - DWORK(1) = MAX( 1, ( N - 1 )*K ) - INFO = -16 - END IF -C -C Return if there were illegal values. -C - IF ( INFO.NE.0 ) THEN - CALL XERBLA( 'MB02CD', -INFO ) - RETURN - END IF -C -C Quick return if possible. -C - IF ( MIN( K, N ).EQ.0 ) THEN - DWORK(1) = ONE - RETURN - END IF -C - MAXWRK = 1 - IF ( ISROW ) THEN -C -C T is the first block row of a block Toeplitz matrix. -C Bring T to proper form by triangularizing its first block. -C - CALL DPOTRF( 'Upper', K, T, LDT, IERR ) - IF ( IERR.NE.0 ) THEN -C -C Error return: The matrix is not positive definite. -C - INFO = 1 - RETURN - END IF -C - IF ( N.GT.1 ) - $ CALL DTRSM( 'Left', 'Upper', 'Transpose', 'NonUnit', K, - $ (N-1)*K, ONE, T, LDT, T(1,K+1), LDT ) -C -C Initialize the output matrices. -C - IF ( COMPG ) THEN - CALL DLASET( 'All', 2*K, N*K, ZERO, ZERO, G, LDG ) - CALL DLASET( 'All', 1, K, ONE, ONE, G(K+1,1), LDG+1 ) - CALL DTRSM( 'Left', 'Upper', 'Transpose', 'NonUnit', K, K, - $ ONE, T, LDT, G(K+1,1), LDG ) - IF ( N.GT.1 ) - $ CALL DLACPY( 'Upper', K, (N-1)*K, T, LDT, G(K+1,K+1), - $ LDG ) - CALL DLACPY( 'Lower', K, K, G(K+1,1), LDG, G, LDG ) - END IF -C - IF ( COMPL ) THEN - CALL DLACPY( 'Lower', K, K, G(K+1,1), LDG, L, LDL ) - END IF -C - IF ( COMPR ) THEN - CALL DLACPY( 'Upper', K, N*K, T, LDT, R, LDR ) - END IF -C -C Processing the generator. -C - IF ( COMPG ) THEN -C -C Here we use G as working array for holding the generator. -C T contains the second row of the generator. -C G contains in its first block row the second row of the -C inverse generator. -C The second block row of G is partitioned as follows: -C -C [ First block of the inverse generator, ... -C First row of the generator, ... -C The rest of the blocks of the inverse generator ] -C -C The reason for the odd partitioning is that the first block -C of the inverse generator will be thrown out at the end and -C we want to avoid reordering. -C -C (N-1)*K locations of DWORK are used by SLICOT Library -C routine MB02CY. -C - DO 10 I = 2, N - STARTR = ( I - 1 )*K + 1 - STARTI = ( N - I + 1 )*K + 1 - STARTT = 3*( I - 2 )*K + 1 -C -C Transformations acting on the generator: -C - CALL MB02CX( 'Row', K, K, K, G(K+1,K+1), LDG, - $ T(1,STARTR), LDT, CS(STARTT), 3*K, DWORK, - $ LDWORK, IERR ) -C - IF ( IERR.NE.0 ) THEN -C -C Error return: The matrix is not positive definite. -C - INFO = 1 - RETURN - END IF -C - MAXWRK = MAX( MAXWRK, INT( DWORK(1) ) ) - IF ( N.GT.I ) THEN - CALL MB02CY( 'Row', 'NoStructure', K, K, (N-I)*K, K, - $ G(K+1,2*K+1), LDG, T(1,STARTR+K), LDT, - $ T(1,STARTR), LDT, CS(STARTT), 3*K, DWORK, - $ LDWORK, IERR ) - MAXWRK = MAX( MAXWRK, INT( DWORK(1) ) ) - END IF -C - IF ( COMPR ) THEN - CALL DLACPY( 'Upper', K, (N-I+1)*K, G(K+1,K+1), LDG, - $ R(STARTR,STARTR), LDR) - END IF -C -C Transformations acting on the inverse generator: -C - CALL DLASET( 'All', K, K, ZERO, ZERO, G(K+1,STARTI), - $ LDG ) - CALL MB02CY( 'Row', 'Triangular', K, K, K, K, G(K+1,1), - $ LDG, G(1,STARTR), LDG, T(1,STARTR), LDT, - $ CS(STARTT), 3*K, DWORK, LDWORK, IERR ) - MAXWRK = MAX( MAXWRK, INT( DWORK(1) ) ) -C - CALL MB02CY( 'Row', 'NoStructure', K, K, (I-1)*K, K, - $ G(K+1,STARTI), LDG, G, LDG, T(1,STARTR), - $ LDT, CS(STARTT), 3*K, DWORK, LDWORK, IERR ) - MAXWRK = MAX( MAXWRK, INT( DWORK(1) ) ) -C - IF ( COMPL ) THEN - CALL DLACPY( 'All', K, (I-1)*K, G(K+1,STARTI), LDG, - $ L(STARTR,1), LDL ) - CALL DLACPY( 'Lower', K, K, G(K+1,1), LDG, - $ L(STARTR,(I-1)*K+1), LDL ) - END IF - 10 CONTINUE -C - ELSE -C -C Here R is used as working array for holding the generator. -C Again, T contains the second row of the generator. -C The current row of R contains the first row of the -C generator. -C - IF ( N.GT.1 ) - $ CALL DLACPY( 'Upper', K, (N-1)*K, T, LDT, R(K+1,K+1), - $ LDR ) -C - DO 20 I = 2, N - STARTR = ( I - 1 )*K + 1 - STARTT = 3*( I - 2 )*K + 1 - CALL MB02CX( 'Row', K, K, K, R(STARTR,STARTR), LDR, - $ T(1,STARTR), LDT, CS(STARTT), 3*K, DWORK, - $ LDWORK, IERR ) - IF ( IERR.NE.0 ) THEN -C -C Error return: The matrix is not positive definite. -C - INFO = 1 - RETURN - END IF -C - MAXWRK = MAX( MAXWRK, INT( DWORK(1) ) ) - IF ( N.GT.I ) THEN - CALL MB02CY( 'Row', 'NoStructure', K, K, (N-I)*K, K, - $ R(STARTR,STARTR+K), LDR, T(1,STARTR+K), - $ LDT, T(1,STARTR), LDT, CS(STARTT), 3*K, - $ DWORK, LDWORK, IERR ) - MAXWRK = MAX( MAXWRK, INT( DWORK(1) ) ) -C - CALL DLACPY( 'Upper', K, (N-I)*K, R(STARTR,STARTR), - $ LDR, R(STARTR+K,STARTR+K), LDR ) - END IF - 20 CONTINUE -C - END IF -C - ELSE -C -C T is the first block column of a block Toeplitz matrix. -C Bring T to proper form by triangularizing its first block. -C - CALL DPOTRF( 'Lower', K, T, LDT, IERR ) - IF ( IERR.NE.0 ) THEN -C -C Error return: The matrix is not positive definite. -C - INFO = 1 - RETURN - END IF -C - IF ( N.GT.1 ) - $ CALL DTRSM( 'Right', 'Lower', 'Transpose', 'NonUnit', - $ (N-1)*K, K, ONE, T, LDT, T(K+1,1), LDT ) -C -C Initialize the output matrices. -C - IF ( COMPG ) THEN - CALL DLASET( 'All', N*K, 2*K, ZERO, ZERO, G, LDG ) - CALL DLASET( 'All', 1, K, ONE, ONE, G(1,K+1), LDG+1 ) - CALL DTRSM( 'Right', 'Lower', 'Transpose', 'NonUnit', K, K, - $ ONE, T, LDT, G(1,K+1), LDG ) - IF ( N.GT.1 ) - $ CALL DLACPY( 'Lower', (N-1)*K, K, T, LDT, G(K+1,K+1), - $ LDG ) - CALL DLACPY( 'Upper', K, K, G(1,K+1), LDG, G, LDG ) - END IF -C - IF ( COMPL ) THEN - CALL DLACPY( 'Upper', K, K, G(1,K+1), LDG, L, LDL ) - END IF -C - IF ( COMPR ) THEN - CALL DLACPY( 'Lower', N*K, K, T, LDT, R, LDR ) - END IF -C -C Processing the generator. -C - IF ( COMPG ) THEN -C -C Here we use G as working array for holding the generator. -C T contains the second column of the generator. -C G contains in its first block column the second column of -C the inverse generator. -C The second block column of G is partitioned as follows: -C -C [ First block of the inverse generator; ... -C First column of the generator; ... -C The rest of the blocks of the inverse generator ] -C -C The reason for the odd partitioning is that the first block -C of the inverse generator will be thrown out at the end and -C we want to avoid reordering. -C -C (N-1)*K locations of DWORK are used by SLICOT Library -C routine MB02CY. -C - DO 30 I = 2, N - STARTR = ( I - 1 )*K + 1 - STARTI = ( N - I + 1 )*K + 1 - STARTT = 3*( I - 2 )*K + 1 -C -C Transformations acting on the generator: -C - CALL MB02CX( 'Column', K, K, K, G(K+1,K+1), LDG, - $ T(STARTR,1), LDT, CS(STARTT), 3*K, DWORK, - $ LDWORK, IERR ) -C - IF ( IERR.NE.0 ) THEN -C -C Error return: The matrix is not positive definite. -C - INFO = 1 - RETURN - END IF -C - MAXWRK = MAX( MAXWRK, INT( DWORK(1) ) ) - IF ( N.GT.I ) THEN - CALL MB02CY( 'Column', 'NoStructure', K, K, (N-I)*K, - $ K, G(2*K+1,K+1), LDG, T(STARTR+K,1), LDT, - $ T(STARTR,1), LDT, CS(STARTT), 3*K, DWORK, - $ LDWORK, IERR ) - MAXWRK = MAX( MAXWRK, INT( DWORK(1) ) ) - END IF -C - IF ( COMPR ) THEN - CALL DLACPY( 'Lower', (N-I+1)*K, K, G(K+1,K+1), LDG, - $ R(STARTR,STARTR), LDR) - END IF -C -C Transformations acting on the inverse generator: -C - CALL DLASET( 'All', K, K, ZERO, ZERO, G(STARTI,K+1), - $ LDG ) - CALL MB02CY( 'Column', 'Triangular', K, K, K, K, - $ G(1,K+1), LDG, G(STARTR,1), LDG, - $ T(STARTR,1), LDT, CS(STARTT), 3*K, DWORK, - $ LDWORK, IERR ) - MAXWRK = MAX( MAXWRK, INT( DWORK(1) ) ) -C - CALL MB02CY( 'Column', 'NoStructure', K, K, (I-1)*K, K, - $ G(STARTI,K+1), LDG, G, LDG, T(STARTR,1), - $ LDT, CS(STARTT), 3*K, DWORK, LDWORK, IERR ) - MAXWRK = MAX( MAXWRK, INT( DWORK(1) ) ) -C - IF ( COMPL ) THEN - CALL DLACPY( 'All', (I-1)*K, K, G(STARTI,K+1), LDG, - $ L(1,STARTR), LDL ) - CALL DLACPY( 'Upper', K, K, G(1,K+1), LDG, - $ L((I-1)*K+1,STARTR), LDL ) - END IF - 30 CONTINUE -C - ELSE -C -C Here R is used as working array for holding the generator. -C Again, T contains the second column of the generator. -C The current column of R contains the first column of the -C generator. -C - IF ( N.GT.1 ) - $ CALL DLACPY( 'Lower', (N-1)*K, K, T, LDT, R(K+1,K+1), - $ LDR ) -C - DO 40 I = 2, N - STARTR = ( I - 1 )*K + 1 - STARTT = 3*( I - 2 )*K + 1 - CALL MB02CX( 'Column', K, K, K, R(STARTR,STARTR), LDR, - $ T(STARTR,1), LDT, CS(STARTT), 3*K, DWORK, - $ LDWORK, IERR ) - IF ( IERR.NE.0 ) THEN -C -C Error return: The matrix is not positive definite. -C - INFO = 1 - RETURN - END IF -C - MAXWRK = MAX( MAXWRK, INT( DWORK(1) ) ) - IF ( N.GT.I ) THEN - CALL MB02CY( 'Column', 'NoStructure', K, K, (N-I)*K, - $ K, R(STARTR+K,STARTR), LDR, - $ T(STARTR+K,1), LDT, T(STARTR,1), LDT, - $ CS(STARTT), 3*K, DWORK, LDWORK, IERR ) - MAXWRK = MAX( MAXWRK, INT( DWORK(1) ) ) -C - CALL DLACPY( 'Lower', (N-I)*K, K, R(STARTR,STARTR), - $ LDR, R(STARTR+K,STARTR+K), LDR ) - END IF - 40 CONTINUE -C - END IF - END IF -C - DWORK(1) = MAXWRK -C - RETURN -C -C *** Last line of MB02CD *** - END diff --git a/mex/sources/libslicot/MB02CU.f b/mex/sources/libslicot/MB02CU.f deleted file mode 100644 index 38bddf38f..000000000 --- a/mex/sources/libslicot/MB02CU.f +++ /dev/null @@ -1,1015 +0,0 @@ - SUBROUTINE MB02CU( TYPEG, K, P, Q, NB, A1, LDA1, A2, LDA2, B, LDB, - $ RNK, IPVT, CS, TOL, DWORK, LDWORK, INFO ) -C -C SLICOT RELEASE 5.0. -C -C Copyright (c) 2002-2009 NICONET e.V. -C -C This program is free software: you can redistribute it and/or -C modify it under the terms of the GNU General Public License as -C published by the Free Software Foundation, either version 2 of -C the License, or (at your option) any later version. -C -C This program is distributed in the hope that it will be useful, -C but WITHOUT ANY WARRANTY; without even the implied warranty of -C MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the -C GNU General Public License for more details. -C -C You should have received a copy of the GNU General Public License -C along with this program. If not, see -C . -C -C PURPOSE -C -C To bring the first blocks of a generator to proper form. -C The positive part of the generator is contained in the arrays A1 -C and A2. The negative part of the generator is contained in B. -C Transformation information will be stored and can be applied -C via SLICOT Library routine MB02CV. -C -C ARGUMENTS -C -C Mode Parameters -C -C TYPEG CHARACTER*1 -C Specifies the type of the generator, as follows: -C = 'D': generator is column oriented and rank -C deficiencies are expected; -C = 'C': generator is column oriented and rank -C deficiencies are not expected; -C = 'R': generator is row oriented and rank -C deficiencies are not expected. -C -C Input/Output Parameters -C -C K (input) INTEGER -C The number of rows in A1 to be processed. K >= 0. -C -C P (input) INTEGER -C The number of columns of the positive generator. P >= K. -C -C Q (input) INTEGER -C The number of columns in B containing the negative -C generators. -C If TYPEG = 'D', Q >= K; -C If TYPEG = 'C' or 'R', Q >= 0. -C -C NB (input) INTEGER -C On entry, if TYPEG = 'C' or TYPEG = 'R', NB specifies -C the block size to be used in the blocked parts of the -C algorithm. If NB <= 0, an unblocked algorithm is used. -C -C A1 (input/output) DOUBLE PRECISION array, dimension -C (LDA1, K) -C On entry, the leading K-by-K part of this array must -C contain the leading submatrix of the positive part of the -C generator. If TYPEG = 'C', A1 is assumed to be lower -C triangular and the strictly upper triangular part is not -C referenced. If TYPEG = 'R', A1 is assumed to be upper -C triangular and the strictly lower triangular part is not -C referenced. -C On exit, if TYPEG = 'D', the leading K-by-RNK part of this -C array contains the lower trapezoidal part of the proper -C generator and information for the Householder -C transformations applied during the reduction process. -C On exit, if TYPEG = 'C', the leading K-by-K part of this -C array contains the leading lower triangular part of the -C proper generator. -C On exit, if TYPEG = 'R', the leading K-by-K part of this -C array contains the leading upper triangular part of the -C proper generator. -C -C LDA1 INTEGER -C The leading dimension of the array A1. LDA1 >= MAX(1,K). -C -C A2 (input/output) DOUBLE PRECISION array, -C if TYPEG = 'D' or TYPEG = 'C', dimension (LDA2, P-K); -C if TYPEG = 'R', dimension (LDA2, K). -C On entry, if TYPEG = 'D' or TYPEG = 'C', the leading -C K-by-(P-K) part of this array must contain the (K+1)-st -C to P-th columns of the positive part of the generator. -C On entry, if TYPEG = 'R', the leading (P-K)-by-K part of -C this array must contain the (K+1)-st to P-th rows of the -C positive part of the generator. -C On exit, if TYPEG = 'D' or TYPEG = 'C', the leading -C K-by-(P-K) part of this array contains information for -C Householder transformations. -C On exit, if TYPEG = 'R', the leading (P-K)-by-K part of -C this array contains information for Householder -C transformations. -C -C LDA2 INTEGER -C The leading dimension of the array A2. -C If P = K, LDA2 >= 1; -C If P > K and (TYPEG = 'D' or TYPEG = 'C'), -C LDA2 >= MAX(1,K); -C if P > K and TYPEG = 'R', LDA2 >= P-K. -C -C B (input/output) DOUBLE PRECISION array, -C if TYPEG = 'D' or TYPEG = 'C', dimension (LDB, Q); -C if TYPEG = 'R', dimension (LDB, K). -C On entry, if TYPEG = 'D' or TYPEG = 'C', the leading -C K-by-Q part of this array must contain the negative part -C of the generator. -C On entry, if TYPEG = 'R', the leading Q-by-K part of this -C array must contain the negative part of the generator. -C On exit, if TYPEG = 'D' or TYPEG = 'C', the leading -C K-by-Q part of this array contains information for -C Householder transformations. -C On exit, if TYPEG = 'R', the leading Q-by-K part of this -C array contains information for Householder transformations. -C -C LDB INTEGER -C The leading dimension of the array B. -C If Q = 0, LDB >= 1; -C if Q > 0 and (TYPEG = 'D' or TYPEG = 'C'), -C LDB >= MAX(1,K); -C if Q > 0 and TYPEG = 'R', LDB >= Q. -C -C RNK (output) INTEGER -C If TYPEG = 'D', the number of columns in the reduced -C generator which are found to be linearly independent. -C If TYPEG = 'C' or TYPEG = 'R', then RNK is not set. -C -C IPVT (output) INTEGER array, dimension (K) -C If TYPEG = 'D', then if IPVT(i) = k, the k-th row of the -C proper generator is the reduced i-th row of the input -C generator. -C If TYPEG = 'C' or TYPEG = 'R', this array is not -C referenced. -C -C CS (output) DOUBLE PRECISION array, dimension (x) -C If TYPEG = 'D' and P = K, x = 3*K; -C if TYPEG = 'D' and P > K, x = 5*K; -C if (TYPEG = 'C' or TYPEG = 'R') and P = K, x = 4*K; -C if (TYPEG = 'C' or TYPEG = 'R') and P > K, x = 6*K. -C On exit, the first x elements of this array contain -C necessary information for the SLICOT library routine -C MB02CV (Givens and modified hyperbolic rotation -C parameters, scalar factors of the Householder -C transformations). -C -C Tolerances -C -C TOL DOUBLE PRECISION -C If TYPEG = 'D', this number specifies the used tolerance -C for handling deficiencies. If the hyperbolic norm -C of two diagonal elements in the positive and negative -C generators appears to be less than or equal to TOL, then -C the corresponding columns are not reduced. -C -C Workspace -C -C DWORK DOUBLE PRECISION array, dimension (LDWORK) -C On exit, if INFO = -17, DWORK(1) returns the minimum -C value of LDWORK. -C -C LDWORK INTEGER -C The length of the array DWORK. -C LDWORK >= MAX(1,4*K), if TYPEG = 'D'; -C LDWORK >= MAX(1,MAX(NB,1)*K), if TYPEG = 'C' or 'R'. -C -C Error Indicator -C -C INFO INTEGER -C = 0: successful exit; -C < 0: if INFO = -i, the i-th argument had an illegal -C value; -C = 1: if TYPEG = 'D', the generator represents a -C (numerically) indefinite matrix; and if TYPEG = 'C' -C or TYPEG = 'R', the generator represents a -C (numerically) semidefinite matrix. -C -C METHOD -C -C If TYPEG = 'C' or TYPEG = 'R', blocked Householder transformations -C and modified hyperbolic rotations are used to downdate the -C matrix [ A1 A2 sqrt(-1)*B ], cf. [1], [2]. -C If TYPEG = 'D', then an algorithm with row pivoting is used. In -C the first stage it maximizes the hyperbolic norm of the active -C row. As soon as the hyperbolic norm is below the threshold TOL, -C the strategy is changed. Now, in the second stage, the algorithm -C applies an LQ decomposition with row pivoting on B such that -C the Euclidean norm of the active row is maximized. -C -C REFERENCES -C -C [1] Kailath, T. and Sayed, A. -C Fast Reliable Algorithms for Matrices with Structure. -C SIAM Publications, Philadelphia, 1999. -C -C [2] Kressner, D. and Van Dooren, P. -C Factorizations and linear system solvers for matrices with -C Toeplitz structure. -C SLICOT Working Note 2000-2, 2000. -C -C NUMERICAL ASPECTS -C 2 -C The algorithm requires 0(K *( P + Q )) floating point operations. -C -C CONTRIBUTOR -C -C D. Kressner, Technical Univ. Berlin, Germany, May 2001. -C -C REVISIONS -C -C V. Sima, Research Institute for Informatics, Bucharest, June 2001. -C D. Kressner, Technical Univ. Berlin, Germany, July 2002. -C V. Sima, Research Institute for Informatics, Bucharest, Mar. 2004. -C -C KEYWORDS -C -C Elementary matrix operations, Householder transformation, matrix -C operations, Toeplitz matrix. -C -C ****************************************************************** -C -C .. Parameters .. - DOUBLE PRECISION ZERO, ONE, P05 - PARAMETER ( ZERO = 0.0D+0, ONE = 1.0D+0, P05 = 0.05D0 ) -C .. Scalar Arguments .. - CHARACTER TYPEG - INTEGER INFO, K, LDA1, LDA2, LDB, LDWORK, NB, P, Q, RNK - DOUBLE PRECISION TOL -C .. Array Arguments .. - INTEGER IPVT(*) - DOUBLE PRECISION A1(LDA1,*), A2(LDA2,*), B(LDB,*), CS(*), - $ DWORK(*) -C .. Local Scalars .. - LOGICAL LCOL, LRDEF - INTEGER COL2, I, IB, IERR, IMAX, ITEMP, J, JJ, LEN, - $ NBL, PDW, PHV, POS, PST2, PVT, WRKMIN - DOUBLE PRECISION ALPHA, ALPHA2, BETA, C, DMAX, S, TAU1, TAU2, - $ TEMP, TEMP2 -C .. External Functions .. - LOGICAL LSAME - INTEGER IDAMAX - DOUBLE PRECISION DLAPY2, DNRM2 - EXTERNAL IDAMAX, DLAPY2, DNRM2, LSAME -C .. External Subroutines .. - EXTERNAL DAXPY, DGELQ2, DGEQR2, DLARF, DLARFB, DLARFG, - $ DLARFT, DLARTG, DROT, DSCAL, DSWAP, MA02FD, - $ XERBLA -C .. Intrinsic Functions .. - INTRINSIC ABS, MAX, MIN, SIGN, SQRT -C -C .. Executable Statements .. -C -C Decode the scalar input parameters. -C - INFO = 0 - COL2 = P - K - LRDEF = LSAME( TYPEG, 'D' ) - LCOL = LSAME( TYPEG, 'C' ) - IF ( LRDEF ) THEN - WRKMIN = MAX( 1, 4*K ) - ELSE - WRKMIN = MAX( 1, NB*K, K ) - END IF -C -C Check the scalar input parameters. -C - IF ( .NOT.( LCOL .OR. LRDEF .OR. LSAME( TYPEG, 'R' ) ) ) THEN - INFO = -1 - ELSE IF ( K.LT.0 ) THEN - INFO = -2 - ELSE IF ( P.LT.K ) THEN - INFO = -3 - ELSE IF ( Q.LT.0 .OR. ( LRDEF .AND. Q.LT.K ) ) THEN - INFO = -4 - ELSE IF ( LDA1.LT.MAX( 1, K ) ) THEN - INFO = -7 - ELSE IF ( ( ( P.EQ.K ) .AND. LDA2.LT.1 ) .OR. - $ ( ( P.GT.K ) .AND. ( LRDEF .OR. LCOL ) .AND. - $ ( LDA2.LT.MAX( 1, K ) ) ) .OR. - $ ( ( P.GT.K ) .AND. .NOT.( LRDEF .OR. LCOL ) .AND. - $ ( LDA2.LT.( P - K ) ) ) ) THEN - INFO = -9 - ELSE IF ( ( ( Q.EQ.0 ) .AND. LDB.LT.1 ) .OR. - $ ( ( Q.GT.0 ) .AND. ( LRDEF .OR. LCOL ) .AND. - $ ( LDB.LT.MAX( 1, K ) ) ) .OR. - $ ( ( Q.GT.0 ) .AND. .NOT.( LRDEF .OR. LCOL ) .AND. - $ ( LDB.LT.Q ) ) ) THEN - INFO = -11 - ELSE IF ( LDWORK.LT.WRKMIN ) THEN - DWORK(1) = DBLE( WRKMIN ) - INFO = -17 - END IF -C -C Return if there were illegal values. -C - IF ( INFO.NE.0 ) THEN - CALL XERBLA( 'MB02CU', -INFO ) - RETURN - END IF -C -C Quick return if possible. -C - IF ( K.EQ.0 .OR. ( .NOT.LRDEF .AND. Q.EQ.0 .AND. P.EQ.K ) ) THEN - IF ( LRDEF ) - $ RNK = 0 - RETURN - END IF -C - IF ( LRDEF ) THEN -C -C Deficient generator. -C - IF ( COL2.EQ.0 ) THEN - PST2 = 2*K - ELSE - PST2 = 4*K - END IF -C -C Initialize partial hyperbolic row norms. -C - RNK = 0 - PHV = 3*K -C - DO 10 I = 1, K - IPVT(I) = I - DWORK(I) = DNRM2( K, A1(I,1), LDA1 ) - 10 CONTINUE -C - DO 20 I = 1, K - DWORK(I) = DLAPY2( DWORK(I), - $ DNRM2( COL2, A2(I,1), LDA2 ) ) - DWORK(I+K) = DWORK(I) - 20 CONTINUE -C - PDW = 2*K -C - DO 30 I = 1, K - PDW = PDW + 1 - DWORK(PDW) = DNRM2( Q, B(I,1), LDB ) - 30 CONTINUE -C -C Compute factorization. -C - DO 90 I = 1, K -C -C Determine pivot row and swap if necessary. -C - PDW = I - ALPHA = ABS( DWORK(PDW) ) - BETA = ABS( DWORK(PDW+2*K) ) - DMAX = SIGN( SQRT( ABS( ALPHA - BETA ) )* - $ SQRT( ALPHA + BETA ), ALPHA - BETA ) - IMAX = I -C - DO 40 J = 1, K - I - PDW = PDW + 1 - ALPHA = ABS( DWORK(PDW) ) - BETA = ABS ( DWORK(PDW+2*K) ) - TEMP = SIGN( SQRT( ABS( ALPHA - BETA ) )* - $ SQRT( ALPHA + BETA ), ALPHA - BETA ) - IF ( TEMP.GT.DMAX ) THEN - IMAX = I + J - DMAX = TEMP - END IF - 40 CONTINUE -C -C Proceed with the reduction if the hyperbolic norm is -C beyond the threshold. -C - IF ( DMAX.GT.TOL ) THEN -C - PVT = IMAX - IF ( PVT.NE.I ) THEN - CALL DSWAP( K, A1(PVT,1), LDA1, A1(I,1), LDA1 ) - CALL DSWAP( COL2, A2(PVT,1), LDA2, A2(I,1), LDA2 ) - CALL DSWAP( Q, B(PVT,1), LDB, B(I,1), LDB ) - ITEMP = IPVT(PVT) - IPVT(PVT) = IPVT(I) - IPVT(I) = ITEMP - DWORK(PVT) = DWORK(I) - DWORK(K+PVT) = DWORK(K+I) - DWORK(2*K+PVT) = DWORK(2*K+I) - END IF -C -C Generate and apply elementary reflectors. -C - IF ( COL2.GT.1 ) THEN - CALL DLARFG( COL2, A2(I,1), A2(I,2), LDA2, TAU2 ) - ALPHA2 = A2(I,1) - IF ( K.GT.I ) THEN - A2(I,1) = ONE - CALL DLARF( 'Right', K-I, COL2, A2(I,1), LDA2, - $ TAU2, A2(I+1,1), LDA2, DWORK(PHV+1) ) - END IF - A2(I,1) = TAU2 - ELSE IF ( COL2.GT.0 ) THEN - ALPHA2 = A2(I,1) - A2(I,1) = ZERO - END IF -C - IF ( K.GT.I ) THEN - CALL DLARFG( K-I+1, A1(I,I), A1(I,I+1), LDA1, TAU1 ) - ALPHA = A1(I,I) - A1(I,I) = ONE - CALL DLARF( 'Right', K-I, K-I+1, A1(I,I), LDA1, TAU1, - $ A1(I+1,I), LDA1, DWORK(PHV+1) ) - CS(PST2+I) = TAU1 - ELSE - ALPHA = A1(I,I) - END IF -C - IF ( COL2.GT.0 ) THEN - TEMP = ALPHA - CALL DLARTG( TEMP, ALPHA2, C, S, ALPHA ) - IF ( K.GT.I ) - $ CALL DROT( K-I, A1(I+1,I), 1, A2(I+1,1), 1, C, S ) - CS(2*K+I*2-1) = C - CS(2*K+I*2) = S - END IF - A1(I,I) = ALPHA -C - IF ( Q.GT.1 ) THEN - CALL DLARFG( Q, B(I,1), B(I,2), LDB, TAU2 ) - BETA = B(I,1) - IF ( K.GT.I ) THEN - B(I,1) = ONE - CALL DLARF( 'Right', K-I, Q, B(I,1), LDB, TAU2, - $ B(I+1,1), LDB, DWORK(PHV+1) ) - END IF - B(I,1) = TAU2 - ELSE IF ( Q.GT.0 ) THEN - BETA = B(I,1) - B(I,1) = ZERO - ELSE - BETA = ZERO - END IF -C -C Create hyperbolic Givens rotation. -C - CALL MA02FD( A1(I,I), BETA, C, S, IERR ) - IF ( IERR.NE.0 ) THEN -C -C Error return: This should not happen. -C - INFO = 1 - RETURN - END IF -C -C Apply hyperbolic rotation. -C - IF ( K.GT.I ) THEN - CALL DSCAL( K-I, ONE/C, A1(I+1,I), 1 ) - CALL DAXPY( K-I, -S/C, B(I+1,1), 1, A1(I+1,I), 1 ) - CALL DSCAL( K-I, C, B(I+1,1), 1 ) - CALL DAXPY( K-I, -S, A1(I+1,I), 1, B(I+1,1), 1 ) - END IF - CS(I*2-1) = C - CS(I*2) = S -C -C Downdate the norms in A1. -C - DO 50 J = I + 1, K - TEMP = ONE - ( ABS( A1(J,I) ) / DWORK(J) )**2 - TEMP2 = ONE + P05*TEMP* - $ ( DWORK(J) / DWORK(K+J) )**2 - IF ( TEMP2.EQ.ONE ) THEN - DWORK(J) = DLAPY2( DNRM2( K-I, A1(J,I+1), LDA1 ), - $ DNRM2( COL2, A2(J,1), LDA2 ) ) - DWORK(K+J) = DWORK(J) - DWORK(2*K+J) = DNRM2( Q, B(J,1), LDB ) - ELSE - IF ( TEMP.GE.ZERO ) THEN - DWORK(J) = DWORK(J)*SQRT( TEMP ) - ELSE - DWORK(J) = -DWORK(J)*SQRT( -TEMP ) - END IF - END IF - 50 CONTINUE -C - RNK = RNK + 1 - ELSE IF ( ABS( DMAX ).LT.TOL ) THEN -C -C Displacement is positive semidefinite. -C Do an LQ decomposition with pivoting of the leftover -C negative part to find diagonal elements with almost zero -C norm. These columns cannot be removed from the -C generator. -C -C Initialize norms. -C - DO 60 J = I, K - DWORK(J) = DNRM2( Q, B(J,1), LDB ) - DWORK(J+K) = DWORK(J) - 60 CONTINUE -C - LEN = Q - POS = 1 -C - DO 80 J = I, K -C -C Generate and apply elementary reflectors. -C - PVT = ( J-1 ) + IDAMAX( K-J+1, DWORK(J), 1 ) -C -C Swap rows if necessary. -C - IF ( PVT.NE.J ) THEN - CALL DSWAP( K, A1(PVT,1), LDA1, A1(J,1), LDA1 ) - CALL DSWAP( COL2, A2(PVT,1), LDA2, A2(J,1), LDA2 ) - CALL DSWAP( Q, B(PVT,1), LDB, B(J,1), LDB ) - ITEMP = IPVT(PVT) - IPVT(PVT) = IPVT(J) - IPVT(J) = ITEMP - DWORK(PVT) = DWORK(J) - DWORK(K+PVT) = DWORK(K+J) - END IF -C -C Annihilate second part of the positive generators. -C - IF ( COL2.GT.1 ) THEN - CALL DLARFG( COL2, A2(J,1), A2(J,2), LDA2, TAU2 ) - ALPHA2 = A2(J,1) - IF ( K.GT.J ) THEN - A2(J,1) = ONE - CALL DLARF( 'Right', K-J, COL2, A2(J,1), LDA2, - $ TAU2, A2(J+1,1), LDA2, DWORK(PHV+1)) - END IF - A2(J,1) = TAU2 - ELSE IF ( COL2.GT.0 ) THEN - ALPHA2 = A2(J,1) - A2(J,1) = ZERO - END IF -C -C Transform first part of the positive generators to -C lower triangular form. -C - IF ( K.GT.J ) THEN - CALL DLARFG( K-J+1, A1(J,J), A1(J,J+1), LDA1, - $ TAU1 ) - ALPHA = A1(J,J) - A1(J,J) = ONE - CALL DLARF( 'Right', K-J, K-J+1, A1(J,J), LDA1, - $ TAU1, A1(J+1,J), LDA1, DWORK(PHV+1) ) - CS(PST2+J) = TAU1 - ELSE - ALPHA = A1(J,J) - END IF -C - IF ( COL2.GT.0 ) THEN - TEMP = ALPHA - CALL DLARTG( TEMP, ALPHA2, C, S, ALPHA ) - IF ( K.GT.J ) - $ CALL DROT( K-J, A1(J+1,J), 1, A2(J+1,1), 1, C, - $ S ) - CS(2*K+J*2-1) = C - CS(2*K+J*2) = S - END IF - A1(J,J) = ALPHA -C -C Transform negative part to lower triangular form. -C - IF ( LEN.GT.1) THEN - CALL DLARFG( LEN, B(J,POS), B(J,POS+1), LDB, TAU2 ) - BETA = B(J,POS) - IF ( K.GT.J ) THEN - B(J,POS) = ONE - CALL DLARF( 'Right', K-J, LEN, B(J,POS), LDB, - $ TAU2, B(J+1,POS), LDB, DWORK(PHV+1)) - END IF - B(J,POS) = BETA - CS(J*2-1) = TAU2 - END IF -C -C Downdate the norms of the rows in the negative part. -C - DO 70 JJ = J + 1, K - IF ( DWORK(JJ).NE.ZERO ) THEN - TEMP = ONE - ( ABS( B(JJ,POS) ) - $ / DWORK(JJ) )**2 - TEMP = MAX( TEMP, ZERO ) - TEMP2 = ONE + P05*TEMP* - $ ( DWORK(JJ) / DWORK(K+JJ) )**2 - IF ( TEMP2.EQ.ONE ) THEN - DWORK(JJ) = DNRM2( LEN-1, B(JJ,POS+1), LDB) - DWORK(K+JJ) = DWORK(JJ) - ELSE - IF ( TEMP.GE.ZERO ) THEN - DWORK(JJ) = DWORK(JJ)*SQRT( TEMP ) - ELSE - DWORK(JJ) = -DWORK(JJ)*SQRT( -TEMP ) - END IF - END IF - END IF - 70 CONTINUE -C - LEN = LEN - 1 - POS = POS + 1 - 80 CONTINUE -C - RETURN - ELSE -C -C Error return: -C -C Displacement is indefinite. -C Due to roundoff error, positive semidefiniteness is -C violated. This is a rather bad situation. There is no -C meaningful way to continue the computations from this -C point. -C - INFO = 1 - RETURN - END IF - 90 CONTINUE -C - ELSE IF ( LCOL ) THEN -C -C Column oriented and not deficient generator. -C -C Apply an LQ like hyperbolic/orthogonal blocked decomposition. -C - IF ( COL2.GT.0 ) THEN - NBL = MIN( COL2, NB ) - IF ( NBL.GT.0 ) THEN -C -C Blocked version. -C - DO 110 I = 1, K - NBL + 1, NBL - IB = MIN( K-I+1, NBL ) - CALL DGELQ2( IB, COL2, A2(I,1), LDA2, CS(4*K+I), - $ DWORK, IERR ) - IF ( I+IB.LE.K ) THEN - CALL DLARFT( 'Forward', 'Rowwise', COL2, IB, - $ A2(I,1), LDA2, CS(4*K+I), DWORK, K ) - CALL DLARFB( 'Right', 'No Transpose', 'Forward', - $ 'Rowwise', K-I-IB+1, COL2, IB, - $ A2(I,1), LDA2, DWORK, K, A2(I+IB,1), - $ LDA2, DWORK(IB+1), K ) - END IF -C -C Annihilate the remaining parts of A2. -C - DO 100 J = I, I + IB - 1 - IF ( COL2.GT.1 ) THEN - LEN = MIN( COL2, J-I+1 ) - CALL DLARFG( LEN, A2(J,1), A2(J,2), LDA2, TAU2 ) - ALPHA2 = A2(J,1) - IF ( K.GT.J ) THEN - A2(J,1) = ONE - CALL DLARF( 'Right', K-J, LEN, A2(J,1), LDA2, - $ TAU2, A2(J+1,1), LDA2, DWORK ) - END IF - A2(J,1) = TAU2 - ELSE - ALPHA2 = A2(J,1) - A2(J,1) = ZERO - END IF - ALPHA = A1(J,J) - CALL DLARTG( ALPHA, ALPHA2, C, S, A1(J,J) ) - IF ( K.GT.J ) - $ CALL DROT( K-J, A1(J+1,J), 1, A2(J+1,1), 1, C, - $ S ) - CS(2*K+J*2-1) = C - CS(2*K+J*2) = S - 100 CONTINUE -C - 110 CONTINUE -C - ELSE - I = 1 - END IF -C -C Unblocked version for the last or only block. -C - DO 120 J = I, K - IF ( COL2.GT.1 ) THEN - CALL DLARFG( COL2, A2(J,1), A2(J,2), LDA2, TAU2 ) - ALPHA2 = A2(J,1) - IF ( K.GT.J ) THEN - A2(J,1) = ONE - CALL DLARF( 'Right', K-J, COL2, A2(J,1), LDA2, - $ TAU2, A2(J+1,1), LDA2, DWORK ) - END IF - A2(J,1) = TAU2 - ELSE - ALPHA2 = A2(J,1) - A2(J,1) = ZERO - END IF - ALPHA = A1(J,J) - CALL DLARTG( ALPHA, ALPHA2, C, S, A1(J,J) ) - IF ( K.GT.J ) - $ CALL DROT( K-J, A1(J+1,J), 1, A2(J+1,1), 1, C, S ) - CS(2*K+J*2-1) = C - CS(2*K+J*2) = S - 120 CONTINUE -C - PST2 = 5*K - ELSE - PST2 = 2*K - END IF -C -C Annihilate B with hyperbolic transformations. -C - NBL = MIN( NB, Q ) - IF ( NBL.GT.0 ) THEN -C -C Blocked version. -C - DO 140 I = 1, K - NBL + 1, NBL - IB = MIN( K-I+1, NBL ) - CALL DGELQ2( IB, Q, B(I,1), LDB, CS(PST2+I), DWORK, - $ IERR ) - IF ( I+IB.LE.K ) THEN - CALL DLARFT( 'Forward', 'Rowwise', Q, IB, B(I,1), - $ LDB, CS(PST2+I), DWORK, K ) - CALL DLARFB( 'Right', 'No Transpose', 'Forward', - $ 'Rowwise', K-I-IB+1, Q, IB, B(I,1), - $ LDB, DWORK, K, B(I+IB,1), LDB, - $ DWORK( IB+1 ), K ) - END IF -C -C Annihilate the remaining parts of B. -C - DO 130 J = I, I + IB - 1 - IF ( Q.GT.1 ) THEN - CALL DLARFG( J-I+1, B(J,1), B(J,2), LDB, TAU2 ) - ALPHA2 = B(J,1) - IF ( K.GT.J ) THEN - B(J,1) = ONE - CALL DLARF( 'Right', K-J, J-I+1, B(J,1), LDB, - $ TAU2, B(J+1,1), LDB, DWORK ) - END IF - B(J,1) = TAU2 - ELSE - ALPHA2 = B(J,1) - B(J,1) = ZERO - END IF -C -C Create hyperbolic rotation. -C - CALL MA02FD( A1(J,J), ALPHA2, C, S, IERR ) - IF ( IERR.NE.0 ) THEN -C -C Error return: The matrix is not positive definite. -C - INFO = 1 - RETURN - END IF -C -C Apply hyperbolic rotation. -C - IF ( K.GT.J ) THEN - CALL DSCAL( K-J, ONE/C, A1(J+1,J), 1 ) - CALL DAXPY( K-J, -S/C, B(J+1,1), 1, A1(J+1,J), 1 ) - CALL DSCAL( K-J, C, B(J+1,1), 1 ) - CALL DAXPY( K-J, -S, A1(J+1,J), 1, B(J+1,1), 1 ) - END IF - CS(J*2-1) = C - CS(J*2) = S - 130 CONTINUE -C - 140 CONTINUE -C - ELSE - I = 1 - END IF -C -C Unblocked version for the last or only block. -C - DO 150 J = I, K - IF ( Q.GT.1 ) THEN - CALL DLARFG( Q, B(J,1), B(J,2), LDB, TAU2 ) - ALPHA2 = B(J,1) - IF ( K.GT.J ) THEN - B(J,1) = ONE - CALL DLARF( 'Right', K-J, Q, B(J,1), LDB, TAU2, - $ B(J+1,1), LDB, DWORK ) - END IF - B(J,1) = TAU2 - ELSE IF ( Q.GT.0 ) THEN - ALPHA2 = B(J,1) - B(J,1) = ZERO - END IF - IF ( Q.GT.0 ) THEN -C -C Create hyperbolic rotation. -C - CALL MA02FD( A1(J,J), ALPHA2, C, S, IERR ) - IF ( IERR.NE.0 ) THEN -C -C Error return: The matrix is not positive definite. -C - INFO = 1 - RETURN - END IF -C -C Apply hyperbolic rotation. -C - IF ( K.GT.J ) THEN - CALL DSCAL( K-J, ONE/C, A1(J+1,J), 1 ) - CALL DAXPY( K-J, -S/C, B(J+1,1), 1, A1(J+1,J), 1 ) - CALL DSCAL( K-J, C, B(J+1,1), 1 ) - CALL DAXPY( K-J, -S, A1(J+1,J), 1, B(J+1,1), 1 ) - END IF - CS(J*2-1) = C - CS(J*2) = S - END IF - 150 CONTINUE -C - ELSE -C -C Row oriented and not deficient generator. -C - IF ( COL2.GT.0 ) THEN - NBL = MIN( NB, COL2 ) - IF ( NBL.GT.0 ) THEN -C -C Blocked version. -C - DO 170 I = 1, K - NBL + 1, NBL - IB = MIN( K-I+1, NBL ) - CALL DGEQR2( COL2, IB, A2(1,I), LDA2, CS(4*K+I), - $ DWORK, IERR ) - IF ( I+IB.LE.K ) THEN - CALL DLARFT( 'Forward', 'Columnwise', COL2, IB, - $ A2(1,I), LDA2, CS(4*K+I), DWORK, K ) - CALL DLARFB( 'Left', 'Transpose', 'Forward', - $ 'Columnwise', COL2, K-I-IB+1, IB, - $ A2(1,I), LDA2, DWORK, K, A2(1,I+IB), - $ LDA2, DWORK(IB+1), K ) - END IF -C -C Annihilate the remaining parts of A2. -C - DO 160 J = I, I + IB - 1 - IF ( COL2.GT.1 ) THEN - LEN = MIN( COL2, J-I+1 ) - CALL DLARFG( LEN, A2(1,J), A2(2,J), 1, TAU2 ) - ALPHA2 = A2(1,J) - IF ( K.GT.J ) THEN - A2(1,J) = ONE - CALL DLARF( 'Left', LEN, K-J, A2(1,J), 1, - $ TAU2, A2(1,J+1), LDA2, DWORK ) - END IF - A2(1,J) = TAU2 - ELSE - ALPHA2 = A2(1,J) - A2(1,J) = ZERO - END IF - ALPHA = A1(J,J) - CALL DLARTG( ALPHA, ALPHA2, C, S, A1(J,J) ) - IF ( K.GT.J ) - $ CALL DROT( K-J, A1(J,J+1), LDA1, A2(1,J+1), - $ LDA2, C, S ) - CS(2*K+J*2-1) = C - CS(2*K+J*2) = S - 160 CONTINUE -C - 170 CONTINUE -C - ELSE - I = 1 - END IF -C -C Unblocked version for the last or only block. -C - DO 180 J = I, K - IF ( COL2.GT.1 ) THEN - CALL DLARFG( COL2, A2(1,J), A2(2,J), 1, TAU2 ) - ALPHA2 = A2(1,J) - IF ( K.GT.J ) THEN - A2(1,J) = ONE - CALL DLARF( 'Left', COL2, K-J, A2(1,J), 1, TAU2, - $ A2(1,J+1), LDA2, DWORK ) - END IF - A2(1,J) = TAU2 - ELSE - ALPHA2 = A2(1,J) - A2(1,J) = ZERO - END IF - ALPHA = A1(J,J) - CALL DLARTG( ALPHA, ALPHA2, C, S, A1(J,J) ) - IF ( K.GT.J ) - $ CALL DROT( K-J, A1(J,J+1), LDA1, A2(1,J+1), LDA2, C, - $ S ) - CS(2*K+J*2-1) = C - CS(2*K+J*2) = S - 180 CONTINUE -C - PST2 = 5*K - ELSE - PST2 = 2*K - END IF -C -C Annihilate B with hyperbolic transformations. -C - NBL = MIN( NB, Q ) - IF ( NBL.GT.0 ) THEN -C -C Blocked version. -C - DO 200 I = 1, K - NBL + 1, NBL - IB = MIN( K-I+1, NBL ) - CALL DGEQR2( Q, IB, B(1,I), LDB, CS(PST2+I), DWORK, - $ IERR ) - IF ( I+IB.LE.K ) THEN - CALL DLARFT( 'Forward', 'Columnwise', Q, IB, B(1,I), - $ LDB, CS(PST2+I), DWORK, K ) - CALL DLARFB( 'Left', 'Transpose', 'Forward', - $ 'Columnwise', Q, K-I-IB+1, IB, B(1,I), - $ LDB, DWORK, K, B(1,I+IB), LDB, - $ DWORK( IB+1 ), K ) - END IF -C -C Annihilate the remaining parts of B. -C - DO 190 J = I, I + IB - 1 - IF ( Q.GT.1 ) THEN - CALL DLARFG( J-I+1, B(1,J), B(2,J), 1, TAU2 ) - ALPHA2 = B(1,J) - IF ( K.GT.J ) THEN - B(1,J) = ONE - CALL DLARF( 'Left', J-I+1, K-J, B(1,J), 1, - $ TAU2, B(1,J+1), LDB, DWORK ) - END IF - B(1,J) = TAU2 - ELSE - ALPHA2 = B(1,J) - B(1,J) = ZERO - END IF -C -C Create hyperbolic rotation. -C - CALL MA02FD( A1(J,J), ALPHA2, C, S, IERR ) - IF ( IERR.NE.0 ) THEN -C -C Error return: The matrix is not positive definite. -C - INFO = 1 - RETURN - END IF -C -C Apply hyperbolic rotation. -C - IF ( K.GT.J ) THEN - CALL DSCAL( K-J, ONE/C, A1(J,J+1), LDA1 ) - CALL DAXPY( K-J, -S/C, B(1,J+1), LDB, A1(J,J+1), - $ LDA1 ) - CALL DSCAL( K-J, C, B(1,J+1), LDB ) - CALL DAXPY( K-J, -S, A1(J,J+1), LDA1, B(1,J+1), - $ LDB ) - END IF - CS(J*2-1) = C - CS(J*2) = S - 190 CONTINUE -C - 200 CONTINUE -C - ELSE - I = 1 - END IF -C -C Unblocked version for the last or only block. -C - DO 210 J = I, K - IF ( Q.GT.1 ) THEN - CALL DLARFG( Q, B(1,J), B(2,J), 1, TAU2 ) - ALPHA2 = B(1,J) - IF ( K.GT.J ) THEN - B(1,J) = ONE - CALL DLARF( 'Left', Q, K-J, B(1,J), 1, TAU2, - $ B(1,J+1), LDB, DWORK ) - END IF - B(1,J) = TAU2 - ELSE IF ( Q.GT.0 ) THEN - ALPHA2 = B(1,J) - B(1,J) = ZERO - END IF - IF ( Q.GT.0 ) THEN -C -C Create hyperbolic rotation. -C - CALL MA02FD( A1(J,J), ALPHA2, C, S, IERR ) - IF ( IERR.NE.0 ) THEN -C -C Error return: The matrix is not positive definite. -C - INFO = 1 - RETURN - END IF -C -C Apply hyperbolic rotation. -C - IF ( K.GT.J ) THEN - CALL DSCAL( K-J, ONE/C, A1(J,J+1), LDA1 ) - CALL DAXPY( K-J, -S/C, B(1,J+1), LDB, A1(J,J+1), LDA1 - $ ) - CALL DSCAL( K-J, C, B(1,J+1), LDB ) - CALL DAXPY( K-J, -S, A1(J,J+1), LDA1, B(1,J+1), LDB - $ ) - END IF - CS(J*2-1) = C - CS(J*2) = S - END IF - 210 CONTINUE -C - END IF -C -C *** Last line of MB02CU *** - END diff --git a/mex/sources/libslicot/MB02CV.f b/mex/sources/libslicot/MB02CV.f deleted file mode 100644 index f049fca50..000000000 --- a/mex/sources/libslicot/MB02CV.f +++ /dev/null @@ -1,795 +0,0 @@ - SUBROUTINE MB02CV( TYPEG, STRUCG, K, N, P, Q, NB, RNK, A1, LDA1, - $ A2, LDA2, B, LDB, F1, LDF1, F2, LDF2, G, LDG, - $ CS, DWORK, LDWORK, INFO ) -C -C SLICOT RELEASE 5.0. -C -C Copyright (c) 2002-2009 NICONET e.V. -C -C This program is free software: you can redistribute it and/or -C modify it under the terms of the GNU General Public License as -C published by the Free Software Foundation, either version 2 of -C the License, or (at your option) any later version. -C -C This program is distributed in the hope that it will be useful, -C but WITHOUT ANY WARRANTY; without even the implied warranty of -C MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the -C GNU General Public License for more details. -C -C You should have received a copy of the GNU General Public License -C along with this program. If not, see -C . -C -C PURPOSE -C -C To apply the transformations created by the SLICOT Library routine -C MB02CU on other columns / rows of the generator, contained in the -C arrays F1, F2 and G. -C -C ARGUMENTS -C -C Mode Parameters -C -C TYPEG CHARACTER*1 -C Specifies the type of the generator, as follows: -C = 'D': generator is column oriented and rank -C deficient; -C = 'C': generator is column oriented and not rank -C deficient; -C = 'R': generator is row oriented and not rank -C deficient. -C Note that this parameter must be equivalent with the -C used TYPEG in the call of MB02CU. -C -C STRUCG CHARACTER*1 -C Information about the structure of the generators, -C as follows: -C = 'T': the trailing block of the positive generator -C is upper / lower triangular, and the trailing -C block of the negative generator is zero; -C = 'N': no special structure to mention. -C -C Input/Output Parameters -C -C K (input) INTEGER -C The number of rows in A1 to be processed. K >= 0. -C -C N (input) INTEGER -C If TYPEG = 'D' or TYPEG = 'C', the number of rows in F1; -C if TYPEG = 'R', the number of columns in F1. N >= 0. -C -C P (input) INTEGER -C The number of columns of the positive generator. P >= K. -C -C Q (input) INTEGER -C The number of columns in B. -C If TYPEG = 'D', Q >= K; -C If TYPEG = 'C' or 'R', Q >= 0. -C -C NB (input) INTEGER -C On entry, if TYPEG = 'C' or TYPEG = 'R', NB specifies -C the block size to be used in the blocked parts of the -C algorithm. NB must be equivalent with the used block size -C in the routine MB02CU. -C -C RNK (input) INTEGER -C If TYPEG = 'D', the number of linearly independent columns -C in the generator as returned by MB02CU. 0 <= RNK <= K. -C If TYPEG = 'C' or 'R', the value of this parameter is -C irrelevant. -C -C A1 (input) DOUBLE PRECISION array, dimension -C (LDA1, K) -C On entry, if TYPEG = 'D', the leading K-by-K part of this -C array must contain the matrix A1 as returned by MB02CU. -C If TYPEG = 'C' or 'R', this array is not referenced. -C -C LDA1 INTEGER -C The leading dimension of the array A1. -C If TYPEG = 'D', LDA1 >= MAX(1,K); -C if TYPEG = 'C' or TYPEG = 'R', LDA1 >= 1. -C -C A2 (input) DOUBLE PRECISION array, -C if TYPEG = 'D' or TYPEG = 'C', dimension (LDA2, P-K); -C if TYPEG = 'R', dimension (LDA2, K). -C On entry, if TYPEG = 'D' or TYPEG = 'C', the leading -C K-by-(P-K) part of this array must contain the matrix -C A2 as returned by MB02CU. -C On entry, if TYPEG = 'R', the leading (P-K)-by-K part of -C this array must contain the matrix A2 as returned by -C MB02CU. -C -C LDA2 INTEGER -C The leading dimension of the array A2. -C If P = K, LDA2 >= 1; -C If P > K and (TYPEG = 'D' or TYPEG = 'C'), -C LDA2 >= MAX(1,K); -C if P > K and TYPEG = 'R', LDA2 >= P-K. -C -C B (input) DOUBLE PRECISION array, -C if TYPEG = 'D' or TYPEG = 'C', dimension (LDB, Q); -C if TYPEG = 'R', dimension (LDB, K). -C On entry, if TYPEG = 'D' or TYPEG = 'C', the leading -C K-by-Q part of this array must contain the matrix B as -C returned by MB02CU. -C On entry, if TYPEG = 'R', the leading Q-by-K part of this -C array must contain the matrix B as returned by MB02CU. -C -C LDB INTEGER -C The leading dimension of the array B. -C If Q = 0, LDB >= 1; -C If Q > 0 and (TYPEG = 'D' or TYPEG = 'C'), -C LDB >= MAX(1,K); -C if Q > 0 and TYPEG = 'R', LDB >= Q. -C -C F1 (input/output) DOUBLE PRECISION array, -C if TYPEG = 'D' or TYPEG = 'C', dimension (LDF1, K); -C if TYPEG = 'R', dimension (LDF1, N). -C On entry, if TYPEG = 'D' or TYPEG = 'C', the leading -C N-by-K part of this array must contain the first part -C of the positive generator to be processed. -C On entry, if TYPEG = 'R', the leading K-by-N part of this -C array must contain the first part of the positive -C generator to be processed. -C On exit, if TYPEG = 'D' or TYPEG = 'C', the leading -C N-by-K part of this array contains the first part of the -C transformed positive generator. -C On exit, if TYPEG = 'R', the leading K-by-N part of this -C array contains the first part of the transformed positive -C generator. -C -C LDF1 INTEGER -C The leading dimension of the array F1. -C If TYPEG = 'D' or TYPEG = 'C', LDF1 >= MAX(1,N); -C if TYPEG = 'R', LDF1 >= MAX(1,K). -C -C F2 (input/output) DOUBLE PRECISION array, -C if TYPEG = 'D' or TYPEG = 'C', dimension (LDF2, P-K); -C if TYPEG = 'R', dimension (LDF2, N). -C On entry, if TYPEG = 'D' or TYPEG = 'C', the leading -C N-by-(P-K) part of this array must contain the second part -C of the positive generator to be processed. -C On entry, if TYPEG = 'R', the leading (P-K)-by-N part of -C this array must contain the second part of the positive -C generator to be processed. -C On exit, if TYPEG = 'D' or TYPEG = 'C', the leading -C N-by-(P-K) part of this array contains the second part of -C the transformed positive generator. -C On exit, if TYPEG = 'R', the leading (P-K)-by-N part of -C this array contains the second part of the transformed -C positive generator. -C -C LDF2 INTEGER -C The leading dimension of the array F2. -C If P = K, LDF2 >= 1; -C If P > K and (TYPEG = 'D' or TYPEG = 'C'), -C LDF2 >= MAX(1,N); -C if P > K and TYPEG = 'R', LDF2 >= P-K. -C -C G (input/output) DOUBLE PRECISION array, -C if TYPEG = 'D' or TYPEG = 'C', dimension (LDG, Q); -C if TYPEG = 'R', dimension (LDG, N). -C On entry, if TYPEG = 'D' or TYPEG = 'C', the leading -C N-by-Q part of this array must contain the negative part -C of the generator to be processed. -C On entry, if TYPEG = 'R', the leading Q-by-N part of this -C array must contain the negative part of the generator to -C be processed. -C On exit, if TYPEG = 'D' or TYPEG = 'C', the leading -C N-by-Q part of this array contains the transformed -C negative generator. -C On exit, if TYPEG = 'R', the leading Q-by-N part of this -C array contains the transformed negative generator. -C -C LDG INTEGER -C The leading dimension of the array G. -C If Q = 0, LDG >= 1; -C If Q > 0 and (TYPEG = 'D' or TYPEG = 'C'), -C LDG >= MAX(1,N); -C if Q > 0 and TYPEG = 'R', LDG >= Q. -C -C CS (input) DOUBLE PRECISION array, dimension (x) -C If TYPEG = 'D' and P = K, x = 3*K; -C If TYPEG = 'D' and P > K, x = 5*K; -C If (TYPEG = 'C' or TYPEG = 'R') and P = K, x = 4*K; -C If (TYPEG = 'C' or TYPEG = 'R') and P > K, x = 6*K. -C On entry, the first x elements of this array must contain -C Givens and modified hyperbolic rotation parameters, and -C scalar factors of the Householder transformations as -C returned by MB02CU. -C -C Workspace -C -C DWORK DOUBLE PRECISION array, dimension (LDWORK) -C On exit, if INFO = -23, DWORK(1) returns the minimum -C value of LDWORK. -C -C LDWORK INTEGER -C The length of the array DWORK. -C TYPEG = 'D': LDWORK >= MAX(1,N); -C (TYPEG = 'C' or TYPEG = 'R') and NB <= 0: -C LDWORK >= MAX(1,N); -C (TYPEG = 'C' or TYPEG = 'R') and NB >= 1: -C LDWORK >= MAX(1,( N + K )*NB). -C -C Error Indicator -C -C INFO INTEGER -C = 0: successful exit; -C < 0: if INFO = -i, the i-th argument had an illegal -C value. -C -C NUMERICAL ASPECTS -C -C The algorithm requires 0(N*K*( P + Q )) floating point operations. -C -C METHOD -C -C The Householder transformations and modified hyperbolic rotations -C computed by SLICOT Library routine MB02CU are applied to the -C corresponding parts of the matrices F1, F2 and G. -C -C CONTRIBUTOR -C -C D. Kressner, Technical Univ. Berlin, Germany, May 2001. -C -C REVISIONS -C -C V. Sima, Research Institute for Informatics, Bucharest, June 2001, -C March 2004, March 2007. -C -C KEYWORDS -C -C Elementary matrix operations, Householder transformation, matrix -C operations, Toeplitz matrix. -C -C ****************************************************************** -C -C .. Parameters .. - DOUBLE PRECISION ZERO, ONE - PARAMETER ( ZERO = 0.0D+0, ONE = 1.0D+0 ) -C .. Scalar Arguments .. - CHARACTER STRUCG, TYPEG - INTEGER INFO, K, LDA1, LDA2, LDB, LDF1, LDF2, LDG, - $ LDWORK, N, NB, P, Q, RNK -C .. Array Arguments .. - DOUBLE PRECISION A1(LDA1,*), A2(LDA2,*), B(LDB,*), CS(*), - $ DWORK(*), F1(LDF1,*), F2(LDF2,*), G(LDG,*) -C .. Local Scalars .. - INTEGER COL2, I, IB, J, JJ, LEN, NBL, POS, PST2, - $ WRKMIN - DOUBLE PRECISION ALPHA, BETA, C, S, TAU, TEMP - LOGICAL LRDEF, LTRI, LCOL -C .. External Functions .. - LOGICAL LSAME - EXTERNAL LSAME -C .. External Subroutines .. - EXTERNAL DAXPY, DLARF, DLARFB, DLARFT, DROT, DSCAL, - $ XERBLA -C .. Intrinsic Functions .. - INTRINSIC MAX, MIN -C -C .. Executable Statements .. -C -C Decode the scalar input parameters. -C - INFO = 0 - COL2 = MAX( 0, P - K ) - LRDEF = LSAME( TYPEG, 'D' ) - LCOL = LSAME( TYPEG, 'C' ) - LTRI = LSAME( STRUCG, 'T' ) - IF ( LRDEF ) THEN - WRKMIN = MAX( 1, N ) - ELSE - IF ( NB.GE.1 ) THEN - WRKMIN = MAX( 1, ( N + K )*NB ) - ELSE - WRKMIN = MAX( 1, N ) - END IF - END IF -C -C Check the scalar input parameters. -C - IF ( .NOT.( LCOL .OR. LRDEF .OR. LSAME( TYPEG, 'R' ) ) ) THEN - INFO = -1 - ELSE IF ( .NOT.( LTRI .OR. LSAME( STRUCG, 'N' ) ) ) THEN - INFO = -2 - ELSE IF ( K.LT.0 ) THEN - INFO = -3 - ELSE IF ( N.LT.0 ) THEN - INFO = -4 - ELSE IF ( P.LT.K ) THEN - INFO = -5 - ELSE IF ( Q.LT.0 .OR. ( LRDEF .AND. Q.LT.K ) ) THEN - INFO = -6 - ELSE IF ( LRDEF .AND. ( RNK.LT.0 .OR. RNK.GT.K ) ) THEN - INFO = -8 - ELSE IF ( ( LDA1.LT.1 ) .OR. ( LRDEF .AND. LDA1.LT.K ) ) THEN - INFO = -10 - ELSE IF ( ( ( P.EQ.K ) .AND. LDA2.LT.1 ) .OR. - $ ( ( P.GT.K ) .AND. ( LRDEF .OR. LCOL ) .AND. - $ ( LDA2.LT.MAX( 1, K ) ) ) .OR. - $ ( ( P.GT.K ) .AND. .NOT.( LRDEF .OR. LCOL ) .AND. - $ ( LDA2.LT.( P-K ) ) ) ) THEN - INFO = -12 - ELSE IF ( ( ( Q.EQ.0 ) .AND. LDB.LT.1 ) .OR. - $ ( ( Q.GT.0 ) .AND. ( LRDEF .OR. LCOL ) .AND. - $ ( LDB.LT.MAX( 1, K ) ) ) .OR. - $ ( ( Q.GT.0 ) .AND. .NOT.( LRDEF .OR. LCOL ) .AND. - $ ( LDB.LT.Q ) ) ) THEN - INFO = -14 - ELSE IF ( ( LRDEF .OR. LCOL ) .AND. LDF1.LT.MAX( 1, N ) ) THEN - INFO = -16 - ELSE IF ( (.NOT.( LRDEF .OR. LCOL ) ) .AND. LDF1.LT.MAX( 1, K ) ) - $ THEN - INFO = -16 - ELSE IF ( ( ( P.EQ.K ) .AND. LDF2.LT.1 ) .OR. - $ ( ( P.GT.K ) .AND. ( LRDEF .OR. LCOL ) .AND. - $ ( LDF2.LT.MAX( 1, N ) ) ) .OR. - $ ( ( P.GT.K ) .AND. .NOT.( LRDEF .OR. LCOL ) .AND. - $ ( LDF2.LT.( P-K ) ) ) ) THEN - INFO = -18 - ELSE IF ( ( ( Q.EQ.0 ) .AND. LDG.LT.1 ) .OR. - $ ( ( Q.GT.0 ) .AND. ( LRDEF .OR. LCOL ) .AND. - $ ( LDG.LT.MAX( 1, N ) ) ) .OR. - $ ( ( Q.GT.0 ) .AND. .NOT.( LRDEF .OR. LCOL ) .AND. - $ ( LDG.LT.Q ) ) ) THEN - INFO = -20 - ELSE IF ( LDWORK.LT.WRKMIN ) THEN - DWORK(1) = DBLE( WRKMIN ) - INFO = -23 - END IF -C -C Return if there were illegal values. -C - IF ( INFO.NE.0 ) THEN - CALL XERBLA( 'MB02CV', -INFO ) - RETURN - END IF -C -C Quick return if possible. -C - IF ( MIN( K, N ).EQ.0 .OR. - $ ( ( .NOT.LRDEF ) .AND. Q.EQ.0 .AND. P.EQ.K ) ) THEN - RETURN - END IF -C - IF ( LRDEF ) THEN -C -C Deficient generator. -C - IF ( COL2.EQ.0 ) THEN - PST2 = 2*K - ELSE - PST2 = 4*K - END IF -C - DO 10 I = 1, RNK -C -C Apply elementary reflectors. -C - IF ( COL2.GT.1 ) THEN - TAU = A2(I,1) - A2(I,1) = ONE - CALL DLARF( 'Right', N, COL2, A2(I,1), LDA2, TAU, F2, - $ LDF2, DWORK ) - A2(I,1) = TAU - END IF -C - IF ( K.GT.I ) THEN - ALPHA = A1(I,I) - A1(I,I) = ONE - CALL DLARF( 'Right', N, K-I+1, A1(I,I), LDA1, CS(PST2+I), - $ F1(1,I), LDF1, DWORK ) - A1(I,I) = ALPHA - END IF -C - IF ( COL2.GT.0 ) THEN - C = CS(2*K+I*2-1) - S = CS(2*K+I*2) - CALL DROT( N, F1(1,I), 1, F2, 1, C, S ) - END IF -C - IF ( Q.GT.1 ) THEN - TAU = B(I,1) - B(I,1) = ONE - CALL DLARF( 'Right', N, Q, B(I,1), LDB, TAU, - $ G, LDG, DWORK ) - B(I,1) = TAU - END IF -C -C Apply hyperbolic rotation. -C - C = CS(I*2-1) - S = CS(I*2) - CALL DSCAL( N, ONE/C, F1(1,I), 1 ) - CALL DAXPY( N, -S/C, G(1,1), 1, F1(1,I), 1 ) - CALL DSCAL( N, C, G(1,1), 1 ) - CALL DAXPY( N, -S, F1(1,I), 1, G(1,1), 1 ) - 10 CONTINUE -C - LEN = Q - POS = 1 -C - DO 20 J = RNK + 1, K -C -C Apply the reductions working on singular rows. -C - IF ( COL2.GT.1 ) THEN - TAU = A2(J,1) - A2(J,1) = ONE - CALL DLARF( 'Right', N, COL2, A2(J,1), LDA2, TAU, F2, - $ LDF2, DWORK ) - A2(J,1) = TAU - END IF - IF ( K.GT.J ) THEN - ALPHA = A1(J,J) - A1(J,J) = ONE - CALL DLARF( 'Right', N, K-J+1, A1(J,J), LDA1, CS(PST2+J), - $ F1(1,J), LDF1, DWORK ) - A1(J,J) = ALPHA - END IF - IF ( COL2.GT.0 ) THEN - C = CS(2*K+J*2-1) - S = CS(2*K+J*2) - CALL DROT( N, F1(1,J), 1, F2, 1, C, S ) - END IF - IF ( LEN.GT.1 ) THEN - BETA = B(J,POS) - B(J,POS) = ONE - CALL DLARF( 'Right', N, LEN, B(J,POS), LDB, CS(J*2-1), - $ G(1,POS), LDG, DWORK ) - B(J,POS) = BETA - END IF - LEN = LEN - 1 - POS = POS + 1 - 20 CONTINUE -C - ELSE IF ( LCOL ) THEN -C -C Column oriented and not deficient generator. -C -C Apply an LQ like hyperbolic/orthogonal blocked decomposition. -C - IF ( LTRI ) THEN - LEN = MAX( N - K, 0 ) - ELSE - LEN = N - END IF - IF ( COL2.GT.0 ) THEN -C - NBL = MIN( COL2, NB ) - IF ( NBL.GT.0 ) THEN -C -C Blocked version. -C - DO 50 I = 1, K - NBL + 1, NBL - IB = MIN( K-I+1, NBL ) - CALL DLARFT( 'Forward', 'Rowwise', COL2, IB, A2(I,1), - $ LDA2, CS(4*K+I), DWORK, N+K ) - CALL DLARFB( 'Right', 'No Transpose', 'Forward', - $ 'Rowwise', LEN, COL2, IB, A2(I,1), - $ LDA2, DWORK, N+K, F2, LDF2, - $ DWORK(IB+1), N+K ) -C - DO 40 J = I, I + IB - 1 - TAU = A2(J,1) - A2(J,1) = ONE - CALL DLARF( 'Right', LEN, MIN( COL2, J-I+1 ), - $ A2(J,1), LDA2, TAU, F2, LDF2, DWORK ) - A2(J,1) = TAU - C = CS(2*K+J*2-1) - S = CS(2*K+J*2) - CALL DROT( LEN, F1(1,J), 1, F2, 1, C, S ) - IF ( LTRI ) THEN - LEN = LEN + 1 - TEMP = F1(LEN,J) - F1(LEN,J) = C*TEMP - F2(LEN,1) = -S*TEMP -C - DO 30 JJ = 2, COL2 - F2(LEN,JJ) = ZERO - 30 CONTINUE -C - END IF - 40 CONTINUE -C - 50 CONTINUE -C - ELSE - I = 1 - END IF -C -C Unblocked version for the last or only block. -C - DO 70 J = I, K - IF ( COL2.GT.1 ) THEN - TAU = A2(J,1) - A2(J,1) = ONE - CALL DLARF( 'Right', LEN, COL2, A2(J,1), LDA2, TAU, - $ F2, LDF2, DWORK ) - A2(J,1) = TAU - END IF -C - C = CS(2*K+J*2-1) - S = CS(2*K+J*2) - CALL DROT( LEN, F1(1,J), 1, F2, 1, C, S ) - IF ( LTRI ) THEN - LEN = LEN + 1 - TEMP = F1(LEN,J) - F1(LEN,J) = C*TEMP - F2(LEN,1) = -S*TEMP -C - DO 60 JJ = 2, COL2 - F2(LEN,JJ) = ZERO - 60 CONTINUE -C - END IF - 70 CONTINUE -C - PST2 = 5*K - ELSE - PST2 = 2*K - END IF -C - IF ( LTRI ) THEN - LEN = N - K - ELSE - LEN = N - END IF -C - NBL = MIN( Q, NB ) - IF ( NBL.GT.0 ) THEN -C -C Blocked version. -C - DO 100 I = 1, K - NBL + 1, NBL - IB = MIN( K-I+1, NBL ) - CALL DLARFT( 'Forward', 'Rowwise', Q, IB, B(I,1), - $ LDB, CS(PST2+I), DWORK, N+K ) - CALL DLARFB( 'Right', 'NonTranspose', 'Forward', - $ 'Rowwise', LEN, Q, IB, B(I,1), - $ LDB, DWORK, N+K, G, LDG, - $ DWORK(IB+1), N+K ) -C - DO 90 J = I, I + IB - 1 - TAU = B(J,1) - B(J,1) = ONE - CALL DLARF( 'Right', LEN, J-I+1, B(J,1), LDB, - $ TAU, G, LDG, DWORK ) - B(J,1) = TAU -C -C Apply hyperbolic rotation. -C - C = CS(J*2-1) - S = CS(J*2) - CALL DSCAL( LEN, ONE/C, F1(1,J), 1 ) - CALL DAXPY( LEN, -S/C, G, 1, F1(1,J), 1 ) - CALL DSCAL( LEN, C, G, 1 ) - CALL DAXPY( LEN, -S, F1(1,J), 1, G, 1 ) - IF ( LTRI ) THEN - LEN = LEN + 1 - G(LEN,1) = -S/C*F1(LEN,J) - F1(LEN,J) = F1(LEN,J) / C -C - DO 80 JJ = 2, Q - G(LEN,JJ) = ZERO - 80 CONTINUE -C - END IF - 90 CONTINUE -C - 100 CONTINUE -C - ELSE - I = 1 - END IF -C -C Unblocked version for the last or only block. -C - DO 120 J = I, K - IF ( Q.GT.1 ) THEN - TAU = B(J,1) - B(J,1) = ONE - CALL DLARF( 'Right', LEN, Q, B(J,1), LDB, TAU, - $ G, LDG, DWORK ) - B(J,1) = TAU - END IF - IF ( Q.GT.0 ) THEN -C -C Apply hyperbolic rotation. -C - C = CS(J*2-1) - S = CS(J*2) - CALL DSCAL( LEN, ONE/C, F1(1,J), 1 ) - CALL DAXPY( LEN, -S/C, G, 1, F1(1,J), 1 ) - CALL DSCAL( LEN, C, G, 1 ) - CALL DAXPY( LEN, -S, F1(1,J), 1, G, 1 ) - IF ( LTRI ) THEN - LEN = LEN + 1 - G(LEN,1) = -S/C*F1(LEN,J) - F1(LEN,J) = F1(LEN,J) / C -C - DO 110 JJ = 2, Q - G(LEN,JJ) = ZERO - 110 CONTINUE -C - END IF - END IF - 120 CONTINUE -C - ELSE -C -C Row oriented and not deficient generator. -C - IF ( LTRI ) THEN - LEN = MAX( N - K, 0 ) - ELSE - LEN = N - END IF -C - IF ( COL2.GT.0 ) THEN - NBL = MIN( NB, COL2 ) - IF ( NBL.GT.0 ) THEN -C -C Blocked version. -C - DO 150 I = 1, K - NBL + 1, NBL - IB = MIN( K-I+1, NBL ) - CALL DLARFT( 'Forward', 'Columnwise', COL2, IB, - $ A2(1,I), LDA2, CS(4*K+I), DWORK, N+K ) - CALL DLARFB( 'Left', 'Transpose', 'Forward', - $ 'Columnwise', COL2, LEN, IB, A2(1,I), - $ LDA2, DWORK, N+K, F2, LDF2, - $ DWORK(IB+1), N+K ) -C - DO 140 J = I, I + IB - 1 - TAU = A2(1,J) - A2(1,J) = ONE - CALL DLARF( 'Left', MIN( COL2, J-I+1 ), LEN, - $ A2(1,J), 1, TAU, F2, LDF2, DWORK ) - A2(1,J) = TAU - C = CS(2*K+J*2-1) - S = CS(2*K+J*2) - CALL DROT( LEN, F1(J,1), LDF1, F2, LDF2, C, S ) - IF ( LTRI ) THEN - LEN = LEN + 1 - TEMP = F1(J,LEN) - F1(J,LEN) = C*TEMP - F2(1,LEN) = -S*TEMP -C - DO 130 JJ = 2, COL2 - F2(JJ,LEN) = ZERO - 130 CONTINUE -C - END IF - 140 CONTINUE -C - 150 CONTINUE -C - ELSE - I = 1 - END IF -C -C Unblocked version for the last or only block. -C - DO 170 J = I, K - IF ( COL2.GT.1 ) THEN - TAU = A2(1,J) - A2(1,J) = ONE - CALL DLARF( 'Left', COL2, LEN, A2(1,J), 1, TAU, - $ F2, LDF2, DWORK ) - A2(1,J) = TAU - END IF -C - C = CS(2*K+J*2-1) - S = CS(2*K+J*2) - CALL DROT( LEN, F1(J,1), LDF1, F2, LDF2, C, S ) - IF ( LTRI ) THEN - LEN = LEN + 1 - TEMP = F1(J,LEN) - F1(J,LEN) = C*TEMP - F2(1,LEN) = -S*TEMP -C - DO 160 JJ = 2, COL2 - F2(JJ,LEN) = ZERO - 160 CONTINUE -C - END IF - 170 CONTINUE -C - PST2 = 5*K - ELSE - PST2 = 2*K - END IF -C - IF ( LTRI ) THEN - LEN = N - K - ELSE - LEN = N - END IF -C - NBL = MIN( Q, NB ) - IF ( NBL.GT.0 ) THEN -C -C Blocked version. -C - DO 200 I = 1, K - NBL + 1, NBL - IB = MIN( K-I+1, NBL ) - CALL DLARFT( 'Forward', 'Columnwise', Q, IB, B(1,I), - $ LDB, CS(PST2+I), DWORK, N+K ) - CALL DLARFB( 'Left', 'Transpose', 'Forward', - $ 'Columnwise', Q, LEN, IB, B(1,I), - $ LDB, DWORK, N+K, G, LDG, - $ DWORK(IB+1), N+K ) -C - DO 190 J = I, I + IB - 1 - TAU = B(1,J) - B(1,J) = ONE - CALL DLARF( 'Left', J-I+1, LEN, B(1,J), 1, - $ TAU, G, LDG, DWORK ) - B(1,J) = TAU -C -C Apply hyperbolic rotation. -C - C = CS(J*2-1) - S = CS(J*2) - CALL DSCAL( LEN, ONE/C, F1(J,1), LDF1 ) - CALL DAXPY( LEN, -S/C, G, LDG, F1(J,1), LDF1 ) - CALL DSCAL( LEN, C, G, LDG ) - CALL DAXPY( LEN, -S, F1(J,1), LDF1, G, LDG ) - IF ( LTRI ) THEN - LEN = LEN + 1 - G(1,LEN) = -S/C*F1(J,LEN) - F1(J,LEN) = F1(J,LEN) / C -C - DO 180 JJ = 2, Q - G(JJ,LEN) = ZERO - 180 CONTINUE -C - END IF - 190 CONTINUE -C - 200 CONTINUE -C - ELSE - I = 1 - END IF -C -C Unblocked version for the last or only block. -C - DO 220 J = I, K - IF ( Q.GT.1 ) THEN - TAU = B(1,J) - B(1,J) = ONE - CALL DLARF( 'Left', Q, LEN, B(1,J), 1, TAU, - $ G, LDG, DWORK ) - B(1,J) = TAU - END IF - IF ( Q.GT.0 ) THEN -C -C Apply hyperbolic rotation. -C - C = CS(J*2-1) - S = CS(J*2) - CALL DSCAL( LEN, ONE/C, F1(J,1), LDF1 ) - CALL DAXPY( LEN, -S/C, G, LDG, F1(J,1), LDF1 ) - CALL DSCAL( LEN, C, G, LDG ) - CALL DAXPY( LEN, -S, F1(J,1), LDF1, G, LDG ) - IF ( LTRI ) THEN - LEN = LEN + 1 - G(1,LEN) = -S/C*F1(J,LEN) - F1(J,LEN) = F1(J,LEN) / C -C - DO 210 JJ = 2, Q - G(JJ,LEN) = ZERO - 210 CONTINUE -C - END IF - END IF - 220 CONTINUE -C - END IF -C -C *** Last line of MB02CV *** - END diff --git a/mex/sources/libslicot/MB02CX.f b/mex/sources/libslicot/MB02CX.f deleted file mode 100644 index be4989cbf..000000000 --- a/mex/sources/libslicot/MB02CX.f +++ /dev/null @@ -1,318 +0,0 @@ - SUBROUTINE MB02CX( TYPET, P, Q, K, A, LDA, B, LDB, CS, LCS, - $ DWORK, LDWORK, INFO ) -C -C SLICOT RELEASE 5.0. -C -C Copyright (c) 2002-2009 NICONET e.V. -C -C This program is free software: you can redistribute it and/or -C modify it under the terms of the GNU General Public License as -C published by the Free Software Foundation, either version 2 of -C the License, or (at your option) any later version. -C -C This program is distributed in the hope that it will be useful, -C but WITHOUT ANY WARRANTY; without even the implied warranty of -C MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the -C GNU General Public License for more details. -C -C You should have received a copy of the GNU General Public License -C along with this program. If not, see -C . -C -C PURPOSE -C -C To bring the first blocks of a generator in proper form. -C The columns / rows of the positive and negative generators -C are contained in the arrays A and B, respectively. -C Transformation information will be stored and can be applied -C via SLICOT Library routine MB02CY. -C -C ARGUMENTS -C -C Mode Parameters -C -C TYPET CHARACTER*1 -C Specifies the type of the generator, as follows: -C = 'R': A and B are the first blocks of the rows of the -C positive and negative generators; -C = 'C': A and B are the first blocks of the columns of the -C positive and negative generators. -C Note: in the sequel, the notation x / y means that -C x corresponds to TYPET = 'R' and y corresponds to -C TYPET = 'C'. -C -C Input/Output Parameters -C -C P (input) INTEGER -C The number of rows / columns in A containing the positive -C generators. P >= 0. -C -C Q (input) INTEGER -C The number of rows / columns in B containing the negative -C generators. Q >= 0. -C -C K (input) INTEGER -C The number of columns / rows in A and B to be processed. -C Normally, the size of the first block. P >= K >= 0. -C -C A (input/output) DOUBLE PRECISION array, dimension -C (LDA, K) / (LDA, P) -C On entry, the leading P-by-K upper / K-by-P lower -C triangular part of this array must contain the rows / -C columns of the positive part in the first block of the -C generator. -C On exit, the leading P-by-K upper / K-by-P lower -C triangular part of this array contains the rows / columns -C of the positive part in the first block of the proper -C generator. -C The lower / upper trapezoidal part is not referenced. -C -C LDA INTEGER -C The leading dimension of the array A. -C LDA >= MAX(1,P), if TYPET = 'R'; -C LDA >= MAX(1,K), if TYPET = 'C'. -C -C B (input/output) DOUBLE PRECISION array, dimension -C (LDB, K) / (LDB, Q) -C On entry, the leading Q-by-K / K-by-Q part of this array -C must contain the rows / columns of the negative part in -C the first block of the generator. -C On exit, the leading Q-by-K / K-by-Q part of this array -C contains part of the necessary information for the -C Householder transformations. -C -C LDB INTEGER -C The leading dimension of the array B. -C LDB >= MAX(1,Q), if TYPET = 'R'; -C LDB >= MAX(1,K), if TYPET = 'C'. -C -C CS (output) DOUBLE PRECISION array, dimension (LCS) -C On exit, the leading 2*K + MIN(K,Q) part of this array -C contains necessary information for the SLICOT Library -C routine MB02CY (modified hyperbolic rotation parameters -C and scalar factors of the Householder transformations). -C -C LCS INTEGER -C The length of the array CS. LCS >= 2*K + MIN(K,Q). -C -C Workspace -C -C DWORK DOUBLE PRECISION array, dimension (LDWORK) -C On exit, if INFO = 0, DWORK(1) returns the optimal -C value of LDWORK. -C On exit, if INFO = -12, DWORK(1) returns the minimum -C value of LDWORK. -C -C LDWORK INTEGER -C The length of the array DWORK. LDWORK >= MAX(1,K). -C For optimum performance LDWORK should be larger. -C -C Error Indicator -C -C INFO INTEGER -C = 0: succesful exit; -C < 0: if INFO = -i, the i-th argument had an illegal -C value; -C = 1: the reduction algorithm failed. The matrix -C associated with the generator is not (numerically) -C positive definite. -C -C METHOD -C -C If TYPET = 'R', a QR decomposition of B is first computed. -C Then, the elements below the first row of each column i of B -C are annihilated by a Householder transformation modifying the -C first element in that column. This first element, in turn, is -C then annihilated by a modified hyperbolic rotation, acting also -C on the i-th row of A. -C -C If TYPET = 'C', an LQ decomposition of B is first computed. -C Then, the elements on the right of the first column of each row i -C of B are annihilated by a Householder transformation modifying the -C first element in that row. This first element, in turn, is -C then annihilated by a modified hyperbolic rotation, acting also -C on the i-th column of A. -C -C CONTRIBUTOR -C -C D. Kressner, Technical Univ. Chemnitz, Germany, June 2000. -C -C REVISIONS -C -C V. Sima, Research Institute for Informatics, Bucharest, July 2000, -C February 2004. -C -C KEYWORDS -C -C Elementary matrix operations, Householder transformation, matrix -C operations, Toeplitz matrix. -C -C ****************************************************************** -C -C .. Parameters .. - DOUBLE PRECISION ZERO, ONE - PARAMETER ( ZERO = 0.0D0, ONE = 1.0D0 ) -C .. Scalar Arguments .. - CHARACTER TYPET - INTEGER INFO, K, LDA, LDB, LCS, LDWORK, P, Q -C .. Array Arguments .. - DOUBLE PRECISION A(LDA, *), B(LDB, *), CS(*), DWORK(*) -C .. Local Scalars .. - LOGICAL ISROW - INTEGER I, IERR - DOUBLE PRECISION ALPHA, BETA, C, MAXWRK, S, TAU -C .. External Functions .. - LOGICAL LSAME - EXTERNAL LSAME -C .. External Subroutines .. - EXTERNAL DAXPY, DGELQF, DGEQRF, DLARF, DLARFG, DSCAL, - $ MA02FD, XERBLA -C .. Intrinsic Functions .. - INTRINSIC MAX, MIN -C -C .. Executable Statements .. -C -C Decode the scalar input parameters. -C - INFO = 0 - ISROW = LSAME( TYPET, 'R' ) -C -C Check the scalar input parameters. -C - IF ( .NOT.( ISROW .OR. LSAME( TYPET, 'C' ) ) ) THEN - INFO = -1 - ELSE IF ( P.LT.0 ) THEN - INFO = -2 - ELSE IF ( Q.LT.0 ) THEN - INFO = -3 - ELSE IF ( K.LT.0 .OR. K.GT.P ) THEN - INFO = -4 - ELSE IF ( LDA.LT.1 .OR. ( ISROW .AND. LDA.LT.P ) .OR. - $ ( .NOT.ISROW .AND. LDA.LT.K ) ) THEN - INFO = -6 - ELSE IF ( LDB.LT.1 .OR. ( ISROW .AND. LDB.LT.Q ) .OR. - $ ( .NOT.ISROW .AND. LDB.LT.K ) ) THEN - INFO = -8 - ELSE IF ( LCS.LT.2*K + MIN( K, Q ) ) THEN - INFO = -10 - ELSE IF ( LDWORK.LT.MAX( 1, K ) ) THEN - DWORK(1) = MAX( 1, K ) - INFO = -12 - END IF -C -C Return if there were illegal values. -C - IF ( INFO.NE.0 ) THEN - CALL XERBLA( 'MB02CX', -INFO ) - RETURN - END IF -C -C Quick return if possible. -C - IF ( MIN( Q, K ).EQ.0 ) THEN - DWORK(1) = ONE - RETURN - END IF -C - IF ( ISROW ) THEN -C -C The generator is row wise stored. -C -C Step 0: Do QR decomposition of B. -C - CALL DGEQRF ( Q, K, B, LDB, CS(2*K+1), DWORK(1), LDWORK, IERR ) - MAXWRK = DWORK(1) -C - DO 10 I = 1, K -C -C Step 1: annihilate the i-th column of B. -C - IF ( Q.GT.1 ) THEN - CALL DLARFG( MIN( I, Q ), B(1,I), B(2,I), 1, TAU ) - ALPHA = B(1,I) - B(1,I) = ONE - IF ( K.GT.I ) - $ CALL DLARF( 'Left', MIN( I, Q ), K-I, B(1,I), 1, TAU, - $ B(1,I+1), LDB, DWORK ) - B(1,I) = ALPHA - ELSE - ALPHA = B(1,I) - TAU = ZERO - END IF -C -C Step 2: annihilate the top entry of the column. -C - BETA = A(I,I) - CALL MA02FD( BETA, ALPHA, C, S, IERR ) - IF ( IERR.NE.0 ) THEN -C -C Error return: The matrix is not positive definite. -C - INFO = 1 - RETURN - END IF -C - CS(I*2-1) = C - CS(I*2) = S - CALL DSCAL( K-I+1, ONE/C, A(I,I), LDA ) - CALL DAXPY( K-I+1, -S/C, B(1,I), LDB, A(I,I), LDA ) - CALL DSCAL( K-I+1, C, B(1,I), LDB ) - CALL DAXPY( K-I+1, -S, A(I,I), LDA, B(1,I), LDB ) - B(1,I) = TAU - 10 CONTINUE -C - ELSE -C -C The generator is column wise stored. -C -C Step 0: Do LQ decomposition of B. -C - CALL DGELQF ( K, Q, B, LDB, CS(2*K+1), DWORK(1), LDWORK, IERR ) - MAXWRK = DWORK(1) -C - DO 20 I = 1, K -C -C Step 1: annihilate the i-th row of B. -C - IF ( Q.GT.1 ) THEN - CALL DLARFG( MIN( I, Q ), B(I,1), B(I,2), LDB, TAU ) - ALPHA = B(I,1) - B(I,1) = ONE - IF ( K.GT.I ) - $ CALL DLARF( 'Right', K-I, MIN( I, Q ), B(I,1), LDB, - $ TAU, B(I+1,1), LDB, DWORK ) - B(I,1) = ALPHA - ELSE - ALPHA = B(I,1) - TAU = ZERO - END IF -C -C Step 2: annihilate the left entry of the row. -C - BETA = A(I,I) - CALL MA02FD( BETA, ALPHA, C, S, IERR ) - IF ( IERR.NE.0 ) THEN -C -C Error return: The matrix is not positive definite. -C - INFO = 1 - RETURN - END IF -C - CS(I*2-1) = C - CS(I*2) = S - CALL DSCAL( K-I+1, ONE/C, A(I,I), 1 ) - CALL DAXPY( K-I+1, -S/C, B(I,1), 1, A(I,I), 1 ) - CALL DSCAL( K-I+1, C, B(I,1), 1 ) - CALL DAXPY( K-I+1, -S, A(I,I), 1, B(I,1), 1 ) - B(I,1) = TAU - 20 CONTINUE -C - END IF -C - DWORK(1) = MAXWRK -C - RETURN -C -C *** Last line of MB02CX *** - END diff --git a/mex/sources/libslicot/MB02CY.f b/mex/sources/libslicot/MB02CY.f deleted file mode 100644 index 7d977dee9..000000000 --- a/mex/sources/libslicot/MB02CY.f +++ /dev/null @@ -1,372 +0,0 @@ - SUBROUTINE MB02CY( TYPET, STRUCG, P, Q, N, K, A, LDA, B, LDB, H, - $ LDH, CS, LCS, DWORK, LDWORK, INFO ) -C -C SLICOT RELEASE 5.0. -C -C Copyright (c) 2002-2009 NICONET e.V. -C -C This program is free software: you can redistribute it and/or -C modify it under the terms of the GNU General Public License as -C published by the Free Software Foundation, either version 2 of -C the License, or (at your option) any later version. -C -C This program is distributed in the hope that it will be useful, -C but WITHOUT ANY WARRANTY; without even the implied warranty of -C MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the -C GNU General Public License for more details. -C -C You should have received a copy of the GNU General Public License -C along with this program. If not, see -C . -C -C PURPOSE -C -C To apply the transformations created by the SLICOT Library -C routine MB02CX on other columns / rows of the generator, -C contained in the arrays A and B of positive and negative -C generators, respectively. -C -C ARGUMENTS -C -C Mode Parameters -C -C TYPET CHARACTER*1 -C Specifies the type of the generator, as follows: -C = 'R': A and B are additional columns of the generator; -C = 'C': A and B are additional rows of the generator. -C Note: in the sequel, the notation x / y means that -C x corresponds to TYPET = 'R' and y corresponds to -C TYPET = 'C'. -C -C STRUCG CHARACTER*1 -C Information about the structure of the two generators, -C as follows: -C = 'T': the trailing block of the positive generator -C is lower / upper triangular, and the trailing -C block of the negative generator is zero; -C = 'N': no special structure to mention. -C -C Input/Output Parameters -C -C P (input) INTEGER -C The number of rows / columns in A containing the positive -C generators. P >= 0. -C -C Q (input) INTEGER -C The number of rows / columns in B containing the negative -C generators. Q >= 0. -C -C N (input) INTEGER -C The number of columns / rows in A and B to be processed. -C N >= 0. -C -C K (input) INTEGER -C The number of columns / rows in H. P >= K >= 0. -C -C A (input/output) DOUBLE PRECISION array, dimension -C (LDA, N) / (LDA, P) -C On entry, the leading P-by-N / N-by-P part of this array -C must contain the positive part of the generator. -C On exit, the leading P-by-N / N-by-P part of this array -C contains the transformed positive part of the generator. -C -C LDA INTEGER -C The leading dimension of the array A. -C LDA >= MAX(1,P), if TYPET = 'R'; -C LDA >= MAX(1,N), if TYPET = 'C'. -C -C B (input/output) DOUBLE PRECISION array, dimension -C (LDB, N) / (LDB, Q) -C On entry, the leading Q-by-N / N-by-Q part of this array -C must contain the negative part of the generator. -C On exit, the leading Q-by-N / N-by-Q part of this array -C contains the transformed negative part of the generator. -C -C LDB INTEGER -C The leading dimension of the array B. -C LDB >= MAX(1,Q), if TYPET = 'R'; -C LDB >= MAX(1,N), if TYPET = 'C'. -C -C H (input) DOUBLE PRECISION array, dimension -C (LDH, K) / (LDH, Q) -C The leading Q-by-K / K-by-Q part of this array must -C contain part of the necessary information for the -C Householder transformations computed by SLICOT Library -C routine MB02CX. -C -C LDH INTEGER -C The leading dimension of the array H. -C LDH >= MAX(1,Q), if TYPET = 'R'; -C LDH >= MAX(1,K), if TYPET = 'C'. -C -C CS (input) DOUBLE PRECISION array, dimension (LCS) -C The leading 2*K + MIN(K,Q) part of this array must -C contain the necessary information for modified hyperbolic -C rotations and the scalar factors of the Householder -C transformations computed by SLICOT Library routine MB02CX. -C -C LCS INTEGER -C The length of the array CS. LCS >= 2*K + MIN(K,Q). -C -C Workspace -C -C DWORK DOUBLE PRECISION array, dimension (LDWORK) -C On exit, if INFO = 0, DWORK(1) returns the optimal -C value of LDWORK. -C On exit, if INFO = -16, DWORK(1) returns the minimum -C value of LDWORK. -C -C LDWORK INTEGER -C The length of the array DWORK. LDWORK >= MAX(1,N). -C For optimum performance LDWORK should be larger. -C -C Error Indicator -C -C INFO INTEGER -C = 0: succesful exit; -C < 0: if INFO = -i, the i-th argument had an illegal -C value. -C -C METHOD -C -C The Householder transformations and modified hyperbolic rotations -C computed by SLICOT Library routine MB02CX are applied to the -C corresponding parts of the matrices A and B. -C -C CONTRIBUTOR -C -C D. Kressner, Technical Univ. Chemnitz, Germany, June 2000. -C -C REVISIONS -C -C V. Sima, Research Institute for Informatics, Bucharest, July 2000, -C February 2004, March 2007. -C -C KEYWORDS -C -C Elementary matrix operations, Householder transformation, matrix -C operations, Toeplitz matrix. -C -C ****************************************************************** -C -C .. Parameters .. - DOUBLE PRECISION ZERO, ONE - PARAMETER ( ZERO = 0.0D0, ONE = 1.0D0 ) -C .. Scalar Arguments .. - INTEGER INFO, K, LDA, LDB, LCS, LDH, LDWORK, N, P, Q - CHARACTER STRUCG, TYPET -C .. Array Arguments .. - DOUBLE PRECISION A(LDA, *), B(LDB, *), CS(*), DWORK(*), H(LDH,*) -C .. Local Scalars .. - LOGICAL ISLWR, ISROW - INTEGER I, IERR, CI, MAXWRK - DOUBLE PRECISION C, S, TAU -C .. External Functions .. - LOGICAL LSAME - EXTERNAL LSAME -C .. External Subroutines .. - EXTERNAL DAXPY, DLARF, DLASET, DORMLQ, DORMQR, DSCAL, - $ XERBLA -C .. Intrinsic Functions .. - INTRINSIC MAX, MIN -C -C .. Executable Statements .. -C -C Decode the scalar input parameters. -C - INFO = 0 - ISROW = LSAME( TYPET, 'R' ) - ISLWR = LSAME( STRUCG, 'T' ) -C -C Check the scalar input parameters. -C - IF ( .NOT.( ISROW .OR. LSAME( TYPET, 'C' ) ) ) THEN - INFO = -1 - ELSE IF ( .NOT.( ISLWR .OR. LSAME( STRUCG, 'N' ) ) ) THEN - INFO = -2 - ELSE IF ( P.LT.0 ) THEN - INFO = -3 - ELSE IF ( Q.LT.0 ) THEN - INFO = -4 - ELSE IF ( N.LT.0 ) THEN - INFO = -5 - ELSE IF ( K.LT.0 .OR. K.GT.P ) THEN - INFO = -6 - ELSE IF ( LDA.LT.1 .OR. ( ISROW .AND. LDA.LT.P ) .OR. - $ ( .NOT.ISROW .AND. LDA.LT.N ) ) THEN - INFO = -8 - ELSE IF ( LDB.LT.1 .OR. ( ISROW .AND. LDB.LT.Q ) .OR. - $ ( .NOT.ISROW .AND. LDB.LT.N ) ) THEN - INFO = -10 - ELSE IF ( LDH.LT.1 .OR. ( ISROW .AND. LDH.LT.Q ) .OR. - $ ( .NOT.ISROW .AND. LDH.LT.K ) ) THEN - INFO = -12 - ELSE IF ( LCS.LT.2*K + MIN( K, Q ) ) THEN - INFO = -14 - ELSE IF ( LDWORK.LT.MAX( 1, N ) ) THEN - DWORK(1) = MAX( 1, N ) - INFO = -16 - END IF -C -C Return if there were illegal values. -C - IF ( INFO.NE.0 ) THEN - CALL XERBLA( 'MB02CY', -INFO ) - RETURN - END IF -C -C Quick return if possible. -C - IF ( MIN( N, K, Q ).EQ.0 ) THEN - DWORK(1) = ONE - RETURN - END IF -C -C Applying the transformations. -C - IF ( ISROW ) THEN -C -C The generator is row wise stored. -C - IF ( ISLWR ) THEN -C - DO 10 I = 1, K -C -C Apply Householder transformation avoiding touching of -C zero blocks. -C - CI = N - K + I - 1 - TAU = H(1,I) - H(1,I) = ONE - CALL DLARF( 'Left', MIN( I, Q ), CI, H(1,I), 1, TAU, B, - $ LDB, DWORK ) - H(1,I) = TAU -C -C Now apply the hyperbolic rotation under the assumption -C that A(I, N-K+I+1:N) and B(1, N-K+I:N) are zero. -C - C = CS(I*2-1) - S = CS(I*2) -C - CALL DSCAL( CI, ONE/C, A(I,1), LDA ) - CALL DAXPY( CI, -S/C, B(1,1), LDB, A(I,1), LDA ) - CALL DSCAL( CI, C, B(1,1), LDB ) - CALL DAXPY( CI, -S, A(I,1), LDA, B(1,1), LDB ) -C - B(1,N-K+I) = -S/C * A(I,N-K+I) - A(I,N-K+I) = ONE/C * A(I,N-K+I) -C -C All below B(1,N-K+I) should be zero. -C - IF( Q.GT.1 ) - $ CALL DLASET( 'All', Q-1, 1, ZERO, ZERO, B(2,N-K+I), - $ 1 ) - 10 CONTINUE -C - ELSE -C -C Apply the QR reduction on B. -C - CALL DORMQR( 'Left', 'Transpose', Q, N, MIN( K, Q ), H, - $ LDH, CS(2*K+1), B, LDB, DWORK, LDWORK, IERR ) - MAXWRK = DWORK(1) -C - DO 20 I = 1, K -C -C Apply Householder transformation. -C - TAU = H(1,I) - H(1,I) = ONE - CALL DLARF( 'Left', MIN( I, Q ), N, H(1,I), 1, TAU, B, - $ LDB, DWORK ) - H(1,I) = TAU -C -C Apply Hyperbolic Rotation. -C - C = CS(I*2-1) - S = CS(I*2) -C - CALL DSCAL( N, ONE/C, A(I,1), LDA ) - CALL DAXPY( N, -S/C, B(1,1), LDB, A(I,1), LDA ) - CALL DSCAL( N, C, B(1,1), LDB ) - CALL DAXPY( N, -S, A(I,1), LDA, B(1,1), LDB ) - 20 CONTINUE -C - END IF -C - ELSE -C -C The generator is column wise stored. -C - IF ( ISLWR ) THEN -C - DO 30 I = 1, K -C -C Apply Householder transformation avoiding touching zeros. -C - CI = N - K + I - 1 - TAU = H(I,1) - H(I,1) = ONE - CALL DLARF( 'Right', CI, MIN( I, Q ), H(I,1), LDH, TAU, - $ B, LDB, DWORK ) - H(I,1) = TAU -C -C Apply Hyperbolic Rotation. -C - C = CS(I*2-1) - S = CS(I*2) -C - CALL DSCAL( CI, ONE/C, A(1,I), 1 ) - CALL DAXPY( CI, -S/C, B(1,1), 1, A(1,I), 1 ) - CALL DSCAL( CI, C, B(1,1), 1 ) - CALL DAXPY( CI, -S, A(1,I), 1, B(1,1), 1 ) -C - B(N-K+I,1) = -S/C * A(N-K+I,I) - A(N-K+I,I) = ONE/C * A(N-K+I,I) -C -C All elements right behind B(N-K+I,1) should be zero. -C - IF( Q.GT.1 ) - $ CALL DLASET( 'All', 1, Q-1, ZERO, ZERO, B(N-K+I,2), - $ LDB ) - 30 CONTINUE -C - ELSE -C -C Apply the LQ reduction on B. -C - CALL DORMLQ( 'Right', 'Transpose', N, Q, MIN( K, Q ), H, - $ LDH, CS(2*K+1), B, LDB, DWORK, LDWORK, IERR ) - MAXWRK = DWORK(1) -C - DO 40 I = 1, K -C -C Apply Householder transformation. -C - TAU = H(I,1) - H(I,1) = ONE - CALL DLARF( 'Right', N, MIN( I, Q ), H(I,1), LDH, TAU, B, - $ LDB, DWORK ) - H(I,1) = TAU -C -C Apply Hyperbolic Rotation. -C - C = CS(I*2-1) - S = CS(I*2) -C - CALL DSCAL( N, ONE/C, A(1,I), 1 ) - CALL DAXPY( N, -S/C, B(1,1), 1, A(1,I), 1 ) - CALL DSCAL( N, C, B(1,1), 1 ) - CALL DAXPY( N, -S, A(1,I), 1, B(1,1), 1 ) - 40 CONTINUE -C - END IF -C - END IF -C - DWORK(1) = MAX( MAXWRK, N ) -C - RETURN -C -C *** Last line of MB02CY *** - END diff --git a/mex/sources/libslicot/MB02DD.f b/mex/sources/libslicot/MB02DD.f deleted file mode 100644 index fadd6b442..000000000 --- a/mex/sources/libslicot/MB02DD.f +++ /dev/null @@ -1,564 +0,0 @@ - SUBROUTINE MB02DD( JOB, TYPET, K, M, N, TA, LDTA, T, LDT, G, - $ LDG, R, LDR, L, LDL, CS, LCS, DWORK, LDWORK, - $ INFO ) -C -C SLICOT RELEASE 5.0. -C -C Copyright (c) 2002-2009 NICONET e.V. -C -C This program is free software: you can redistribute it and/or -C modify it under the terms of the GNU General Public License as -C published by the Free Software Foundation, either version 2 of -C the License, or (at your option) any later version. -C -C This program is distributed in the hope that it will be useful, -C but WITHOUT ANY WARRANTY; without even the implied warranty of -C MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the -C GNU General Public License for more details. -C -C You should have received a copy of the GNU General Public License -C along with this program. If not, see -C . -C -C PURPOSE -C -C To update the Cholesky factor and the generator and/or the -C Cholesky factor of the inverse of a symmetric positive definite -C (s.p.d.) block Toeplitz matrix T, given the information from -C a previous factorization and additional blocks in TA of its first -C block row, or its first block column, depending on the routine -C parameter TYPET. Transformation information is stored. -C -C ARGUMENTS -C -C Mode Parameters -C -C JOB CHARACTER*1 -C Specifies the output of the routine, as follows: -C = 'R': updates the generator G of the inverse and -C computes the new columns / rows for the Cholesky -C factor R of T; -C = 'A': updates the generator G, computes the new -C columns / rows for the Cholesky factor R of T and -C the new rows / columns for the Cholesky factor L -C of the inverse; -C = 'O': only computes the new columns / rows for the -C Cholesky factor R of T. -C -C TYPET CHARACTER*1 -C Specifies the type of T, as follows: -C = 'R': the first block row of an s.p.d. block Toeplitz -C matrix was/is defined; if demanded, the Cholesky -C factors R and L are upper and lower triangular, -C respectively, and G contains the transposed -C generator of the inverse; -C = 'C': the first block column of an s.p.d. block Toeplitz -C matrix was/is defined; if demanded, the Cholesky -C factors R and L are lower and upper triangular, -C respectively, and G contains the generator of the -C inverse. This choice results in a column oriented -C algorithm which is usually faster. -C Note: in this routine, the notation x / y means that -C x corresponds to TYPET = 'R' and y corresponds to -C TYPET = 'C'. -C -C Input/Output Parameters -C -C K (input) INTEGER -C The number of rows / columns in T, which should be equal -C to the blocksize. K >= 0. -C -C M (input) INTEGER -C The number of blocks in TA. M >= 0. -C -C N (input) INTEGER -C The number of blocks in T. N >= 0. -C -C TA (input/output) DOUBLE PRECISION array, dimension -C (LDTA,M*K) / (LDTA,K) -C On entry, the leading K-by-M*K / M*K-by-K part of this -C array must contain the (N+1)-th to (N+M)-th blocks in the -C first block row / column of an s.p.d. block Toeplitz -C matrix. -C On exit, if INFO = 0, the leading K-by-M*K / M*K-by-K part -C of this array contains information on the Householder -C transformations used, such that the array -C -C [ T TA ] / [ T ] -C [ TA ] -C -C serves as the new transformation matrix T for further -C applications of this routine. -C -C LDTA INTEGER -C The leading dimension of the array TA. -C LDTA >= MAX(1,K), if TYPET = 'R'; -C LDTA >= MAX(1,M*K), if TYPET = 'C'. -C -C T (input) DOUBLE PRECISION array, dimension (LDT,N*K) / -C (LDT,K) -C The leading K-by-N*K / N*K-by-K part of this array must -C contain transformation information generated by the SLICOT -C Library routine MB02CD, i.e., in the first K-by-K block, -C the upper / lower Cholesky factor of T(1:K,1:K), and in -C the remaining part, the Householder transformations -C applied during the initial factorization process. -C -C LDT INTEGER -C The leading dimension of the array T. -C LDT >= MAX(1,K), if TYPET = 'R'; -C LDT >= MAX(1,N*K), if TYPET = 'C'. -C -C G (input/output) DOUBLE PRECISION array, dimension -C (LDG,( N + M )*K) / (LDG,2*K) -C On entry, if JOB = 'R', or 'A', then the leading -C 2*K-by-N*K / N*K-by-2*K part of this array must contain, -C in the first K-by-K block of the second block row / -C column, the lower right block of the Cholesky factor of -C the inverse of T, and in the remaining part, the generator -C of the inverse of T. -C On exit, if INFO = 0 and JOB = 'R', or 'A', then the -C leading 2*K-by-( N + M )*K / ( N + M )*K-by-2*K part of -C this array contains the same information as on entry, now -C for the updated Toeplitz matrix. Actually, to obtain a -C generator of the inverse one has to set -C G(K+1:2*K, 1:K) = 0, if TYPET = 'R'; -C G(1:K, K+1:2*K) = 0, if TYPET = 'C'. -C -C LDG INTEGER -C The leading dimension of the array G. -C LDG >= MAX(1,2*K), if TYPET = 'R' and JOB = 'R', or 'A'; -C LDG >= MAX(1,( N + M )*K), -C if TYPET = 'C' and JOB = 'R', or 'A'; -C LDG >= 1, if JOB = 'O'. -C -C R (input/output) DOUBLE PRECISION array, dimension -C (LDR,M*K) / (LDR,( N + M )*K) -C On input, the leading N*K-by-K part of R(K+1,1) / -C K-by-N*K part of R(1,K+1) contains the last block column / -C row of the previous Cholesky factor R. -C On exit, if INFO = 0, then the leading -C ( N + M )*K-by-M*K / M*K-by-( N + M )*K part of this -C array contains the last M*K columns / rows of the upper / -C lower Cholesky factor of T. The elements in the strictly -C lower / upper triangular part are not referenced. -C -C LDR INTEGER -C The leading dimension of the array R. -C LDR >= MAX(1, ( N + M )*K), if TYPET = 'R'; -C LDR >= MAX(1, M*K), if TYPET = 'C'. -C -C L (output) DOUBLE PRECISION array, dimension -C (LDL,( N + M )*K) / (LDL,M*K) -C If INFO = 0 and JOB = 'A', then the leading -C M*K-by-( N + M )*K / ( N + M )*K-by-M*K part of this -C array contains the last M*K rows / columns of the lower / -C upper Cholesky factor of the inverse of T. The elements -C in the strictly upper / lower triangular part are not -C referenced. -C -C LDL INTEGER -C The leading dimension of the array L. -C LDL >= MAX(1, M*K), if TYPET = 'R' and JOB = 'A'; -C LDL >= MAX(1, ( N + M )*K), if TYPET = 'C' and JOB = 'A'; -C LDL >= 1, if JOB = 'R', or 'O'. -C -C CS (input/output) DOUBLE PRECISION array, dimension (LCS) -C On input, the leading 3*(N-1)*K part of this array must -C contain the necessary information about the hyperbolic -C rotations and Householder transformations applied -C previously by SLICOT Library routine MB02CD. -C On exit, if INFO = 0, then the leading 3*(N+M-1)*K part of -C this array contains information about all the hyperbolic -C rotations and Householder transformations applied during -C the whole process. -C -C LCS INTEGER -C The length of the array CS. LCS >= 3*(N+M-1)*K. -C -C Workspace -C -C DWORK DOUBLE PRECISION array, dimension (LDWORK) -C On exit, if INFO = 0, DWORK(1) returns the optimal -C value of LDWORK. -C On exit, if INFO = -19, DWORK(1) returns the minimum -C value of LDWORK. -C -C LDWORK INTEGER -C The length of the array DWORK. -C LDWORK >= MAX(1,(N+M-1)*K). -C For optimum performance LDWORK should be larger. -C -C Error Indicator -C -C INFO INTEGER -C = 0: successful exit; -C < 0: if INFO = -i, the i-th argument had an illegal -C value; -C = 1: the reduction algorithm failed. The block Toeplitz -C matrix associated with [ T TA ] / [ T' TA' ]' is -C not (numerically) positive definite. -C -C METHOD -C -C Householder transformations and modified hyperbolic rotations -C are used in the Schur algorithm [1], [2]. -C -C REFERENCES -C -C [1] Kailath, T. and Sayed, A. -C Fast Reliable Algorithms for Matrices with Structure. -C SIAM Publications, Philadelphia, 1999. -C -C [2] Kressner, D. and Van Dooren, P. -C Factorizations and linear system solvers for matrices with -C Toeplitz structure. -C SLICOT Working Note 2000-2, 2000. -C -C NUMERICAL ASPECTS -C -C The implemented method is numerically stable. -C 3 2 -C The algorithm requires 0(K ( N M + M ) ) floating point -C operations. -C -C FURTHER COMMENTS -C -C For min(K,N,M) = 0, the routine sets DWORK(1) = 1 and returns. -C Although the calculations could still be performed when N = 0, -C but min(K,M) > 0, this case is not considered as an "update". -C SLICOT Library routine MB02CD should be called with the argument -C M instead of N. -C -C CONTRIBUTOR -C -C D. Kressner, Technical Univ. Chemnitz, Germany, December 2000. -C -C REVISIONS -C -C V. Sima, Research Institute for Informatics, Bucharest, Dec. 2000, -C Feb. 2004. -C -C KEYWORDS -C -C Elementary matrix operations, Householder transformation, matrix -C operations, Toeplitz matrix. -C -C ****************************************************************** -C -C .. Parameters .. - DOUBLE PRECISION ZERO, ONE - PARAMETER ( ZERO = 0.0D0, ONE = 1.0D0 ) -C .. Scalar Arguments .. - CHARACTER JOB, TYPET - INTEGER INFO, K, LCS, LDG, LDL, LDR, LDT, LDTA, LDWORK, - $ M, N -C .. Array Arguments .. - DOUBLE PRECISION CS(*), DWORK(*), G(LDG, *), L(LDL,*), R(LDR,*), - $ T(LDT,*), TA(LDTA,*) -C .. Local Scalars .. - INTEGER I, IERR, J, MAXWRK, STARTI, STARTR, STARTT - LOGICAL COMPG, COMPL, ISROW -C .. External Functions .. - LOGICAL LSAME - EXTERNAL LSAME -C .. External Subroutines .. - EXTERNAL DCOPY, DLACPY, DLASET, DTRSM, MB02CX, MB02CY, - $ XERBLA -C .. Intrinsic Functions .. - INTRINSIC INT, MAX, MIN -C -C .. Executable Statements .. -C -C Decode the scalar input parameters. -C - INFO = 0 - COMPL = LSAME( JOB, 'A' ) - COMPG = LSAME( JOB, 'R' ) .OR. COMPL - ISROW = LSAME( TYPET, 'R' ) -C -C Check the scalar input parameters. -C - IF ( .NOT.( COMPG .OR. LSAME( JOB, 'O' ) ) ) THEN - INFO = -1 - ELSE IF ( .NOT.( ISROW .OR. LSAME( TYPET, 'C' ) ) ) THEN - INFO = -2 - ELSE IF ( K.LT.0 ) THEN - INFO = -3 - ELSE IF ( M.LT.0 ) THEN - INFO = -4 - ELSE IF ( N.LT.0 ) THEN - INFO = -5 - ELSE IF ( LDTA.LT.1 .OR. ( ISROW .AND. LDTA.LT.K ) .OR. - $ ( .NOT.ISROW .AND. LDTA.LT.M*K ) ) THEN - INFO = -7 - ELSE IF ( LDT.LT.1 .OR. ( ISROW .AND. LDT.LT.K ) .OR. - $ ( .NOT.ISROW .AND. LDT.LT.N*K ) ) THEN - INFO = -9 - ELSE IF ( ( COMPG .AND. ( ( ISROW .AND. LDG.LT.2*K ) - $ .OR. ( .NOT.ISROW .AND. LDG.LT.( N + M )*K ) ) ) - $ .OR. LDG.LT.1 ) THEN - INFO = -11 - ELSE IF ( ( ( ISROW .AND. LDR.LT.( N + M )*K ) .OR. - $ ( .NOT.ISROW .AND. LDR.LT.M*K ) ) .OR. - $ LDR.LT.1 ) THEN - INFO = -13 - ELSE IF ( ( COMPL .AND. ( ( ISROW .AND. LDL.LT.M*K ) - $ .OR. ( .NOT.ISROW .AND. LDL.LT.( N + M )*K ) ) ) - $ .OR. LDL.LT.1 ) THEN - INFO = -15 - ELSE IF ( LCS.LT.3*( N + M - 1 )*K ) THEN - INFO = -17 - ELSE IF ( LDWORK.LT.MAX( 1, ( N + M - 1 )*K ) ) THEN - DWORK(1) = MAX( 1, ( N + M - 1 )*K ) - INFO = -19 - END IF -C -C Return if there were illegal values. -C - IF ( INFO.NE.0 ) THEN - CALL XERBLA( 'MB02DD', -INFO ) - RETURN - END IF -C -C Quick return if possible. -C - IF ( MIN( K, N, M ).EQ.0 ) THEN - DWORK(1) = ONE - RETURN - END IF -C - MAXWRK = 1 - IF ( ISROW ) THEN -C -C Apply Cholesky factor of T(1:K, 1:K) on TA. -C - CALL DTRSM( 'Left', 'Upper', 'Transpose', 'NonUnit', K, M*K, - $ ONE, T, LDT, TA, LDTA ) -C -C Initialize the output matrices. -C - IF ( COMPG ) THEN - CALL DLASET( 'All', K, M*K, ZERO, ZERO, G(1,N*K+1), LDG ) - IF ( M.GE.N-1 .AND. N.GT.1 ) THEN - CALL DLACPY( 'All', K, (N-1)*K, G(K+1,K+1), LDG, - $ G(K+1,K*(M+1)+1), LDG ) - ELSE - DO 10 I = N*K, K + 1, -1 - CALL DCOPY( K, G(K+1,I), 1, G(K+1,M*K+I), 1 ) - 10 CONTINUE - END IF - CALL DLASET( 'All', K, M*K, ZERO, ZERO, G(K+1,K+1), LDG ) - END IF -C - CALL DLACPY( 'All', K, M*K, TA, LDTA, R, LDR ) -C -C Apply the stored transformations on the new columns. -C - DO 20 I = 2, N -C -C Copy the last M-1 blocks of the positive generator together; -C the last M blocks of the negative generator are contained -C in TA. -C - STARTR = ( I - 1 )*K + 1 - STARTT = 3*( I - 2 )*K + 1 - CALL DLACPY( 'All', K, (M-1)*K, R(STARTR-K,1), LDR, - $ R(STARTR,K+1), LDR ) -C -C Apply the transformations stored in T on the generator. -C - CALL MB02CY( 'Row', 'NoStructure', K, K, M*K, K, - $ R(STARTR,1), LDR, TA, LDTA, T(1,STARTR), LDT, - $ CS(STARTT), 3*K, DWORK, LDWORK, IERR ) - MAXWRK = MAX( MAXWRK, INT( DWORK(1) ) ) - 20 CONTINUE -C -C Now, we have "normality" and can apply further M Schur steps. -C - DO 30 I = 1, M -C -C Copy the first M-I+1 blocks of the positive generator -C together; the first M-I+1 blocks of the negative generator -C are contained in TA. -C - STARTT = 3*( N + I - 2 )*K + 1 - STARTI = ( M - I + 1 )*K + 1 - STARTR = ( N + I - 1 )*K + 1 - IF ( I.EQ.1 ) THEN - CALL DLACPY( 'All', K, (M-1)*K, R(STARTR-K,1), LDR, - $ R(STARTR,K+1), LDR ) - ELSE - CALL DLACPY( 'Upper', K, (M-I+1)*K, - $ R(STARTR-K,(I-2)*K+1), LDR, - $ R(STARTR,(I-1)*K+1), LDR ) - END IF -C -C Reduce the generator to proper form. -C - CALL MB02CX( 'Row', K, K, K, R(STARTR,(I-1)*K+1), LDR, - $ TA(1,(I-1)*K+1), LDTA, CS(STARTT), 3*K, DWORK, - $ LDWORK, IERR ) - IF ( IERR.NE.0 ) THEN -C -C Error return: The matrix is not positive definite. -C - INFO = 1 - RETURN - END IF -C - MAXWRK = MAX( MAXWRK, INT( DWORK(1) ) ) - IF ( M.GT.I ) THEN - CALL MB02CY( 'Row', 'NoStructure', K, K, (M-I)*K, K, - $ R(STARTR,I*K+1), LDR, TA(1,I*K+1), LDTA, - $ TA(1,(I-1)*K+1), LDTA, CS(STARTT), 3*K, - $ DWORK, LDWORK, IERR ) - MAXWRK = MAX( MAXWRK, INT( DWORK(1) ) ) - END IF -C - IF ( COMPG ) THEN -C -C Transformations acting on the inverse generator: -C - CALL MB02CY( 'Row', 'Triangular', K, K, K, K, G(K+1,1), - $ LDG, G(1,STARTR), LDG, TA(1,(I-1)*K+1), - $ LDTA, CS(STARTT), 3*K, DWORK, LDWORK, IERR ) - MAXWRK = MAX( MAXWRK, INT( DWORK(1) ) ) -C - CALL MB02CY( 'Row', 'NoStructure', K, K, (N+I-1)*K, K, - $ G(K+1,STARTI), LDG, G, LDG, TA(1,(I-1)*K+1), - $ LDTA, CS(STARTT), 3*K, DWORK, LDWORK, IERR ) - MAXWRK = MAX( MAXWRK, INT( DWORK(1) ) ) -C - IF ( COMPL ) THEN - CALL DLACPY( 'All', K, (N+I-1)*K, G(K+1,STARTI), LDG, - $ L((I-1)*K+1,1), LDL ) - CALL DLACPY( 'Lower', K, K, G(K+1,1), LDG, - $ L((I-1)*K+1,STARTR), LDL ) - END IF -C - END IF - 30 CONTINUE -C - ELSE -C -C Apply Cholesky factor of T(1:K, 1:K) on TA. -C - CALL DTRSM( 'Right', 'Lower', 'Transpose', 'NonUnit', M*K, K, - $ ONE, T, LDT, TA, LDTA ) -C -C Initialize the output matrices. -C - IF ( COMPG ) THEN - CALL DLASET( 'All', M*K, K, ZERO, ZERO, G(N*K+1,1), LDG ) - IF ( M.GE.N-1 .AND. N.GT.1 ) THEN - CALL DLACPY( 'All', (N-1)*K, K, G(K+1,K+1), LDG, - $ G(K*(M+1)+1,K+1), LDG ) - ELSE - DO 40 I = 1, K - DO 35 J = N*K, K + 1, -1 - G(J+M*K,K+I) = G(J,K+I) - 35 CONTINUE - 40 CONTINUE - END IF - CALL DLASET( 'All', M*K, K, ZERO, ZERO, G(K+1,K+1), LDG ) - END IF -C - CALL DLACPY( 'All', M*K, K, TA, LDTA, R, LDR ) -C -C Apply the stored transformations on the new rows. -C - DO 50 I = 2, N -C -C Copy the last M-1 blocks of the positive generator together; -C the last M blocks of the negative generator are contained -C in TA. -C - STARTR = ( I - 1 )*K + 1 - STARTT = 3*( I - 2 )*K + 1 - CALL DLACPY( 'All', (M-1)*K, K, R(1,STARTR-K), LDR, - $ R(K+1,STARTR), LDR ) -C -C Apply the transformations stored in T on the generator. -C - CALL MB02CY( 'Column', 'NoStructure', K, K, M*K, K, - $ R(1,STARTR), LDR, TA, LDTA, T(STARTR,1), LDT, - $ CS(STARTT), 3*K, DWORK, LDWORK, IERR ) - MAXWRK = MAX( MAXWRK, INT( DWORK(1) ) ) - 50 CONTINUE -C -C Now, we have "normality" and can apply further M Schur steps. -C - DO 60 I = 1, M -C -C Copy the first M-I+1 blocks of the positive generator -C together; the first M-I+1 blocks of the negative generator -C are contained in TA. -C - STARTT = 3*( N + I - 2 )*K + 1 - STARTI = ( M - I + 1 )*K + 1 - STARTR = ( N + I - 1 )*K + 1 - IF ( I.EQ.1 ) THEN - CALL DLACPY( 'All', (M-1)*K, K, R(1,STARTR-K), LDR, - $ R(K+1,STARTR), LDR ) - ELSE - CALL DLACPY( 'Lower', (M-I+1)*K, K, - $ R((I-2)*K+1,STARTR-K), LDR, - $ R((I-1)*K+1,STARTR), LDR ) - END IF -C -C Reduce the generator to proper form. -C - CALL MB02CX( 'Column', K, K, K, R((I-1)*K+1,STARTR), LDR, - $ TA((I-1)*K+1,1), LDTA, CS(STARTT), 3*K, DWORK, - $ LDWORK, IERR ) - IF ( IERR.NE.0 ) THEN -C -C Error return: The matrix is not positive definite. -C - INFO = 1 - RETURN - END IF -C - MAXWRK = MAX( MAXWRK, INT( DWORK(1) ) ) - IF ( M.GT.I ) THEN - CALL MB02CY( 'Column', 'NoStructure', K, K, (M-I)*K, K, - $ R(I*K+1,STARTR), LDR, TA(I*K+1,1), LDTA, - $ TA((I-1)*K+1,1), LDTA, CS(STARTT), 3*K, - $ DWORK, LDWORK, IERR ) - MAXWRK = MAX( MAXWRK, INT( DWORK(1) ) ) - END IF -C - IF ( COMPG ) THEN -C -C Transformations acting on the inverse generator: -C - CALL MB02CY( 'Column', 'Triangular', K, K, K, K, - $ G(1,K+1), LDG, G(STARTR,1), LDG, - $ TA((I-1)*K+1,1), LDTA, CS(STARTT), 3*K, - $ DWORK, LDWORK, IERR ) - MAXWRK = MAX( MAXWRK, INT( DWORK(1) ) ) -C - CALL MB02CY( 'Column', 'NoStructure', K, K, (N+I-1)*K, K, - $ G(STARTI,K+1), LDG, G, LDG, TA((I-1)*K+1,1), - $ LDTA, CS(STARTT), 3*K, DWORK, LDWORK, IERR ) - MAXWRK = MAX( MAXWRK, INT( DWORK(1) ) ) -C - IF ( COMPL ) THEN - CALL DLACPY( 'All', (N+I-1)*K, K, G(STARTI,K+1), LDG, - $ L(1,(I-1)*K+1), LDL ) - CALL DLACPY( 'Upper', K, K, G(1,K+1), LDG, - $ L(STARTR,(I-1)*K+1), LDL ) - END IF -C - END IF - 60 CONTINUE -C - END IF -C - DWORK(1) = MAXWRK -C - RETURN -C -C *** Last line of MB02DD *** - END diff --git a/mex/sources/libslicot/MB02ED.f b/mex/sources/libslicot/MB02ED.f deleted file mode 100644 index d5c366cbc..000000000 --- a/mex/sources/libslicot/MB02ED.f +++ /dev/null @@ -1,445 +0,0 @@ - SUBROUTINE MB02ED( TYPET, K, N, NRHS, T, LDT, B, LDB, DWORK, - $ LDWORK, INFO ) -C -C SLICOT RELEASE 5.0. -C -C Copyright (c) 2002-2009 NICONET e.V. -C -C This program is free software: you can redistribute it and/or -C modify it under the terms of the GNU General Public License as -C published by the Free Software Foundation, either version 2 of -C the License, or (at your option) any later version. -C -C This program is distributed in the hope that it will be useful, -C but WITHOUT ANY WARRANTY; without even the implied warranty of -C MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the -C GNU General Public License for more details. -C -C You should have received a copy of the GNU General Public License -C along with this program. If not, see -C . -C -C PURPOSE -C -C To solve a system of linear equations T*X = B or X*T = B with -C a symmetric positive definite (s.p.d.) block Toeplitz matrix T. -C T is defined either by its first block row or its first block -C column, depending on the parameter TYPET. -C -C ARGUMENTS -C -C Mode Parameters -C -C TYPET CHARACTER*1 -C Specifies the type of T, as follows: -C = 'R': T contains the first block row of an s.p.d. block -C Toeplitz matrix, and the system X*T = B is solved; -C = 'C': T contains the first block column of an s.p.d. -C block Toeplitz matrix, and the system T*X = B is -C solved. -C Note: in the sequel, the notation x / y means that -C x corresponds to TYPET = 'R' and y corresponds to -C TYPET = 'C'. -C -C Input/Output Parameters -C -C K (input) INTEGER -C The number of rows / columns in T, which should be equal -C to the blocksize. K >= 0. -C -C N (input) INTEGER -C The number of blocks in T. N >= 0. -C -C NRHS (input) INTEGER -C The number of right hand sides. NRHS >= 0. -C -C T (input/output) DOUBLE PRECISION array, dimension -C (LDT,N*K) / (LDT,K) -C On entry, the leading K-by-N*K / N*K-by-K part of this -C array must contain the first block row / column of an -C s.p.d. block Toeplitz matrix. -C On exit, if INFO = 0 and NRHS > 0, then the leading -C K-by-N*K / N*K-by-K part of this array contains the last -C row / column of the Cholesky factor of inv(T). -C -C LDT INTEGER -C The leading dimension of the array T. -C LDT >= MAX(1,K), if TYPET = 'R'; -C LDT >= MAX(1,N*K), if TYPET = 'C'. -C -C B (input/output) DOUBLE PRECISION array, dimension -C (LDB,N*K) / (LDB,NRHS) -C On entry, the leading NRHS-by-N*K / N*K-by-NRHS part of -C this array must contain the right hand side matrix B. -C On exit, the leading NRHS-by-N*K / N*K-by-NRHS part of -C this array contains the solution matrix X. -C -C LDB INTEGER -C The leading dimension of the array B. -C LDB >= MAX(1,NRHS), if TYPET = 'R'; -C LDB >= MAX(1,N*K), if TYPET = 'C'. -C -C Workspace -C -C DWORK DOUBLE PRECISION array, dimension (LDWORK) -C On exit, if INFO = 0, DWORK(1) returns the optimal -C value of LDWORK. -C On exit, if INFO = -10, DWORK(1) returns the minimum -C value of LDWORK. -C -C LDWORK INTEGER -C The length of the array DWORK. -C LDWORK >= MAX(1,N*K*K+(N+2)*K). -C For optimum performance LDWORK should be larger. -C -C Error Indicator -C -C INFO INTEGER -C = 0: successful exit; -C < 0: if INFO = -i, the i-th argument had an illegal -C value; -C = 1: the reduction algorithm failed. The Toeplitz matrix -C associated with T is not (numerically) positive -C definite. -C -C METHOD -C -C Householder transformations, modified hyperbolic rotations and -C block Gaussian eliminations are used in the Schur algorithm [1], -C [2]. -C -C REFERENCES -C -C [1] Kailath, T. and Sayed, A. -C Fast Reliable Algorithms for Matrices with Structure. -C SIAM Publications, Philadelphia, 1999. -C -C [2] Kressner, D. and Van Dooren, P. -C Factorizations and linear system solvers for matrices with -C Toeplitz structure. -C SLICOT Working Note 2000-2, 2000. -C -C NUMERICAL ASPECTS -C -C The implemented method is numerically equivalent with forming -C the Cholesky factor R and the inverse Cholesky factor of T, using -C the generalized Schur algorithm, and solving the systems of -C equations R*X = L*B or X*R = B*L by a blocked backward -C substitution algorithm. -C 3 2 2 2 -C The algorithm requires 0(K N + K N NRHS) floating point -C operations. -C -C CONTRIBUTOR -C -C D. Kressner, Technical Univ. Chemnitz, Germany, December 2000. -C -C REVISIONS -C -C V. Sima, Research Institute for Informatics, Bucharest, Dec. 2000, -C February 2004. -C -C KEYWORDS -C -C Elementary matrix operations, Householder transformation, matrix -C operations, Toeplitz matrix. -C -C ****************************************************************** -C -C .. Parameters .. - DOUBLE PRECISION ZERO, ONE - PARAMETER ( ZERO = 0.0D0, ONE = 1.0D0 ) -C .. Scalar Arguments .. - CHARACTER TYPET - INTEGER INFO, K, LDB, LDT, LDWORK, N, NRHS -C .. Array Arguments .. - DOUBLE PRECISION B(LDB,*), DWORK(*), T(LDT,*) -C .. Local Scalars .. - INTEGER I, IERR, MAXWRK, STARTH, STARTI, STARTN, - $ STARTR, STARTT - LOGICAL ISROW -C .. External Functions .. - LOGICAL LSAME - EXTERNAL LSAME -C .. External Subroutines .. - EXTERNAL DGEMM, DLACPY, DLASET, DPOTRF, DTRMM, DTRSM, - $ MB02CX, MB02CY, XERBLA -C .. Intrinsic Functions .. - INTRINSIC INT, MAX, MIN -C -C .. Executable Statements .. -C -C Decode the scalar input parameters. -C - INFO = 0 - ISROW = LSAME( TYPET, 'R' ) -C -C Check the scalar input parameters. -C - IF ( .NOT.( ISROW .OR. LSAME( TYPET, 'C' ) ) ) THEN - INFO = -1 - ELSE IF ( K.LT.0 ) THEN - INFO = -2 - ELSE IF ( N.LT.0 ) THEN - INFO = -3 - ELSE IF ( NRHS.LT.0 ) THEN - INFO = -4 - ELSE IF ( LDT.LT.1 .OR. ( ISROW .AND. LDT.LT.K ) .OR. - $ ( .NOT.ISROW .AND. LDT.LT.N*K ) ) THEN - INFO = -6 - ELSE IF ( LDB.LT.1 .OR. ( ISROW .AND. LDB.LT.NRHS ) .OR. - $ ( .NOT.ISROW .AND. LDB.LT.N*K ) ) THEN - INFO = -8 - ELSE IF ( LDWORK.LT.MAX( 1, N*K*K + ( N + 2 )*K ) ) THEN - DWORK(1) = MAX( 1, N*K*K + ( N + 2 )*K ) - INFO = -10 - END IF -C -C Return if there were illegal values. -C - IF ( INFO.NE.0 ) THEN - CALL XERBLA( 'MB02ED', -INFO ) - RETURN - END IF -C -C Quick return if possible. -C - IF ( MIN( K, N, NRHS ).EQ.0 ) THEN - DWORK(1) = ONE - RETURN - END IF -C - MAXWRK = 0 - STARTN = 1 - STARTT = N*K*K + 1 - STARTH = STARTT + 3*K -C - IF ( ISROW ) THEN -C -C T is the first block row of a block Toeplitz matrix. -C Bring T to proper form by triangularizing its first block. -C - CALL DPOTRF( 'Upper', K, T, LDT, IERR ) - IF ( IERR.NE.0 ) THEN -C -C Error return: The matrix is not positive definite. -C - INFO = 1 - RETURN - END IF -C - IF ( N.GT.1 ) - $ CALL DTRSM( 'Left', 'Upper', 'Transpose', 'NonUnit', K, - $ (N-1)*K, ONE, T, LDT, T(1,K+1), LDT ) -C -C Initialize the generator, do the first Schur step and set -C B = -B. -C T contains the nonzero blocks of the positive parts in the -C generator and the inverse generator. -C DWORK(STARTN) contains the nonzero blocks of the negative parts -C in the generator and the inverse generator. -C - CALL DTRSM( 'Right', 'Upper', 'NonTranspose', 'NonUnit', NRHS, - $ K, ONE, T, LDT, B, LDB ) - IF ( N.GT.1 ) - $ CALL DGEMM( 'NonTranspose', 'NonTranspose', NRHS, (N-1)*K, - $ K, ONE, B, LDB, T(1,K+1), LDT, -ONE, B(1,K+1), - $ LDB ) -C - CALL DLASET( 'All', K, K, ZERO, ONE, DWORK(STARTN), K ) - CALL DTRSM( 'Left', 'Upper', 'Transpose', 'NonUnit', K, K, - $ ONE, T, LDT, DWORK(STARTN), K ) - IF ( N.GT.1 ) - $ CALL DLACPY( 'All', K, (N-1)*K, T(1,K+1), LDT, - $ DWORK(STARTN+K*K), K ) - CALL DLACPY( 'All', K, K, DWORK(STARTN), K, T(1,(N-1)*K+1), - $ LDT ) -C - CALL DTRMM ( 'Right', 'Lower', 'NonTranspose', 'NonUnit', NRHS, - $ K, ONE, T(1,(N-1)*K+1), LDT, B, LDB ) -C -C Processing the generator. -C - DO 10 I = 2, N - STARTR = ( I - 1 )*K + 1 - STARTI = ( N - I )*K + 1 -C -C Transform the generator of T to proper form. -C - CALL MB02CX( 'Row', K, K, K, T, LDT, - $ DWORK(STARTN+(I-1)*K*K), K, DWORK(STARTT), 3*K, - $ DWORK(STARTH), LDWORK-STARTH+1, IERR ) -C - IF ( IERR.NE.0 ) THEN -C -C Error return: The matrix is not positive definite. -C - INFO = 1 - RETURN - END IF -C - MAXWRK = MAX( MAXWRK, INT( DWORK(STARTH) ) ) - CALL MB02CY( 'Row', 'NoStructure', K, K, (N-I)*K, K, - $ T(1,K+1), LDT, DWORK(STARTN+I*K*K), K, - $ DWORK(STARTN+(I-1)*K*K), K, DWORK(STARTT), - $ 3*K, DWORK(STARTH), LDWORK-STARTH+1, IERR ) - MAXWRK = MAX( MAXWRK, INT( DWORK(STARTH) ) ) -C -C Block Gaussian eliminates the i-th block in B. -C - CALL DTRSM( 'Right', 'Upper', 'NonTranspose', 'NonUnit', - $ NRHS, K, -ONE, T, LDT, B(1,STARTR), LDB ) - IF ( N.GT.I ) - $ CALL DGEMM( 'NonTranspose', 'NonTranspose', NRHS, - $ (N-I)*K, K, ONE, B(1,STARTR), LDB, T(1,K+1), - $ LDT, ONE, B(1,STARTR+K), LDB ) -C -C Apply hyperbolic transformations on the negative generator. -C - CALL DLASET( 'All', K, K, ZERO, ZERO, T(1,STARTI), LDT ) - CALL MB02CY( 'Row', 'NoStructure', K, K, (I-1)*K, K, - $ T(1,STARTI), LDT, DWORK(STARTN), K, - $ DWORK(STARTN+(I-1)*K*K), K, DWORK(STARTT), 3*K, - $ DWORK(STARTH), LDWORK-STARTH+1, IERR ) - MAXWRK = MAX( MAXWRK, INT( DWORK(STARTH) ) ) -C -C Note that DWORK(STARTN+(I-1)*K*K) serves simultaneously -C as the transformation container as well as the new block in -C the negative generator. -C - CALL MB02CY( 'Row', 'Triangular', K, K, K, K, - $ T(1,(N-1)*K+1), LDT, DWORK(STARTN+(I-1)*K*K), - $ K, DWORK(STARTN+(I-1)*K*K), K, DWORK(STARTT), - $ 3*K, DWORK(STARTH), LDWORK-STARTH+1, IERR ) - MAXWRK = MAX( MAXWRK, INT( DWORK(STARTH) ) ) -C -C Finally the Gaussian elimination is applied on the inverse -C generator. -C - CALL DGEMM( 'NonTranspose', 'NonTranspose', NRHS, (I-1)*K, - $ K, ONE, B(1,STARTR), LDB, T(1,STARTI), LDT, ONE, - $ B, LDB ) - CALL DTRMM( 'Right', 'Lower', 'NonTranspose', 'NonUnit', - $ NRHS, K, ONE, T(1,(N-1)*K+1), LDT, B(1,STARTR), - $ LDB ) - 10 CONTINUE -C - ELSE -C -C T is the first block column of a block Toeplitz matrix. -C Bring T to proper form by triangularizing its first block. -C - CALL DPOTRF( 'Lower', K, T, LDT, IERR ) - IF ( IERR.NE.0 ) THEN -C -C Error return: The matrix is not positive definite. -C - INFO = 1 - RETURN - END IF -C - IF ( N.GT.1 ) - $ CALL DTRSM( 'Right', 'Lower', 'Transpose', 'NonUnit', - $ (N-1)*K, K, ONE, T, LDT, T(K+1,1), LDT ) -C -C Initialize the generator, do the first Schur step and set -C B = -B. -C T contains the nonzero blocks of the positive parts in the -C generator and the inverse generator. -C DWORK(STARTN) contains the nonzero blocks of the negative parts -C in the generator and the inverse generator. -C - CALL DTRSM( 'Left', 'Lower', 'NonTranspose', 'NonUnit', K, - $ NRHS, ONE, T, LDT, B, LDB ) - IF ( N.GT.1 ) - $ CALL DGEMM( 'NonTranspose', 'NonTranspose', (N-1)*K, NRHS, - $ K, ONE, T(K+1,1), LDT, B, LDB, -ONE, B(K+1,1), - $ LDB ) -C - CALL DLASET( 'All', K, K, ZERO, ONE, DWORK(STARTN), N*K ) - CALL DTRSM( 'Right', 'Lower', 'Transpose', 'NonUnit', K, K, - $ ONE, T, LDT, DWORK(STARTN), N*K ) - IF ( N.GT.1 ) - $ CALL DLACPY( 'All', (N-1)*K, K, T(K+1,1), LDT, - $ DWORK(STARTN+K), N*K ) - CALL DLACPY( 'All', K, K, DWORK(STARTN), N*K, T((N-1)*K+1,1), - $ LDT ) -C - CALL DTRMM ( 'Left', 'Upper', 'NonTranspose', 'NonUnit', K, - $ NRHS, ONE, T((N-1)*K+1,1), LDT, B, LDB ) -C -C Processing the generator. -C - DO 20 I = 2, N - STARTR = ( I - 1 )*K + 1 - STARTI = ( N - I )*K + 1 -C -C Transform the generator of T to proper form. -C - CALL MB02CX( 'Column', K, K, K, T, LDT, - $ DWORK(STARTN+(I-1)*K), N*K, DWORK(STARTT), 3*K, - $ DWORK(STARTH), LDWORK-STARTH+1, IERR ) -C - IF ( IERR.NE.0 ) THEN -C -C Error return: The matrix is not positive definite. -C - INFO = 1 - RETURN - END IF -C - MAXWRK = MAX( MAXWRK, INT( DWORK(STARTH) ) ) - CALL MB02CY( 'Column', 'NoStructure', K, K, (N-I)*K, K, - $ T(K+1,1), LDT, DWORK(STARTN+I*K), N*K, - $ DWORK(STARTN+(I-1)*K), N*K, DWORK(STARTT), - $ 3*K, DWORK(STARTH), LDWORK-STARTH+1, IERR ) - MAXWRK = MAX( MAXWRK, INT( DWORK(STARTH) ) ) -C -C Block Gaussian eliminates the i-th block in B. -C - CALL DTRSM( 'Left', 'Lower', 'NonTranspose', 'NonUnit', K, - $ NRHS, -ONE, T, LDT, B(STARTR,1), LDB ) - IF ( N.GT.I ) - $ CALL DGEMM( 'NonTranspose', 'NonTranspose', (N-I)*K, - $ NRHS, K, ONE, T(K+1,1), LDT, B(STARTR,1), - $ LDB, ONE, B(STARTR+K,1), LDB ) -C -C Apply hyperbolic transformations on the negative generator. -C - CALL DLASET( 'All', K, K, ZERO, ZERO, T(STARTI,1), LDT ) - CALL MB02CY( 'Column', 'NoStructure', K, K, (I-1)*K, K, - $ T(STARTI,1), LDT, DWORK(STARTN), N*K, - $ DWORK(STARTN+(I-1)*K), N*K, DWORK(STARTT), 3*K, - $ DWORK(STARTH), LDWORK-STARTH+1, IERR ) - MAXWRK = MAX( MAXWRK, INT( DWORK(STARTH) ) ) -C -C Note that DWORK(STARTN+(I-1)*K) serves simultaneously -C as the transformation container as well as the new block in -C the negative generator. -C - CALL MB02CY( 'Column', 'Triangular', K, K, K, K, - $ T((N-1)*K+1,1), LDT, DWORK(STARTN+(I-1)*K), - $ N*K, DWORK(STARTN+(I-1)*K), N*K, DWORK(STARTT), - $ 3*K, DWORK(STARTH), LDWORK-STARTH+1, IERR ) - MAXWRK = MAX( MAXWRK, INT( DWORK(STARTH) ) ) -C -C Finally the Gaussian elimination is applied on the inverse -C generator. -C - CALL DGEMM( 'NonTranspose', 'NonTranspose', (I-1)*K, NRHS, - $ K, ONE, T(STARTI,1), LDT, B(STARTR,1), LDB, ONE, - $ B, LDB ) - CALL DTRMM( 'Left', 'Upper', 'NonTranspose', 'NonUnit', - $ K, NRHS, ONE, T((N-1)*K+1,1), LDT, B(STARTR,1), - $ LDB ) -C - 20 CONTINUE -C - END IF -C - DWORK(1) = MAX( 1, STARTH - 1 + MAXWRK ) -C - RETURN -C -C *** Last line of MB02ED *** - END diff --git a/mex/sources/libslicot/MB02FD.f b/mex/sources/libslicot/MB02FD.f deleted file mode 100644 index 0e608a832..000000000 --- a/mex/sources/libslicot/MB02FD.f +++ /dev/null @@ -1,383 +0,0 @@ - SUBROUTINE MB02FD( TYPET, K, N, P, S, T, LDT, R, LDR, DWORK, - $ LDWORK, INFO ) -C -C SLICOT RELEASE 5.0. -C -C Copyright (c) 2002-2009 NICONET e.V. -C -C This program is free software: you can redistribute it and/or -C modify it under the terms of the GNU General Public License as -C published by the Free Software Foundation, either version 2 of -C the License, or (at your option) any later version. -C -C This program is distributed in the hope that it will be useful, -C but WITHOUT ANY WARRANTY; without even the implied warranty of -C MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the -C GNU General Public License for more details. -C -C You should have received a copy of the GNU General Public License -C along with this program. If not, see -C . -C -C PURPOSE -C -C To compute the incomplete Cholesky (ICC) factor of a symmetric -C positive definite (s.p.d.) block Toeplitz matrix T, defined by -C either its first block row, or its first block column, depending -C on the routine parameter TYPET. -C -C By subsequent calls of this routine, further rows / columns of -C the Cholesky factor can be added. -C Furthermore, the generator of the Schur complement of the leading -C (P+S)*K-by-(P+S)*K block in T is available, which can be used, -C e.g., for measuring the quality of the ICC factorization. -C -C ARGUMENTS -C -C Mode Parameters -C -C TYPET CHARACTER*1 -C Specifies the type of T, as follows: -C = 'R': T contains the first block row of an s.p.d. block -C Toeplitz matrix; the ICC factor R is upper -C trapezoidal; -C = 'C': T contains the first block column of an s.p.d. -C block Toeplitz matrix; the ICC factor R is lower -C trapezoidal; this choice leads to better -C localized memory references and hence a faster -C algorithm. -C Note: in the sequel, the notation x / y means that -C x corresponds to TYPET = 'R' and y corresponds to -C TYPET = 'C'. -C -C Input/Output Parameters -C -C K (input) INTEGER -C The number of rows / columns in T, which should be equal -C to the blocksize. K >= 0. -C -C N (input) INTEGER -C The number of blocks in T. N >= 0. -C -C P (input) INTEGER -C The number of previously computed block rows / columns -C of R. 0 <= P <= N. -C -C S (input) INTEGER -C The number of block rows / columns of R to compute. -C 0 <= S <= N-P. -C -C T (input/output) DOUBLE PRECISION array, dimension -C (LDT,(N-P)*K) / (LDT,K) -C On entry, if P = 0, then the leading K-by-N*K / N*K-by-K -C part of this array must contain the first block row / -C column of an s.p.d. block Toeplitz matrix. -C If P > 0, the leading K-by-(N-P)*K / (N-P)*K-by-K must -C contain the negative generator of the Schur complement of -C the leading P*K-by-P*K part in T, computed from previous -C calls of this routine. -C On exit, if INFO = 0, then the leading K-by-(N-P)*K / -C (N-P)*K-by-K part of this array contains, in the first -C K-by-K block, the upper / lower Cholesky factor of -C T(1:K,1:K), in the following S-1 K-by-K blocks, the -C Householder transformations applied during the process, -C and in the remaining part, the negative generator of the -C Schur complement of the leading (P+S)*K-by(P+S)*K part -C in T. -C -C LDT INTEGER -C The leading dimension of the array T. -C LDT >= MAX(1,K), if TYPET = 'R'; -C LDT >= MAX(1,(N-P)*K), if TYPET = 'C'. -C -C R (input/output) DOUBLE PRECISION array, dimension -C (LDR, N*K) / (LDR, S*K ) if P = 0; -C (LDR, (N-P+1)*K) / (LDR, (S+1)*K ) if P > 0. -C On entry, if P > 0, then the leading K-by-(N-P+1)*K / -C (N-P+1)*K-by-K part of this array must contain the -C nonzero blocks of the last block row / column in the -C ICC factor from a previous call of this routine. Note that -C this part is identical with the positive generator of -C the Schur complement of the leading P*K-by-P*K part in T. -C If P = 0, then R is only an output parameter. -C On exit, if INFO = 0 and P = 0, then the leading -C S*K-by-N*K / N*K-by-S*K part of this array contains the -C upper / lower trapezoidal ICC factor. -C On exit, if INFO = 0 and P > 0, then the leading -C (S+1)*K-by-(N-P+1)*K / (N-P+1)*K-by-(S+1)*K part of this -C array contains the upper / lower trapezoidal part of the -C P-th to (P+S)-th block rows / columns of the ICC factor. -C The elements in the strictly lower / upper trapezoidal -C part are not referenced. -C -C LDR INTEGER -C The leading dimension of the array R. -C LDR >= MAX(1, S*K ), if TYPET = 'R' and P = 0; -C LDR >= MAX(1, (S+1)*K ), if TYPET = 'R' and P > 0; -C LDR >= MAX(1, N*K ), if TYPET = 'C' and P = 0; -C LDR >= MAX(1, (N-P+1)*K ), if TYPET = 'C' and P > 0. -C -C Workspace -C -C DWORK DOUBLE PRECISION array, dimension (LDWORK) -C On exit, if INFO = 0, DWORK(1) returns the optimal -C value of LDWORK. -C On exit, if INFO = -11, DWORK(1) returns the minimum -C value of LDWORK. -C -C LDWORK INTEGER -C The length of the array DWORK. -C LDWORK >= MAX(1,(N+1)*K,4*K), if P = 0; -C LDWORK >= MAX(1,(N-P+2)*K,4*K), if P > 0. -C For optimum performance LDWORK should be larger. -C -C Error Indicator -C -C INFO INTEGER -C = 0: successful exit; -C < 0: if INFO = -i, the i-th argument had an illegal -C value; -C = 1: the reduction algorithm failed; the Toeplitz matrix -C associated with T is not (numerically) positive -C definite in its leading (P+S)*K-by-(P+S)*K part. -C -C METHOD -C -C Householder transformations and modified hyperbolic rotations -C are used in the Schur algorithm [1], [2]. -C -C REFERENCES -C -C [1] Kailath, T. and Sayed, A. -C Fast Reliable Algorithms for Matrices with Structure. -C SIAM Publications, Philadelphia, 1999. -C -C [2] Kressner, D. and Van Dooren, P. -C Factorizations and linear system solvers for matrices with -C Toeplitz structure. -C SLICOT Working Note 2000-2, 2000. -C -C NUMERICAL ASPECTS -C -C The implemented method is numerically stable. -C 3 -C The algorithm requires 0(K S (N-P)) floating point operations. -C -C CONTRIBUTOR -C -C D. Kressner, Technical Univ. Berlin, Germany, April 2001. -C -C REVISIONS -C -C V. Sima, Research Institute for Informatics, Bucharest, Apr. 2001, -C Mar. 2004. -C -C KEYWORDS -C -C Elementary matrix operations, Householder transformation, matrix -C operations, Toeplitz matrix. -C -C ****************************************************************** -C -C .. Parameters .. - DOUBLE PRECISION ONE - PARAMETER ( ONE = 1.0D0 ) -C .. Scalar Arguments .. - CHARACTER TYPET - INTEGER INFO, K, LDR, LDT, LDWORK, N, P, S -C .. Array Arguments .. - DOUBLE PRECISION DWORK(*), R(LDR,*), T(LDT,*) -C .. Local Scalars .. - INTEGER COUNTR, I, IERR, MAXWRK, ST, STARTR - LOGICAL ISROW -C .. External Functions .. - LOGICAL LSAME - EXTERNAL LSAME -C .. External Subroutines .. - EXTERNAL DLACPY, DPOTRF, DTRSM, MB02CX, MB02CY, XERBLA -C .. Intrinsic Functions .. - INTRINSIC INT, MAX, MIN -C -C .. Executable Statements .. -C -C Decode the scalar input parameters. -C - INFO = 0 - ISROW = LSAME( TYPET, 'R' ) -C -C Check the scalar input parameters. -C - IF ( .NOT.( ISROW .OR. LSAME( TYPET, 'C' ) ) ) THEN - INFO = -1 - ELSE IF ( K.LT.0 ) THEN - INFO = -2 - ELSE IF ( N.LT.0 ) THEN - INFO = -3 - ELSE IF ( P.LT.0 .OR. P.GT.N ) THEN - INFO = -4 - ELSE IF ( S.LT.0 .OR. S.GT.( N-P ) ) THEN - INFO = -5 - ELSE IF ( LDT.LT.1 .OR. ( ISROW .AND. LDT.LT.K ) .OR. - $ ( .NOT.ISROW .AND. LDT.LT.( N-P )*K ) ) THEN - INFO = -7 - ELSE IF ( LDR.LT.1 .OR. - $ ( ISROW .AND. P.EQ.0 .AND. ( LDR.LT.S*K ) ) .OR. - $ ( ISROW .AND. P.GT.0 .AND. ( LDR.LT.( S+1 )*K ) ) .OR. - $ ( .NOT.ISROW .AND. P.EQ.0 .AND. ( LDR.LT.N*K ) ) .OR. - $ ( .NOT.ISROW .AND. P.GT.0 .AND. ( LDR.LT.( N-P+1 )*K ) ) ) THEN - INFO = -9 - ELSE - IF ( P.EQ.0 ) THEN - COUNTR = ( N + 1 )*K - ELSE - COUNTR = ( N - P + 2 )*K - END IF - COUNTR = MAX( COUNTR, 4*K ) - IF ( LDWORK.LT.MAX( 1, COUNTR ) ) THEN - DWORK(1) = MAX( 1, COUNTR ) - INFO = -11 - END IF - END IF -C -C Return if there were illegal values. -C - IF ( INFO.NE.0 ) THEN - CALL XERBLA( 'MB02FD', -INFO ) - RETURN - END IF -C -C Quick return if possible. -C - IF ( MIN( K, N, S ).EQ.0 ) THEN - DWORK(1) = ONE - RETURN - END IF -C - MAXWRK = 1 -C - IF ( ISROW ) THEN -C - IF ( P.EQ.0 ) THEN -C -C T is the first block row of a block Toeplitz matrix. -C Bring T to proper form by triangularizing its first block. -C - CALL DPOTRF( 'Upper', K, T, LDT, IERR ) - IF ( IERR.NE.0 ) THEN -C -C Error return: The matrix is not positive definite. -C - INFO = 1 - RETURN - END IF -C - IF ( N.GT.1 ) - $ CALL DTRSM( 'Left', 'Upper', 'Transpose', 'NonUnit', K, - $ (N-1)*K, ONE, T, LDT, T(1,K+1), LDT ) - CALL DLACPY( 'Upper', K, N*K, T, LDT, R, LDR ) -C - IF ( S.EQ.1 ) THEN - DWORK(1) = ONE - RETURN - END IF -C - ST = 2 - COUNTR = ( N - 1 )*K - ELSE - ST = 1 - COUNTR = ( N - P )*K - END IF -C - STARTR = 1 -C - DO 10 I = ST, S - CALL DLACPY( 'Upper', K, COUNTR, R(STARTR,STARTR), LDR, - $ R(STARTR+K,STARTR+K), LDR ) - STARTR = STARTR + K - COUNTR = COUNTR - K - CALL MB02CX( 'Row', K, K, K, R(STARTR,STARTR), LDR, - $ T(1,STARTR), LDT, DWORK, 3*K, DWORK(3*K+1), - $ LDWORK-3*K, IERR ) - IF ( IERR.NE.0 ) THEN -C -C Error return: The matrix is not positive definite. -C - INFO = 1 - RETURN - END IF -C - MAXWRK = MAX( MAXWRK, INT( DWORK(3*K+1) ) + 3*K ) - CALL MB02CY( 'Row', 'NoStructure', K, K, COUNTR, K, - $ R(STARTR,STARTR+K), LDR, T(1,STARTR+K), LDT, - $ T(1,STARTR), LDT, DWORK, 3*K, DWORK(3*K+1), - $ LDWORK-3*K, IERR ) - MAXWRK = MAX( MAXWRK, INT( DWORK(3*K+1) ) + 3*K ) - 10 CONTINUE -C - ELSE -C - IF ( P.EQ.0 ) THEN -C -C T is the first block column of a block Toeplitz matrix. -C Bring T to proper form by triangularizing its first block. -C - CALL DPOTRF( 'Lower', K, T, LDT, IERR ) - IF ( IERR.NE.0 ) THEN -C -C Error return: The matrix is not positive definite. -C - INFO = 1 - RETURN - END IF -C - IF ( N.GT.1 ) - $ CALL DTRSM( 'Right', 'Lower', 'Transpose', 'NonUnit', - $ (N-1)*K, K, ONE, T, LDT, T(K+1,1), LDT ) - CALL DLACPY( 'Lower', N*K, K, T, LDT, R, LDR ) -C - IF ( S.EQ.1 ) THEN - DWORK(1) = ONE - RETURN - END IF -C - ST = 2 - COUNTR = ( N - 1 )*K - ELSE - ST = 1 - COUNTR = ( N - P )*K - END IF -C - STARTR = 1 -C - DO 20 I = ST, S - CALL DLACPY( 'Lower', COUNTR, K, R(STARTR,STARTR), LDR, - $ R(STARTR+K,STARTR+K), LDR ) - STARTR = STARTR + K - COUNTR = COUNTR - K - CALL MB02CX( 'Column', K, K, K, R(STARTR,STARTR), LDR, - $ T(STARTR,1), LDT, DWORK, 3*K, DWORK(3*K+1), - $ LDWORK-3*K, IERR ) - IF ( IERR.NE.0 ) THEN -C -C Error return: The matrix is not positive definite. -C - INFO = 1 - RETURN - END IF -C - MAXWRK = MAX( MAXWRK, INT( DWORK(3*K+1) ) + 3*K ) - CALL MB02CY( 'Column', 'NoStructure', K, K, COUNTR, K, - $ R(STARTR+K,STARTR), LDR, T(STARTR+K,1), LDT, - $ T(STARTR,1), LDT, DWORK, 3*K, DWORK(3*K+1), - $ LDWORK-3*K, IERR ) - MAXWRK = MAX( MAXWRK, INT( DWORK(3*K+1) ) + 3*K ) - 20 CONTINUE -C - END IF -C - DWORK(1) = MAXWRK -C - RETURN -C -C *** Last line of MB02FD *** - END diff --git a/mex/sources/libslicot/MB02GD.f b/mex/sources/libslicot/MB02GD.f deleted file mode 100644 index c227a556a..000000000 --- a/mex/sources/libslicot/MB02GD.f +++ /dev/null @@ -1,558 +0,0 @@ - SUBROUTINE MB02GD( TYPET, TRIU, K, N, NL, P, S, T, LDT, RB, LDRB, - $ DWORK, LDWORK, INFO ) -C -C SLICOT RELEASE 5.0. -C -C Copyright (c) 2002-2009 NICONET e.V. -C -C This program is free software: you can redistribute it and/or -C modify it under the terms of the GNU General Public License as -C published by the Free Software Foundation, either version 2 of -C the License, or (at your option) any later version. -C -C This program is distributed in the hope that it will be useful, -C but WITHOUT ANY WARRANTY; without even the implied warranty of -C MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the -C GNU General Public License for more details. -C -C You should have received a copy of the GNU General Public License -C along with this program. If not, see -C . -C -C PURPOSE -C -C To compute the Cholesky factor of a banded symmetric positive -C definite (s.p.d.) block Toeplitz matrix, defined by either its -C first block row, or its first block column, depending on the -C routine parameter TYPET. -C -C By subsequent calls of this routine the Cholesky factor can be -C computed block column by block column. -C -C ARGUMENTS -C -C Mode Parameters -C -C TYPET CHARACTER*1 -C Specifies the type of T, as follows: -C = 'R': T contains the first block row of an s.p.d. block -C Toeplitz matrix; the Cholesky factor is upper -C triangular; -C = 'C': T contains the first block column of an s.p.d. -C block Toeplitz matrix; the Cholesky factor is -C lower triangular. This choice results in a column -C oriented algorithm which is usually faster. -C Note: in the sequel, the notation x / y means that -C x corresponds to TYPET = 'R' and y corresponds to -C TYPET = 'C'. -C -C TRIU CHARACTER*1 -C Specifies the structure of the last block in T, as -C follows: -C = 'N': the last block has no special structure; -C = 'T': the last block is lower / upper triangular. -C -C Input/Output Parameters -C -C K (input) INTEGER -C The number of rows / columns in T, which should be equal -C to the blocksize. K >= 0. -C -C N (input) INTEGER -C The number of blocks in T. N >= 1. -C If TRIU = 'N', N >= 1; -C if TRIU = 'T', N >= 2. -C -C NL (input) INTEGER -C The lower block bandwidth, i.e., NL + 1 is the number of -C nonzero blocks in the first block column of the block -C Toeplitz matrix. -C If TRIU = 'N', 0 <= NL < N; -C if TRIU = 'T', 1 <= NL < N. -C -C P (input) INTEGER -C The number of previously computed block rows / columns of -C the Cholesky factor. 0 <= P <= N. -C -C S (input) INTEGER -C The number of block rows / columns of the Cholesky factor -C to compute. 0 <= S <= N - P. -C -C T (input/output) DOUBLE PRECISION array, dimension -C (LDT,(NL+1)*K) / (LDT,K) -C On entry, if P = 0, the leading K-by-(NL+1)*K / -C (NL+1)*K-by-K part of this array must contain the first -C block row / column of an s.p.d. block Toeplitz matrix. -C On entry, if P > 0, the leading K-by-(NL+1)*K / -C (NL+1)*K-by-K part of this array must contain the P-th -C block row / column of the Cholesky factor. -C On exit, if INFO = 0, then the leading K-by-(NL+1)*K / -C (NL+1)*K-by-K part of this array contains the (P+S)-th -C block row / column of the Cholesky factor. -C -C LDT INTEGER -C The leading dimension of the array T. -C LDT >= MAX(1,K) / MAX(1,(NL+1)*K). -C -C RB (input/output) DOUBLE PRECISION array, dimension -C (LDRB,MIN(P+NL+S,N)*K) / (LDRB,MIN(P+S,N)*K) -C On entry, if TYPET = 'R' and TRIU = 'N' and P > 0, -C the leading (NL+1)*K-by-MIN(NL,N-P)*K part of this array -C must contain the (P*K+1)-st to ((P+NL)*K)-th columns -C of the upper Cholesky factor in banded format from a -C previous call of this routine. -C On entry, if TYPET = 'R' and TRIU = 'T' and P > 0, -C the leading (NL*K+1)-by-MIN(NL,N-P)*K part of this array -C must contain the (P*K+1)-st to (MIN(P+NL,N)*K)-th columns -C of the upper Cholesky factor in banded format from a -C previous call of this routine. -C On exit, if TYPET = 'R' and TRIU = 'N', the leading -C (NL+1)*K-by-MIN(NL+S,N-P)*K part of this array contains -C the (P*K+1)-st to (MIN(P+NL+S,N)*K)-th columns of the -C upper Cholesky factor in banded format. -C On exit, if TYPET = 'R' and TRIU = 'T', the leading -C (NL*K+1)-by-MIN(NL+S,N-P)*K part of this array contains -C the (P*K+1)-st to (MIN(P+NL+S,N)*K)-th columns of the -C upper Cholesky factor in banded format. -C On exit, if TYPET = 'C' and TRIU = 'N', the leading -C (NL+1)*K-by-MIN(S,N-P)*K part of this array contains -C the (P*K+1)-st to (MIN(P+S,N)*K)-th columns of the lower -C Cholesky factor in banded format. -C On exit, if TYPET = 'C' and TRIU = 'T', the leading -C (NL*K+1)-by-MIN(S,N-P)*K part of this array contains -C the (P*K+1)-st to (MIN(P+S,N)*K)-th columns of the lower -C Cholesky factor in banded format. -C For further details regarding the band storage scheme see -C the documentation of the LAPACK routine DPBTF2. -C -C LDRB INTEGER -C The leading dimension of the array RB. -C If TRIU = 'N', LDRB >= MAX( (NL+1)*K,1 ); -C if TRIU = 'T', LDRB >= NL*K+1. -C -C Workspace -C -C DWORK DOUBLE PRECISION array, dimension (LDWORK) -C On exit, if INFO = 0, DWORK(1) returns the optimal -C value of LDWORK. -C On exit, if INFO = -13, DWORK(1) returns the minimum -C value of LDWORK. -C The first 1 + ( NL + 1 )*K*K elements of DWORK should be -C preserved during successive calls of the routine. -C -C LDWORK INTEGER -C The length of the array DWORK. -C LDWORK >= 1 + ( NL + 1 )*K*K + NL*K. -C For optimum performance LDWORK should be larger. -C -C Error Indicator -C -C INFO INTEGER -C = 0: successful exit; -C < 0: if INFO = -i, the i-th argument had an illegal -C value; -C = 1: the reduction algorithm failed. The Toeplitz matrix -C associated with T is not (numerically) positive -C definite. -C -C METHOD -C -C Householder transformations and modified hyperbolic rotations -C are used in the Schur algorithm [1], [2]. -C -C REFERENCES -C -C [1] Kailath, T. and Sayed, A. -C Fast Reliable Algorithms for Matrices with Structure. -C SIAM Publications, Philadelphia, 1999. -C -C [2] Kressner, D. and Van Dooren, P. -C Factorizations and linear system solvers for matrices with -C Toeplitz structure. -C SLICOT Working Note 2000-2, 2000. -C -C NUMERICAL ASPECTS -C -C The implemented method is numerically stable. -C 3 -C The algorithm requires O( K *N*NL ) floating point operations. -C -C CONTRIBUTOR -C -C D. Kressner, Technical Univ. Berlin, Germany, May 2001. -C -C REVISIONS -C -C V. Sima, Research Institute for Informatics, Bucharest, June 2001, -C Mar. 2004. -C -C KEYWORDS -C -C Elementary matrix operations, Householder transformation, matrix -C operations, Toeplitz matrix. -C -C ****************************************************************** -C -C .. Parameters .. - DOUBLE PRECISION ZERO, ONE - PARAMETER ( ZERO = 0.0D0, ONE = 1.0D0 ) -C .. Scalar Arguments .. - CHARACTER TRIU, TYPET - INTEGER INFO, K, LDRB, LDT, LDWORK, N, NL, P, S -C .. Array Arguments .. - DOUBLE PRECISION DWORK(LDWORK), RB(LDRB,*), T(LDT,*) -C .. Local Scalars .. - CHARACTER STRUCT - LOGICAL ISROW, LTRI - INTEGER HEAD, I, IERR, J, JJ, KK, LEN, LEN2, LENR, NB, - $ NBMIN, PDW, POSR, PRE, RNK, SIZR, STPS, WRKMIN, - $ WRKOPT -C .. Local Arrays .. - INTEGER IPVT(1) - DOUBLE PRECISION DUM(1) -C .. External Functions .. - LOGICAL LSAME - INTEGER ILAENV - EXTERNAL ILAENV, LSAME -C .. External Subroutines .. - EXTERNAL DCOPY, DLACPY, DLASET, DPOTRF, DTRSM, MB02CU, - $ MB02CV, XERBLA -C .. Intrinsic Functions .. - INTRINSIC DBLE, MAX, MIN, MOD -C -C .. Executable Statements .. -C -C Decode the scalar input parameters. -C - INFO = 0 - LTRI = LSAME( TRIU, 'T' ) - LENR = ( NL + 1 )*K - IF ( LTRI ) THEN - SIZR = NL*K + 1 - ELSE - SIZR = LENR - END IF - ISROW = LSAME( TYPET, 'R' ) - WRKMIN = 1 + ( LENR + NL )*K -C -C Check the scalar input parameters. -C - IF ( .NOT.( ISROW .OR. LSAME( TYPET, 'C' ) ) ) THEN - INFO = -1 - ELSE IF ( .NOT.( LTRI .OR. LSAME( TRIU, 'N' ) ) ) THEN - INFO = -2 - ELSE IF ( K.LT.0 ) THEN - INFO = -3 - ELSE IF ( ( LTRI .AND. N.LT.2 ) .OR. - $ ( .NOT.LTRI .AND. N.LT.1 ) ) THEN - INFO = -4 - ELSE IF ( NL.GE.N .OR. ( LTRI .AND. NL.LT.1 ) .OR. - $ ( .NOT.LTRI .AND. NL.LT.0 ) ) THEN - INFO = -5 - ELSE IF ( P.LT.0 .OR. P.GT.N ) THEN - INFO = -6 - ELSE IF ( S.LT.0 .OR. S.GT.N-P ) THEN - INFO = -7 - ELSE IF ( ( ISROW .AND. LDT.LT.MAX( 1, K ) ) .OR. - $ ( .NOT.ISROW .AND. LDT.LT.MAX( 1, LENR ) ) ) - $ THEN - INFO = -9 - ELSE IF ( ( LTRI .AND. LDRB.LT.SIZR ) .OR. - $ ( .NOT.LTRI .AND. LDRB.LT.MAX( 1, LENR ) ) ) - $ THEN - INFO = -11 - ELSE IF ( LDWORK.LT.WRKMIN ) THEN - DWORK(1) = DBLE( WRKMIN ) - INFO = -13 - END IF -C -C Return if there were illegal values. -C - IF ( INFO.NE.0 ) THEN - CALL XERBLA( 'MB02GD', -INFO ) - RETURN - END IF -C -C Quick return if possible. -C - IF ( S*K.EQ.0 ) THEN - DWORK(1) = ONE - RETURN - END IF -C -C Compute the generator if P = 0. -C - IF ( P.EQ.0 ) THEN - IF ( ISROW ) THEN - CALL DPOTRF( 'Upper', K, T, LDT, IERR ) - IF ( IERR.NE.0 ) THEN -C -C Error return: The matrix is not positive definite. -C - INFO = 1 - RETURN - END IF - IF ( NL.GT.0 ) - $ CALL DTRSM( 'Left', 'Upper', 'Transpose', 'NonUnit', K, - $ NL*K, ONE, T, LDT, T(1,K+1), LDT ) -C -C Copy the first block row to RB. -C - IF ( LTRI ) THEN -C - DO 10 I = 1, LENR - K - CALL DCOPY( MIN( I, K ), T(1,I), 1, - $ RB( MAX( SIZR-I+1, 1 ),I ), 1 ) - 10 CONTINUE -C - DO 20 I = K, 1, -1 - CALL DCOPY( I, T(K-I+1,LENR-I+1), 1, - $ RB( 1,LENR-I+1 ), 1 ) - 20 CONTINUE -C - ELSE -C - DO 30 I = 1, LENR - CALL DCOPY( MIN( I, K ), T(1,I), 1, - $ RB( MAX( SIZR-I+1, 1 ),I ), 1 ) - 30 CONTINUE -C - END IF -C -C Quick return if N = 1. -C - IF ( N.EQ.1 ) THEN - DWORK(1) = ONE - RETURN - END IF -C - CALL DLACPY( 'All', K, NL*K, T(1,K+1), LDT, DWORK(2), K ) - CALL DLASET( 'All', K, K, ZERO, ZERO, DWORK(NL*K*K+2), K ) - POSR = K + 1 - ELSE - CALL DPOTRF( 'Lower', K, T, LDT, IERR ) - IF ( IERR.NE.0 ) THEN -C -C Error return: The matrix is not positive definite. -C - INFO = 1 - RETURN - END IF - IF ( NL.GT.0 ) - $ CALL DTRSM( 'Right', 'Lower', 'Transpose', 'NonUnit', - $ NL*K, K, ONE, T, LDT, T(K+1,1), LDT ) -C -C Copy the first block column to RB. -C - POSR = 1 - IF ( LTRI ) THEN -C - DO 40 I = 1, K - CALL DCOPY( SIZR, T(I,I), 1, RB(1,POSR), 1 ) - POSR = POSR + 1 - 40 CONTINUE -C - ELSE -C - DO 50 I = 1, K - CALL DCOPY( LENR-I+1, T(I,I), 1, RB(1,POSR), 1 ) - IF ( LENR.LT.N*K .AND. I.GT.1 ) THEN - CALL DLASET( 'All', I-1, 1, ZERO, ZERO, - $ RB(LENR-I+2,POSR), LDRB ) - END IF - POSR = POSR + 1 - 50 CONTINUE -C - END IF -C -C Quick return if N = 1. -C - IF ( N.EQ.1 ) THEN - DWORK(1) = ONE - RETURN - END IF -C - CALL DLACPY( 'All', NL*K, K, T(K+1,1), LDT, DWORK(2), LENR ) - CALL DLASET( 'All', K, K, ZERO, ZERO, DWORK(NL*K+2), LENR ) - END IF - PRE = 1 - STPS = S - 1 - ELSE - PRE = P - STPS = S - POSR = 1 - END IF -C - PDW = LENR*K + 1 - HEAD = MOD( ( PRE - 1 )*K, LENR ) -C -C Determine block size for the involved block Householder -C transformations. -C - IF ( ISROW ) THEN - NB = MIN( ILAENV( 1, 'DGEQRF', ' ', K, LENR, -1, -1 ), K ) - ELSE - NB = MIN( ILAENV( 1, 'DGELQF', ' ', LENR, K, -1, -1 ), K ) - END IF - KK = PDW + 4*K - WRKOPT = KK + LENR*NB - KK = LDWORK - KK - IF ( KK.LT.LENR*NB ) NB = KK / LENR - IF ( ISROW ) THEN - NBMIN = MAX( 2, ILAENV( 2, 'DGEQRF', ' ', K, LENR, -1, -1 ) ) - ELSE - NBMIN = MAX( 2, ILAENV( 2, 'DGELQF', ' ', LENR, K, -1, -1 ) ) - END IF - IF ( NB.LT.NBMIN ) NB = 0 -C -C Generator reduction process. -C - IF ( ISROW ) THEN -C - DO 90 I = PRE, PRE + STPS - 1 - CALL MB02CU( 'Row', K, K, K, NB, T, LDT, DUM, 1, - $ DWORK(HEAD*K+2), K, RNK, IPVT, DWORK(PDW+1), - $ ZERO, DWORK(PDW+4*K+1), LDWORK-PDW-4*K, IERR ) -C - IF ( IERR.NE.0 ) THEN -C -C Error return: The positive definiteness is (numerically) -C not satisfied. -C - INFO = 1 - RETURN - END IF -C - LEN = MAX( MIN( ( N - I )*K - K, LENR - HEAD - K ), 0 ) - LEN2 = MAX( MIN( ( N - I )*K - LEN - K, HEAD ), 0 ) - IF ( LEN.EQ.( LENR-K ) ) THEN - STRUCT = TRIU - ELSE - STRUCT = 'N' - END IF - CALL MB02CV( 'Row', STRUCT, K, LEN, K, K, NB, -1, DUM, 1, - $ DUM, 1, DWORK(HEAD*K+2), K, T(1,K+1), LDT, - $ DUM, 1, DWORK((HEAD+K)*K+2), K, DWORK(PDW+1), - $ DWORK(PDW+4*K+1), LDWORK-PDW-4*K, IERR ) -C - IF ( ( N - I )*K.GE.LENR ) THEN - STRUCT = TRIU - ELSE - STRUCT = 'N' - END IF - CALL MB02CV( 'Row', STRUCT, K, LEN2, K, K, NB, -1, DUM, 1, - $ DUM, 1, DWORK(HEAD*K+2), K, T(1,K+LEN+1), LDT, - $ DUM, 1, DWORK(2), K, DWORK(PDW+1), - $ DWORK(PDW+4*K+1), LDWORK-PDW-4*K, IERR ) -C - CALL DLASET( 'All', K, K, ZERO, ZERO, DWORK(HEAD*K+2), K ) -C -C Copy current block row to RB. -C - IF ( LTRI ) THEN -C - DO 60 J = 1, MIN( LEN + LEN2 + K, LENR - K ) - CALL DCOPY( MIN( J, K ), T(1,J), 1, - $ RB(MAX( SIZR-J+1, 1 ),POSR+J-1 ), 1 ) - 60 CONTINUE -C - IF ( LEN+LEN2+K.GE.LENR ) THEN -C - DO 70 JJ = K, 1, -1 - CALL DCOPY( JJ, T(K-JJ+1,LENR-JJ+1), 1, - $ RB(1,POSR+LENR-JJ), 1 ) - 70 CONTINUE -C - END IF - POSR = POSR + K -C - ELSE -C - DO 80 J = 1, LEN + LEN2 + K - CALL DCOPY( MIN( J, K ), T(1,J), 1, - $ RB(MAX( SIZR-J+1, 1 ),POSR+J-1), 1 ) - IF ( J.GT.LENR-K ) THEN - CALL DLASET( 'All', SIZR-J, 1, ZERO, ZERO, - $ RB(1,POSR+J-1), 1 ) - END IF - 80 CONTINUE -C - POSR = POSR + K - END IF - HEAD = MOD( HEAD + K, LENR ) - 90 CONTINUE -C - ELSE -C - DO 120 I = PRE, PRE + STPS - 1 -C - CALL MB02CU( 'Column', K, K, K, NB, T, LDT, DUM, 1, - $ DWORK(HEAD+2), LENR, RNK, IPVT, DWORK(PDW+1), - $ ZERO, DWORK(PDW+4*K+1), LDWORK-PDW-4*K, IERR ) -C - IF ( IERR.NE.0 ) THEN -C -C Error return: The positive definiteness is (numerically) -C not satisfied. -C - INFO = 1 - RETURN - END IF -C - LEN = MAX( MIN( ( N - I )*K - K, LENR - HEAD - K ), 0 ) - LEN2 = MAX( MIN( ( N - I )*K - LEN - K, HEAD ), 0 ) - IF ( LEN.EQ.( LENR-K ) ) THEN - STRUCT = TRIU - ELSE - STRUCT = 'N' - END IF - CALL MB02CV( 'Column', STRUCT, K, LEN, K, K, NB, -1, DUM, - $ 1, DUM, 1, DWORK(HEAD+2), LENR, T(K+1,1), LDT, - $ DUM, 1, DWORK(HEAD+K+2), LENR, DWORK(PDW+1), - $ DWORK(PDW+4*K+1), LDWORK-PDW-4*K, IERR ) -C - IF ( ( N - I )*K.GE.LENR ) THEN - STRUCT = TRIU - ELSE - STRUCT = 'N' - END IF - CALL MB02CV( 'Column', STRUCT, K, LEN2, K, K, NB, -1, DUM, - $ 1, DUM, 1, DWORK(HEAD+2), LENR, T(K+LEN+1,1), - $ LDT, DUM, 1, DWORK(2), LENR, DWORK(PDW+1), - $ DWORK(PDW+4*K+1), LDWORK-PDW-4*K, IERR ) -C - CALL DLASET( 'All', K, K, ZERO, ZERO, DWORK(HEAD+2), LENR ) -C -C Copy current block column to RB. -C - IF ( LTRI ) THEN -C - DO 100 J = 1, K - CALL DCOPY( MIN( SIZR, (N-I)*K-J+1 ), T(J,J), 1, - $ RB(1,POSR), 1 ) - POSR = POSR + 1 - 100 CONTINUE -C - ELSE -C - DO 110 J = 1, K - CALL DCOPY( MIN( SIZR-J+1, (N-I)*K-J+1 ), T(J,J), 1, - $ RB(1,POSR), 1 ) - IF ( LENR.LT.(N-I)*K ) THEN - CALL DLASET( 'All', J-1, 1, ZERO, ZERO, - $ RB(MIN( SIZR-J+1, (N-I)*K-J+1 ) + 1, - $ POSR), LDRB ) - END IF - POSR = POSR + 1 - 110 CONTINUE -C - END IF - HEAD = MOD( HEAD + K, LENR ) - 120 CONTINUE -C - END IF - DWORK(1) = DBLE( WRKOPT ) - RETURN -C -C *** Last line of MB02GD *** - END diff --git a/mex/sources/libslicot/MB02HD.f b/mex/sources/libslicot/MB02HD.f deleted file mode 100644 index c93d2474a..000000000 --- a/mex/sources/libslicot/MB02HD.f +++ /dev/null @@ -1,545 +0,0 @@ - SUBROUTINE MB02HD( TRIU, K, L, M, ML, N, NU, P, S, TC, LDTC, TR, - $ LDTR, RB, LDRB, DWORK, LDWORK, INFO ) -C -C SLICOT RELEASE 5.0. -C -C Copyright (c) 2002-2009 NICONET e.V. -C -C This program is free software: you can redistribute it and/or -C modify it under the terms of the GNU General Public License as -C published by the Free Software Foundation, either version 2 of -C the License, or (at your option) any later version. -C -C This program is distributed in the hope that it will be useful, -C but WITHOUT ANY WARRANTY; without even the implied warranty of -C MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the -C GNU General Public License for more details. -C -C You should have received a copy of the GNU General Public License -C along with this program. If not, see -C . -C -C PURPOSE -C -C To compute, for a banded K*M-by-L*N block Toeplitz matrix T with -C block size (K,L), specified by the nonzero blocks of its first -C block column TC and row TR, a LOWER triangular matrix R (in band -C storage scheme) such that -C T T -C T T = R R . (1) -C -C It is assumed that the first MIN(M*K, N*L) columns of T are -C linearly independent. -C -C By subsequent calls of this routine, the matrix R can be computed -C block column by block column. -C -C ARGUMENTS -C -C Mode Parameters -C -C TRIU CHARACTER*1 -C Specifies the structure, if any, of the last blocks in TC -C and TR, as follows: -C = 'N': TC and TR have no special structure; -C = 'T': TC and TR are upper and lower triangular, -C respectively. Depending on the block sizes, two -C different shapes of the last blocks in TC and TR -C are possible, as illustrated below: -C -C 1) TC TR 2) TC TR -C -C x x x x 0 0 x x x x x 0 0 0 -C 0 x x x x 0 0 x x x x x 0 0 -C 0 0 x x x x 0 0 x x x x x 0 -C 0 0 0 x x x -C -C Input/Output Parameters -C -C K (input) INTEGER -C The number of rows in the blocks of T. K >= 0. -C -C L (input) INTEGER -C The number of columns in the blocks of T. L >= 0. -C -C M (input) INTEGER -C The number of blocks in the first block column of T. -C M >= 1. -C -C ML (input) INTEGER -C The lower block bandwidth, i.e., ML + 1 is the number of -C nonzero blocks in the first block column of T. -C 0 <= ML < M and (ML + 1)*K >= L and -C if ( M*K <= N*L ), ML >= M - INT( ( M*K - 1 )/L ) - 1; -C ML >= M - INT( M*K/L ) or -C MOD( M*K, L ) >= K; -C if ( M*K >= N*L ), ML*K >= N*( L - K ). -C -C N (input) INTEGER -C The number of blocks in the first block row of T. -C N >= 1. -C -C NU (input) INTEGER -C The upper block bandwidth, i.e., NU + 1 is the number of -C nonzero blocks in the first block row of T. -C If TRIU = 'N', 0 <= NU < N and -C (M + NU)*L >= MIN( M*K, N*L ); -C if TRIU = 'T', MAX(1-ML,0) <= NU < N and -C (M + NU)*L >= MIN( M*K, N*L ). -C -C P (input) INTEGER -C The number of previously computed block columns of R. -C P*L < MIN( M*K,N*L ) + L and P >= 0. -C -C S (input) INTEGER -C The number of block columns of R to compute. -C (P+S)*L < MIN( M*K,N*L ) + L and S >= 0. -C -C TC (input) DOUBLE PRECISION array, dimension (LDTC,L) -C On entry, if P = 0, the leading (ML+1)*K-by-L part of this -C array must contain the nonzero blocks in the first block -C column of T. -C -C LDTC INTEGER -C The leading dimension of the array TC. -C LDTC >= MAX(1,(ML+1)*K), if P = 0. -C -C TR (input) DOUBLE PRECISION array, dimension (LDTR,NU*L) -C On entry, if P = 0, the leading K-by-NU*L part of this -C array must contain the 2nd to the (NU+1)-st blocks of -C the first block row of T. -C -C LDTR INTEGER -C The leading dimension of the array TR. -C LDTR >= MAX(1,K), if P = 0. -C -C RB (output) DOUBLE PRECISION array, dimension -C (LDRB,MIN( S*L,MIN( M*K,N*L )-P*L )) -C On exit, if INFO = 0 and TRIU = 'N', the leading -C MIN( ML+NU+1,N )*L-by-MIN( S*L,MIN( M*K,N*L )-P*L ) part -C of this array contains the (P+1)-th to (P+S)-th block -C column of the lower R factor (1) in band storage format. -C On exit, if INFO = 0 and TRIU = 'T', the leading -C MIN( (ML+NU)*L+1,N*L )-by-MIN( S*L,MIN( M*K,N*L )-P*L ) -C part of this array contains the (P+1)-th to (P+S)-th block -C column of the lower R factor (1) in band storage format. -C For further details regarding the band storage scheme see -C the documentation of the LAPACK routine DPBTF2. -C -C LDRB INTEGER -C The leading dimension of the array RB. -C LDRB >= MAX( MIN( ML+NU+1,N )*L,1 ), if TRIU = 'N'; -C LDRB >= MAX( MIN( (ML+NU)*L+1,N*L ),1 ), if TRIU = 'T'. -C -C Workspace -C -C DWORK DOUBLE PRECISION array, dimension (LDWORK) -C On exit, if INFO = 0, DWORK(1) returns the optimal -C value of LDWORK. -C On exit, if INFO = -17, DWORK(1) returns the minimum -C value of LDWORK. -C The first 1 + 2*MIN( ML+NU+1,N )*L*(K+L) elements of DWORK -C should be preserved during successive calls of the routine. -C -C LDWORK INTEGER -C The length of the array DWORK. -C Let x = MIN( ML+NU+1,N ), then -C LDWORK >= 1 + MAX( x*L*L + (2*NU+1)*L*K, -C 2*x*L*(K+L) + (6+x)*L ), if P = 0; -C LDWORK >= 1 + 2*x*L*(K+L) + (6+x)*L, if P > 0. -C For optimum performance LDWORK should be larger. -C -C Error Indicator -C -C INFO INTEGER -C = 0: successful exit; -C < 0: if INFO = -i, the i-th argument had an illegal -C value; -C = 1: the full rank condition for the first MIN(M*K, N*L) -C columns of T is (numerically) violated. -C -C METHOD -C -C Householder transformations and modified hyperbolic rotations -C are used in the Schur algorithm [1], [2]. -C -C REFERENCES -C -C [1] Kailath, T. and Sayed, A. -C Fast Reliable Algorithms for Matrices with Structure. -C SIAM Publications, Philadelphia, 1999. -C -C [2] Kressner, D. and Van Dooren, P. -C Factorizations and linear system solvers for matrices with -C Toeplitz structure. -C SLICOT Working Note 2000-2, 2000. -C -C NUMERICAL ASPECTS -C -C The implemented method yields a factor R which has comparable -C accuracy with the Cholesky factor of T^T * T. -C The algorithm requires -C 2 2 -C O( L *K*N*( ML + NU ) + N*( ML + NU )*L *( L + K ) ) -C -C floating point operations. -C -C CONTRIBUTOR -C -C D. Kressner, Technical Univ. Berlin, Germany, May 2001. -C -C REVISIONS -C -C V. Sima, Research Institute for Informatics, Bucharest, June 2001. -C D. Kressner, Technical Univ. Berlin, Germany, July 2002. -C V. Sima, Research Institute for Informatics, Bucharest, Mar. 2004. -C -C KEYWORDS -C -C Elementary matrix operations, Householder transformation, matrix -C operations, Toeplitz matrix. -C -C ****************************************************************** -C -C .. Parameters .. - DOUBLE PRECISION ZERO, ONE - PARAMETER ( ZERO = 0.0D0, ONE = 1.0D0 ) -C .. Scalar Arguments .. - CHARACTER TRIU - INTEGER INFO, K, L, LDRB, LDTC, LDTR, LDWORK, M, ML, N, - $ NU, P, S -C .. Array Arguments .. - DOUBLE PRECISION DWORK(LDWORK), RB(LDRB,*), TC(LDTC,*), - $ TR(LDTR,*) -C .. Local Scalars .. - CHARACTER STRUCT - INTEGER COL2, HEAD, I, IERR, J, KK, LEN, LEN2, LENC, - $ LENL, LENR, NB, NBMIN, PDC, PDR, PDW, PFR, PNR, - $ POSR, PRE, PT, RNK, SIZR, STPS, WRKMIN, WRKOPT, - $ X - LOGICAL LTRI -C .. Local Arrays .. - INTEGER IPVT(1) -C .. External Functions .. - LOGICAL LSAME - INTEGER ILAENV - EXTERNAL ILAENV, LSAME -C .. External Subroutines .. - EXTERNAL DCOPY, DGEMM, DGEQRF, DLACPY, DLASET, DORGQR, - $ MA02AD, MB02CU, MB02CV, XERBLA -C .. Intrinsic Functions .. - INTRINSIC DBLE, INT, MAX, MIN, MOD -C -C .. Executable Statements .. -C -C Decode the scalar input parameters. -C - INFO = 0 - LTRI = LSAME( TRIU, 'T' ) - X = MIN( ML + NU + 1, N ) - LENR = X*L - IF ( LTRI ) THEN - SIZR = MIN( ( ML + NU )*L + 1, N*L ) - ELSE - SIZR = LENR - END IF - IF ( P.EQ.0 ) THEN - WRKMIN = 1 + MAX( LENR*L + ( 2*NU + 1 )*L*K, - $ 2*LENR*( K + L ) + ( 6 + X )*L ) - ELSE - WRKMIN = 1 + 2*LENR*( K + L ) + ( 6 + X )*L - END IF - POSR = 1 -C -C Check the scalar input parameters. -C - IF ( .NOT.( LTRI .OR. LSAME( TRIU, 'N' ) ) ) THEN - INFO = -1 - ELSE IF ( K.LT.0 ) THEN - INFO = -2 - ELSE IF ( L.LT.0 ) THEN - INFO = -3 - ELSE IF ( M.LT.1 ) THEN - INFO = -4 - ELSE IF ( ML.GE.M .OR. ( ML + 1 )*K.LT.L .OR. ( M*K.LE.N*L .AND. - $ ( ( ML.LT.M - INT( ( M*K - 1 )/L ) - 1 ) .OR. - $ ( ML.LT.M - INT( M*K/L ).AND.MOD( M*K, L ).LT.K ) ) ) - $ .OR. ( M*K.GE.N*L .AND. ML*K.LT.N*( L - K ) ) ) THEN - INFO = -5 - ELSE IF ( N.LT.1 ) THEN - INFO = -6 - ELSE IF ( NU.GE.N .OR. NU.LT.0 .OR. ( LTRI .AND. NU.LT.1-ML ) .OR. - $ (M + NU)*L.LT.MIN( M*K, N*L ) ) THEN - INFO = -7 - ELSE IF ( P.LT.0 .OR. ( P*L - L ).GE.MIN( M*K, N*L ) ) THEN - INFO = -8 - ELSE IF ( S.LT.0 .OR. ( P + S - 1 )*L.GE.MIN( M*K, N*L ) ) THEN - INFO = -9 - ELSE IF ( P.EQ.0 .AND. LDTC.LT.MAX( 1, ( ML + 1 )*K ) ) THEN - INFO = -11 - ELSE IF ( P.EQ.0 .AND. LDTR.LT.MAX( 1, K ) ) THEN - INFO = -13 - ELSE IF ( LDRB.LT.MAX( SIZR, 1 ) ) THEN - INFO = 15 - ELSE IF ( LDWORK.LT.WRKMIN ) THEN - DWORK(1) = DBLE( WRKMIN ) - INFO = -17 - END IF -C -C Return if there were illegal values. -C - IF ( INFO.NE.0 ) THEN - CALL XERBLA( 'MB02HD', -INFO ) - RETURN - END IF -C -C Quick return if possible. -C - IF ( L*K*S.EQ.0 ) THEN - DWORK(1) = ONE - RETURN - END IF -C - WRKOPT = 1 -C -C Compute the generator if P = 0. -C - IF ( P.EQ.0 ) THEN -C -C 1st column of the generator. -C - LENC = ( ML + 1 )*K - LENL = MAX( ML + 1 + MIN( NU, N - M ), 0 ) - PDC = LENR*L + 1 - PDW = PDC + LENC*L -C -C QR decomposition of the nonzero blocks in TC. -C - CALL DLACPY( 'All', LENC, L, TC, LDTC, DWORK(PDC+1), LENC ) - CALL DGEQRF( LENC, L, DWORK(PDC+1), LENC, DWORK(PDW+1), - $ DWORK(PDW+L+1), LDWORK-PDW-L, IERR ) - WRKOPT = MAX( WRKOPT, INT( DWORK(PDW+L+1) ) + PDW + L ) -C -C The R factor is the transposed of the first block in the -C generator. -C - CALL MA02AD( 'Upper part', L, L, DWORK(PDC+1), LENC, DWORK(2), - $ LENR ) -C -C Get the first block column of the Q factor. -C - CALL DORGQR( LENC, L, L, DWORK(PDC+1), LENC, DWORK(PDW+1), - $ DWORK(PDW+L+1), LDWORK-PDW-L, IERR ) - WRKOPT = MAX( WRKOPT, INT( DWORK(PDW+L+1) ) + PDW + L ) -C -C Construct a flipped copy of TC for faster multiplication. -C - PT = LENC - 2*K + 1 -C - DO 10 I = PDW + 1, PDW + ML*K*L, K*L - CALL DLACPY( 'All', K, L, TC(PT,1), LDTC, DWORK(I), K ) - PT = PT - K - 10 CONTINUE -C -C Multiply T^T with the first block column of Q. -C - PDW = I - PDR = L + 2 - LEN = NU*L - CALL DLASET( 'All', LENR-L, L, ZERO, ZERO, DWORK(PDR), LENR ) -C - DO 20 I = 1, ML + 1 - CALL DGEMM( 'Transpose', 'NonTranspose', MIN( I-1, N-1 )*L, - $ L, K, ONE, DWORK(PDW), K, DWORK(PDC+1), LENC, - $ ONE, DWORK(PDR), LENR ) - IF ( LEN.GT.0 ) THEN - CALL DGEMM( 'Transpose', 'NonTranspose', LEN, L, K, ONE, - $ TR, LDTR, DWORK(PDC+1), LENC, ONE, - $ DWORK(PDR+(I-1)*L), LENR ) - END IF - PDW = PDW - K*L - PDC = PDC + K - IF ( I.GE.N-NU ) LEN = LEN - L - 20 CONTINUE -C -C Copy the first block column to R. -C - IF ( LTRI ) THEN -C - DO 30 I = 1, L - CALL DCOPY( MIN( SIZR, N*L - I + 1 ), - $ DWORK(( I - 1 )*LENR + I + 1), 1, RB(1,POSR), - $ 1 ) - POSR = POSR + 1 - 30 CONTINUE -C - ELSE -C - DO 40 I = 1, L - CALL DCOPY( LENR-I+1, DWORK(( I - 1 )*LENR + I + 1), 1, - $ RB(1,POSR), 1 ) - IF ( LENR.LT.N*L .AND. I.GT.1 ) THEN - CALL DLASET( 'All', I-1, 1, ZERO, ZERO, - $ RB(LENR-I+2,POSR), LDRB ) - END IF - POSR = POSR + 1 - 40 CONTINUE -C - END IF -C -C Quick return if N = 1. -C - IF ( N.EQ.1 ) THEN - DWORK(1) = DBLE( WRKOPT ) - RETURN - END IF -C -C 2nd column of the generator. -C - PDR = LENR*L + 1 - CALL MA02AD( 'All', K, NU*L, TR, LDTR, DWORK(PDR+1), LENR ) - CALL DLASET( 'All', LENR-NU*L, K, ZERO, ZERO, - $ DWORK(PDR+NU*L+1), LENR ) -C -C 3rd column of the generator. -C - PNR = PDR + LENR*K - CALL DLACPY( 'All', LENR-L, L, DWORK(L+2), LENR, DWORK(PNR+1), - $ LENR ) - CALL DLASET( 'All', L, L, ZERO, ZERO, DWORK(PNR+LENR-L+1), - $ LENR ) -C -C 4th column of the generator. -C - PFR = PNR + LENR*L -C - PDW = PFR + MOD( ( M - ML - 1 )*L, LENR ) - PT = ML*K + 1 - DO 50 I = 1, MIN( ML + 1, LENL ) - CALL MA02AD( 'All', K, L, TC(PT,1), LDTC, DWORK(PDW+1), - $ LENR ) - PT = PT - K - PDW = PFR + MOD( PDW + L - PFR, LENR ) - 50 CONTINUE - PT = 1 - DO 60 I = ML + 2, LENL - CALL MA02AD( 'All', K, L, TR(1,PT), LDTR, DWORK(PDW+1), - $ LENR ) - PT = PT + L - PDW = PFR + MOD( PDW + L - PFR, LENR ) - 60 CONTINUE - PRE = 1 - STPS = S - 1 - ELSE - PDR = LENR*L + 1 - PNR = PDR + LENR*K - PFR = PNR + LENR*L - PRE = P - STPS = S - END IF -C - PDW = PFR + LENR*K - HEAD = MOD( ( PRE - 1 )*L, LENR ) -C -C Determine block size for the involved block Householder -C transformations. -C - NB = MIN( ILAENV( 1, 'DGELQF', ' ', LENR, L, -1, -1 ), L ) - KK = PDW + 6*L - WRKOPT = MAX( WRKOPT, KK + LENR*NB ) - KK = LDWORK - KK - IF ( KK.LT.LENR*NB ) NB = KK / LENR - NBMIN = MAX( 2, ILAENV( 2, 'DGELQF', ' ', LENR, L, -1, -1 ) ) - IF ( NB.LT.NBMIN ) NB = 0 -C -C Generator reduction process. -C - DO 90 I = PRE, PRE + STPS - 1 -C -C The 4th generator column is not used in the first (M-ML) steps. -C - IF ( I.LT.M-ML ) THEN - COL2 = L - ELSE - COL2 = K + L - END IF -C - KK = MIN( L, M*K - I*L ) - CALL MB02CU( 'Column', KK, KK+K, COL2, NB, DWORK(2), LENR, - $ DWORK(PDR+HEAD+1), LENR, DWORK(PNR+HEAD+1), LENR, - $ RNK, IPVT, DWORK(PDW+1), ZERO, DWORK(PDW+6*L+1), - $ LDWORK-PDW-6*L, IERR ) - IF ( IERR.NE.0 ) THEN -C -C Error return: The rank condition is (numerically) not -C satisfied. -C - INFO = 1 - RETURN - END IF -C - LEN = MAX( MIN( ( N - I )*L - KK, LENR - HEAD - KK ), 0 ) - LEN2 = MAX( MIN( ( N - I )*L - LEN - KK, HEAD ), 0 ) - IF ( LEN.EQ.( LENR - KK ) ) THEN - STRUCT = TRIU - ELSE - STRUCT = 'N' - END IF - CALL MB02CV( 'Column', STRUCT, KK, LEN, KK+K, COL2, NB, -1, - $ DWORK(2), LENR, DWORK(PDR+HEAD+1), LENR, - $ DWORK(PNR+HEAD+1), LENR, DWORK(KK+2), LENR, - $ DWORK(PDR+HEAD+KK+1), LENR, DWORK(PNR+HEAD+KK+1), - $ LENR, DWORK(PDW+1), DWORK(PDW+6*L+1), - $ LDWORK-PDW-6*L, IERR ) -C - IF ( ( N - I )*L.GE.LENR ) THEN - STRUCT = TRIU - ELSE - STRUCT = 'N' - END IF -C - CALL MB02CV( 'Column', STRUCT, KK, LEN2, KK+K, COL2, NB, -1, - $ DWORK(2), LENR, DWORK(PDR+HEAD+1), LENR, - $ DWORK(PNR+HEAD+1), LENR, DWORK(KK+LEN+2), LENR, - $ DWORK(PDR+1), LENR, DWORK(PNR+1), LENR, - $ DWORK(PDW+1), DWORK(PDW+6*L+1), - $ LDWORK-PDW-6*L, IERR ) -C - CALL DLASET( 'All', L, K+COL2, ZERO, ZERO, DWORK(PDR+HEAD+1), - $ LENR ) -C -C Copy current block column to R. -C - IF ( LTRI ) THEN -C - DO 70 J = 1, KK - CALL DCOPY( MIN( SIZR, (N-I)*L-J+1 ), - $ DWORK(( J - 1 )*LENR + J + 1), 1, - $ RB(1,POSR), 1 ) - POSR = POSR + 1 - 70 CONTINUE -C - ELSE -C - DO 80 J = 1, KK - CALL DCOPY( MIN( SIZR-J+1, (N-I)*L-J+1 ), - $ DWORK(( J - 1 )*LENR + J + 1), 1, - $ RB(1,POSR), 1 ) - IF ( LENR.LT.( N - I )*L .AND. J.GT.1 ) THEN - CALL DLASET( 'All', J-1, 1, ZERO, ZERO, - $ RB(MIN( SIZR-J+1, (N-I)*L-J+1 )+1,POSR), - $ LDRB ) - END IF - POSR = POSR + 1 - 80 CONTINUE -C - END IF -C - HEAD = MOD( HEAD + L, LENR ) - 90 CONTINUE -C - DWORK(1) = DBLE( WRKOPT ) - RETURN -C -C *** Last line of MB02HD *** - END diff --git a/mex/sources/libslicot/MB02ID.f b/mex/sources/libslicot/MB02ID.f deleted file mode 100644 index a0e5e659b..000000000 --- a/mex/sources/libslicot/MB02ID.f +++ /dev/null @@ -1,508 +0,0 @@ - SUBROUTINE MB02ID( JOB, K, L, M, N, RB, RC, TC, LDTC, TR, LDTR, B, - $ LDB, C, LDC, DWORK, LDWORK, INFO ) -C -C SLICOT RELEASE 5.0. -C -C Copyright (c) 2002-2009 NICONET e.V. -C -C This program is free software: you can redistribute it and/or -C modify it under the terms of the GNU General Public License as -C published by the Free Software Foundation, either version 2 of -C the License, or (at your option) any later version. -C -C This program is distributed in the hope that it will be useful, -C but WITHOUT ANY WARRANTY; without even the implied warranty of -C MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the -C GNU General Public License for more details. -C -C You should have received a copy of the GNU General Public License -C along with this program. If not, see -C . -C -C PURPOSE -C -C To solve the overdetermined or underdetermined real linear systems -C involving an M*K-by-N*L block Toeplitz matrix T that is specified -C by its first block column and row. It is assumed that T has full -C rank. -C The following options are provided: -C -C 1. If JOB = 'O' or JOB = 'A' : find the least squares solution of -C an overdetermined system, i.e., solve the least squares problem -C -C minimize || B - T*X ||. (1) -C -C 2. If JOB = 'U' or JOB = 'A' : find the minimum norm solution of -C the undetermined system -C T -C T * X = C. (2) -C -C ARGUMENTS -C -C Mode Parameters -C -C JOB CHARACTER*1 -C Specifies the problem to be solved as follows -C = 'O': solve the overdetermined system (1); -C = 'U': solve the underdetermined system (2); -C = 'A': solve (1) and (2). -C -C Input/Output Parameters -C -C K (input) INTEGER -C The number of rows in the blocks of T. K >= 0. -C -C L (input) INTEGER -C The number of columns in the blocks of T. L >= 0. -C -C M (input) INTEGER -C The number of blocks in the first block column of T. -C M >= 0. -C -C N (input) INTEGER -C The number of blocks in the first block row of T. -C 0 <= N <= M*K / L. -C -C RB (input) INTEGER -C If JOB = 'O' or 'A', the number of columns in B. RB >= 0. -C -C RC (input) INTEGER -C If JOB = 'U' or 'A', the number of columns in C. RC >= 0. -C -C TC (input) DOUBLE PRECISION array, dimension (LDTC,L) -C On entry, the leading M*K-by-L part of this array must -C contain the first block column of T. -C -C LDTC INTEGER -C The leading dimension of the array TC. LDTC >= MAX(1,M*K) -C -C TR (input) DOUBLE PRECISION array, dimension (LDTR,(N-1)*L) -C On entry, the leading K-by-(N-1)*L part of this array must -C contain the 2nd to the N-th blocks of the first block row -C of T. -C -C LDTR INTEGER -C The leading dimension of the array TR. LDTR >= MAX(1,K). -C -C B (input/output) DOUBLE PRECISION array, dimension (LDB,RB) -C On entry, if JOB = 'O' or JOB = 'A', the leading M*K-by-RB -C part of this array must contain the right hand side -C matrix B of the overdetermined system (1). -C On exit, if JOB = 'O' or JOB = 'A', the leading N*L-by-RB -C part of this array contains the solution of the -C overdetermined system (1). -C This array is not referenced if JOB = 'U'. -C -C LDB INTEGER -C The leading dimension of the array B. -C LDB >= MAX(1,M*K), if JOB = 'O' or JOB = 'A'; -C LDB >= 1, if JOB = 'U'. -C -C C (input) DOUBLE PRECISION array, dimension (LDC,RC) -C On entry, if JOB = 'U' or JOB = 'A', the leading N*L-by-RC -C part of this array must contain the right hand side -C matrix C of the underdetermined system (2). -C On exit, if JOB = 'U' or JOB = 'A', the leading M*K-by-RC -C part of this array contains the solution of the -C underdetermined system (2). -C This array is not referenced if JOB = 'O'. -C -C LDC INTEGER -C The leading dimension of the array C. -C LDB >= 1, if JOB = 'O'; -C LDB >= MAX(1,M*K), if JOB = 'U' or JOB = 'A'. -C -C Workspace -C -C DWORK DOUBLE PRECISION array, dimension (LDWORK) -C On exit, if INFO = 0, DWORK(1) returns the optimal -C value of LDWORK. -C On exit, if INFO = -17, DWORK(1) returns the minimum -C value of LDWORK. -C -C LDWORK INTEGER -C The length of the array DWORK. -C Let x = MAX( 2*N*L*(L+K) + (6+N)*L,(N*L+M*K+1)*L + M*K ) -C and y = N*M*K*L + N*L, then -C if MIN( M,N ) = 1 and JOB = 'O', -C LDWORK >= MAX( y + MAX( M*K,RB ),1 ); -C if MIN( M,N ) = 1 and JOB = 'U', -C LDWORK >= MAX( y + MAX( M*K,RC ),1 ); -C if MIN( M,N ) = 1 and JOB = 'A', -C LDWORK >= MAX( y +MAX( M*K,MAX( RB,RC ),1 ); -C if MIN( M,N ) > 1 and JOB = 'O', -C LDWORK >= MAX( x,N*L*RB + 1 ); -C if MIN( M,N ) > 1 and JOB = 'U', -C LDWORK >= MAX( x,N*L*RC + 1 ); -C if MIN( M,N ) > 1 and JOB = 'A', -C LDWORK >= MAX( x,N*L*MAX( RB,RC ) + 1 ). -C For optimum performance LDWORK should be larger. -C -C Error Indicator -C -C INFO INTEGER -C = 0: successful exit; -C < 0: if INFO = -i, the i-th argument had an illegal -C value; -C = 1: the reduction algorithm failed. The Toeplitz matrix -C associated with T is (numerically) not of full rank. -C -C METHOD -C -C Householder transformations and modified hyperbolic rotations -C are used in the Schur algorithm [1], [2]. -C -C REFERENCES -C -C [1] Kailath, T. and Sayed, A. -C Fast Reliable Algorithms for Matrices with Structure. -C SIAM Publications, Philadelphia, 1999. -C -C [2] Kressner, D. and Van Dooren, P. -C Factorizations and linear system solvers for matrices with -C Toeplitz structure. -C SLICOT Working Note 2000-2, 2000. -C -C NUMERICAL ASPECTS -C -C The algorithm requires O( L*L*K*(N+M)*log(N+M) + N*N*L*L*(L+K) ) -C and additionally -C -C if JOB = 'O' or JOB = 'A', -C O( (K*L+RB*L+K*RB)*(N+M)*log(N+M) + N*N*L*L*RB ); -C if JOB = 'U' or JOB = 'A', -C O( (K*L+RC*L+K*RC)*(N+M)*log(N+M) + N*N*L*L*RC ); -C -C floating point operations. -C -C CONTRIBUTOR -C -C D. Kressner, Technical Univ. Berlin, Germany, May 2001. -C -C REVISIONS -C -C V. Sima, Research Institute for Informatics, Bucharest, June 2001. -C D. Kressner, Technical Univ. Berlin, Germany, July 2002. -C V. Sima, Research Institute for Informatics, Bucharest, Mar. 2004. -C -C KEYWORDS -C -C Elementary matrix operations, Householder transformation, matrix -C operations, Toeplitz matrix. -C -C ****************************************************************** -C -C .. Parameters .. - DOUBLE PRECISION ZERO, ONE - PARAMETER ( ZERO = 0.0D0, ONE = 1.0D0 ) -C .. Scalar Arguments .. - CHARACTER JOB - INTEGER INFO, K, L, LDB, LDC, LDTC, LDTR, LDWORK, M, N, - $ RB, RC -C .. Array Arguments .. - DOUBLE PRECISION B(LDB,*), C(LDC,*), DWORK(LDWORK), TC(LDTC,*), - $ TR(LDTR,*) -C .. Local Scalars .. - INTEGER I, IERR, KK, LEN, NB, NBMIN, PDI, PDW, PNI, PNR, - $ PPI, PPR, PT, RNK, WRKMIN, WRKOPT, X, Y - LOGICAL COMPO, COMPU -C .. Local Arrays .. - INTEGER IPVT(1) -C .. External Functions .. - LOGICAL LSAME - INTEGER ILAENV - EXTERNAL ILAENV, LSAME -C .. External Subroutines .. - EXTERNAL DGELS, DGEMM, DGEQRF, DLACPY, DLASET, DORGQR, - $ DTRMM, DTRSM, DTRTRI, MA02AD, MB02CU, MB02CV, - $ MB02KD, XERBLA -C .. Intrinsic Functions .. - INTRINSIC DBLE, INT, MAX, MIN -C -C .. Executable Statements .. -C -C Decode the scalar input parameters. -C - INFO = 0 - COMPO = LSAME( JOB, 'O' ) .OR. LSAME( JOB, 'A' ) - COMPU = LSAME( JOB, 'U' ) .OR. LSAME( JOB, 'A' ) - X = MAX( 2*N*L*( L + K ) + ( 6 + N )*L, - $ ( N*L + M*K + 1 )*L + M*K ) - Y = N*M*K*L + N*L - IF ( MIN( M, N ).EQ.1 ) THEN - WRKMIN = MAX( M*K, 1 ) - IF ( COMPO ) WRKMIN = MAX( WRKMIN, RB ) - IF ( COMPU ) WRKMIN = MAX( WRKMIN, RC ) - WRKMIN = MAX( Y + WRKMIN, 1 ) - ELSE - WRKMIN = X - IF ( COMPO ) WRKMIN = MAX( WRKMIN, N*L*RB + 1 ) - IF ( COMPU ) WRKMIN = MAX( WRKMIN, N*L*RC + 1 ) - END IF - WRKOPT = 1 -C -C Check the scalar input parameters. -C - IF ( .NOT.( COMPO .OR. COMPU ) ) THEN - INFO = -1 - ELSE IF ( K.LT.0 ) THEN - INFO = -2 - ELSE IF ( L.LT.0 ) THEN - INFO = -3 - ELSE IF ( M.LT.0 ) THEN - INFO = -4 - ELSE IF ( N.LT.0 .OR. ( N*L ).GT.( M*K ) ) THEN - INFO = -5 - ELSE IF ( COMPO .AND. RB.LT.0 ) THEN - INFO = -6 - ELSE IF ( COMPU .AND. RC.LT.0 ) THEN - INFO = -7 - ELSE IF ( LDTC.LT.MAX( 1, M*K ) ) THEN - INFO = -9 - ELSE IF ( LDTR.LT.MAX( 1, K ) ) THEN - INFO = -11 - ELSE IF ( LDB.LT.1 .OR. ( COMPO .AND. LDB.LT.M*K ) ) THEN - INFO = -13 - ELSE IF ( LDC.LT.1 .OR. ( COMPU .AND. LDC.LT.M*K ) ) THEN - INFO = -15 - ELSE IF ( LDWORK.LT.WRKMIN ) THEN - DWORK(1) = DBLE( WRKMIN ) - INFO = -17 - END IF -C -C Return if there were illegal values. -C - IF ( INFO.NE.0 ) THEN - CALL XERBLA( 'MB02ID', -INFO ) - RETURN - END IF -C -C Quick return if possible. -C - IF( COMPO .AND. MIN( N*L, RB ).EQ.0 ) THEN - COMPO = .FALSE. - END IF - IF( COMPU .AND. MIN( N*L, RC ).EQ.0 ) THEN - CALL DLASET( 'Full', M*K, RC, ZERO, ZERO, C, LDC ) - COMPU = .FALSE. - END IF - IF ( .NOT.( COMPO .OR. COMPU ) ) THEN - DWORK(1) = ONE - RETURN - END IF -C -C Check cases M = 1 or N = 1. -C - IF ( MIN( M, N ).EQ.1 ) THEN - PDW = K*L*M*N - IF ( COMPO ) THEN - CALL DLACPY( 'All', M*K, L, TC, LDTC, DWORK, M*K ) - CALL DLACPY( 'All', K, (N-1)*L, TR, LDTR, DWORK(K*L+1), - $ M*K ) - CALL DGELS( 'NonTranspose', M*K, N*L, RB, DWORK, M*K, B, - $ LDB, DWORK(PDW+1), LDWORK-PDW, IERR ) - WRKOPT = MAX( WRKOPT, INT( DWORK(PDW+1) ) + PDW ) - END IF - IF ( COMPU ) THEN - CALL DLACPY( 'All', M*K, L, TC, LDTC, DWORK, M*K ) - CALL DLACPY( 'All', K, (N-1)*L, TR, LDTR, DWORK(K*L+1), - $ M*K ) - CALL DGELS( 'Transpose', M*K, N*L, RC, DWORK, M*K, C, LDC, - $ DWORK(PDW+1), LDWORK-PDW, IERR ) - WRKOPT = MAX( WRKOPT, INT( DWORK(PDW+1) ) + PDW ) - END IF - DWORK(1) = DBLE( WRKOPT ) - RETURN - END IF -C -C Step 1: Compute the generator. -C - IF ( COMPO ) THEN - CALL MB02KD( 'Column', 'Transpose', K, L, M, N, RB, ONE, ZERO, - $ TC, LDTC, TR, LDTR, B, LDB, DWORK, N*L, - $ DWORK(N*L*RB+1), LDWORK-N*L*RB, IERR ) - WRKOPT = MAX( WRKOPT, INT( DWORK(N*L*RB+1) ) + N*L*RB ) - CALL DLACPY( 'All', N*L, RB, DWORK, N*L, B, LDB ) - END IF -C - PDW = N*L*L + 1 - CALL DLACPY( 'All', M*K, L, TC, LDTC, DWORK(PDW), M*K ) - CALL DGEQRF( M*K, L, DWORK(PDW), M*K, DWORK(PDW+M*K*L), - $ DWORK(PDW+(M*K+1)*L), LDWORK-PDW-(M*K+1)*L-1, IERR ) - WRKOPT = MAX( WRKOPT, INT( DWORK(PDW+(M*K+1)*L) ) + - $ PDW + (M*K+1)*L - 1 ) -C - DO 10 I = PDW, PDW + M*K*L - 1, M*K + 1 - IF ( DWORK(I).EQ.ZERO ) THEN - INFO = 1 - RETURN - END IF - 10 CONTINUE -C - CALL MA02AD( 'Upper', L, L, DWORK(PDW), M*K, DWORK, N*L ) - CALL DORGQR( M*K, L, L, DWORK(PDW), M*K, DWORK(PDW+M*K*L), - $ DWORK(PDW+(M*K+1)*L), LDWORK-PDW-(M*K+1)*L-1, IERR ) - WRKOPT = MAX( WRKOPT, INT( DWORK(PDW+(M*K+1)*L) ) + - $ PDW + (M*K+1)*L - 1 ) - CALL MB02KD( 'Row', 'Transpose', K, L, M, N-1, L, ONE, ZERO, - $ TC, LDTC, TR, LDTR, DWORK(PDW), M*K, DWORK(L+1), - C N*L, DWORK(PDW+M*K*L), LDWORK-PDW-M*K*L+1, IERR ) - WRKOPT = MAX( WRKOPT, INT( DWORK(PDW+M*K*L) ) + PDW + M*K*L - 1 ) - PPR = N*L*L + 1 - PNR = N*L*( L + K ) + 1 - CALL MA02AD( 'All', K, (N-1)*L, TR, LDTR, DWORK(PPR+L), N*L ) - CALL DLACPY( 'All', (N-1)*L, L, DWORK(L+1), N*L, DWORK(PNR+L), - $ N*L ) - PT = ( M - 1 )*K + 1 - PDW = PNR + N*L*L + L -C - DO 30 I = 1, MIN( M, N-1 ) - CALL MA02AD( 'All', K, L, TC(PT,1), LDTC, DWORK(PDW), N*L ) - PT = PT - K - PDW = PDW + L - 30 CONTINUE -C - PT = 1 -C - DO 40 I = M + 1, N - 1 - CALL MA02AD( 'All', K, L, TR(1,PT), LDTR, DWORK(PDW), N*L ) - PT = PT + L - PDW = PDW + L - 40 CONTINUE -C - IF ( COMPO ) THEN -C -C Apply the first reduction step to T'*B. -C - CALL DTRSM( 'Left', 'Lower', 'NonTranspose', 'NonUnit', - $ L, RB, ONE, DWORK, N*L, B, LDB ) - CALL DGEMM( 'NoTranspose', 'NoTranspose', (N-1)*L, RB, L, ONE, - $ DWORK(L+1), N*L, B, LDB, -ONE, B(L+1,1), LDB ) - CALL DTRSM( 'Left', 'Lower', 'Transpose', 'NonUnit', L, - $ RB, ONE, DWORK, N*L, B, LDB ) - END IF -C - IF ( COMPU ) THEN -C -C Apply the first reduction step to C. -C - CALL DTRSM( 'Left', 'Lower', 'NonTranspose', 'NonUnit', - $ L, RC, ONE, DWORK, N*L, C, LDC ) - CALL DGEMM( 'NoTranspose', 'NoTranspose', (N-1)*L, RC, L, ONE, - $ DWORK(L+1), N*L, C, LDC, -ONE, C(L+1,1), LDC ) - CALL DTRSM( 'Left', 'Lower', 'Transpose', 'NonUnit', L, - $ RC, ONE, DWORK, N*L, C, LDC ) - END IF -C - PDI = ( N - 1 )*L + 1 - CALL DLACPY( 'Lower', L, L, DWORK, N*L, DWORK(PDI), N*L ) - CALL DTRTRI( 'Lower', 'NonUnit', L, DWORK(PDI), N*L, IERR ) - CALL MA02AD( 'Lower', L-1, L, DWORK(PDI+1), N*L, - $ DWORK((2*N-1)*L+1), N*L ) - CALL DLASET( 'Lower', L-1, L, ZERO, ZERO, DWORK(PDI+1), N*L ) - CALL DLACPY( 'Upper', L, L, DWORK(PDI), N*L, DWORK(PNR), N*L ) - CALL DLASET( 'Lower', L-1, L, ZERO, ZERO, DWORK(PNR+1), N*L ) - CALL DLASET( 'All', L, K, ZERO, ZERO, DWORK(PPR), N*L ) - CALL DLASET( 'All', L, K, ZERO, ZERO, DWORK(PNR+N*L*L), N*L ) -C - PPI = PPR - PPR = PPR + L - PNI = PNR - PNR = PNR + L - PDW = 2*N*L*( L + K ) + 1 - LEN = ( N - 1 )*L -C -C Determine block size for the involved block Householder -C transformations. -C - NB = MIN( ILAENV( 1, 'DGELQF', ' ', N*L, L, -1, -1 ), L ) - KK = PDW + 6*L - 1 - WRKOPT = MAX( WRKOPT, KK + N*L*NB ) - KK = LDWORK - KK - IF ( KK.LT.N*L*NB ) NB = KK / ( N*L ) - NBMIN = MAX( 2, ILAENV( 2, 'DGELQF', ' ', N*L, L, -1, -1 ) ) - IF ( NB.LT.NBMIN ) NB = 0 -C - DO 50 I = L + 1, N*L, L - CALL MB02CU( 'Column', L, L+K, L+K, NB, DWORK, N*L, DWORK(PPR), - $ N*L, DWORK(PNR), N*L, RNK, IPVT, DWORK(PDW), ZERO, - $ DWORK(PDW+6*L), LDWORK-PDW-6*L+1, IERR ) - IF ( IERR.NE.0 ) THEN -C -C Error return: The rank condition is (numerically) not -C satisfied. -C - INFO = 1 - RETURN - END IF - CALL MB02CV( 'Column', 'NoStructure', L, LEN-L, L+K, L+K, NB, - $ -1, DWORK, N*L, DWORK(PPR), N*L, DWORK(PNR), N*L, - $ DWORK(L+1), N*L, DWORK(PPR+L), N*L, DWORK(PNR+L), - $ N*L, DWORK(PDW), DWORK(PDW+6*L), LDWORK-PDW-6*L+1, - $ IERR ) - PDI = PDI - L - IF ( COMPO ) THEN -C -C Block Gaussian elimination to B. -C - CALL DTRSM( 'Left', 'Lower', 'NonTranspose', 'NonUnit', - $ L, RB, -ONE, DWORK, N*L, B(I,1), LDB ) - IF ( LEN.GT.L ) THEN - CALL DGEMM( 'NonTranspose', 'NonTranspose', LEN-L, RB, L, - $ ONE, DWORK(L+1), N*L, B(I,1), LDB, ONE, - $ B(I+L,1), LDB ) - END IF - END IF - IF ( COMPU ) THEN -C -C Block Gaussian elimination to C. -C - CALL DTRSM( 'Left', 'Lower', 'NonTranspose', 'NonUnit', - $ L, RC, -ONE, DWORK, N*L, C(I,1), LDC ) - IF ( LEN.GT.L ) THEN - CALL DGEMM( 'NonTranspose', 'NonTranspose', LEN-L, RC, L, - $ ONE, DWORK(L+1), N*L, C(I,1), LDC, ONE, - $ C(I+L,1), LDC ) - END IF - END IF - CALL DLASET( 'All', L, L, ZERO, ZERO, DWORK(PDI), N*L ) - CALL MB02CV( 'Column', 'Triangular', L, I+L-1, L+K, L+K, NB, - $ -1, DWORK, N*L, DWORK(PPR), N*L, DWORK(PNR), N*L, - $ DWORK(PDI), N*L, DWORK(PPI), N*L, DWORK(PNI), N*L, - $ DWORK(PDW), DWORK(PDW+6*L), LDWORK-PDW-6*L+1, - $ IERR ) - IF ( COMPO ) THEN -C -C Apply block Gaussian elimination to B. -C - CALL DGEMM( 'NoTranspose', 'NoTranspose', I-1, RB, L, ONE, - $ DWORK(PDI), N*L, B(I,1), LDB, ONE, B, LDB ) - CALL DTRMM( 'Left', 'Upper', 'NonTranspose', 'NonUnit', L, - $ RB, ONE, DWORK((N-1)*L+1), N*L, B(I,1), LDB ) - END IF - IF ( COMPU ) THEN -C -C Apply block Gaussian elimination to C. -C - CALL DGEMM( 'NonTranspose', 'NonTranspose', I-1, RC, L, ONE, - $ DWORK(PDI), N*L, C(I,1), LDC, ONE, C, LDC ) - CALL DTRMM( 'Left', 'Upper', 'NonTranspose', 'NonUnit', L, - $ RC, ONE, DWORK((N-1)*L+1), N*L, C(I,1), LDC ) - END IF - LEN = LEN - L - PNR = PNR + L - PPR = PPR + L - 50 CONTINUE -C - IF ( COMPU ) THEN - CALL MB02KD( 'Column', 'NonTranspose', K, L, M, N, RC, ONE, - $ ZERO, TC, LDTC, TR, LDTR, C, LDC, DWORK, M*K, - $ DWORK(M*K*RC+1), LDWORK-M*K*RC, IERR ) - WRKOPT = MAX( WRKOPT, INT( DWORK(M*K*RC+1) ) + M*K*RC ) - CALL DLACPY( 'All', M*K, RC, DWORK, M*K, C, LDC ) - END IF - DWORK(1) = DBLE( WRKOPT ) - RETURN -C -C *** Last line of MB02ID *** - END diff --git a/mex/sources/libslicot/MB02JD.f b/mex/sources/libslicot/MB02JD.f deleted file mode 100644 index 95c49b43a..000000000 --- a/mex/sources/libslicot/MB02JD.f +++ /dev/null @@ -1,486 +0,0 @@ - SUBROUTINE MB02JD( JOB, K, L, M, N, P, S, TC, LDTC, TR, LDTR, Q, - $ LDQ, R, LDR, DWORK, LDWORK, INFO ) -C -C SLICOT RELEASE 5.0. -C -C Copyright (c) 2002-2009 NICONET e.V. -C -C This program is free software: you can redistribute it and/or -C modify it under the terms of the GNU General Public License as -C published by the Free Software Foundation, either version 2 of -C the License, or (at your option) any later version. -C -C This program is distributed in the hope that it will be useful, -C but WITHOUT ANY WARRANTY; without even the implied warranty of -C MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the -C GNU General Public License for more details. -C -C You should have received a copy of the GNU General Public License -C along with this program. If not, see -C . -C -C PURPOSE -C -C To compute a lower triangular matrix R and a matrix Q with -C Q^T Q = I such that -C T -C T = Q R , -C -C where T is a K*M-by-L*N block Toeplitz matrix with blocks of size -C (K,L). The first column of T will be denoted by TC and the first -C row by TR. It is assumed that the first MIN(M*K, N*L) columns of T -C have full rank. -C -C By subsequent calls of this routine the factors Q and R can be -C computed block column by block column. -C -C ARGUMENTS -C -C Mode Parameters -C -C JOB CHARACTER*1 -C Specifies the output of the routine as follows: -C = 'Q': computes Q and R; -C = 'R': only computes R. -C -C Input/Output Parameters -C -C K (input) INTEGER -C The number of rows in one block of T. K >= 0. -C -C L (input) INTEGER -C The number of columns in one block of T. L >= 0. -C -C M (input) INTEGER -C The number of blocks in one block column of T. M >= 0. -C -C N (input) INTEGER -C The number of blocks in one block row of T. N >= 0. -C -C P (input) INTEGER -C The number of previously computed block columns of R. -C P*L < MIN( M*K,N*L ) + L and P >= 0. -C -C S (input) INTEGER -C The number of block columns of R to compute. -C (P+S)*L < MIN( M*K,N*L ) + L and S >= 0. -C -C TC (input) DOUBLE PRECISION array, dimension (LDTC, L) -C On entry, if P = 0, the leading M*K-by-L part of this -C array must contain the first block column of T. -C -C LDTC INTEGER -C The leading dimension of the array TC. -C LDTC >= MAX(1,M*K). -C -C TR (input) DOUBLE PRECISION array, dimension (LDTR,(N-1)*L) -C On entry, if P = 0, the leading K-by-(N-1)*L part of this -C array must contain the first block row of T without the -C leading K-by-L block. -C -C LDTR INTEGER -C The leading dimension of the array TR. -C LDTR >= MAX(1,K). -C -C Q (input/output) DOUBLE PRECISION array, dimension -C (LDQ,MIN( S*L, MIN( M*K,N*L )-P*L )) -C On entry, if JOB = 'Q' and P > 0, the leading M*K-by-L -C part of this array must contain the last block column of Q -C from a previous call of this routine. -C On exit, if JOB = 'Q' and INFO = 0, the leading -C M*K-by-MIN( S*L, MIN( M*K,N*L )-P*L ) part of this array -C contains the P-th to (P+S)-th block columns of the factor -C Q. -C -C LDQ INTEGER -C The leading dimension of the array Q. -C LDQ >= MAX(1,M*K), if JOB = 'Q'; -C LDQ >= 1, if JOB = 'R'. -C -C R (input/output) DOUBLE PRECISION array, dimension -C (LDR,MIN( S*L, MIN( M*K,N*L )-P*L )) -C On entry, if P > 0, the leading (N-P+1)*L-by-L -C part of this array must contain the nozero part of the -C last block column of R from a previous call of this -C routine. -C One exit, if INFO = 0, the leading -C MIN( N, N-P+1 )*L-by-MIN( S*L, MIN( M*K,N*L )-P*L ) -C part of this array contains the nonzero parts of the P-th -C to (P+S)-th block columns of the lower triangular -C factor R. -C Note that elements in the strictly upper triangular part -C will not be referenced. -C -C LDR INTEGER -C The leading dimension of the array R. -C LDR >= MAX( 1, MIN( N, N-P+1 )*L ) -C -C Workspace -C -C DWORK DOUBLE PRECISION array, dimension (LDWORK) -C On exit, if INFO = 0, DWORK(1) returns the optimal value -C of LDWORK. -C On exit, if INFO = -17, DWORK(1) returns the minimum -C value of LDWORK. -C If JOB = 'Q', the first 1 + ( (N-1)*L + M*K )*( 2*K + L ) -C elements of DWORK should be preserved during successive -C calls of the routine. -C If JOB = 'R', the first 1 + (N-1)*L*( 2*K + L ) elements -C of DWORK should be preserved during successive calls of -C the routine. -C -C LDWORK INTEGER -C The length of the array DWORK. -C JOB = 'Q': -C LDWORK >= 1 + ( M*K + ( N - 1 )*L )*( L + 2*K ) + 6*L -C + MAX( M*K,( N - MAX( 1,P )*L ) ); -C JOB = 'R': -C If P = 0, -C LDWORK >= MAX( 1 + ( N - 1 )*L*( L + 2*K ) + 6*L -C + (N-1)*L, M*K*( L + 1 ) + L ); -C If P > 0, -C LDWORK >= 1 + (N-1)*L*( L + 2*K ) + 6*L + (N-P)*L. -C For optimum performance LDWORK should be larger. -C -C Error Indicator -C -C INFO INTEGER -C = 0: successful exit; -C < 0: if INFO = -i, the i-th argument had an illegal -C value; -C = 1: the full rank condition for the first MIN(M*K, N*L) -C columns of T is (numerically) violated. -C -C METHOD -C -C Block Householder transformations and modified hyperbolic -C rotations are used in the Schur algorithm [1], [2]. -C -C REFERENCES -C -C [1] Kailath, T. and Sayed, A. -C Fast Reliable Algorithms for Matrices with Structure. -C SIAM Publications, Philadelphia, 1999. -C -C [2] Kressner, D. and Van Dooren, P. -C Factorizations and linear system solvers for matrices with -C Toeplitz structure. -C SLICOT Working Note 2000-2, 2000. -C -C NUMERICAL ASPECTS -C -C The implemented method yields a factor R which has comparable -C accuracy with the Cholesky factor of T^T * T. Q is implicitly -C computed from the formula Q = T * inv(R^T R) * R, i.e., for ill -C conditioned problems this factor is of very limited value. -C 2 -C The algorithm requires 0(K*L *M*N) floating point operations. -C -C CONTRIBUTOR -C -C D. Kressner, Technical Univ. Berlin, Germany, May 2001. -C -C REVISIONS -C -C V. Sima, Research Institute for Informatics, Bucharest, June 2001. -C D. Kressner, Technical Univ. Berlin, Germany, July 2002. -C V. Sima, Research Institute for Informatics, Bucharest, Mar. 2004. -C -C KEYWORDS -C -C Elementary matrix operations, Householder transformation, matrix -C operations, Toeplitz matrix. -C -C ****************************************************************** -C -C .. Parameters .. - DOUBLE PRECISION ZERO, ONE - PARAMETER ( ZERO = 0.0D0, ONE = 1.0D0 ) -C .. Scalar Arguments .. - CHARACTER JOB - INTEGER INFO, K, L, LDQ, LDR, LDTC, LDTR, LDWORK, - $ M, N, P, S -C .. Array Arguments .. - DOUBLE PRECISION DWORK(LDWORK), Q(LDQ,*), R(LDR,*), TC(LDTC,*), - $ TR(LDTR,*) -C .. Local Scalars .. - INTEGER COLR, I, IERR, KK, LEN, NB, NBMIN, PDQ, PDW, - $ PNQ, PNR, PRE, PT, RNK, SHFR, STPS, WRKMIN, - $ WRKOPT - LOGICAL COMPQ -C .. Local Arrays .. - INTEGER IPVT(1) -C .. External Functions .. - LOGICAL LSAME - INTEGER ILAENV - EXTERNAL ILAENV, LSAME -C .. External Subroutines .. - EXTERNAL DGEQRF, DLACPY, DLASET, DORGQR, MA02AD, MB02CU, - $ MB02CV, MB02KD, XERBLA -C .. Intrinsic Functions .. - INTRINSIC DBLE, INT, MAX, MIN -C -C .. Executable Statements .. -C -C Decode the scalar input parameters. -C - INFO = 0 - COMPQ = LSAME( JOB, 'Q' ) - IF ( COMPQ ) THEN - WRKMIN = 1 + ( M*K + ( N - 1 )*L )*( L + 2*K ) + 6*L - $ + MAX( M*K, ( N - MAX( 1, P ) )*L ) - ELSE - WRKMIN = 1 + ( N - 1 )*L*( L + 2*K ) + 6*L - $ + ( N - MAX( P, 1 ) )*L - IF ( P.EQ.0 ) THEN - WRKMIN = MAX( WRKMIN, M*K*( L + 1 ) + L ) - END IF - END IF -C -C Check the scalar input parameters. -C - IF ( .NOT.( COMPQ .OR. LSAME( JOB, 'R' ) ) ) THEN - INFO = -1 - ELSE IF ( K.LT.0 ) THEN - INFO = -2 - ELSE IF ( L.LT.0 ) THEN - INFO = -3 - ELSE IF ( M.LT.0 ) THEN - INFO = -4 - ELSE IF ( N.LT.0 ) THEN - INFO = -5 - ELSE IF ( P*L.GE.MIN( M*K, N*L ) + L .OR. P.LT.0 ) THEN - INFO = -6 - ELSE IF ( ( P + S )*L.GE.MIN( M*K, N*L ) + L .OR. S.LT.0 ) THEN - INFO = -7 - ELSE IF ( LDTC.LT.MAX( 1, M*K ) ) THEN - INFO = -9 - ELSE IF ( LDTR.LT.MAX( 1, K ) ) THEN - INFO = -11 - ELSE IF ( LDQ.LT.1 .OR. ( COMPQ .AND. LDQ.LT.M*K ) ) THEN - INFO = -13 - ELSE IF ( LDR.LT.MAX( 1, MIN( N, N - P + 1 )*L ) ) THEN - INFO = -15 - ELSE IF ( LDWORK.LT.WRKMIN ) THEN - DWORK(1) = DBLE( WRKMIN ) - INFO = -17 - END IF -C -C Return if there were illegal values. -C - IF ( INFO .NE. 0 ) THEN - CALL XERBLA( 'MB02JD', -INFO ) - RETURN - END IF -C -C Quick return if possible. -C - IF ( MIN( M, N, K*L, S ) .EQ.0 ) THEN - DWORK(1) = ONE - RETURN - END IF -C -C Catch M*K <= L. -C - WRKOPT = 1 - IF ( M*K.LE.L ) THEN - CALL DLACPY( 'All', M*K, L, TC, LDTC, DWORK, M*K ) - PDW = M*K*L + 1 - CALL DGEQRF( M*K, L, DWORK, M*K, DWORK(PDW), - $ DWORK(PDW+M*K), LDWORK-PDW-M*K+1, IERR ) - WRKOPT = MAX( WRKOPT, INT( DWORK(PDW+M*K) ) + PDW + M*K - 1 ) - CALL MA02AD( 'Upper part', M*K, L, DWORK, M*K, R, LDR ) - CALL DORGQR( M*K, M*K, M*K, DWORK, M*K, DWORK(PDW), - $ DWORK(PDW+M*K), LDWORK-PDW-M*K+1, IERR ) - WRKOPT = MAX( WRKOPT, INT( DWORK(PDW+M*K) ) + PDW + M*K - 1 ) - IF ( COMPQ ) THEN - CALL DLACPY( 'All', M*K, M*K, DWORK, M*K, Q, LDQ ) - END IF - PDW = M*K*M*K + 1 - IF ( N.GT.1 ) THEN - CALL MB02KD( 'Row', 'Transpose', K, L, M, N-1, M*K, ONE, - $ ZERO, TC, LDTC, TR, LDTR, DWORK, M*K, R(L+1,1), - $ LDR, DWORK(PDW), LDWORK-PDW+1, IERR ) - END IF - WRKOPT = MAX( WRKOPT, INT( DWORK(PDW) ) + PDW - 1 ) - DWORK(1) = DBLE( WRKOPT ) - RETURN - END IF -C -C Compute the generator if P = 0. -C - IF ( P.EQ.0 ) THEN -C -C 1st column of the generator. -C - IF ( COMPQ ) THEN - CALL DLACPY( 'All', M*K, L, TC, LDTC, Q, LDQ ) - CALL DGEQRF( M*K, L, Q, LDQ, DWORK, DWORK(L+1), - $ LDWORK-L, IERR ) - WRKOPT = MAX( WRKOPT, INT( DWORK(L+1) ) + L ) - CALL MA02AD( 'Upper part', L, L, Q, LDQ, R, LDR ) - CALL DORGQR( M*K, L, L, Q, LDQ, DWORK, DWORK(L+1), LDWORK-L, - $ IERR ) - WRKOPT = MAX( WRKOPT, INT( DWORK(L+1) ) + L ) - IF ( N.GT.1 ) THEN - CALL MB02KD( 'Row', 'Transpose', K, L, M, N-1, L, ONE, - $ ZERO, TC, LDTC, TR, LDTR, Q, LDQ, R(L+1,1), - $ LDR, DWORK, LDWORK, IERR ) - END IF - WRKOPT = MAX( WRKOPT, INT( DWORK(1) ) ) - ELSE - PDW = M*K*L + 1 - CALL DLACPY( 'All', M*K, L, TC, LDTC, DWORK, M*K ) - CALL DGEQRF( M*K, L, DWORK, M*K, DWORK(PDW), DWORK(PDW+L), - $ LDWORK-PDW-L+1, IERR ) - WRKOPT = MAX( WRKOPT, INT( DWORK(PDW+L) ) + PDW + L - 1 ) - CALL MA02AD( 'Upper part', L, L, DWORK, M*K, R, LDR ) - CALL DORGQR( M*K, L, L, DWORK, M*K, DWORK(PDW), - $ DWORK(PDW+L), LDWORK-PDW-L+1, IERR ) - WRKOPT = MAX( WRKOPT, INT( DWORK(PDW+L) ) + PDW + L - 1 ) - IF ( N.GT.1 ) THEN - CALL MB02KD( 'Row', 'Transpose', K, L, M, N-1, L, ONE, - $ ZERO, TC, LDTC, TR, LDTR, DWORK, M*K, - $ R(L+1,1), LDR, DWORK(PDW), LDWORK-PDW+1, - $ IERR ) - END IF - WRKOPT = MAX( WRKOPT, INT( DWORK(PDW) ) + PDW - 1 ) - END IF -C -C Quick return if N = 1. -C - IF ( N.EQ.1 ) THEN - DWORK(1) = DBLE( WRKOPT ) - RETURN - END IF -C -C 2nd column of the generator. -C - PNR = ( N - 1 )*L*K + 2 - CALL MA02AD( 'All', K, (N-1)*L, TR, LDTR, DWORK(2), (N-1)*L ) -C -C 3rd and 4th column of the generator. -C - CALL DLACPY( 'All', (N-1)*L, L, R(L+1,1), LDR, DWORK(PNR), - $ (N-1)*L ) - PT = ( M - 1 )*K + 1 - PDW = PNR + ( N - 1 )*L*L -C - DO 10 I = 1, MIN( M, N-1 ) - CALL MA02AD( 'All', K, L, TC(PT,1), LDTC, DWORK(PDW), - $ (N-1)*L ) - PT = PT - K - PDW = PDW + L - 10 CONTINUE -C - PT = 1 -C - DO 20 I = M + 1, N - 1 - CALL MA02AD( 'All', K, L, TR(1,PT), LDTR, DWORK(PDW), - $ (N-1)*L ) - PT = PT + L - PDW = PDW + L - 20 CONTINUE -C - IF ( COMPQ ) THEN - PDQ = ( 2*K + L )*( N - 1 )*L + 2 - PDW = ( 2*K + L )*( ( N - 1 )*L + M*K ) + 2 - PNQ = PDQ + M*K*K - CALL DLASET( 'All', K, K, ZERO, ONE, DWORK(PDQ), M*K ) - CALL DLASET( 'All', (M-1)*K, K, ZERO, ZERO, DWORK(PDQ+K), - $ M*K ) - CALL DLACPY( 'All', M*K, L, Q, LDQ, DWORK(PNQ), M*K ) - CALL DLASET( 'All', M*K, K, ZERO, ZERO, DWORK(PNQ+M*L*K), - $ M*K ) - ELSE - PDW = ( 2*K + L )*( N - 1 )*L + 2 - END IF - PRE = 1 - STPS = S - 1 - ELSE -C -C Set workspace pointers. -C - PNR = ( N - 1 )*L*K + 2 - IF ( COMPQ ) THEN - PDQ = ( 2*K + L )*( N - 1 )*L + 2 - PDW = ( 2*K + L )*( ( N - 1 )*L + M*K ) + 2 - PNQ = PDQ + M*K*K - ELSE - PDW = ( 2*K + L )*( N - 1 )*L + 2 - END IF - PRE = P - STPS = S - END IF -C -C Determine suitable size for the block Housholder reflectors. -C - IF ( COMPQ ) THEN - LEN = MAX( L + M*K, ( N - PRE + 1 )*L ) - ELSE - LEN = ( N - PRE + 1 )*L - END IF - NB = MIN( ILAENV( 1, 'DGELQF', ' ', LEN, L, -1, -1 ), L ) - KK = PDW + 6*L - 1 - WRKOPT = MAX( WRKOPT, KK + LEN*NB ) - KK = LDWORK - KK - IF ( KK.LT.LEN*NB ) NB = KK / LEN - NBMIN = MAX( 2, ILAENV( 2, 'DGELQF', ' ', LEN, L, -1, -1 ) ) - IF ( NB.LT.NBMIN ) NB = 0 - COLR = L + 1 -C -C Generator reduction process. -C - LEN = ( N - PRE )*L - SHFR = ( PRE - 1 )*L - DO 30 I = PRE, PRE + STPS - 1 -C -C IF M*K < N*L the last block might have less than L columns. -C - KK = MIN( L, M*K - I*L ) - CALL DLACPY( 'Lower', LEN, KK, R(COLR-L,COLR-L), LDR, - $ R(COLR,COLR), LDR ) - CALL MB02CU( 'Column', KK, KK+K, L+K, NB, R(COLR,COLR), LDR, - $ DWORK(SHFR+2), (N-1)*L, DWORK(PNR+SHFR), (N-1)*L, - $ RNK, IPVT, DWORK(PDW), ZERO, DWORK(PDW+6*L), - $ LDWORK-PDW-6*L+1, IERR ) - IF ( IERR.NE.0 ) THEN -C -C Error return: The rank condition is (numerically) not -C satisfied. -C - INFO = 1 - RETURN - END IF - IF ( LEN.GT.KK ) THEN - CALL MB02CV( 'Column', 'NoStructure', KK, LEN-KK, KK+K, L+K, - $ NB, -1, R(COLR,COLR), LDR, DWORK(SHFR+2), - $ (N-1)*L, DWORK(PNR+SHFR), (N-1)*L, - $ R(COLR+KK,COLR), LDR, DWORK(SHFR+KK+2), - $ (N-1)*L, DWORK(PNR+SHFR+KK), (N-1)*L, - $ DWORK(PDW), DWORK(PDW+6*L), LDWORK-PDW-6*L+1, - $ IERR ) - END IF - IF ( COMPQ ) THEN - CALL DLASET( 'All', K, KK, ZERO, ZERO, Q(1,COLR), LDQ ) - IF ( M.GT.1 ) THEN - CALL DLACPY( 'All', (M-1)*K, KK, Q(1,COLR-L), LDQ, - $ Q(K+1,COLR), LDQ ) - END IF - CALL MB02CV( 'Column', 'NoStructure', KK, M*K, KK+K, L+K, - $ NB, -1, R(COLR,COLR), LDR, DWORK(SHFR+2), - $ (N-1)*L, DWORK(PNR+SHFR), (N-1)*L, Q(1,COLR), - $ LDQ, DWORK(PDQ), M*K, DWORK(PNQ), M*K, - $ DWORK(PDW), DWORK(PDW+6*L), LDWORK-PDW-6*L+1, - $ IERR ) - END IF - LEN = LEN - L - COLR = COLR + L - SHFR = SHFR + L - 30 CONTINUE -C - DWORK(1) = DBLE( WRKOPT ) - RETURN -C -C *** Last line of MB02JD *** - END diff --git a/mex/sources/libslicot/MB02JX.f b/mex/sources/libslicot/MB02JX.f deleted file mode 100644 index c941bd446..000000000 --- a/mex/sources/libslicot/MB02JX.f +++ /dev/null @@ -1,737 +0,0 @@ - SUBROUTINE MB02JX( JOB, K, L, M, N, TC, LDTC, TR, LDTR, RNK, Q, - $ LDQ, R, LDR, JPVT, TOL1, TOL2, DWORK, LDWORK, - $ INFO ) -C -C SLICOT RELEASE 5.0. -C -C Copyright (c) 2002-2009 NICONET e.V. -C -C This program is free software: you can redistribute it and/or -C modify it under the terms of the GNU General Public License as -C published by the Free Software Foundation, either version 2 of -C the License, or (at your option) any later version. -C -C This program is distributed in the hope that it will be useful, -C but WITHOUT ANY WARRANTY; without even the implied warranty of -C MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the -C GNU General Public License for more details. -C -C You should have received a copy of the GNU General Public License -C along with this program. If not, see -C . -C -C PURPOSE -C -C To compute a low rank QR factorization with column pivoting of a -C K*M-by-L*N block Toeplitz matrix T with blocks of size (K,L); -C specifically, -C T -C T P = Q R , -C -C where R is lower trapezoidal, P is a block permutation matrix -C and Q^T Q = I. The number of columns in R is equivalent to the -C numerical rank of T with respect to the given tolerance TOL1. -C Note that the pivoting scheme is local, i.e., only columns -C belonging to the same block in T are permuted. -C -C ARGUMENTS -C -C Mode Parameters -C -C JOB CHARACTER*1 -C Specifies the output of the routine as follows: -C = 'Q': computes Q and R; -C = 'R': only computes R. -C -C Input/Output Parameters -C -C K (input) INTEGER -C The number of rows in one block of T. K >= 0. -C -C L (input) INTEGER -C The number of columns in one block of T. L >= 0. -C -C M (input) INTEGER -C The number of blocks in one block column of T. M >= 0. -C -C N (input) INTEGER -C The number of blocks in one block row of T. N >= 0. -C -C TC (input) DOUBLE PRECISION array, dimension (LDTC, L) -C The leading M*K-by-L part of this array must contain -C the first block column of T. -C -C LDTC INTEGER -C The leading dimension of the array TC. -C LDTC >= MAX(1,M*K). -C -C TR (input) DOUBLE PRECISION array, dimension (LDTR,(N-1)*L) -C The leading K-by-(N-1)*L part of this array must contain -C the first block row of T without the leading K-by-L -C block. -C -C LDTR INTEGER -C The leading dimension of the array TR. LDTR >= MAX(1,K). -C -C RNK (output) INTEGER -C The number of columns in R, which is equivalent to the -C numerical rank of T. -C -C Q (output) DOUBLE PRECISION array, dimension (LDQ,RNK) -C If JOB = 'Q', then the leading M*K-by-RNK part of this -C array contains the factor Q. -C If JOB = 'R', then this array is not referenced. -C -C LDQ INTEGER -C The leading dimension of the array Q. -C LDQ >= MAX(1,M*K), if JOB = 'Q'; -C LDQ >= 1, if JOB = 'R'. -C -C R (output) DOUBLE PRECISION array, dimension (LDR,RNK) -C The leading N*L-by-RNK part of this array contains the -C lower trapezoidal factor R. -C -C LDR INTEGER -C The leading dimension of the array R. -C LDR >= MAX(1,N*L) -C -C JPVT (output) INTEGER array, dimension (MIN(M*K,N*L)) -C This array records the column pivoting performed. -C If JPVT(j) = k, then the j-th column of T*P was -C the k-th column of T. -C -C Tolerances -C -C TOL1 DOUBLE PRECISION -C If TOL1 >= 0.0, the user supplied diagonal tolerance; -C if TOL1 < 0.0, a default diagonal tolerance is used. -C -C TOL2 DOUBLE PRECISION -C If TOL2 >= 0.0, the user supplied offdiagonal tolerance; -C if TOL2 < 0.0, a default offdiagonal tolerance is used. -C -C Workspace -C -C DWORK DOUBLE PRECISION array, dimension (LDWORK) -C On exit, if INFO = 0, DWORK(1) returns the optimal value -C of LDWORK; DWORK(2) and DWORK(3) return the used values -C for TOL1 and TOL2, respectively. -C On exit, if INFO = -19, DWORK(1) returns the minimum -C value of LDWORK. -C -C LDWORK INTEGER -C The length of the array DWORK. -C LDWORK >= MAX( 3, ( M*K + ( N - 1 )*L )*( L + 2*K ) + 9*L -C + MAX(M*K,(N-1)*L) ), if JOB = 'Q'; -C LDWORK >= MAX( 3, ( N - 1 )*L*( L + 2*K + 1 ) + 9*L, -C M*K*( L + 1 ) + L ), if JOB = 'R'. -C -C Error Indicator -C -C INFO INTEGER -C = 0: successful exit; -C < 0: if INFO = -i, the i-th argument had an illegal -C value; -C = 1: due to perturbations induced by roundoff errors, or -C removal of nearly linearly dependent columns of the -C generator, the Schur algorithm encountered a -C situation where a diagonal element in the negative -C generator is larger in magnitude than the -C corresponding diagonal element in the positive -C generator (modulo TOL1); -C = 2: due to perturbations induced by roundoff errors, or -C removal of nearly linearly dependent columns of the -C generator, the Schur algorithm encountered a -C situation where diagonal elements in the positive -C and negative generator are equal in magnitude -C (modulo TOL1), but the offdiagonal elements suggest -C that these columns are not linearly dependent -C (modulo TOL2*ABS(diagonal element)). -C -C METHOD -C -C Householder transformations and modified hyperbolic rotations -C are used in the Schur algorithm [1], [2]. -C If, during the process, the hyperbolic norm of a row in the -C leading part of the generator is found to be less than or equal -C to TOL1, then this row is not reduced. If the difference of the -C corresponding columns has a norm less than or equal to TOL2 times -C the magnitude of the leading element, then this column is removed -C from the generator, as well as from R. Otherwise, the algorithm -C breaks down. TOL1 is set to norm(TC)*sqrt(eps) and TOL2 is set -C to N*L*sqrt(eps) by default. -C If M*K > L, the columns of T are permuted so that the diagonal -C elements in one block column of R have decreasing magnitudes. -C -C REFERENCES -C -C [1] Kailath, T. and Sayed, A. -C Fast Reliable Algorithms for Matrices with Structure. -C SIAM Publications, Philadelphia, 1999. -C -C [2] Kressner, D. and Van Dooren, P. -C Factorizations and linear system solvers for matrices with -C Toeplitz structure. -C SLICOT Working Note 2000-2, 2000. -C -C NUMERICAL ASPECTS -C -C The algorithm requires 0(K*RNK*L*M*N) floating point operations. -C -C CONTRIBUTOR -C -C D. Kressner, Technical Univ. Berlin, Germany, May 2001. -C -C REVISIONS -C -C V. Sima, Research Institute for Informatics, Bucharest, June 2001. -C D. Kressner, Technical Univ. Berlin, Germany, July 2002. -C V. Sima, Research Institute for Informatics, Bucharest, Mar. 2004. -C -C KEYWORDS -C -C Elementary matrix operations, Householder transformation, matrix -C operations, Toeplitz matrix. -C -C ****************************************************************** -C -C .. Parameters .. - DOUBLE PRECISION ZERO, ONE - PARAMETER ( ZERO = 0.0D0, ONE = 1.0D0 ) -C .. Scalar Arguments .. - CHARACTER JOB - INTEGER INFO, K, L, LDQ, LDR, LDTC, LDTR, LDWORK, M, N, - $ RNK - DOUBLE PRECISION TOL1, TOL2 -C .. Array Arguments .. - DOUBLE PRECISION DWORK(LDWORK), Q(LDQ,*), R(LDR,*), TC(LDTC,*), - $ TR(LDTR,*) - INTEGER JPVT(*) -C .. Local Scalars .. - LOGICAL COMPQ, LAST - INTEGER CPCOL, GAP, I, IERR, J, JJ, JWORK, KK, LEN, MK, - $ NZC, PDP, PDQ, PDW, PNQ, PNR, PP, PPR, PT, RDEF, - $ RRDF, RRNK, WRKMIN, WRKOPT - DOUBLE PRECISION LTOL1, LTOL2, NRM, TEMP -C .. External Functions .. - LOGICAL LSAME - DOUBLE PRECISION DLAMCH, DNRM2 - EXTERNAL DLAMCH, DNRM2, LSAME -C .. External Subroutines .. - EXTERNAL DAXPY, DCOPY, DGEQP3, DGEQRF, DLACPY, DLASET, - $ DORGQR, DSCAL, DSWAP, DTRMV, MA02AD, MB02CU, - $ MB02CV, MB02KD, XERBLA -C .. Intrinsic Functions .. - INTRINSIC ABS, DBLE, MAX, MIN, SQRT -C -C .. Executable Statements .. -C -C Decode the scalar input parameters. -C - INFO = 0 - WRKOPT = 3 - MK = M*K - COMPQ = LSAME( JOB, 'Q' ) - IF ( COMPQ ) THEN - WRKMIN = MAX( 3, ( MK + ( N - 1 )*L )*( L + 2*K ) + 9*L + - $ MAX( MK, ( N - 1 )*L ) ) - ELSE - WRKMIN = MAX( 3, MAX ( ( N - 1 )*L*( L + 2*K + 1 ) + 9*L, - $ MK*( L + 1 ) + L ) ) - END IF -C -C Check the scalar input parameters. -C - IF ( .NOT.( COMPQ .OR. LSAME( JOB, 'R' ) ) ) THEN - INFO = -1 - ELSE IF ( K.LT.0 ) THEN - INFO = -2 - ELSE IF ( L.LT.0 ) THEN - INFO = -3 - ELSE IF ( M.LT.0 ) THEN - INFO = -4 - ELSE IF ( N.LT.0 ) THEN - INFO = -5 - ELSE IF ( LDTC.LT.MAX( 1, MK ) ) THEN - INFO = -7 - ELSE IF ( LDTR.LT.MAX( 1, K ) ) THEN - INFO = -9 - ELSE IF ( LDQ.LT.1 .OR. ( COMPQ .AND. LDQ.LT.MK ) ) THEN - INFO = -12 - ELSE IF ( LDR.LT.MAX( 1, N*L ) ) THEN - INFO = -14 - ELSE IF ( LDWORK.LT.WRKMIN ) THEN - DWORK(1) = DBLE( WRKMIN ) - INFO = -19 - END IF -C -C Return if there were illegal values. -C - IF ( INFO.NE.0 ) THEN - CALL XERBLA( 'MB02JX', -INFO ) - RETURN - END IF -C -C Quick return if possible. -C - IF ( MIN( M, N, K, L ).EQ.0 ) THEN - RNK = 0 - DWORK(1) = DBLE( WRKOPT ) - DWORK(2) = ZERO - DWORK(3) = ZERO - RETURN - END IF -C - WRKOPT = WRKMIN -C - IF ( MK.LE.L ) THEN -C -C Catch M*K <= L. -C - CALL DLACPY( 'All', MK, L, TC, LDTC, DWORK, MK ) - PDW = MK*L + 1 - JWORK = PDW + MK - CALL DGEQRF( MK, L, DWORK, MK, DWORK(PDW), DWORK(JWORK), - $ LDWORK-JWORK+1, IERR ) - WRKOPT = MAX( WRKOPT, INT( DWORK(JWORK) ) + JWORK - 1 ) - CALL MA02AD( 'Upper part', MK, L, DWORK, MK, R, LDR ) - CALL DORGQR( MK, MK, MK, DWORK, MK, DWORK(PDW), - $ DWORK(JWORK), LDWORK-JWORK+1, IERR ) - WRKOPT = MAX( WRKOPT, INT( DWORK(JWORK) ) + JWORK - 1 ) - IF ( COMPQ ) - $ CALL DLACPY( 'All', MK, MK, DWORK, MK, Q, LDQ ) - PDW = MK*MK + 1 - IF ( N.GT.1 ) THEN - CALL MB02KD( 'Row', 'Transpose', K, L, M, N-1, MK, ONE, - $ ZERO, TC, LDTC, TR, LDTR, DWORK, MK, R(L+1,1), - $ LDR, DWORK(PDW), LDWORK-PDW+1, IERR ) - END IF - WRKOPT = MAX( WRKOPT, INT( DWORK(PDW) ) + PDW - 1 ) -C - DO 10 I = 1, MK - JPVT(I) = I - 10 CONTINUE -C - RNK = MK - DWORK(1) = DBLE( WRKOPT ) - DWORK(2) = ZERO - DWORK(3) = ZERO - RETURN - END IF -C -C Compute the generator: -C -C 1st column of the generator. -C - DO 20 I = 1, L - JPVT(I) = 0 - 20 CONTINUE -C - LTOL1 = TOL1 - LTOL2 = TOL2 -C - IF ( COMPQ ) THEN - CALL DLACPY( 'All', MK, L, TC, LDTC, Q, LDQ ) - CALL DGEQP3( MK, L, Q, LDQ, JPVT, DWORK, DWORK(L+1), - $ LDWORK-L, IERR ) - WRKOPT = MAX( WRKOPT, INT( DWORK(L+1) ) + L ) -C - IF ( LTOL1.LT.ZERO ) THEN -C -C Compute default tolerance LTOL1. -C -C Estimate the 2-norm of the first block column of the -C matrix with 5 power iterations. -C - TEMP = ONE / SQRT( DBLE( L ) ) - CALL DLASET( 'All', L, 1, TEMP, TEMP, DWORK(L+1), 1 ) -C - DO 30 I = 1, 5 - CALL DTRMV( 'Upper', 'NonTranspose', 'NonUnit', L, Q, - $ LDQ, DWORK(L+1), 1 ) - CALL DTRMV( 'Upper', 'Transpose', 'NonUnit', L, Q, LDQ, - $ DWORK(L+1), 1 ) - NRM = DNRM2( L, DWORK(L+1), 1 ) - CALL DSCAL( L, ONE/NRM, DWORK(L+1), 1 ) - 30 CONTINUE -C - LTOL1 = SQRT( NRM*DLAMCH( 'Epsilon' ) ) - END IF -C - I = L -C - 40 CONTINUE - IF ( ABS( Q(I,I) ).LE.LTOL1 ) THEN - I = I - 1 - IF ( I.GT.0 ) GO TO 40 - END IF -C - RRNK = I - RRDF = L - RRNK - CALL MA02AD( 'Upper', RRNK, L, Q, LDQ, R, LDR ) - IF ( RRNK.GT.1 ) - $ CALL DLASET( 'Upper', L-1, RRNK-1, ZERO, ZERO, R(1,2), LDR ) - CALL DORGQR( MK, L, RRNK, Q, LDQ, DWORK, DWORK(L+1), LDWORK-L, - $ IERR ) - WRKOPT = MAX( WRKOPT, INT( DWORK(L+1) ) + L ) - IF ( N.GT.1 ) THEN - CALL MB02KD( 'Row', 'Transpose', K, L, M, N-1, RRNK, ONE, - $ ZERO, TC, LDTC, TR, LDTR, Q, LDQ, R(L+1,1), - $ LDR, DWORK, LDWORK, IERR ) - WRKOPT = MAX( WRKOPT, INT( DWORK(1) ) ) - END IF -C - ELSE -C - PDW = MK*L + 1 - JWORK = PDW + L - CALL DLACPY( 'All', MK, L, TC, LDTC, DWORK, MK ) - CALL DGEQP3( MK, L, DWORK, MK, JPVT, DWORK(PDW), - $ DWORK(JWORK), LDWORK-JWORK+1, IERR ) - WRKOPT = MAX( WRKOPT, INT( DWORK(JWORK) ) + JWORK - 1 ) -C - IF ( LTOL1.LT.ZERO ) THEN -C -C Compute default tolerance LTOL1. -C -C Estimate the 2-norm of the first block column of the -C matrix with 5 power iterations. -C - TEMP = ONE / SQRT( DBLE( L ) ) - CALL DLASET( 'All', L, 1, TEMP, TEMP, DWORK(JWORK), 1 ) -C - DO 50 I = 1, 5 - CALL DTRMV( 'Upper', 'NonTranspose', 'NonUnit', L, DWORK, - $ MK, DWORK(JWORK), 1 ) - CALL DTRMV( 'Upper', 'Transpose', 'NonUnit', L, DWORK, - $ MK, DWORK(JWORK), 1 ) - NRM = DNRM2( L, DWORK(JWORK), 1 ) - CALL DSCAL( L, ONE/NRM, DWORK(JWORK), 1 ) - 50 CONTINUE -C - LTOL1 = SQRT( NRM*DLAMCH( 'Epsilon' ) ) - END IF -C - RRNK = L - I = ( L - 1 )*MK + L -C - 60 CONTINUE - IF ( ABS( DWORK(I) ).LE.LTOL1 ) THEN - RRNK = RRNK - 1 - I = I - MK - 1 - IF ( I.GT.0 ) GO TO 60 - END IF -C - RRDF = L - RRNK - CALL MA02AD( 'Upper part', RRNK, L, DWORK, MK, R, LDR ) - IF ( RRNK.GT.1 ) - $ CALL DLASET( 'Upper', L-1, RRNK-1, ZERO, ZERO, R(1,2), LDR ) - CALL DORGQR( MK, L, RRNK, DWORK, MK, DWORK(PDW), - $ DWORK(JWORK), LDWORK-JWORK+1, IERR ) - WRKOPT = MAX( WRKOPT, INT( DWORK(JWORK) ) + JWORK - 1 ) - IF ( N.GT.1 ) THEN - CALL MB02KD( 'Row', 'Transpose', K, L, M, N-1, RRNK, ONE, - $ ZERO, TC, LDTC, TR, LDTR, DWORK, MK, R(L+1,1), - $ LDR, DWORK(PDW), LDWORK-PDW+1, IERR ) - WRKOPT = MAX( WRKOPT, INT( DWORK(PDW) ) + PDW - 1 ) - END IF - END IF -C -C Quick return if N = 1. -C - IF ( N.EQ.1 ) THEN - RNK = RRNK - DWORK(1) = DBLE( WRKOPT ) - DWORK(2) = LTOL1 - DWORK(3) = ZERO - RETURN - END IF -C -C Compute default tolerance LTOL2. -C - IF ( LTOL2.LT.ZERO ) - $ LTOL2 = DBLE( N*L )*SQRT( DLAMCH( 'Epsilon' ) ) -C - DO 70 J = 1, L - CALL DCOPY( RRNK, R(J,1), LDR, R(L+JPVT(J),RRNK+1), LDR ) - 70 CONTINUE -C - IF ( N.GT.2 ) - $ CALL DLACPY( 'All', (N-2)*L, RRNK, R(L+1,1), LDR, - $ R(2*L+1,RRNK+1), LDR ) -C -C 2nd column of the generator. -C - IF ( RRDF.GT.0 ) - $ CALL MA02AD( 'All', MIN( RRDF, K ), (N-1)*L, TR, LDTR, - $ R(L+1,2*RRNK+1), LDR ) - IF ( K.GT.RRDF ) - $ CALL MA02AD( 'All', K-RRDF, (N-1)*L, TR(RRDF+1,1), LDTR, DWORK, - $ (N-1)*L ) -C -C 3rd column of the generator. -C - PNR = ( N - 1 )*L*MAX( 0, K-RRDF ) + 1 - CALL DLACPY( 'All', (N-1)*L, RRNK, R(L+1,1), LDR, DWORK(PNR), - $ (N-1)*L ) -C -C 4th column of the generator. -C - PDW = PNR + ( N - 1 )*L*RRNK - PT = ( M - 1 )*K + 1 -C - DO 80 I = 1, MIN( M, N-1 ) - CALL MA02AD( 'All', K, L, TC(PT,1), LDTC, DWORK(PDW), (N-1)*L ) - PT = PT - K - PDW = PDW + L - 80 CONTINUE -C - PT = 1 -C - DO 90 I = M + 1, N - 1 - CALL MA02AD( 'All', K, L, TR(1,PT), LDTR, DWORK(PDW), (N-1)*L ) - PT = PT + L - PDW = PDW + L - 90 CONTINUE -C - IF ( COMPQ ) THEN - PDQ = PNR + ( N - 1 )*L*( RRNK + K ) - PNQ = PDQ + MK*MAX( 0, K-RRDF ) - PDW = PNQ + MK*( RRNK + K ) - CALL DLACPY( 'All', MK, RRNK, Q, LDQ, DWORK(PNQ), MK ) - IF ( M.GT.1 ) - $ CALL DLACPY( 'All', (M-1)*K, RRNK, Q, LDQ, Q(K+1,RRNK+1), - $ LDQ ) - CALL DLASET( 'All', K, RRNK, ZERO, ZERO, Q(1,RRNK+1), LDQ ) - IF ( RRDF.GT.0 ) - $ CALL DLASET( 'All', MK, RRDF, ZERO, ONE, Q(1,2*RRNK+1), - $ LDQ ) - CALL DLASET( 'All', RRDF, MAX( 0, K-RRDF ), ZERO, ZERO, - $ DWORK(PDQ), MK ) - CALL DLASET( 'All', M*K-RRDF, MAX( 0, K-RRDF ), ZERO, ONE, - $ DWORK(PDQ+RRDF), MK ) - CALL DLASET( 'All', MK, K, ZERO, ZERO, DWORK(PNQ+MK*RRNK), MK ) - ELSE - PDW = PNR + ( N - 1 )*L*( RRNK + K ) - END IF - PPR = 1 - RNK = RRNK - RDEF = RRDF - LEN = N*L - GAP = N*L - MIN( N*L, MK ) -C -C KK is the number of columns in the leading part of the -C generator. After sufficiently many rank drops or if -C M*K < N*L it may be less than L. -C - KK = MIN( L+K-RDEF, L ) - KK = MIN( KK, MK-L ) -C -C Generator reduction process. -C - DO 190 I = L + 1, MIN( MK, N*L ), L - IF ( I+L.LE.MIN( MK, N*L ) ) THEN - LAST = .FALSE. - ELSE - LAST = .TRUE. - END IF - PP = KK + MAX( K - RDEF, 0 ) - LEN = LEN - L - CALL MB02CU( 'Deficient', KK, PP, L+K-RDEF, -1, R(I,RNK+1), - $ LDR, DWORK(PPR), (N-1)*L, DWORK(PNR), (N-1)*L, - $ RRNK, JPVT(I), DWORK(PDW), LTOL1, DWORK(PDW+5*L), - $ LDWORK-PDW-5*L+1, IERR ) - IF ( IERR.NE.0 ) THEN -C -C Error return: The current generator is indefinite. -C - INFO = 1 - RETURN - END IF -C -C Apply pivoting to other columns of R. -C - PDP = PDW + 6*L - I -C - DO 100 J = I, I + KK - 1 - JPVT(J) = JPVT(J) + I - 1 - DWORK(PDP+JPVT(J)) = DBLE(J) - 100 CONTINUE -C - DO 120 J = I, I + KK - 1 - TEMP = DBLE(J) - JJ = J-1 -C - 110 CONTINUE - JJ = JJ + 1 - IF ( DWORK(PDP+JJ).NE.TEMP ) GO TO 110 -C - IF ( JJ.NE.J ) THEN - DWORK(PDP+JJ) = DWORK(PDP+J) - CALL DSWAP( RNK, R(J,1), LDR, R(JJ,1), LDR ) - END IF - 120 CONTINUE -C - DO 130 J = I + KK, I + L - 1 - JPVT(J) = J - 130 CONTINUE -C -C Apply reduction to other rows of R. -C - IF ( LEN.GT.KK ) THEN - CALL MB02CV( 'Deficient', 'NoStructure', KK, LEN-KK, PP, - $ L+K-RDEF, -1, RRNK, R(I,RNK+1), LDR, - $ DWORK(PPR), (N-1)*L, DWORK(PNR), (N-1)*L, - $ R(I+KK,RNK+1), LDR, DWORK(PPR+KK), (N-1)*L, - $ DWORK(PNR+KK), (N-1)*L, DWORK(PDW), - $ DWORK(PDW+5*L), LDWORK-PDW-5*L+1, IERR ) - END IF -C -C Apply reduction to Q. -C - IF ( COMPQ ) THEN - CALL MB02CV( 'Deficient', 'NoStructure', KK, MK, PP, - $ L+K-RDEF, -1, RRNK, R(I,RNK+1), LDR, - $ DWORK(PPR), (N-1)*L, DWORK(PNR), (N-1)*L, - $ Q(1,RNK+1), LDQ, DWORK(PDQ), MK, DWORK(PNQ), - $ MK, DWORK(PDW), DWORK(PDW+5*L), - $ LDWORK-PDW-5*L+1, IERR ) - END IF -C -C Inspection of the rank deficient columns: -C Look for small diagonal entries. -C - NZC = 0 -C - DO 140 J = KK, RRNK + 1, -1 - IF ( ABS( R(I+J-1,RNK+J) ).LE.LTOL1 ) NZC = NZC + 1 - 140 CONTINUE -C -C The last NZC columns of the generator cannot be removed. -C Now, decide whether for the other rank deficient columns -C it is safe to remove. -C - PT = PNR -C - DO 150 J = RRNK + 1, KK - NZC - TEMP = R(I+J-1,RNK+J) - CALL DSCAL( LEN-J-GAP, TEMP, R(I+J,RNK+J), 1 ) - CALL DAXPY( LEN-J-GAP, -DWORK(PT+J-1), DWORK(PT+J), 1, - $ R(I+J,RNK+J), 1 ) - IF ( DNRM2( LEN-J-GAP, R(I+J,RNK+J), 1 ) - $ .GT.LTOL2*ABS( TEMP ) ) THEN -C -C Unlucky case: -C It is neither advisable to remove the whole column nor -C possible to remove the diagonal entries by Hyperbolic -C rotations. -C - INFO = 2 - RETURN - END IF - PT = PT + ( N - 1 )*L - 150 CONTINUE -C -C Annihilate unwanted elements in the factor R. -C - RRDF = KK - RRNK - CALL DLASET( 'All', I-1, RRNK, ZERO, ZERO, R(1,RNK+1), LDR ) - CALL DLASET( 'Upper', L-1, RRNK-1, ZERO, ZERO, R(I,RNK+2), - $ LDR ) -C -C Construct the generator for the next step. -C - IF ( .NOT.LAST ) THEN -C -C Compute KK for the next step. -C - KK = MIN( L+K-RDEF-RRDF+NZC, L ) - KK = MIN( KK, MK-I-L+1 ) -C - IF ( KK.LE.0 ) THEN - RNK = RNK + RRNK - GO TO 200 - END IF -C - CALL DLASET( 'All', L, RRDF, ZERO, ZERO, R(I,RNK+RRNK+1), - $ LDR ) -C -C The columns with small diagonal entries form parts of the -C new positive generator. -C - IF ( ( RRDF-NZC ).GT.0 .AND. NZC.GT.0 ) THEN - CPCOL = MIN( NZC, KK ) -C - DO 160 J = RNK + RRNK + 1, RNK + RRNK + CPCOL - CALL DCOPY( LEN-L, R(I+L,J+RRDF-NZC), 1, - $ R(I+L,J), 1 ) - 160 CONTINUE -C - END IF -C -C Construct the leading parts of the positive generator. -C - CPCOL = MIN( RRNK, KK-NZC ) - IF ( CPCOL.GT.0 ) THEN -C - DO 170 J = I, I + L - 1 - CALL DCOPY( CPCOL, R(J,RNK+1), LDR, - $ R(JPVT(J)+L,RNK+RRNK+NZC+1), LDR ) - 170 CONTINUE -C - IF ( LEN.GT.2*L ) THEN - CALL DLACPY( 'All', LEN-2*L, CPCOL, R(I+L,RNK+1), LDR, - $ R(I+2*L,RNK+RRNK+NZC+1), LDR ) - END IF - END IF - PPR = PPR + L -C -C Refill the leading parts of the positive generator. -C - CPCOL = MIN( K-RDEF, KK-RRNK-NZC ) - IF ( CPCOL.GT.0 ) THEN - CALL DLACPY( 'All', LEN-L, CPCOL, DWORK(PPR), (N-1)*L, - $ R(I+L,RNK+2*RRNK+NZC+1), LDR ) - PPR = PPR + CPCOL*( N - 1 )*L - END IF - PNR = PNR + ( RRDF - NZC )*( N - 1 )*L + L -C -C Do the same things for Q. -C - IF ( COMPQ ) THEN - IF ( ( RRDF - NZC ).GT.0 .AND. NZC.GT.0 ) THEN - CPCOL = MIN( NZC, KK ) -C - DO 180 J = RNK + RRNK + 1, RNK + RRNK + CPCOL - CALL DCOPY( MK, Q(1,J+RRDF-NZC), 1, Q(1,J), 1 ) - 180 CONTINUE -C - END IF - CPCOL = MIN( RRNK, KK-NZC ) - IF ( CPCOL.GT.0 ) THEN - CALL DLASET( 'All', K, CPCOL, ZERO, ZERO, - $ Q(1,RNK+RRNK+NZC+1), LDQ ) - IF ( M.GT.1 ) - $ CALL DLACPY( 'All', (M-1)*K, CPCOL, Q(1,RNK+1), - $ LDQ, Q(K+1,RNK+RRNK+NZC+1), LDQ ) - END IF - CPCOL = MIN( K-RDEF, KK-RRNK-NZC ) - IF ( CPCOL.GT.0 ) THEN - CALL DLACPY( 'All', MK, CPCOL, DWORK(PDQ), MK, - $ Q(1,RNK+2*RRNK+NZC+1), LDQ ) - PDQ = PDQ + CPCOL*MK - END IF - PNQ = PNQ + ( RRDF - NZC )*MK - END IF - END IF - RNK = RNK + RRNK - RDEF = RDEF + RRDF - NZC - 190 CONTINUE -C - 200 CONTINUE - DWORK(1) = DBLE( WRKOPT ) - DWORK(2) = LTOL1 - DWORK(3) = LTOL2 -C -C *** Last line of MB02JX *** - END diff --git a/mex/sources/libslicot/MB02KD.f b/mex/sources/libslicot/MB02KD.f deleted file mode 100644 index c45c7cd62..000000000 --- a/mex/sources/libslicot/MB02KD.f +++ /dev/null @@ -1,842 +0,0 @@ - SUBROUTINE MB02KD( LDBLK, TRANS, K, L, M, N, R, ALPHA, BETA, - $ TC, LDTC, TR, LDTR, B, LDB, C, LDC, DWORK, - $ LDWORK, INFO ) -C -C SLICOT RELEASE 5.0. -C -C Copyright (c) 2002-2009 NICONET e.V. -C -C This program is free software: you can redistribute it and/or -C modify it under the terms of the GNU General Public License as -C published by the Free Software Foundation, either version 2 of -C the License, or (at your option) any later version. -C -C This program is distributed in the hope that it will be useful, -C but WITHOUT ANY WARRANTY; without even the implied warranty of -C MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the -C GNU General Public License for more details. -C -C You should have received a copy of the GNU General Public License -C along with this program. If not, see -C . -C -C PURPOSE -C -C To compute the matrix product -C -C C = alpha*op( T )*B + beta*C, -C -C where alpha and beta are scalars and T is a block Toeplitz matrix -C specified by its first block column TC and first block row TR; -C B and C are general matrices of appropriate dimensions. -C -C ARGUMENTS -C -C Mode Parameters -C -C LDBLK CHARACTER*1 -C Specifies where the (1,1)-block of T is stored, as -C follows: -C = 'C': in the first block of TC; -C = 'R': in the first block of TR. -C -C TRANS CHARACTER*1 -C Specifies the form of op( T ) to be used in the matrix -C multiplication as follows: -C = 'N': op( T ) = T; -C = 'T': op( T ) = T'; -C = 'C': op( T ) = T'. -C -C Input/Output Parameters -C -C K (input) INTEGER -C The number of rows in the blocks of T. K >= 0. -C -C L (input) INTEGER -C The number of columns in the blocks of T. L >= 0. -C -C M (input) INTEGER -C The number of blocks in the first block column of T. -C M >= 0. -C -C N (input) INTEGER -C The number of blocks in the first block row of T. N >= 0. -C -C R (input) INTEGER -C The number of columns in B and C. R >= 0. -C -C ALPHA (input) DOUBLE PRECISION -C The scalar alpha. When alpha is zero then TC, TR and B -C are not referenced. -C -C BETA (input) DOUBLE PRECISION -C The scalar beta. When beta is zero then C need not be set -C before entry. -C -C TC (input) DOUBLE PRECISION array, dimension (LDTC,L) -C On entry with LDBLK = 'C', the leading M*K-by-L part of -C this array must contain the first block column of T. -C On entry with LDBLK = 'R', the leading (M-1)*K-by-L part -C of this array must contain the 2nd to the M-th blocks of -C the first block column of T. -C -C LDTC INTEGER -C The leading dimension of the array TC. -C LDTC >= MAX(1,M*K), if LDBLK = 'C'; -C LDTC >= MAX(1,(M-1)*K), if LDBLK = 'R'. -C -C TR (input) DOUBLE PRECISION array, dimension (LDTR,k) -C where k is (N-1)*L when LDBLK = 'C' and is N*L when -C LDBLK = 'R'. -C On entry with LDBLK = 'C', the leading K-by-(N-1)*L part -C of this array must contain the 2nd to the N-th blocks of -C the first block row of T. -C On entry with LDBLK = 'R', the leading K-by-N*L part of -C this array must contain the first block row of T. -C -C LDTR INTEGER -C The leading dimension of the array TR. LDTR >= MAX(1,K). -C -C B (input) DOUBLE PRECISION array, dimension (LDB,R) -C On entry with TRANS = 'N', the leading N*L-by-R part of -C this array must contain the matrix B. -C On entry with TRANS = 'T' or TRANS = 'C', the leading -C M*K-by-R part of this array must contain the matrix B. -C -C LDB INTEGER -C The leading dimension of the array B. -C LDB >= MAX(1,N*L), if TRANS = 'N'; -C LDB >= MAX(1,M*K), if TRANS = 'T' or TRANS = 'C'. -C -C C (input/output) DOUBLE PRECISION array, dimension (LDC,R) -C On entry with TRANS = 'N', the leading M*K-by-R part of -C this array must contain the matrix C. -C On entry with TRANS = 'T' or TRANS = 'C', the leading -C N*L-by-R part of this array must contain the matrix C. -C On exit with TRANS = 'N', the leading M*K-by-R part of -C this array contains the updated matrix C. -C On exit with TRANS = 'T' or TRANS = 'C', the leading -C N*L-by-R part of this array contains the updated matrix C. -C -C LDC INTEGER -C The leading dimension of the array C. -C LDC >= MAX(1,M*K), if TRANS = 'N'; -C LDC >= MAX(1,N*L), if TRANS = 'T' or TRANS = 'C'. -C -C Workspace -C -C DWORK DOUBLE PRECISION array, dimension (LDWORK) -C On exit, if INFO = 0, DWORK(1) returns the optimal -C value of LDWORK. -C On exit, if INFO = -19, DWORK(1) returns the minimum -C value of LDWORK. -C -C LDWORK INTEGER -C The length of the array DWORK. LDWORK >= 1. -C For optimum performance LDWORK should be larger. -C -C Error Indicator -C -C INFO INTEGER -C = 0: successful exit; -C < 0: if INFO = -i, the i-th argument had an illegal -C value. -C -C METHOD -C -C For point Toeplitz matrices or sufficiently large block Toeplitz -C matrices, this algorithm uses convolution algorithms based on -C the fast Hartley transforms [1]. Otherwise, TC is copied in -C reversed order into the workspace such that C can be computed from -C barely M matrix-by-matrix multiplications. -C -C REFERENCES -C -C [1] Van Loan, Charles. -C Computational frameworks for the fast Fourier transform. -C SIAM, 1992. -C -C NUMERICAL ASPECTS -C -C The algorithm requires O( (K*L+R*L+K*R)*(N+M)*log(N+M) + K*L*R ) -C floating point operations. -C -C CONTRIBUTOR -C -C D. Kressner, Technical Univ. Berlin, Germany, May 2001. -C -C REVISIONS -C -C V. Sima, Research Institute for Informatics, Bucharest, June 2001, -C March 2004. -C -C KEYWORDS -C -C Convolution, elementary matrix operations, -C fast Hartley transform, Toeplitz matrix. -C -C ****************************************************************** -C -C .. Parameters .. - DOUBLE PRECISION ZERO, ONE, TWO, THREE, FOUR, THOM50 - PARAMETER ( ZERO = 0.0D0, ONE = 1.0D0, TWO = 2.0D0, - $ THREE = 3.0D0, FOUR = 4.0D0, THOM50 = .95D3 ) -C .. Scalar Arguments .. - CHARACTER LDBLK, TRANS - INTEGER INFO, K, L, LDB, LDC, LDTC, LDTR, LDWORK, M, N, - $ R - DOUBLE PRECISION ALPHA, BETA -C .. Array Arguments .. - DOUBLE PRECISION B(LDB,*), C(LDC,*), DWORK(*), TC(LDTC,*), - $ TR(LDTR,*) -C .. Local Scalars .. - LOGICAL FULLC, LMULT, LTRAN - CHARACTER*1 WGHT - INTEGER DIMB, DIMC, I, ICP, ICQ, IERR, IR, J, JJ, KK, - $ LEN, LL, LN, METH, MK, NL, P, P1, P2, PB, PC, - $ PDW, PP, PT, Q1, Q2, R1, R2, S1, S2, SHFT, WPOS, - $ WRKOPT - DOUBLE PRECISION CF, COEF, PARAM, SCAL, SF, T1, T2, TH -C .. External Functions .. - LOGICAL LSAME - EXTERNAL LSAME -C .. External Subroutines .. - EXTERNAL DAXPY, DCOPY, DG01OD, DGEMM, DLACPY, DLASET, - $ DSCAL, XERBLA -C .. Intrinsic Functions .. - INTRINSIC ATAN, COS, DBLE, MAX, MIN, SIN -C -C .. Executable Statements .. -C -C Decode the scalar input parameters. -C - INFO = 0 - FULLC = LSAME( LDBLK, 'C' ) - LTRAN = LSAME( TRANS, 'T' ) .OR. LSAME( TRANS, 'C' ) - LMULT = ALPHA.NE.ZERO - MK = M*K - NL = N*L -C -C Check the scalar input parameters. -C - IF ( .NOT.( FULLC .OR. LSAME( LDBLK, 'R' ) ) ) THEN - INFO = -1 - ELSE IF ( .NOT.( LTRAN .OR. LSAME( TRANS, 'N' ) ) ) THEN - INFO = -2 - ELSE IF ( K.LT.0 ) THEN - INFO = -3 - ELSE IF ( L.LT.0 ) THEN - INFO = -4 - ELSE IF ( M.LT.0 ) THEN - INFO = -5 - ELSE IF ( N.LT.0 ) THEN - INFO = -6 - ELSE IF ( R.LT.0 ) THEN - INFO = -7 - ELSE IF ( LMULT .AND. FULLC .AND. LDTC.LT.MAX( 1, MK ) ) THEN - INFO = -11 - ELSE IF ( LMULT .AND. .NOT.FULLC .AND. - $ LDTC.LT.MAX( 1,( M - 1 )*K ) ) THEN - INFO = -11 - ELSE IF ( LMULT .AND. LDTR.LT.MAX( 1, K ) ) THEN - INFO = -13 - ELSE IF ( LMULT .AND. .NOT.LTRAN .AND. LDB.LT.MAX( 1, NL ) ) THEN - INFO = -15 - ELSE IF ( LMULT .AND. LTRAN .AND. LDB.LT.MAX( 1, MK ) ) THEN - INFO = -15 - ELSE IF ( .NOT.LTRAN .AND. LDC.LT.MAX( 1, MK ) ) THEN - INFO = -17 - ELSE IF ( LTRAN .AND. LDC.LT.MAX( 1, NL ) ) THEN - INFO = -17 - ELSE IF ( LDWORK.LT.1 ) THEN - DWORK(1) = ONE - INFO = -19 - END IF -C -C Return if there were illegal values. -C - IF ( INFO.NE.0 ) THEN - CALL XERBLA( 'MB02KD', -INFO ) - RETURN - END IF -C -C Scale C beforehand. -C - IF ( BETA.EQ.ZERO ) THEN - IF ( LTRAN ) THEN - CALL DLASET( 'All', NL, R, ZERO, ZERO, C, LDC ) - ELSE - CALL DLASET( 'All', MK, R, ZERO, ZERO, C, LDC ) - END IF - ELSE IF ( BETA.NE.ONE ) THEN - IF ( LTRAN ) THEN -C - DO 10 I = 1, R - CALL DSCAL( NL, BETA, C(1,I), 1 ) - 10 CONTINUE -C - ELSE -C - DO 20 I = 1, R - CALL DSCAL( MK, BETA, C(1,I), 1 ) - 20 CONTINUE -C - END IF - END IF -C -C Quick return if possible. -C - IF ( .NOT.LMULT .OR. MIN( MK, NL, R ).EQ.0 ) THEN - DWORK(1) = ONE - RETURN - END IF -C -C The parameter PARAM is the watershed between conventional -C multiplication and convolution. This is of course depending -C on the used computer architecture. The lower this value is set -C the more likely the routine will use convolution to compute -C op( T )*B. Note that if there is enough workspace available, -C convolution is always used for point Toeplitz matrices. -C - PARAM = THOM50 -C -C Decide which method to choose, based on the block sizes and -C the available workspace. -C - LEN = 1 - P = 0 -C - 30 CONTINUE - IF ( LEN.LT.M+N-1 ) THEN - LEN = LEN*2 - P = P + 1 - GO TO 30 - END IF -C - COEF = THREE*DBLE( M*N )*DBLE( K*L )*DBLE( R ) / - $ DBLE( LEN*( K*L + L*R + K*R ) ) -C - IF ( FULLC ) THEN - P1 = MK*L - SHFT = 0 - ELSE - P1 = ( M - 1 )*K*L - SHFT = 1 - END IF - IF ( K*L.EQ.1 .AND. MIN( M, N ).GT.1 ) THEN - WRKOPT = LEN*( 2 + R ) - P - METH = 3 - ELSE IF ( ( LEN.LT.M*N ) .AND. ( COEF.GE.PARAM ) ) THEN - WRKOPT = LEN*( K*L + K*R + L*R + 1 ) - P - METH = 3 - ELSE - METH = 2 - WRKOPT = P1 - END IF -C - IF ( LDWORK.LT.WRKOPT ) METH = METH - 1 - IF ( LDWORK.LT.P1 ) METH = 1 -C -C Start computations. -C - IF ( METH.EQ.1 .AND. .NOT.LTRAN ) THEN -C -C Method 1 is the most unlucky way to multiply Toeplitz matrices -C with vectors. Due to the memory restrictions it is not -C possible to flip TC. -C - PC = 1 -C - DO 50 I = 1, M - PT = ( I - 1 - SHFT )*K + 1 - PB = 1 -C - DO 40 J = SHFT + 1, I - CALL DGEMM( 'No Transpose', 'No Transpose', K, R, L, - $ ALPHA, TC(PT,1), LDTC, B(PB,1), LDB, ONE, - $ C(PC,1), LDC ) - PT = PT - K - PB = PB + L - 40 CONTINUE -C - IF ( N.GT.I-SHFT ) THEN - CALL DGEMM( 'No Transpose', 'No Transpose', K, R, - $ (N-I+SHFT)*L, ALPHA, TR, LDTR, B(PB,1), LDB, - $ ONE, C(PC,1), LDC ) - END IF - PC = PC + K - 50 CONTINUE -C - ELSE IF ( METH.EQ.1 .AND. LTRAN ) THEN -C - PB = 1 -C - DO 70 I = 1, M - PT = ( I - 1 - SHFT )*K + 1 - PC = 1 -C - DO 60 J = SHFT + 1, I - CALL DGEMM( 'Transpose', 'No Transpose', L, R, K, ALPHA, - $ TC(PT,1), LDTC, B(PB,1), LDB, ONE, C(PC,1), - $ LDC ) - PT = PT - K - PC = PC + L - 60 CONTINUE -C - IF ( N.GT.I-SHFT ) THEN - CALL DGEMM( 'Transpose', 'No Transpose', (N-I+SHFT)*L, - $ R, K, ALPHA, TR, LDTR, B(PB,1), LDB, ONE, - $ C(PC,1), LDC ) - END IF - PB = PB + K - 70 CONTINUE -C - ELSE IF ( METH.EQ.2 .AND. .NOT.LTRAN ) THEN -C -C In method 2 TC is flipped resulting in less calls to the BLAS -C routine DGEMM. Actually this seems often to be the best way to -C multiply with Toeplitz matrices except the point Toeplitz -C case. -C - PT = ( M - 1 - SHFT )*K + 1 -C - DO 80 I = 1, ( M - SHFT )*K*L, K*L - CALL DLACPY( 'All', K, L, TC(PT,1), LDTC, DWORK(I), K ) - PT = PT - K - 80 CONTINUE -C - PT = ( M - 1 )*K*L + 1 - PC = 1 -C - DO 90 I = 1, M - CALL DGEMM( 'No Transpose', 'No Transpose', K, R, - $ MIN( I-SHFT, N )*L, ALPHA, DWORK(PT), K, B, LDB, - $ ONE, C(PC,1), LDC ) - IF ( N.GT.I-SHFT ) THEN - CALL DGEMM( 'No Transpose', 'No Transpose', K, R, - $ (N-I+SHFT)*L, ALPHA, TR, LDTR, - $ B((I-SHFT)*L+1,1), LDB, ONE, C(PC,1), LDC ) - END IF - PC = PC + K - PT = PT - K*L - 90 CONTINUE -C - ELSE IF ( METH.EQ.2 .AND. LTRAN ) THEN -C - PT = ( M - 1 - SHFT )*K + 1 -C - DO 100 I = 1, ( M - SHFT )*K*L, K*L - CALL DLACPY( 'All', K, L, TC(PT,1), LDTC, DWORK(I), K ) - PT = PT - K - 100 CONTINUE -C - PT = ( M - 1 )*K*L + 1 - PB = 1 -C - DO 110 I = 1, M - CALL DGEMM( 'Tranpose', 'No Transpose', MIN( I-SHFT, N )*L, - $ R, K, ALPHA, DWORK(PT), K, B(PB,1), LDB, ONE, - $ C, LDC ) - IF ( N.GT.I-SHFT ) THEN - CALL DGEMM( 'Transpose', 'No Transpose', (N-I+SHFT)*L, R, - $ K, ALPHA, TR, LDTR, B(PB,1), LDB, ONE, - $ C((I-SHFT)*L+1,1), LDC ) - END IF - PB = PB + K - PT = PT - K*L - 110 CONTINUE -C - ELSE IF ( METH.EQ.3 ) THEN -C -C In method 3 the matrix-vector product is computed by a suitable -C block convolution via fast Hartley transforms similar to the -C SLICOT routine DE01PD. -C -C Step 1: Copy input data into the workspace arrays. -C - PDW = 1 - IF ( LTRAN ) THEN - DIMB = K - DIMC = L - ELSE - DIMB = L - DIMC = K - END IF - PB = LEN*K*L - PC = LEN*( K*L + DIMB*R ) - IF ( LTRAN ) THEN - IF ( FULLC ) THEN - CALL DLACPY( 'All', K, L, TC, LDTC, DWORK, LEN*K ) - END IF -C - DO 120 I = 1, N - 1 + SHFT - CALL DLACPY( 'All', K, L, TR(1,(I-1)*L+1), LDTR, - $ DWORK((I-SHFT)*K+1), LEN*K ) - 120 CONTINUE -C - PDW = N*K + 1 - R1 = ( LEN - M - N + 1 )*K - CALL DLASET( 'All', R1, L, ZERO, ZERO, DWORK(PDW), LEN*K ) - PDW = PDW + R1 -C - DO 130 I = ( M - 1 - SHFT )*K + 1, K - SHFT*K + 1, -K - CALL DLACPY( 'All', K, L, TC(I,1), LDTC, - $ DWORK(PDW), LEN*K ) - PDW = PDW + K - 130 CONTINUE -C - PDW = PB + 1 - CALL DLACPY( 'All', MK, R, B, LDB, DWORK(PDW), LEN*K ) - PDW = PDW + MK - CALL DLASET( 'All', (LEN-M)*K, R, ZERO, ZERO, DWORK(PDW), - $ LEN*K ) - ELSE - IF ( .NOT.FULLC ) THEN - CALL DLACPY( 'All', K, L, TR, LDTR, DWORK, LEN*K ) - END IF - CALL DLACPY( 'All', (M-SHFT)*K, L, TC, LDTC, - $ DWORK(SHFT*K+1), LEN*K ) - PDW = MK + 1 - R1 = ( LEN - M - N + 1 )*K - CALL DLASET( 'All', R1, L, ZERO, ZERO, DWORK(PDW), LEN*K ) - PDW = PDW + R1 -C - DO 140 I = ( N - 2 + SHFT )*L + 1, SHFT*L + 1, -L - CALL DLACPY( 'All', K, L, TR(1,I), LDTR, DWORK(PDW), - $ LEN*K ) - PDW = PDW + K - 140 CONTINUE -C - PDW = PB + 1 - CALL DLACPY( 'All', NL, R, B, LDB, DWORK(PDW), LEN*L ) - PDW = PDW + NL - CALL DLASET( 'All', (LEN-N)*L, R, ZERO, ZERO, DWORK(PDW), - $ LEN*L ) - END IF -C -C Take point Toeplitz matrices into extra consideration. -C - IF ( K*L.EQ.1 ) THEN - WGHT = 'N' - CALL DG01OD( 'OutputScrambled', WGHT, LEN, DWORK, - $ DWORK(PC+1), IERR ) -C - DO 170 I = PB, PB + LEN*R - 1, LEN - CALL DG01OD( 'OutputScrambled', WGHT, LEN, DWORK(I+1), - $ DWORK(PC+1), IERR ) - SCAL = ALPHA / DBLE( LEN ) - DWORK(I+1) = SCAL*DWORK(I+1)*DWORK(1) - DWORK(I+2) = SCAL*DWORK(I+2)*DWORK(2) - SCAL = SCAL / TWO -C - LN = 1 -C - DO 160 LL = 1, P - 1 - LN = 2*LN - R1 = 2*LN -C - DO 150 P1 = LN + 1, LN + LN/2 - T1 = DWORK(P1) + DWORK(R1) - T2 = DWORK(P1) - DWORK(R1) - TH = T2*DWORK(I+P1) - DWORK(I+P1) = SCAL*( T1*DWORK(I+P1) - $ + T2*DWORK(I+R1) ) - DWORK(I+R1) = SCAL*( T1*DWORK(I+R1) - TH ) - R1 = R1 - 1 - 150 CONTINUE -C - 160 CONTINUE -C - CALL DG01OD( 'InputScrambled', WGHT, LEN, DWORK(I+1), - $ DWORK(PC+1), IERR ) - 170 CONTINUE -C - PC = PB - GOTO 420 - END IF -C -C Step 2: Compute the weights for the Hartley transforms. -C - PDW = PC - R1 = 1 - LN = 1 - TH = FOUR*ATAN( ONE ) / DBLE( LEN ) -C - DO 190 LL = 1, P - 2 - LN = 2*LN - TH = TWO*TH - CF = COS( TH ) - SF = SIN( TH ) - DWORK(PDW+R1) = CF - DWORK(PDW+R1+1) = SF - R1 = R1 + 2 -C - DO 180 I = 1, LN-2, 2 - DWORK(PDW+R1) = CF*DWORK(PDW+I) - SF*DWORK(PDW+I+1) - DWORK(PDW+R1+1) = SF*DWORK(PDW+I) + CF*DWORK(PDW+I+1) - R1 = R1 + 2 - 180 CONTINUE -C - 190 CONTINUE -C - P1 = 3 - Q1 = R1 - 2 -C - DO 210 LL = P - 2, 1, -1 -C - DO 200 I = P1, Q1, 4 - DWORK(PDW+R1) = DWORK(PDW+I) - DWORK(PDW+R1+1) = DWORK(PDW+I+1) - R1 = R1 + 2 - 200 CONTINUE -C - P1 = Q1 + 4 - Q1 = R1 - 2 - 210 CONTINUE -C -C Step 3: Compute the Hartley transforms with scrambled output. -C - J = 0 - KK = K -C -C WHILE J < (L*LEN*K + R*LEN*DIMB), -C - 220 CONTINUE -C - LN = LEN - WPOS = PDW+1 -C - DO 270 PP = P - 1, 1, -1 - LN = LN / 2 - P2 = 1 - Q2 = LN*KK + 1 - R2 = ( LN/2 )*KK + 1 - S2 = R2 + Q2 - 1 -C - DO 260 I = 0, LEN/( 2*LN ) - 1 -C - DO 230 IR = 0, KK - 1 - T1 = DWORK(Q2+IR+J) - DWORK(Q2+IR+J) = DWORK(P2+IR+J) - T1 - DWORK(P2+IR+J) = DWORK(P2+IR+J) + T1 - T1 = DWORK(S2+IR+J) - DWORK(S2+IR+J) = DWORK(R2+IR+J) - T1 - DWORK(R2+IR+J) = DWORK(R2+IR+J) + T1 - 230 CONTINUE -C - P1 = P2 + KK - Q1 = P1 + LN*KK - R1 = Q1 - 2*KK - S1 = R1 + LN*KK -C - DO 250 JJ = WPOS, WPOS + LN - 3, 2 - CF = DWORK(JJ) - SF = DWORK(JJ+1) -C - DO 240 IR = 0, KK-1 - T1 = DWORK(P1+IR+J) - DWORK(Q1+IR+J) - T2 = DWORK(R1+IR+J) - DWORK(S1+IR+J) - DWORK(P1+IR+J) = DWORK(P1+IR+J) + - $ DWORK(Q1+IR+J) - DWORK(R1+IR+J) = DWORK(R1+IR+J) + - $ DWORK(S1+IR+J) - DWORK(Q1+IR+J) = CF*T1 + SF*T2 - DWORK(S1+IR+J) = -CF*T2 + SF*T1 - 240 CONTINUE -C - P1 = P1 + KK - Q1 = Q1 + KK - R1 = R1 - KK - S1 = S1 - KK - 250 CONTINUE -C - P2 = P2 + 2*KK*LN - Q2 = Q2 + 2*KK*LN - R2 = R2 + 2*KK*LN - S2 = S2 + 2*KK*LN - 260 CONTINUE -C - WPOS = WPOS + LN - 2 - 270 CONTINUE -C - DO 290 ICP = KK + 1, LEN*KK, 2*KK - ICQ = ICP - KK -C - DO 280 IR = 0, KK - 1 - T1 = DWORK(ICP+IR+J) - DWORK(ICP+IR+J) = DWORK(ICQ+IR+J) - T1 - DWORK(ICQ+IR+J) = DWORK(ICQ+IR+J) + T1 - 280 CONTINUE -C - 290 CONTINUE -C - J = J + LEN*KK - IF ( J.EQ.L*LEN*K ) THEN - KK = DIMB - END IF - IF ( J.LT.PC ) GOTO 220 -C END WHILE 220 -C -C Step 4: Compute a Hadamard like product. -C - CALL DCOPY( LEN-P, DWORK(PDW+1), 1,DWORK(PDW+1+R*LEN*DIMC), 1 ) - PDW = PDW + R*LEN*DIMC - SCAL = ALPHA / DBLE( LEN ) - P1 = 1 - R1 = LEN*K*L + 1 - S1 = R1 + LEN*DIMB*R - IF ( LTRAN ) THEN - KK = L - LL = K - ELSE - KK = K - LL = L - END IF - CALL DGEMM( TRANS, 'No Transpose', KK, R, LL, SCAL, DWORK(P1), - $ LEN*K, DWORK(R1), LEN*DIMB, ZERO, DWORK(S1), - $ LEN*DIMC ) - P1 = P1 + K - R1 = R1 + DIMB - S1 = S1 + DIMC - CALL DGEMM( TRANS, 'No Transpose', KK, R, LL, SCAL, DWORK(P1), - $ LEN*K, DWORK(R1), LEN*DIMB, ZERO, DWORK(S1), - $ LEN*DIMC ) - SCAL = SCAL / TWO - LN = 1 -C - DO 330 PP = 1, P - 1 - LN = 2*LN - P2 = ( 2*LN - 1 )*K + 1 - R1 = PB + LN*DIMB + 1 - R2 = PB + ( 2*LN - 1 )*DIMB + 1 - S1 = PC + LN*DIMC + 1 - S2 = PC + ( 2*LN - 1 )*DIMC + 1 -C - DO 320 P1 = LN*K + 1, ( LN + LN/2 )*K, K -C - DO 310 J = 0, LEN*K*( L - 1 ), LEN*K -C - DO 300 I = P1, P1 + K - 1 - T1 = DWORK(P2) - DWORK(P2) = DWORK(J+I) - T1 - DWORK(J+I) = DWORK(J+I) + T1 - P2 = P2 + 1 - 300 CONTINUE -C - P2 = P2 + ( LEN - 1 )*K - 310 CONTINUE -C - P2 = P2 - LEN*K*L - CALL DGEMM( TRANS, 'No Transpose', KK, R, LL, SCAL, - $ DWORK(P1), LEN*K, DWORK(R1), LEN*DIMB, - $ ZERO, DWORK(S1), LEN*DIMC ) - CALL DGEMM( TRANS, 'No Transpose', KK, R, LL, SCAL, - $ DWORK(P2), LEN*K, DWORK(R2), LEN*DIMB, ONE, - $ DWORK(S1), LEN*DIMC ) - CALL DGEMM( TRANS, 'No Transpose', KK, R, LL, SCAL, - $ DWORK(P1), LEN*K, DWORK(R2), LEN*DIMB, ZERO, - $ DWORK(S2), LEN*DIMC ) - CALL DGEMM( TRANS, 'No Transpose', KK, R, LL, -SCAL, - $ DWORK(P2), LEN*K, DWORK(R1), LEN*DIMB, ONE, - $ DWORK(S2), LEN*DIMC ) - P2 = P2 - K - R1 = R1 + DIMB - R2 = R2 - DIMB - S1 = S1 + DIMC - S2 = S2 - DIMC - 320 CONTINUE -C - 330 CONTINUE -C -C Step 5: Hartley transform with scrambled input. -C - DO 410 J = PC, PC + LEN*DIMC*R, LEN*DIMC -C - DO 350 ICP = DIMC + 1, LEN*DIMC, 2*DIMC - ICQ = ICP - DIMC -C - DO 340 IR = 0, DIMC - 1 - T1 = DWORK(ICP+IR+J) - DWORK(ICP+IR+J) = DWORK(ICQ+IR+J) - T1 - DWORK(ICQ+IR+J) = DWORK(ICQ+IR+J) + T1 - 340 CONTINUE -C - 350 CONTINUE -C - LN = 1 - WPOS = PDW + LEN - 2*P + 1 -C - DO 400 PP = 1, P - 1 - LN = 2*LN - P2 = 1 - Q2 = LN*DIMC + 1 - R2 = ( LN/2 )*DIMC + 1 - S2 = R2 + Q2 - 1 -C - DO 390 I = 0, LEN/( 2*LN ) - 1 -C - DO 360 IR = 0, DIMC - 1 - T1 = DWORK(Q2+IR +J) - DWORK(Q2+IR+J) = DWORK(P2+IR+J) - T1 - DWORK(P2+IR+J) = DWORK(P2+IR+J) + T1 - T1 = DWORK(S2+IR+J) - DWORK(S2+IR+J) = DWORK(R2+IR+J) - T1 - DWORK(R2+IR+J) = DWORK(R2+IR+J) + T1 - 360 CONTINUE -C - P1 = P2 + DIMC - Q1 = P1 + LN*DIMC - R1 = Q1 - 2*DIMC - S1 = R1 + LN*DIMC -C - DO 380 JJ = WPOS, WPOS + LN - 3, 2 - CF = DWORK(JJ) - SF = DWORK(JJ+1) -C - DO 370 IR = 0, DIMC - 1 - T1 = CF*DWORK(Q1+IR+J) + SF*DWORK(S1+IR+J) - T2 = -CF*DWORK(S1+IR+J) + SF*DWORK(Q1+IR+J) - DWORK(Q1+IR+J) = DWORK(P1+IR+J) - T1 - DWORK(P1+IR+J) = DWORK(P1+IR+J) + T1 - DWORK(S1+IR+J) = DWORK(R1+IR+J) - T2 - DWORK(R1+IR+J) = DWORK(R1+IR+J) + T2 - 370 CONTINUE -C - P1 = P1 + DIMC - Q1 = Q1 + DIMC - R1 = R1 - DIMC - S1 = S1 - DIMC - 380 CONTINUE -C - P2 = P2 + 2*DIMC*LN - Q2 = Q2 + 2*DIMC*LN - R2 = R2 + 2*DIMC*LN - S2 = S2 + 2*DIMC*LN - 390 CONTINUE -C - WPOS = WPOS - 2*LN + 2 - 400 CONTINUE -C - 410 CONTINUE -C -C Step 6: Copy data from workspace to output. -C - 420 CONTINUE -C - IF ( LTRAN ) THEN - I = NL - ELSE - I = MK - END IF -C - DO 430 J = 0, R - 1 - CALL DAXPY( I, ONE, DWORK(PC+(J*LEN*DIMC) + 1), 1, - $ C(1,J+1), 1 ) - 430 CONTINUE -C - END IF - DWORK(1) = DBLE( MAX( 1, WRKOPT ) ) - RETURN -C -C *** Last line of MB02KD *** - END diff --git a/mex/sources/libslicot/MB02MD.f b/mex/sources/libslicot/MB02MD.f deleted file mode 100644 index 28cbdadaa..000000000 --- a/mex/sources/libslicot/MB02MD.f +++ /dev/null @@ -1,577 +0,0 @@ - SUBROUTINE MB02MD( JOB, M, N, L, RANK, C, LDC, S, X, LDX, TOL, - $ IWORK, DWORK, LDWORK, IWARN, INFO ) -C -C SLICOT RELEASE 5.0. -C -C Copyright (c) 2002-2009 NICONET e.V. -C -C This program is free software: you can redistribute it and/or -C modify it under the terms of the GNU General Public License as -C published by the Free Software Foundation, either version 2 of -C the License, or (at your option) any later version. -C -C This program is distributed in the hope that it will be useful, -C but WITHOUT ANY WARRANTY; without even the implied warranty of -C MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the -C GNU General Public License for more details. -C -C You should have received a copy of the GNU General Public License -C along with this program. If not, see -C . -C -C PURPOSE -C -C To solve the Total Least Squares (TLS) problem using a Singular -C Value Decomposition (SVD) approach. -C The TLS problem assumes an overdetermined set of linear equations -C AX = B, where both the data matrix A as well as the observation -C matrix B are inaccurate. The routine also solves determined and -C underdetermined sets of equations by computing the minimum norm -C solution. -C It is assumed that all preprocessing measures (scaling, coordinate -C transformations, whitening, ... ) of the data have been performed -C in advance. -C -C ARGUMENTS -C -C Mode Parameters -C -C JOB CHARACTER*1 -C Determines whether the values of the parameters RANK and -C TOL are to be specified by the user or computed by the -C routine as follows: -C = 'R': Compute RANK only; -C = 'T': Compute TOL only; -C = 'B': Compute both RANK and TOL; -C = 'N': Compute neither RANK nor TOL. -C -C Input/Output Parameters -C -C M (input) INTEGER -C The number of rows in the data matrix A and the -C observation matrix B. M >= 0. -C -C N (input) INTEGER -C The number of columns in the data matrix A. N >= 0. -C -C L (input) INTEGER -C The number of columns in the observation matrix B. -C L >= 0. -C -C RANK (input/output) INTEGER -C On entry, if JOB = 'T' or JOB = 'N', then RANK must -C specify r, the rank of the TLS approximation [A+DA|B+DB]. -C RANK <= min(M,N). -C Otherwise, r is computed by the routine. -C On exit, if JOB = 'R' or JOB = 'B', and INFO = 0, then -C RANK contains the computed (effective) rank of the TLS -C approximation [A+DA|B+DB]. -C Otherwise, the user-supplied value of RANK may be -C changed by the routine on exit if the RANK-th and the -C (RANK+1)-th singular values of C = [A|B] are considered -C to be equal, or if the upper triangular matrix F (as -C defined in METHOD) is (numerically) singular. -C -C C (input/output) DOUBLE PRECISION array, dimension (LDC,N+L) -C On entry, the leading M-by-(N+L) part of this array must -C contain the matrices A and B. Specifically, the first N -C columns must contain the data matrix A and the last L -C columns the observation matrix B (right-hand sides). -C On exit, the leading (N+L)-by-(N+L) part of this array -C contains the (transformed) right singular vectors, -C including null space vectors, if any, of C = [A|B]. -C Specifically, the leading (N+L)-by-RANK part of this array -C always contains the first RANK right singular vectors, -C corresponding to the largest singular values of C. If -C L = 0, or if RANK = 0 and IWARN <> 2, the remaining -C (N+L)-by-(N+L-RANK) top-right part of this array contains -C the remaining N+L-RANK right singular vectors. Otherwise, -C this part contains the matrix V2 transformed as described -C in Step 3 of the TLS algorithm (see METHOD). -C -C LDC INTEGER -C The leading dimension of array C. LDC >= max(1,M,N+L). -C -C S (output) DOUBLE PRECISION array, dimension (min(M,N+L)) -C If INFO = 0, the singular values of matrix C, ordered -C such that S(1) >= S(2) >= ... >= S(p-1) >= S(p) >= 0, -C where p = min(M,N+L). -C -C X (output) DOUBLE PRECISION array, dimension (LDX,L) -C If INFO = 0, the leading N-by-L part of this array -C contains the solution X to the TLS problem specified -C by A and B. -C -C LDX INTEGER -C The leading dimension of array X. LDX >= max(1,N). -C -C Tolerances -C -C TOL DOUBLE PRECISION -C A tolerance used to determine the rank of the TLS -C approximation [A+DA|B+DB] and to check the multiplicity -C of the singular values of matrix C. Specifically, S(i) -C and S(j) (i < j) are considered to be equal if -C SQRT(S(i)**2 - S(j)**2) <= TOL, and the TLS approximation -C [A+DA|B+DB] has rank r if S(i) > TOL*S(1) (or S(i) > TOL, -C if TOL specifies sdev (see below)), for i = 1,2,...,r. -C TOL is also used to check the singularity of the upper -C triangular matrix F (as defined in METHOD). -C If JOB = 'R' or JOB = 'N', then TOL must specify the -C desired tolerance. If the user sets TOL to be less than or -C equal to 0, the tolerance is taken as EPS, where EPS is -C the machine precision (see LAPACK Library routine DLAMCH). -C Otherwise, the tolerance is computed by the routine and -C the user must supply the non-negative value sdev, i.e. the -C estimated standard deviation of the error on each element -C of the matrix C, as input value of TOL. -C -C Workspace -C -C IWORK INTEGER array, dimension (L) -C -C DWORK DOUBLE PRECISION array, dimension (LDWORK) -C On exit, if INFO = 0, DWORK(1) returns the optimal value -C of LDWORK, and DWORK(2) returns the reciprocal of the -C condition number of the matrix F. -C If INFO > 0, DWORK(1:min(M,N+L)-1) contain the unconverged -C non-diagonal elements of the bidiagonal matrix whose -C diagonal is in S (see LAPACK Library routine DGESVD). -C -C LDWORK INTEGER -C The length of the array DWORK. -C LDWORK = max(2, 3*(N+L) + M, 5*(N+L)), if M >= N+L; -C LDWORK = max(2, M*(N+L) + max( 3M+N+L, 5*M), 3*L), -C if M < N+L. -C For optimum performance LDWORK should be larger. -C -C Warning Indicator -C -C IWARN INTEGER -C = 0: no warnings; -C = 1: if the rank of matrix C has been lowered because a -C singular value of multiplicity greater than 1 was -C found; -C = 2: if the rank of matrix C has been lowered because the -C upper triangular matrix F is (numerically) singular. -C -C Error Indicator -C -C INFO INTEGER -C = 0: successful exit; -C < 0: if INFO = -i, the i-th argument had an illegal -C value; -C > 0: if the SVD algorithm (in LAPACK Library routine -C DBDSQR) has failed to converge. In this case, S(1), -C S(2), ..., S(INFO) may not have been found -C correctly and the remaining singular values may -C not be the smallest. This failure is not likely -C to occur. -C -C METHOD -C -C The method used is an extension (see [3,4,5]) of the classical -C TLS algorithm proposed by Golub and Van Loan [1]. -C -C Let [A|B] denote the matrix formed by adjoining the columns of B -C to the columns of A on the right. -C -C Total Least Squares (TLS) definition: -C ------------------------------------- -C -C Given matrices A and B, find a matrix X satisfying -C -C (A + DA) X = B + DB, -C -C where A and DA are M-by-N matrices, B and DB are M-by-L matrices -C and X is an N-by-L matrix. -C The solution X must be such that the Frobenius norm of [DA|DB] -C is a minimum and each column of B + DB is in the range of -C A + DA. Whenever the solution is not unique, the routine singles -C out the minimum norm solution X. -C -C Define matrix C = [A|B] and s(i) as its i-th singular value for -C i = 1,2,...,min(M,NL), where NL = N + L. If M < NL, then s(j) = 0 -C for j = M+1,...,NL. -C -C The Classical TLS algorithm proceeds as follows (see [3,4,5]): -C -C Step 1: Compute part of the singular value decomposition (SVD) -C USV' of C = [A|B], namely compute S and V'. (An initial -C QR factorization of C is used when M is larger enough -C than NL.) -C -C Step 2: If not fixed by the user, compute the rank r0 of the data -C [A|B] based on TOL as follows: if JOB = 'R' or JOB = 'N', -C -C s(1) >= ... >= s(r0) > TOL*s(1) >= ... >= s(NL). -C -C Otherwise, using [2], TOL can be computed from the -C standard deviation sdev of the errors on [A|B]: -C -C TOL = SQRT(2 * max(M,NL)) * sdev, -C -C and the rank r0 is determined (if JOB = 'R' or 'B') using -C -C s(1) >= ... >= s(r0) > TOL >= ... >= s(NL). -C -C The rank r of the approximation [A+DA|B+DB] is then equal -C to the minimum of N and r0. -C -C Step 3: Let V2 be the matrix of the columns of V corresponding to -C the (NL - r) smallest singular values of C, i.e. the last -C (NL - r) columns of V. -C Compute with Householder transformations the orthogonal -C matrix Q such that: -C -C |VH Y| -C V2 x Q = | | -C |0 F| -C -C where VH is an N-by-(N - r) matrix, Y is an N-by-L matrix -C and F is an L-by-L upper triangular matrix. -C If F is singular, then lower the rank r with the -C multiplicity of s(r) and repeat this step. -C -C Step 4: If F is nonsingular then the solution X is obtained by -C solving the following equations by forward elimination: -C -C X F = -Y. -C -C Notes : -C The TLS solution is unique if r = N, F is nonsingular and -C s(N) > s(N+1). -C If F is singular, however, then the computed solution is infinite -C and hence does not satisfy the second TLS criterion (see TLS -C definition). For these cases, Golub and Van Loan [1] claim that -C the TLS problem has no solution. The properties of these so-called -C nongeneric problems are described in [4] and the TLS computations -C are generalized in order to solve them. As proven in [4], the -C proposed generalization satisfies the TLS criteria for any -C number L of observation vectors in B provided that, in addition, -C the solution | X| is constrained to be orthogonal to all vectors -C |-I| -C of the form |w| which belong to the space generated by the columns -C |0| -C of the submatrix |Y|. -C |F| -C -C REFERENCES -C -C [1] Golub, G.H. and Van Loan, C.F. -C An Analysis of the Total Least-Squares Problem. -C SIAM J. Numer. Anal., 17, pp. 883-893, 1980. -C -C [2] Staar, J., Vandewalle, J. and Wemans, M. -C Realization of Truncated Impulse Response Sequences with -C Prescribed Uncertainty. -C Proc. 8th IFAC World Congress, Kyoto, I, pp. 7-12, 1981. -C -C [3] Van Huffel, S. -C Analysis of the Total Least Squares Problem and its Use in -C Parameter Estimation. -C Doctoral dissertation, Dept. of Electr. Eng., Katholieke -C Universiteit Leuven, Belgium, June 1987. -C -C [4] Van Huffel, S. and Vandewalle, J. -C Analysis and Solution of the Nongeneric Total Least Squares -C Problem. -C SIAM J. Matr. Anal. and Appl., 9, pp. 360-372, 1988. -C -C [5] Van Huffel, S. and Vandewalle, J. -C The Total Least Squares Problem: Computational Aspects and -C Analysis. -C Series "Frontiers in Applied Mathematics", Vol. 9, -C SIAM, Philadelphia, 1991. -C -C NUMERICAL ASPECTS -C -C The algorithm consists in (backward) stable steps. -C -C CONTRIBUTOR -C -C Release 3.0: V. Sima, Katholieke Univ. Leuven, Belgium, Apr. 1997. -C Supersedes Release 2.0 routine MB02AD by S. Van Huffel, Katholieke -C University, Leuven, Belgium. -C -C REVISIONS -C -C June 24, 1997, Feb. 27, 2000, Oct. 19, 2003, Feb. 21, 2004. -C -C KEYWORDS -C -C Least-squares approximation, singular subspace, singular value -C decomposition, singular values, total least-squares. -C -C ****************************************************************** -C -C .. Parameters .. - DOUBLE PRECISION ZERO, ONE, TWO - PARAMETER ( ZERO = 0.0D0, ONE = 1.0D0, TWO = 2.0D0 ) -C .. Scalar Arguments .. - CHARACTER JOB - INTEGER INFO, IWARN, L, LDC, LDWORK, LDX, M, N, RANK - DOUBLE PRECISION TOL -C .. Array Arguments .. - INTEGER IWORK(*) - DOUBLE PRECISION C(LDC,*), DWORK(*), S(*), X(LDX,*) -C .. Local Scalars .. - LOGICAL CRANK, CTOL, LJOBN, LJOBR, LJOBT - INTEGER ITAU, J, JWORK, LDW, K, MINMNL, N1, NL, P, R1, - $ WRKOPT - DOUBLE PRECISION FNORM, RCOND, SMAX, TOLTMP -C .. External Functions .. - LOGICAL LSAME - DOUBLE PRECISION DLAMCH, DLANGE, DLANTR - EXTERNAL DLAMCH, DLANGE, DLANTR, LSAME -C .. External Subroutines .. - EXTERNAL DGERQF, DGESVD, DLACPY, DLASET, DORMRQ, DSWAP, - $ DTRCON, DTRSM, XERBLA -C .. Intrinsic Functions .. - INTRINSIC DBLE, INT, MAX, MIN, SQRT -C .. Executable Statements .. -C - IWARN = 0 - INFO = 0 - NL = N + L - K = MAX( M, NL ) - P = MIN( M, N ) - MINMNL = MIN( M, NL ) - LDW = MAX( 3*MINMNL + K, 5*MINMNL ) - LJOBR = LSAME( JOB, 'R' ) - LJOBT = LSAME( JOB, 'T' ) - LJOBN = LSAME( JOB, 'N' ) -C -C Determine whether RANK or/and TOL is/are to be computed. -C - CRANK = .NOT.LJOBT .AND. .NOT.LJOBN - CTOL = .NOT.LJOBR .AND. .NOT.LJOBN -C -C Test the input scalar arguments. -C - IF( CTOL .AND. CRANK .AND. .NOT.LSAME( JOB, 'B' ) ) THEN - INFO = -1 - ELSE IF( M.LT.0 ) THEN - INFO = -2 - ELSE IF( N.LT.0 ) THEN - INFO = -3 - ELSE IF( L.LT.0 ) THEN - INFO = -4 - ELSE IF( .NOT.CRANK .AND. RANK.GT.P ) THEN - INFO = -5 - ELSE IF( LDC.LT.MAX( 1, K ) ) THEN - INFO = -7 - ELSE IF( LDX.LT.MAX( 1, N ) ) THEN - INFO = -10 - ELSE IF( CTOL .AND. TOL.LT.ZERO ) THEN - INFO = -11 - ELSE IF( ( M.GE.NL .AND. LDWORK.LT.MAX( 2, LDW ) ).OR. - $ ( M.LT.NL .AND. LDWORK.LT.MAX( 2, M*NL + LDW, 3*L ) ) ) - $ THEN - INFO = -14 - END IF -C - IF ( INFO.NE.0 ) THEN -C -C Error return. -C - CALL XERBLA( 'MB02MD', -INFO ) - RETURN - END IF -C -C Quick return if possible. -C - IF ( CRANK ) - $ RANK = P - IF ( MIN( M, NL ).EQ.0 ) THEN - IF ( M.EQ.0 ) THEN - CALL DLASET( 'Full', NL, NL, ZERO, ONE, C, LDC ) - CALL DLASET( 'Full', N, L, ZERO, ZERO, X, LDX ) - END IF - DWORK(1) = TWO - DWORK(2) = ONE - RETURN - END IF -C -C Subroutine MB02MD solves a set of linear equations by a Total -C Least Squares Approximation. -C -C Step 1: Compute part of the singular value decomposition (SVD) -C USV' of C = [A |B ], namely compute S and V'. -C M,N M,L -C -C (Note: Comments in the code beginning "Workspace:" describe the -C minimal amount of real workspace needed at that point in the -C code, as well as the preferred amount for good performance. -C NB refers to the optimal block size for the immediately -C following subroutine, as returned by ILAENV.) -C - IF ( M.GE.NL ) THEN -C -C M >= N + L: Overwrite V' on C. -C Workspace: need max(3*min(M,N+L) + max(M,N+L), 5*min(M,N+L)). -C - JWORK = 1 - CALL DGESVD( 'No left vectors', 'Overwritten on C', M, NL, C, - $ LDC, S, DWORK, 1, DWORK, 1, DWORK(JWORK), - $ LDWORK-JWORK+1, INFO ) - ELSE -C -C M < N + L: Save C in the workspace and compute V' in C. -C Note that the previous DGESVD call cannot be used in this case. -C Workspace: need M*(N+L) + max(3*min(M,N+L) + max(M,N+L), -C 5*min(M,N+L)). -C - CALL DLACPY( 'Full', M, NL, C, LDC, DWORK, M ) - JWORK = M*NL + 1 - CALL DGESVD( 'No left vectors', 'All right vectors', M, NL, - $ DWORK, M, S, DWORK, 1, C, LDC, DWORK(JWORK), - $ LDWORK-JWORK+1, INFO ) - END IF -C - IF ( INFO.GT.0 ) THEN -C -C Save the unconverged non-diagonal elements of the bidiagonal -C matrix and exit. -C - DO 10 J = 1, MINMNL - 1 - DWORK(J) = DWORK(JWORK+J) - 10 CONTINUE -C - RETURN - END IF - WRKOPT = MAX( 2, INT( DWORK(JWORK) ) + JWORK - 1 ) -C -C Transpose V' in-situ (in C). -C - DO 20 J = 2, NL - CALL DSWAP( J-1, C(J,1), LDC, C(1,J), 1 ) - 20 CONTINUE -C -C Step 2: Compute the rank of the approximation [A+DA|B+DB]. -C - IF ( CTOL ) THEN - TOLTMP = SQRT( TWO*DBLE( K ) )*TOL - SMAX = TOLTMP - ELSE - TOLTMP = TOL - IF ( TOLTMP.LE.ZERO ) TOLTMP = DLAMCH( 'Precision' ) - SMAX = MAX( TOLTMP*S(1), DLAMCH( 'Safe minimum' ) ) - END IF -C - IF ( CRANK ) THEN -C WHILE ( RANK .GT. 0 ) .AND. ( S(RANK) .LE. SMAX ) DO - 40 IF ( RANK.GT.0 ) THEN - IF ( S(RANK).LE.SMAX ) THEN - RANK = RANK - 1 - GO TO 40 - END IF - END IF -C END WHILE 40 - END IF -C - IF ( L.EQ.0 ) THEN - DWORK(1) = WRKOPT - DWORK(2) = ONE - RETURN - END IF -C - N1 = N + 1 - ITAU = 1 - JWORK = ITAU + L -C -C Step 3: Compute the orthogonal matrix Q and matrices F and Y -C such that F is nonsingular. -C -C REPEAT -C -C Adjust the rank if S(RANK) has multiplicity greater than 1. -C - 60 CONTINUE - R1 = RANK + 1 - IF ( RANK.LT.MINMNL ) THEN -C WHILE RANK.GT.0 .AND. S(RANK)**2 - S(R1)**2.LE.TOL**2 DO - 80 IF ( RANK.GT.0 ) THEN - IF ( ONE - ( S(R1)/S(RANK) )**2.LE.( TOLTMP/S(RANK) )**2 - $ ) THEN - RANK = RANK - 1 - IWARN = 1 - GO TO 80 - END IF - END IF -C END WHILE 80 - END IF -C - IF ( RANK.EQ.0 ) THEN -C -C Return zero solution. -C - CALL DLASET( 'Full', N, L, ZERO, ZERO, X, LDX ) - DWORK(1) = WRKOPT - DWORK(2) = ONE - RETURN - END IF -C -C Compute the orthogonal matrix Q (in factorized form) and the -C matrices F and Y using RQ factorization. It is assumed that, -C generically, the last L rows of V2 matrix have full rank. -C The code could not be the most efficient one when RANK has been -C lowered, because the already created zero pattern of the last -C L rows of V2 matrix is not exploited. -C Workspace: need 2*L; prefer L + L*NB. -C - R1 = RANK + 1 - CALL DGERQF( L, NL-RANK, C(N1,R1), LDC, DWORK(ITAU), - $ DWORK(JWORK), LDWORK-JWORK+1, INFO ) - WRKOPT = MAX( WRKOPT, INT( DWORK(JWORK) )+JWORK-1 ) -C -C Workspace: need N+L; prefer L + N*NB. -C - CALL DORMRQ( 'Right', 'Transpose', N, NL-RANK, L, C(N1,R1), - $ LDC, DWORK(ITAU), C(1,R1), LDC, DWORK(JWORK), - $ LDWORK-JWORK+1, INFO ) - WRKOPT = MAX( WRKOPT, INT( DWORK(JWORK) )+JWORK-1 ) -C - CALL DLASET( 'Full', L, N-RANK, ZERO, ZERO, C(N1,R1), LDC ) - IF ( L.GT.1 ) - $ CALL DLASET( 'Lower', L-1, L-1, ZERO, ZERO, C(N1+1,N1), - $ LDC ) -C -C Estimate the reciprocal condition number of the matrix F, -C and lower the rank if F can be considered as singular. -C Workspace: need 3*L. -C - CALL DTRCON( '1-norm', 'Upper', 'Non-unit', L, C(N1,N1), LDC, - $ RCOND, DWORK, IWORK, INFO ) - WRKOPT = MAX( WRKOPT, 3*L ) -C - FNORM = DLANTR( '1-norm', 'Upper', 'Non-unit', L, L, C(N1,N1), - $ LDC, DWORK ) - IF ( RCOND.LE.TOLTMP*FNORM ) THEN - RANK = RANK - 1 - IWARN = 2 - GO TO 60 - ELSE IF ( FNORM.LE.TOLTMP*DLANGE( '1-norm', N, L, C(1,N1), LDC, - $ DWORK ) ) THEN - RANK = RANK - L - IWARN = 2 - GO TO 60 - END IF -C UNTIL ( F nonsingular, i.e., RCOND.GT.TOL*FNORM or -C FNORM.GT.TOL*norm(Y) ) -C -C Step 4: Solve X F = -Y by forward elimination, -C (F is upper triangular). -C - CALL DLACPY( 'Full', N, L, C(1,N1), LDC, X, LDX ) - CALL DTRSM( 'Right', 'Upper', 'No transpose', 'Non-unit', N, L, - $ -ONE, C(N1,N1), LDC, X, LDX ) -C -C Set the optimal workspace and reciprocal condition number of F. -C - DWORK(1) = WRKOPT - DWORK(2) = RCOND -C - RETURN -C *** Last line of MB02MD *** - END diff --git a/mex/sources/libslicot/MB02ND.f b/mex/sources/libslicot/MB02ND.f deleted file mode 100644 index 047296025..000000000 --- a/mex/sources/libslicot/MB02ND.f +++ /dev/null @@ -1,889 +0,0 @@ - SUBROUTINE MB02ND( M, N, L, RANK, THETA, C, LDC, X, LDX, Q, INUL, - $ TOL, RELTOL, IWORK, DWORK, LDWORK, BWORK, - $ IWARN, INFO ) -C -C SLICOT RELEASE 5.0. -C -C Copyright (c) 2002-2009 NICONET e.V. -C -C This program is free software: you can redistribute it and/or -C modify it under the terms of the GNU General Public License as -C published by the Free Software Foundation, either version 2 of -C the License, or (at your option) any later version. -C -C This program is distributed in the hope that it will be useful, -C but WITHOUT ANY WARRANTY; without even the implied warranty of -C MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the -C GNU General Public License for more details. -C -C You should have received a copy of the GNU General Public License -C along with this program. If not, see -C . -C -C PURPOSE -C -C To solve the Total Least Squares (TLS) problem using a Partial -C Singular Value Decomposition (PSVD) approach. -C The TLS problem assumes an overdetermined set of linear equations -C AX = B, where both the data matrix A as well as the observation -C matrix B are inaccurate. The routine also solves determined and -C underdetermined sets of equations by computing the minimum norm -C solution. -C It is assumed that all preprocessing measures (scaling, coordinate -C transformations, whitening, ... ) of the data have been performed -C in advance. -C -C ARGUMENTS -C -C Input/Output Parameters -C -C M (input) INTEGER -C The number of rows in the data matrix A and the -C observation matrix B. M >= 0. -C -C N (input) INTEGER -C The number of columns in the data matrix A. N >= 0. -C -C L (input) INTEGER -C The number of columns in the observation matrix B. -C L >= 0. -C -C RANK (input/output) INTEGER -C On entry, if RANK < 0, then the rank of the TLS -C approximation [A+DA|B+DB] (r say) is computed by the -C routine. -C Otherwise, RANK must specify the value of r. -C RANK <= min(M,N). -C On exit, if RANK < 0 on entry and INFO = 0, then RANK -C contains the computed rank of the TLS approximation -C [A+DA|B+DB]. -C Otherwise, the user-supplied value of RANK may be -C changed by the routine on exit if the RANK-th and the -C (RANK+1)-th singular values of C = [A|B] are considered -C to be equal, or if the upper triangular matrix F (as -C defined in METHOD) is (numerically) singular. -C -C THETA (input/output) DOUBLE PRECISION -C On entry, if RANK < 0, then the rank of the TLS -C approximation [A+DA|B+DB] is computed using THETA as -C (min(M,N+L) - d), where d is the number of singular -C values of [A|B] <= THETA. THETA >= 0.0. -C Otherwise, THETA is an initial estimate (t say) for -C computing a lower bound on the RANK largest singular -C values of [A|B]. If THETA < 0.0 on entry however, then -C t is computed by the routine. -C On exit, if RANK >= 0 on entry, then THETA contains the -C computed bound such that precisely RANK singular values -C of C = [A|B] are greater than THETA + TOL. -C Otherwise, THETA is unchanged. -C -C C (input/output) DOUBLE PRECISION array, dimension (LDC,N+L) -C On entry, the leading M-by-(N+L) part of this array must -C contain the matrices A and B. Specifically, the first N -C columns must contain the data matrix A and the last L -C columns the observation matrix B (right-hand sides). -C On exit, if INFO = 0, the first N+L components of the -C columns of this array whose index i corresponds with -C INUL(i) = .TRUE., are the possibly transformed (N+L-RANK) -C base vectors of the right singular subspace corresponding -C to the singular values of C = [A|B] which are less than or -C equal to THETA. Specifically, if L = 0, or if RANK = 0 and -C IWARN <> 2, these vectors are indeed the base vectors -C above. Otherwise, these vectors form the matrix V2, -C transformed as described in Step 4 of the PTLS algorithm -C (see METHOD). The TLS solution is computed from these -C vectors. The other columns of array C contain no useful -C information. -C -C LDC INTEGER -C The leading dimension of array C. LDC >= max(1,M,N+L). -C -C X (output) DOUBLE PRECISION array, dimension (LDX,L) -C If INFO = 0, the leading N-by-L part of this array -C contains the solution X to the TLS problem specified by -C A and B. -C -C LDX INTEGER -C The leading dimension of array X. LDX >= max(1,N). -C -C Q (output) DOUBLE PRECISION array, dimension -C (max(1,2*min(M,N+L)-1)) -C This array contains the partially diagonalized bidiagonal -C matrix J computed from C, at the moment that the desired -C singular subspace has been found. Specifically, the -C leading p = min(M,N+L) entries of Q contain the diagonal -C elements q(1),q(2),...,q(p) and the entries Q(p+1),Q(p+2), -C ...,Q(2*p-1) contain the superdiagonal elements e(1),e(2), -C ...,e(p-1) of J. -C -C INUL (output) LOGICAL array, dimension (N+L) -C The indices of the elements of this array with value -C .TRUE. indicate the columns in C containing the base -C vectors of the right singular subspace of C from which -C the TLS solution has been computed. -C -C Tolerances -C -C TOL DOUBLE PRECISION -C This parameter defines the multiplicity of singular values -C by considering all singular values within an interval of -C length TOL as coinciding. TOL is used in checking how many -C singular values are less than or equal to THETA. Also in -C computing an appropriate upper bound THETA by a bisection -C method, TOL is used as a stopping criterion defining the -C minimum (absolute) subinterval width. TOL is also taken -C as an absolute tolerance for negligible elements in the -C QR/QL iterations. If the user sets TOL to be less than or -C equal to 0, then the tolerance is taken as specified in -C SLICOT Library routine MB04YD document. -C -C RELTOL DOUBLE PRECISION -C This parameter specifies the minimum relative width of an -C interval. When an interval is narrower than TOL, or than -C RELTOL times the larger (in magnitude) endpoint, then it -C is considered to be sufficiently small and bisection has -C converged. If the user sets RELTOL to be less than -C BASE * EPS, where BASE is machine radix and EPS is machine -C precision (see LAPACK Library routine DLAMCH), then the -C tolerance is taken as BASE * EPS. -C -C Workspace -C -C IWORK INTEGER array, dimension (N+2*L) -C -C DWORK DOUBLE PRECISION array, dimension (LDWORK) -C On exit, if INFO = 0, DWORK(1) returns the optimal value -C of LDWORK, and DWORK(2) returns the reciprocal of the -C condition number of the matrix F. -C -C LDWORK INTEGER -C The length of the array DWORK. -C LDWORK = max(2, max(M,N+L) + 2*min(M,N+L), -C min(M,N+L) + LW + max(6*(N+L)-5, -C L*L+max(N+L,3*L)), -C where -C LW = (N+L)*(N+L-1)/2, if M >= N+L, -C LW = M*(N+L-(M-1)/2), if M < N+L. -C For optimum performance LDWORK should be larger. -C -C BWORK LOGICAL array, dimension (N+L) -C -C Warning Indicator -C -C IWARN INTEGER -C = 0: no warnings; -C = 1: if the rank of matrix C has been lowered because a -C singular value of multiplicity greater than 1 was -C found; -C = 2: if the rank of matrix C has been lowered because the -C upper triangular matrix F is (numerically) singular. -C -C Error Indicator -C -C INFO INTEGER -C = 0: successful exit; -C < 0: if INFO = -i, the i-th argument had an illegal -C value; -C = 1: if the maximum number of QR/QL iteration steps -C (30*MIN(M,N)) has been exceeded; -C = 2: if the computed rank of the TLS approximation -C [A+DA|B+DB] exceeds MIN(M,N). Try increasing the -C value of THETA or set the value of RANK to min(M,N). -C -C METHOD -C -C The method used is the Partial Total Least Squares (PTLS) approach -C proposed by Van Huffel and Vandewalle [5]. -C -C Let C = [A|B] denote the matrix formed by adjoining the columns of -C B to the columns of A on the right. -C -C Total Least Squares (TLS) definition: -C ------------------------------------- -C -C Given matrices A and B, find a matrix X satisfying -C -C (A + DA) X = B + DB, -C -C where A and DA are M-by-N matrices, B and DB are M-by-L matrices -C and X is an N-by-L matrix. -C The solution X must be such that the Frobenius norm of [DA|DB] -C is a minimum and each column of B + DB is in the range of -C A + DA. Whenever the solution is not unique, the routine singles -C out the minimum norm solution X. -C -C Let V denote the right singular subspace of C. Since the TLS -C solution can be computed from any orthogonal basis of the subspace -C of V corresponding to the smallest singular values of C, the -C Partial Singular Value Decomposition (PSVD) can be used instead of -C the classical SVD. The dimension of this subspace of V may be -C determined by the rank of C or by an upper bound for those -C smallest singular values. -C -C The PTLS algorithm proceeds as follows (see [2 - 5]): -C -C Step 1: Bidiagonalization phase -C ----------------------- -C (a) If M is large enough than N + L, transform C into upper -C triangular form R by Householder transformations. -C (b) Transform C (or R) into upper bidiagonal form -C (p = min(M,N+L)): -C -C |q(1) e(1) 0 ... 0 | -C (0) | 0 q(2) e(2) . | -C J = | . . | -C | . e(p-1)| -C | 0 ... q(p) | -C -C if M >= N + L, or lower bidiagonal form: -C -C |q(1) 0 0 ... 0 0 | -C (0) |e(1) q(2) 0 . . | -C J = | . . . | -C | . q(p) . | -C | 0 ... e(p-1) q(p)| -C -C if M < N + L, using Householder transformations. -C In the second case, transform the matrix to the upper -C bidiagonal form by applying Givens rotations. -C (c) Initialize the right singular base matrix with the identity -C matrix. -C -C Step 2: Partial diagonalization phase -C ----------------------------- -C If the upper bound THETA is not given, then compute THETA such -C that precisely p - RANK singular values (p=min(M,N+L)) of the -C bidiagonal matrix are less than or equal to THETA, using a -C bisection method [5]. Diagonalize the given bidiagonal matrix J -C partially, using either QL iterations (if the upper left diagonal -C element of the considered bidiagonal submatrix is smaller than the -C lower right diagonal element) or QR iterations, such that J is -C split into unreduced bidiagonal submatrices whose singular values -C are either all larger than THETA or are all less than or equal -C to THETA. Accumulate the Givens rotations in V. -C -C Step 3: Back transformation phase -C ------------------------- -C Apply the Householder transformations of Step 1(b) onto the base -C vectors of V associated with the bidiagonal submatrices with all -C singular values less than or equal to THETA. -C -C Step 4: Computation of F and Y -C ---------------------- -C Let V2 be the matrix of the columns of V corresponding to the -C (N + L - RANK) smallest singular values of C. -C Compute with Householder transformations the matrices F and Y -C such that: -C -C |VH Y| -C V2 x Q = | | -C |0 F| -C -C where Q is an orthogonal matrix, VH is an N-by-(N-RANK) matrix, -C Y is an N-by-L matrix and F is an L-by-L upper triangular matrix. -C If F is singular, then reduce the value of RANK by one and repeat -C Steps 2, 3 and 4. -C -C Step 5: Computation of the TLS solution -C ------------------------------- -C If F is non-singular then the solution X is obtained by solving -C the following equations by forward elimination: -C -C X F = -Y. -C -C Notes: -C If RANK is lowered in Step 4, some additional base vectors must -C be computed in Step 2. The additional computations are kept to -C a minimum. -C If RANK is lowered in Step 4 but the multiplicity of the RANK-th -C singular value is larger than 1, then the value of RANK is further -C lowered with its multiplicity defined by the parameter TOL. This -C is done at the beginning of Step 2 by calling SLICOT Library -C routine MB03MD (from MB04YD), which estimates THETA using a -C bisection method. If F in Step 4 is singular, then the computed -C solution is infinite and hence does not satisfy the second TLS -C criterion (see TLS definition). For these cases, Golub and -C Van Loan [1] claim that the TLS problem has no solution. The -C properties of these so-called nongeneric problems are described -C in [6] and the TLS computations are generalized in order to solve -C them. As proven in [6], the proposed generalization satisfies the -C TLS criteria for any number L of observation vectors in B provided -C that, in addition, the solution | X| is constrained to be -C |-I| -C orthogonal to all vectors of the form |w| which belong to the -C |0| -C space generated by the columns of the submatrix |Y|. -C |F| -C -C REFERENCES -C -C [1] Golub, G.H. and Van Loan, C.F. -C An Analysis of the Total Least-Squares Problem. -C SIAM J. Numer. Anal., 17, pp. 883-893, 1980. -C -C [2] Van Huffel, S., Vandewalle, J. and Haegemans, A. -C An Efficient and Reliable Algorithm for Computing the -C Singular Subspace of a Matrix Associated with its Smallest -C Singular Values. -C J. Comput. and Appl. Math., 19, pp. 313-330, 1987. -C -C [3] Van Huffel, S. -C Analysis of the Total Least Squares Problem and its Use in -C Parameter Estimation. -C Doctoral dissertation, Dept. of Electr. Eng., Katholieke -C Universiteit Leuven, Belgium, June 1987. -C -C [4] Chan, T.F. -C An Improved Algorithm for Computing the Singular Value -C Decomposition. -C ACM TOMS, 8, pp. 72-83, 1982. -C -C [5] Van Huffel, S. and Vandewalle, J. -C The Partial Total Least Squares Algorithm. -C J. Comput. Appl. Math., 21, pp. 333-341, 1988. -C -C [6] Van Huffel, S. and Vandewalle, J. -C Analysis and Solution of the Nongeneric Total Least Squares -C Problem. -C SIAM J. Matr. Anal. and Appl., 9, pp. 360-372, 1988. -C -C NUMERICAL ASPECTS -C -C The computational efficiency of the PTLS algorithm compared with -C the classical TLS algorithm (see [2 - 5]) is obtained by making -C use of PSVD (see [1]) instead of performing the entire SVD. -C Depending on the gap between the RANK-th and the (RANK+1)-th -C singular values of C, the number (N + L - RANK) of base vectors to -C be computed with respect to the column dimension (N + L) of C and -C the desired accuracy RELTOL, the algorithm used by this routine is -C approximately twice as fast as the classical TLS algorithm at the -C expense of extra storage requirements, namely: -C (N + L) x (N + L - 1)/2 if M >= N + L or -C M x (N + L - (M - 1)/2) if M < N + L. -C This is because the Householder transformations performed on the -C rows of C in the bidiagonalization phase (see Step 1) must be kept -C until the end (Step 5). -C -C CONTRIBUTOR -C -C Release 3.0: V. Sima, Katholieke Univ. Leuven, Belgium, Apr. 1997. -C Supersedes Release 2.0 routine MB02BD by S. Van Huffel, Katholieke -C University, Leuven, Belgium. -C -C REVISIONS -C -C June 30, 1997, Oct. 19, 2003, Feb. 15, 2004. -C -C KEYWORDS -C -C Least-squares approximation, singular subspace, singular value -C decomposition, singular values, total least-squares. -C -C ****************************************************************** -C -C .. Parameters .. - DOUBLE PRECISION ZERO, ONE, TWO - PARAMETER ( ZERO = 0.0D0, ONE = 1.0D0, TWO = 2.0D0 ) -C .. Scalar Arguments .. - INTEGER INFO, IWARN, L, LDC, LDWORK, LDX, M, N, RANK - DOUBLE PRECISION RELTOL, THETA, TOL -C .. Array Arguments .. - LOGICAL BWORK(*), INUL(*) - INTEGER IWORK(*) - DOUBLE PRECISION C(LDC,*), DWORK(*), Q(*), X(LDX,*) -C .. Local Scalars .. - LOGICAL LFIRST, SUFWRK - INTEGER I, I1, IFAIL, IHOUSH, IJ, IOFF, ITAUP, ITAUQ, - $ IWARM, J, J1, JF, JV, JWORK, K, KF, KJ, LDF, LW, - $ MC, MJ, MNL, N1, NJ, NL, P, WRKOPT - DOUBLE PRECISION CS, EPS, FIRST, FNORM, HH, INPROD, RCOND, SN, - $ TEMP -C .. Local Arrays .. - DOUBLE PRECISION DUMMY(1) -C .. External Functions .. - LOGICAL LSAME - INTEGER ILAENV - DOUBLE PRECISION DLAMCH, DLANGE, DLANTR - EXTERNAL DLAMCH, DLANGE, DLANTR, ILAENV, LSAME -C .. External Subroutines .. - EXTERNAL DCOPY, DGEBRD, DGEQRF, DGERQF, DLARF, DLARFG, - $ DLARTG, DLASET, DORMBR, DORMRQ, DTRCON, DTRSM, - $ MB04YD, XERBLA -C .. Intrinsic Functions .. - INTRINSIC INT, MAX, MIN -C .. Executable Statements .. -C - IWARN = 0 - INFO = 0 - NL = N + L - K = MAX( M, NL ) - P = MIN( M, NL ) - IF ( M.GE.NL ) THEN - LW = ( NL*( NL - 1 ) )/2 - ELSE - LW = M*NL - ( M*( M - 1 ) )/2 - END IF - JV = P + LW + MAX( 6*NL - 5, L*L + MAX( NL, 3*L ) ) -C -C Test the input scalar arguments. -C - IF( M.LT.0 ) THEN - INFO = -1 - ELSE IF( N.LT.0 ) THEN - INFO = -2 - ELSE IF( L.LT.0 ) THEN - INFO = -3 - ELSE IF( RANK.GT.MIN( M, N ) ) THEN - INFO = -4 - ELSE IF( ( RANK.LT.0 ) .AND. ( THETA.LT.ZERO ) ) THEN - INFO = -5 - ELSE IF( LDC.LT.MAX( 1, K ) ) THEN - INFO = -7 - ELSE IF( LDX.LT.MAX( 1, N ) ) THEN - INFO = -9 - ELSE IF( LDWORK.LT.MAX( 2, K + 2*P, JV ) ) THEN - INFO = -16 - END IF -C - IF ( INFO.NE.0 ) THEN -C -C Error return. -C - CALL XERBLA( 'MB02ND', -INFO ) - RETURN - END IF -C -C Quick return if possible. -C - IF ( MIN( M, NL ).EQ.0 ) THEN - IF ( M.EQ.0 ) THEN - CALL DLASET( 'Full', NL, NL, ZERO, ONE, C, LDC ) - CALL DLASET( 'Full', N, L, ZERO, ZERO, X, LDX ) -C - DO 10 I = 1, NL - INUL(I) = .TRUE. - 10 CONTINUE -C - END IF - IF ( RANK.GE.0 ) - $ THETA = ZERO - RANK = 0 - DWORK(1) = TWO - DWORK(2) = ONE - RETURN - END IF -C - WRKOPT = 2 - N1 = N + 1 -C - EPS = DLAMCH( 'Precision' ) - LFIRST = .TRUE. -C -C Initializations. -C - DO 20 I = 1, P - INUL(I) = .FALSE. - BWORK(I) = .FALSE. - 20 CONTINUE -C - DO 40 I = P + 1, NL - INUL(I) = .TRUE. - BWORK(I) = .FALSE. - 40 CONTINUE -C -C Subroutine MB02ND solves a set of linear equations by a Total -C Least Squares Approximation, based on the Partial SVD. -C -C Step 1: Bidiagonalization phase -C ----------------------- -C 1.a): If M is large enough than N+L, transform C into upper -C triangular form R by Householder transformations. -C -C (Note: Comments in the code beginning "Workspace:" describe the -C minimal amount of real workspace needed at that point in the -C code, as well as the preferred amount for good performance. -C NB refers to the optimal block size for the immediately -C following subroutine, as returned by ILAENV.) -C - IF ( M.GE.MAX( NL, - $ ILAENV( 6, 'DGESVD', 'N' // 'N', M, NL, 0, 0 ) ) ) - $ THEN -C -C Workspace: need 2*(N+L), -C prefer N+L + (N+L)*NB. -C - ITAUQ = 1 - JWORK = ITAUQ + NL - CALL DGEQRF( M, NL, C, LDC, DWORK(ITAUQ), DWORK(JWORK), - $ LDWORK-JWORK+1, IFAIL ) - WRKOPT = MAX( WRKOPT, INT( DWORK(JWORK) )+JWORK-1 ) - IF ( NL.GT.1 ) - $ CALL DLASET( 'Lower', NL-1, NL-1, ZERO, ZERO, C(2,1), LDC ) - MNL = NL - ELSE - MNL = M - END IF -C -C 1.b): Transform C (or R) into bidiagonal form Q using Householder -C transformations. -C Workspace: need 2*min(M,N+L) + max(M,N+L), -C prefer 2*min(M,N+L) + (M+N+L)*NB. -C - ITAUP = 1 - ITAUQ = ITAUP + P - JWORK = ITAUQ + P - CALL DGEBRD( MNL, NL, C, LDC, Q, Q(P+1), DWORK(ITAUQ), - $ DWORK(ITAUP), DWORK(JWORK), LDWORK-JWORK+1, IFAIL ) - WRKOPT = MAX( WRKOPT, INT( DWORK(JWORK) )+JWORK-1 ) -C -C If the matrix is lower bidiagonal, rotate to be upper bidiagonal -C by applying Givens rotations on the left. -C - IF ( M.LT.NL ) THEN - IOFF = 0 -C - DO 60 I = 1, P - 1 - CALL DLARTG( Q(I), Q(P+I), CS, SN, TEMP ) - Q(I) = TEMP - Q(P+I) = SN*Q(I+1) - Q(I+1) = CS*Q(I+1) - 60 CONTINUE -C - ELSE - IOFF = 1 - END IF -C -C Store the Householder transformations performed onto the rows of C -C in the extra storage locations DWORK(IHOUSH). -C Workspace: need LDW = min(M,N+L) + (N+L)*(N+L-1)/2, if M >= N+L, -C LDW = min(M,N+L) + M*(N+L-(M-1)/2), if M < N+L; -C prefer LDW = min(M,N+L) + (N+L)**2, if M >= N+L, -C LDW = min(M,N+L) + M*(N+L), if M < N+L. -C - IHOUSH = ITAUQ - MC = NL - IOFF - KF = IHOUSH + P*NL - SUFWRK = LDWORK.GE.( KF + MAX( 6*(N+L)-5, - $ NL**2 + MAX( NL, 3*L ) - 1 ) ) - IF ( SUFWRK ) THEN -C -C Enough workspace for a fast algorithm. -C - CALL DLACPY( 'Upper', P, NL, C, LDC, DWORK(IHOUSH), P ) - KJ = KF - WRKOPT = MAX( WRKOPT, KF - 1 ) - ELSE -C -C Not enough workspace for a fast algorithm. -C - KJ = IHOUSH -C - DO 80 NJ = 1, MIN( P, MC ) - J = MC - NJ + 1 - CALL DCOPY( J, C(NJ,NJ+IOFF), LDC, DWORK(KJ), 1 ) - KJ = KJ + J - 80 CONTINUE -C - END IF -C -C 1.c): Initialize the right singular base matrix V with the -C identity matrix (V overwrites C). -C - CALL DLASET( 'Full', NL, NL, ZERO, ONE, C, LDC ) - JV = KJ - IWARM = 0 -C -C REPEAT -C -C Compute the Householder matrix Q and matrices F and Y such that -C F is nonsingular. -C -C Step 2: Partial diagonalization phase. -C ----------------------------- -C Diagonalize the bidiagonal Q partially until convergence to -C the desired right singular subspace. -C Workspace: LDW + 6*(N+L)-5. -C - 100 CONTINUE - JWORK = JV - CALL MB04YD( 'No U', 'Update V', P, NL, RANK, THETA, Q, Q(P+1), - $ DUMMY, 1, C, LDC, INUL, TOL, RELTOL, DWORK(JWORK), - $ LDWORK-JWORK+1, IWARN, INFO ) - WRKOPT = MAX( WRKOPT, JWORK + 6*NL - 6 ) -C - IWARN = MAX( IWARN, IWARM ) - IF ( INFO.GT.0 ) - $ RETURN -C -C Set pointers to the selected base vectors in the right singular -C matrix of C. -C - K = 0 -C - DO 120 I = 1, NL - IF ( INUL(I) ) THEN - K = K + 1 - IWORK(K) = I - END IF - 120 CONTINUE -C - IF ( K.LT.L ) THEN -C -C Rank of the TLS approximation is larger than min(M,N). -C - INFO = 2 - RETURN - END IF -C -C Step 3: Back transformation phase. -C ------------------------- -C Apply in backward order the Householder transformations (stored -C in DWORK(IHOUSH)) performed onto the rows of C during the -C bidiagonalization phase, to the selected base vectors (specified -C by INUL(I) = .TRUE.). Already transformed vectors are those for -C which BWORK(I) = .TRUE.. -C - KF = K - IF ( SUFWRK.AND.LFIRST ) THEN -C -C Enough workspace for a fast algorithm and first pass. -C - IJ = JV -C - DO 140 J = 1, K - CALL DCOPY (NL, C(1,IWORK(J)), 1, DWORK(IJ), 1 ) - IJ = IJ + NL - 140 CONTINUE -C -C Workspace: need LDW + (N+L)*K + K, -C prefer LDW + (N+L)*K + K*NB. -C - IJ = JV - JWORK = IJ + NL*K - CALL DORMBR( 'P vectors', 'Left', 'No transpose', NL, K, - $ MNL, DWORK(IHOUSH), P, DWORK(ITAUP), DWORK(IJ), - $ NL, DWORK(JWORK), LDWORK-JWORK+1, IFAIL ) - WRKOPT = MAX( WRKOPT, INT( DWORK(JWORK) )+JWORK-1 ) -C - DO 160 I = 1, NL - IF ( INUL(I) .AND. ( .NOT. BWORK(I) ) ) - $ BWORK(I) = .TRUE. - 160 CONTINUE -C - ELSE -C -C Not enough workspace for a fast algorithm or subsequent passes. -C - DO 180 I = 1, NL - IF ( INUL(I) .AND. ( .NOT. BWORK(I) ) ) THEN - KJ = JV -C - DO 170 NJ = MIN( P, MC ), 1, -1 - J = MC - NJ + 1 - KJ = KJ - J - FIRST = DWORK(KJ) - DWORK(KJ) = ONE - CALL DLARF( 'Left', J, 1, DWORK(KJ), 1, - $ DWORK(ITAUP+NJ-1), C(NJ+IOFF,I), LDC, - $ DWORK(JWORK) ) - DWORK(KJ) = FIRST - 170 CONTINUE -C - BWORK(I) = .TRUE. - END IF - 180 CONTINUE - END IF -C - IF ( RANK.LE.0 ) - $ RANK = 0 - IF ( MIN( RANK, L ).EQ.0 ) THEN - IF ( SUFWRK.AND.LFIRST ) - $ CALL DLACPY( 'Full', NL, K, DWORK(JV), NL, C, LDC ) - DWORK(1) = WRKOPT - DWORK(2) = ONE - RETURN - END IF -C -C Step 4: Compute matrices F and Y -C ------------------------ -C using Householder transformation Q. -C -C Compute the orthogonal matrix Q (in factorized form) and the -C matrices F and Y using RQ factorization. It is assumed that, -C generically, the last L rows of V2 matrix have full rank. -C The code could not be the most efficient when RANK has been -C lowered, because the already created zero pattern of the last -C L rows of V2 matrix is not exploited. -C - IF ( SUFWRK.AND.LFIRST ) THEN -C -C Enough workspace for a fast algorithm and first pass. -C Workspace: need LDW1 + 2*L, -C prefer LDW1 + L + L*NB, where -C LDW1 = LDW + (N+L)*K; -C - ITAUQ = JWORK - JWORK = ITAUQ + L - CALL DGERQF( L, K, DWORK(JV+N), NL, DWORK(ITAUQ), DWORK(JWORK), - $ LDWORK-JWORK+1, INFO ) - WRKOPT = MAX( WRKOPT, INT( DWORK(JWORK) )+JWORK-1 ) -C -C Workspace: need LDW1 + N+L, -C prefer LDW1 + L + N*NB. -C - CALL DORMRQ( 'Right', 'Transpose', N, K, L, DWORK(JV+N), NL, - $ DWORK(ITAUQ), DWORK(JV), NL, DWORK(JWORK), - $ LDWORK-JWORK+1, INFO ) - WRKOPT = MAX( WRKOPT, INT( DWORK(JWORK) )+JWORK-1 ) -C - JF = JV + NL*(K-L) + N - LDF = NL - JWORK = JF + LDF*L - N - CALL DLASET( 'Full', L, K-L, ZERO, ZERO, DWORK(JV+N), LDF ) - IF ( L.GT.1 ) - $ CALL DLASET( 'Lower', L-1, L-1, ZERO, ZERO, DWORK(JF+1), - $ LDF ) - IJ = JV -C - DO 200 J = 1, K - CALL DCOPY( NL, DWORK(IJ), 1, C(1,IWORK(J)), 1 ) - IJ = IJ + NL - 200 CONTINUE -C - ELSE -C -C Not enough workspace for a fast algorithm or subsequent passes. -C Workspace: LDW2 + N+L, where LDW2 = LDW + L*L. -C - I = NL - JF = JV - LDF = L - JWORK = JF + LDF*L - WRKOPT = MAX( WRKOPT, JWORK+NL-1 ) -C -C WHILE ( ( K >= 1 ) .AND. ( I > N ) ) DO - 220 CONTINUE - IF ( ( K.GE.1 ) .AND. ( I.GT.N ) ) THEN -C - DO 240 J = 1, K - DWORK(JWORK+J-1) = C(I,IWORK(J)) - 240 CONTINUE -C -C Compute Householder transformation. -C - CALL DLARFG( K, DWORK(JWORK+K-1), DWORK(JWORK), 1, TEMP ) - C(I,IWORK(K)) = DWORK(JWORK+K-1) - IF ( TEMP.NE.ZERO ) THEN -C -C Apply Householder transformation onto the selected base -C vectors. -C - DO 300 I1 = 1, I - 1 - INPROD = C(I1,IWORK(K)) -C - DO 260 J = 1, K - 1 - INPROD = INPROD + DWORK(JWORK+J-1)*C(I1,IWORK(J)) - 260 CONTINUE -C - HH = INPROD*TEMP - C(I1,IWORK(K)) = C(I1,IWORK(K)) - HH -C - DO 280 J = 1, K - 1 - J1 = IWORK(J) - C(I1,J1) = C(I1,J1) - DWORK(JWORK+J-1)*HH - C(I,J1) = ZERO - 280 CONTINUE -C - 300 CONTINUE -C - END IF - CALL DCOPY( I-N, C(N1,IWORK(K)), 1, DWORK(JF+(I-N-1)*L), 1 ) - K = K - 1 - I = I - 1 - GO TO 220 - END IF -C END WHILE 220 - END IF -C -C Estimate the reciprocal condition number of the matrix F. -C If F singular, lower the rank of the TLS approximation. -C Workspace: LDW1 + 3*L or -C LDW2 + 3*L. -C - CALL DTRCON( '1-norm', 'Upper', 'Non-unit', L, DWORK(JF), LDF, - $ RCOND, DWORK(JWORK), IWORK(KF+1), INFO ) - WRKOPT = MAX( WRKOPT, JWORK + 3*L - 1 ) -C - DO 320 J = 1, L - CALL DCOPY( N, C(1,IWORK(KF-L+J)), 1, X(1,J), 1 ) - 320 CONTINUE -C - FNORM = DLANTR( '1-norm', 'Upper', 'Non-unit', L, L, DWORK(JF), - $ LDF, DWORK(JWORK) ) - IF ( RCOND.LE.EPS*FNORM ) THEN - RANK = RANK - 1 - GO TO 340 - END IF - IF ( FNORM.LE.EPS*DLANGE( '1-norm', N, L, X, LDX, - $ DWORK(JWORK) ) ) THEN - RANK = RANK - L - GO TO 340 - ELSE - GO TO 400 - END IF -C - 340 CONTINUE - IWARM = 2 - THETA = -ONE - IF ( SUFWRK.AND.LFIRST ) THEN -C -C Rearrange the stored Householder transformations for -C subsequent passes, taking care to avoid overwriting. -C - IF ( P.LT.NL ) THEN - KJ = IHOUSH + NL*(NL - 1) - MJ = IHOUSH + P*(NL - 1) -C - DO 360 NJ = 1, NL - DO 350 J = P - 1, 0, -1 - DWORK(KJ+J) = DWORK(MJ+J) - 350 CONTINUE - KJ = KJ - NL - MJ = MJ - P - 360 CONTINUE -C - END IF - KJ = IHOUSH - MJ = IHOUSH + NL*IOFF -C - DO 380 NJ = 1, MIN( P, MC ) - DO 370 J = 0, MC - NJ - DWORK(KJ) = DWORK(MJ+J*P) - KJ = KJ + 1 - 370 CONTINUE - MJ = MJ + NL + 1 - 380 CONTINUE -C - JV = KJ - LFIRST = .FALSE. - END IF - GO TO 100 -C UNTIL ( F nonsingular, i.e., RCOND.GT.EPS*FNORM or -C FNORM.GT.EPS*norm(Y) ) - 400 CONTINUE -C -C Step 5: Compute TLS solution. -C -------------------- -C Solve X F = -Y by forward elimination (F is upper triangular). -C - CALL DTRSM( 'Right', 'Upper', 'No transpose', 'Non-unit', N, L, - $ -ONE, DWORK(JF), LDF, X, LDX ) -C -C Set the optimal workspace and reciprocal condition number of F. -C - DWORK(1) = WRKOPT - DWORK(2) = RCOND -C - RETURN -C *** Last line of MB02ND *** - END diff --git a/mex/sources/libslicot/MB02NY.f b/mex/sources/libslicot/MB02NY.f deleted file mode 100644 index acf0bce5a..000000000 --- a/mex/sources/libslicot/MB02NY.f +++ /dev/null @@ -1,261 +0,0 @@ - SUBROUTINE MB02NY( UPDATU, UPDATV, M, N, I, K, Q, E, U, LDU, V, - $ LDV, DWORK ) -C -C SLICOT RELEASE 5.0. -C -C Copyright (c) 2002-2009 NICONET e.V. -C -C This program is free software: you can redistribute it and/or -C modify it under the terms of the GNU General Public License as -C published by the Free Software Foundation, either version 2 of -C the License, or (at your option) any later version. -C -C This program is distributed in the hope that it will be useful, -C but WITHOUT ANY WARRANTY; without even the implied warranty of -C MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the -C GNU General Public License for more details. -C -C You should have received a copy of the GNU General Public License -C along with this program. If not, see -C . -C -C PURPOSE -C -C To separate a zero singular value of a bidiagonal submatrix of -C order k, k <= p, of the bidiagonal matrix -C -C |Q(1) E(1) 0 ... 0 | -C | 0 Q(2) E(2) . | -C J = | . . | -C | . E(p-1)| -C | 0 ... ... ... Q(p) | -C -C with p = MIN(M,N), by annihilating one or two superdiagonal -C elements E(i-1) (if i > 1) and/or E(i) (if i < k). -C -C ARGUMENTS -C -C Mode Parameters -C -C UPDATU LOGICAL -C Indicates whether the user wishes to accumulate in a -C matrix U the left-hand Givens rotations S, as follows: -C = .FALSE.: Do not form U; -C = .TRUE. : The given matrix U is updated (postmultiplied) -C by the left-hand Givens rotations S. -C -C UPDATV LOGICAL -C Indicates whether the user wishes to accumulate in a -C matrix V the right-hand Givens rotations T, as follows: -C = .FALSE.: Do not form V; -C = .TRUE. : The given matrix V is updated (postmultiplied) -C by the right-hand Givens rotations T. -C -C Input/Output Parameters -C -C M (input) INTEGER -C The number of rows of the matrix U. M >= 0. -C -C N (input) INTEGER -C The number of rows of the matrix V. N >= 0. -C -C I (input) INTEGER -C The index of the negligible diagonal entry Q(I) of the -C bidiagonal matrix J, I <= p. -C -C K (input) INTEGER -C The index of the last diagonal entry of the considered -C bidiagonal submatrix of J, i.e., E(K-1) is considered -C negligible, K <= p. -C -C Q (input/output) DOUBLE PRECISION array, dimension (p) -C where p = MIN(M,N). -C On entry, Q must contain the diagonal entries of the -C bidiagonal matrix J. -C On exit, Q contains the diagonal entries of the -C transformed bidiagonal matrix S' J T. -C -C E (input/output) DOUBLE PRECISION array, dimension (p-1) -C On entry, E must contain the superdiagonal entries of J. -C On exit, E contains the superdiagonal entries of the -C transformed bidiagonal matrix S' J T. -C -C U (input/output) DOUBLE PRECISION array, dimension (LDU,p) -C On entry, if UPDATU = .TRUE., U must contain the M-by-p -C left transformation matrix. -C On exit, if UPDATU = .TRUE., the Givens rotations S on the -C left, annihilating E(i) if i < k, have been postmultiplied -C into U. -C U is not referenced if UPDATU = .FALSE.. -C -C LDU INTEGER -C The leading dimension of the array U. -C LDU >= max(1,M) if UPDATU = .TRUE.; -C LDU >= 1 if UPDATU = .FALSE.. -C -C V (input/output) DOUBLE PRECISION array, dimension (LDV,p) -C On entry, if UPDATV = .TRUE., V must contain the N-by-p -C right transformation matrix. -C On exit, if UPDATV = .TRUE., the Givens rotations T on the -C right, annihilating E(i-1) if i > 1, have been -C postmultiplied into V. -C V is not referenced if UPDATV = .FALSE.. -C -C LDV INTEGER -C The leading dimension of the array V. -C LDV >= max(1,N) if UPDATV = .TRUE.; -C LDV >= 1 if UPDATV = .FALSE.. -C -C Workspace -C -C DWORK DOUBLE PRECISION array, dimension (MAX(1,LDWORK)) -C LDWORK >= 2*MAX(K-I,I-1), if UPDATV = UPDATU = .TRUE.; -C LDWORK >= 2*(K-I), if UPDATU = .TRUE., UPDATV = .FALSE.; -C LDWORK >= 2*(I-1), if UPDATV = .TRUE., UPDATU = .FALSE.; -C LDWORK >= 1, if UPDATU = UPDATV = .FALSE.. -C -C METHOD -C -C Let the considered bidiagonal submatrix be -C -C |Q(1) E(1) 0 ... 0 | -C | 0 Q(2) E(2) . | -C | . . | -C | . Q(i-1) E(i-1) . | -C Jk = | . Q(i) E(i) . |. -C | . Q(i+1) . . | -C | . .. . | -C | . E(k-1)| -C | 0 ... ... Q(k) | -C -C A zero singular value of Jk manifests itself by a zero diagonal -C entry Q(i) or in practice, a negligible value of Q(i). -C When a negligible diagonal element Q(i) in Jk is present, the -C bidiagonal submatrix Jk is split by the routine into 2 or 3 -C unreduced bidiagonal submatrices by annihilating E(i) (if i < k) -C using Givens rotations S on the left and by annihilating E(i-1) -C (if i > 1) using Givens rotations T on the right until Jk is -C reduced to the form: -C -C |Q(1) E(1) 0 ... 0 | -C | 0 . ... . | -C | . ... . | -C | . Q(i-1) 0 . | -C S' Jk T = | . 0 0 . |. -C | . Q(i+1) . . | -C | . .. . | -C | . E(k-1)| -C | 0 ... ... Q(k) | -C -C For more details, see [1, pp.11.12-11.14]. -C -C REFERENCES -C -C [1] Dongarra, J.J., Bunch, J.R., Moler C.B. and Stewart, G.W. -C LINPACK User's Guide. -C SIAM, Philadelphia, 1979. -C -C NUMERICAL ASPECTS -C -C The algorithm is backward stable. -C -C CONTRIBUTOR -C -C Release 3.0: V. Sima, Katholieke Univ. Leuven, Belgium, June 1997. -C Supersedes Release 2.0 routine MB02BZ by S. Van Huffel, Katholieke -C University, Leuven, Belgium. -C -C REVISIONS -C -C - -C -C KEYWORDS -C -C Bidiagonal matrix, orthogonal transformation, singular values. -C -C ****************************************************************** -C -C .. Parameters .. - DOUBLE PRECISION ZERO, ONE - PARAMETER ( ZERO = 0.0D0, ONE = 1.0D0 ) -C .. Scalar Arguments .. - LOGICAL UPDATU, UPDATV - INTEGER I, K, LDU, LDV, M, N -C .. Array Arguments .. - DOUBLE PRECISION DWORK(*), E(*), Q(*), U(LDU,*), V(LDV,*) -C .. Local Scalars .. - INTEGER I1, IROT, L, L1, NROT - DOUBLE PRECISION C, F, G, R, S -C .. External Subroutines .. - EXTERNAL DLARTG, DLASR -C .. Intrinsic Functions .. - INTRINSIC MIN -C .. Executable Statements .. -C -C For speed, no tests of the input scalar arguments are done. -C -C Quick return if possible. -C - IF ( M.LE.0 .OR. N.LE.0 ) - $ RETURN -C - IF ( I.LE.MIN( M, N ) ) Q(I) = ZERO -C -C Annihilate E(I) (if I < K). -C - IF ( I.LT.K ) THEN - C = ZERO - S = ONE - IROT = 0 - NROT = K - I -C - DO 20 L = I, K-1 - G = E(L) - E(L) = C*G - CALL DLARTG( Q(L+1), S*G, C, S, R ) - Q(L+1) = R - IF ( UPDATU ) THEN - IROT = IROT + 1 - DWORK(IROT) = C - DWORK(IROT+NROT) = S - END IF - 20 CONTINUE -C - IF ( UPDATU ) - $ CALL DLASR( 'Right', 'Top', 'Forward', M, NROT+1, DWORK(1), - $ DWORK(NROT+1), U(1,I), LDU ) - END IF -C -C Annihilate E(I-1) (if I > 1). -C - IF ( I.GT.1 ) THEN - I1 = I - 1 - F = E(I1) - E(I1) = ZERO -C - DO 40 L1 = 1, I1 - 1 - L = I - L1 - CALL DLARTG( Q(L), F, C, S, R ) - Q(L) = R - IF ( UPDATV ) THEN - DWORK(L) = C - DWORK(L+I1) = S - END IF - G = E(L-1) - F = -S*G - E(L-1) = C*G - 40 CONTINUE -C - CALL DLARTG( Q(1), F, C, S, R ) - Q(1) = R - IF ( UPDATV ) THEN - DWORK(1) = C - DWORK(I) = S - CALL DLASR( 'Right', 'Bottom', 'Backward', N, I, DWORK(1), - $ DWORK(I), V(1,1), LDV ) - END IF - END IF -C - RETURN -C *** Last line of MB02NY *** - END diff --git a/mex/sources/libslicot/MB02OD.f b/mex/sources/libslicot/MB02OD.f deleted file mode 100644 index 0a6929954..000000000 --- a/mex/sources/libslicot/MB02OD.f +++ /dev/null @@ -1,267 +0,0 @@ - SUBROUTINE MB02OD( SIDE, UPLO, TRANS, DIAG, NORM, M, N, ALPHA, A, - $ LDA, B, LDB, RCOND, TOL, IWORK, DWORK, INFO ) -C -C SLICOT RELEASE 5.0. -C -C Copyright (c) 2002-2009 NICONET e.V. -C -C This program is free software: you can redistribute it and/or -C modify it under the terms of the GNU General Public License as -C published by the Free Software Foundation, either version 2 of -C the License, or (at your option) any later version. -C -C This program is distributed in the hope that it will be useful, -C but WITHOUT ANY WARRANTY; without even the implied warranty of -C MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the -C GNU General Public License for more details. -C -C You should have received a copy of the GNU General Public License -C along with this program. If not, see -C . -C -C PURPOSE -C -C To solve (if well-conditioned) one of the matrix equations -C -C op( A )*X = alpha*B, or X*op( A ) = alpha*B, -C -C where alpha is a scalar, X and B are m-by-n matrices, A is a unit, -C or non-unit, upper or lower triangular matrix and op( A ) is one -C of -C -C op( A ) = A or op( A ) = A'. -C -C An estimate of the reciprocal of the condition number of the -C triangular matrix A, in either the 1-norm or the infinity-norm, is -C also computed as -C -C RCOND = 1 / ( norm(A) * norm(inv(A)) ). -C -C and the specified matrix equation is solved only if RCOND is -C larger than a given tolerance TOL. In that case, the matrix X is -C overwritten on B. -C -C ARGUMENTS -C -C Mode Parameters -C -C SIDE CHARACTER*1 -C Specifies whether op( A ) appears on the left or right -C of X as follows: -C = 'L': op( A )*X = alpha*B; -C = 'R': X*op( A ) = alpha*B. -C -C UPLO CHARACTER*1 -C Specifies whether the matrix A is an upper or lower -C triangular matrix as follows: -C = 'U': A is an upper triangular matrix; -C = 'L': A is a lower triangular matrix. -C -C TRANS CHARACTER*1 -C Specifies the form of op( A ) to be used in the matrix -C multiplication as follows: -C = 'N': op( A ) = A; -C = 'T': op( A ) = A'; -C = 'C': op( A ) = A'. -C -C DIAG CHARACTER*1 -C Specifies whether or not A is unit triangular as follows: -C = 'U': A is assumed to be unit triangular; -C = 'N': A is not assumed to be unit triangular. -C -C NORM CHARACTER*1 -C Specifies whether the 1-norm condition number or the -C infinity-norm condition number is required: -C = '1' or 'O': 1-norm; -C = 'I': Infinity-norm. -C -C Input/Output Parameters -C -C M (input) INTEGER -C The number of rows of B. M >= 0. -C -C N (input) INTEGER -C The number of columns of B. N >= 0. -C -C ALPHA (input) DOUBLE PRECISION -C The scalar alpha. When alpha is zero then A is not -C referenced and B need not be set before entry. -C -C A (input) DOUBLE PRECISION array, dimension (LDA,k), -C where k is M when SIDE = 'L' and is N when SIDE = 'R'. -C On entry with UPLO = 'U', the leading k-by-k upper -C triangular part of this array must contain the upper -C triangular matrix and the strictly lower triangular part -C of A is not referenced. -C On entry with UPLO = 'L', the leading k-by-k lower -C triangular part of this array must contain the lower -C triangular matrix and the strictly upper triangular part -C of A is not referenced. -C Note that when DIAG = 'U', the diagonal elements of A are -C not referenced either, but are assumed to be unity. -C -C LDA INTEGER -C The leading dimension of array A. -C LDA >= max(1,M) when SIDE = 'L'; -C LDA >= max(1,N) when SIDE = 'R'. -C -C B (input/output) DOUBLE PRECISION array, dimension (LDB,N) -C On entry, the leading M-by-N part of this array must -C contain the right-hand side matrix B. -C On exit, if INFO = 0, the leading M-by-N part of this -C array contains the solution matrix X. -C Otherwise, this array is not modified by the routine. -C -C LDB INTEGER -C The leading dimension of array B. LDB >= max(1,M). -C -C RCOND (output) DOUBLE PRECISION -C The reciprocal of the condition number of the matrix A, -C computed as RCOND = 1/(norm(A) * norm(inv(A))). -C -C Tolerances -C -C TOL DOUBLE PRECISION -C The tolerance to be used to test for near singularity of -C the matrix A. If the user sets TOL > 0, then the given -C value of TOL is used as a lower bound for the reciprocal -C condition number of that matrix; a matrix whose estimated -C condition number is less than 1/TOL is considered to be -C nonsingular. If the user sets TOL <= 0, then an implicitly -C computed, default tolerance, defined by TOLDEF = k*k*EPS, -C is used instead, where EPS is the machine precision (see -C LAPACK Library routine DLAMCH). -C -C Workspace -C -C IWORK INTEGER array, dimension (k) -C -C DWORK DOUBLE PRECISION array, dimension (3*k) -C -C Error Indicator -C -C INFO INTEGER -C = 0: successful exit; -C < 0: if INFO = -i, the i-th argument had an illegal -C value; -C = 1: the matrix A is numerically singular, i.e. the -C condition number estimate of A (in the specified -C norm) exceeds 1/TOL. -C -C METHOD -C -C An estimate of the reciprocal of the condition number of the -C triangular matrix A (in the specified norm) is computed, and if -C this estimate is larger then the given (or default) tolerance, -C the specified matrix equation is solved using Level 3 BLAS -C routine DTRSM. -C -C -C REFERENCES -C -C None. -C -C NUMERICAL ASPECTS -C 2 -C The algorithm requires k N/2 operations. -C -C CONTRIBUTORS -C -C V. Sima, Katholieke Univ. Leuven, Belgium, Feb. 1997. -C -C REVISIONS -C -C February 20, 1998. -C -C KEYWORDS -C -C Condition number, matrix algebra, matrix operations. -C -C ****************************************************************** -C -C .. Parameters .. - DOUBLE PRECISION ZERO, ONE - PARAMETER ( ZERO = 0.0D0, ONE = 1.0D0 ) -C .. Scalar Arguments .. - CHARACTER DIAG, NORM, SIDE, TRANS, UPLO - INTEGER INFO, LDA, LDB, M, N - DOUBLE PRECISION ALPHA, RCOND, TOL -C .. Array Arguments .. - INTEGER IWORK(*) - DOUBLE PRECISION A(LDA,*), B(LDB,*), DWORK(*) -C .. Local Scalars .. - LOGICAL LSIDE, ONENRM - INTEGER NROWA - DOUBLE PRECISION TOLDEF -C .. External Functions .. - LOGICAL LSAME - DOUBLE PRECISION DLAMCH - EXTERNAL DLAMCH, LSAME -C .. External Subroutines .. - EXTERNAL DTRCON, DTRSM, XERBLA -C .. Intrinsic Functions .. - INTRINSIC DBLE, MAX -C .. Executable Statements .. -C - LSIDE = LSAME( SIDE, 'L' ) - IF( LSIDE )THEN - NROWA = M - ELSE - NROWA = N - END IF - ONENRM = NORM.EQ.'1' .OR. LSAME( NORM, 'O' ) -C -C Test the input scalar arguments. -C - INFO = 0 - IF( ( .NOT.LSIDE ).AND.( .NOT.LSAME( SIDE, 'R' ) ) )THEN - INFO = -1 - ELSE IF( ( .NOT.LSAME( UPLO, 'U' ) ).AND. - $ ( .NOT.LSAME( UPLO, 'L' ) ) )THEN - INFO = -2 - ELSE IF( ( .NOT.LSAME( TRANS, 'N' ) ).AND. - $ ( .NOT.LSAME( TRANS, 'T' ) ).AND. - $ ( .NOT.LSAME( TRANS, 'C' ) ) )THEN - INFO = -3 - ELSE IF( ( .NOT.LSAME( DIAG, 'U' ) ).AND. - $ ( .NOT.LSAME( DIAG, 'N' ) ) )THEN - INFO = -4 - ELSE IF( .NOT.ONENRM .AND. .NOT.LSAME( NORM, 'I' ) ) THEN - INFO = -5 - ELSE IF( M.LT.0 )THEN - INFO = -6 - ELSE IF( N.LT.0 )THEN - INFO = -7 - ELSE IF( LDA.LT.MAX( 1, NROWA ) )THEN - INFO = -10 - ELSE IF( LDB.LT.MAX( 1, M ) )THEN - INFO = -12 - END IF -C - IF( INFO.NE.0 ) THEN - CALL XERBLA( 'MB02OD', -INFO ) - RETURN - END IF -C -C Quick return if possible. -C - IF( NROWA.EQ.0 ) THEN - RCOND = ONE - RETURN - END IF -C - TOLDEF = TOL - IF ( TOLDEF.LE.ZERO ) - $ TOLDEF = DBLE( NROWA*NROWA )*DLAMCH( 'Epsilon' ) -C - CALL DTRCON( NORM, UPLO, DIAG, NROWA, A, LDA, RCOND, DWORK, - $ IWORK, INFO ) -C - IF ( RCOND.GT.TOLDEF ) THEN - CALL DTRSM( SIDE, UPLO, TRANS, DIAG, M, N, ALPHA, A, LDA, B, - $ LDB ) - ELSE - INFO = 1 - END IF -C *** Last line of MB02OD *** - END diff --git a/mex/sources/libslicot/MB02PD.f b/mex/sources/libslicot/MB02PD.f deleted file mode 100644 index e8fb4a9a8..000000000 --- a/mex/sources/libslicot/MB02PD.f +++ /dev/null @@ -1,553 +0,0 @@ - SUBROUTINE MB02PD( FACT, TRANS, N, NRHS, A, LDA, AF, LDAF, IPIV, - $ EQUED, R, C, B, LDB, X, LDX, RCOND, FERR, BERR, - $ IWORK, DWORK, INFO ) -C -C SLICOT RELEASE 5.0. -C -C Copyright (c) 2002-2009 NICONET e.V. -C -C This program is free software: you can redistribute it and/or -C modify it under the terms of the GNU General Public License as -C published by the Free Software Foundation, either version 2 of -C the License, or (at your option) any later version. -C -C This program is distributed in the hope that it will be useful, -C but WITHOUT ANY WARRANTY; without even the implied warranty of -C MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the -C GNU General Public License for more details. -C -C You should have received a copy of the GNU General Public License -C along with this program. If not, see -C . -C -C PURPOSE -C -C To solve (if well-conditioned) the matrix equations -C -C op( A )*X = B, -C -C where X and B are N-by-NRHS matrices, A is an N-by-N matrix and -C op( A ) is one of -C -C op( A ) = A or op( A ) = A'. -C -C Error bounds on the solution and a condition estimate are also -C provided. -C -C ARGUMENTS -C -C Mode Parameters -C -C FACT CHARACTER*1 -C Specifies whether or not the factored form of the matrix A -C is supplied on entry, and if not, whether the matrix A -C should be equilibrated before it is factored. -C = 'F': On entry, AF and IPIV contain the factored form -C of A. If EQUED is not 'N', the matrix A has been -C equilibrated with scaling factors given by R -C and C. A, AF, and IPIV are not modified. -C = 'N': The matrix A will be copied to AF and factored. -C = 'E': The matrix A will be equilibrated if necessary, -C then copied to AF and factored. -C -C TRANS CHARACTER*1 -C Specifies the form of the system of equations as follows: -C = 'N': A * X = B (No transpose); -C = 'T': A**T * X = B (Transpose); -C = 'C': A**H * X = B (Transpose). -C -C Input/Output Parameters -C -C N (input) INTEGER -C The number of linear equations, i.e., the order of the -C matrix A. N >= 0. -C -C NRHS (input) INTEGER -C The number of right hand sides, i.e., the number of -C columns of the matrices B and X. NRHS >= 0. -C -C A (input/output) DOUBLE PRECISION array, dimension (LDA,N) -C On entry, the leading N-by-N part of this array must -C contain the matrix A. If FACT = 'F' and EQUED is not 'N', -C then A must have been equilibrated by the scaling factors -C in R and/or C. A is not modified if FACT = 'F' or 'N', -C or if FACT = 'E' and EQUED = 'N' on exit. -C On exit, if EQUED .NE. 'N', the leading N-by-N part of -C this array contains the matrix A scaled as follows: -C EQUED = 'R': A := diag(R) * A; -C EQUED = 'C': A := A * diag(C); -C EQUED = 'B': A := diag(R) * A * diag(C). -C -C LDA INTEGER -C The leading dimension of the array A. LDA >= max(1,N). -C -C AF (input or output) DOUBLE PRECISION array, dimension -C (LDAF,N) -C If FACT = 'F', then AF is an input argument and on entry -C the leading N-by-N part of this array must contain the -C factors L and U from the factorization A = P*L*U as -C computed by DGETRF. If EQUED .NE. 'N', then AF is the -C factored form of the equilibrated matrix A. -C If FACT = 'N', then AF is an output argument and on exit -C the leading N-by-N part of this array contains the factors -C L and U from the factorization A = P*L*U of the original -C matrix A. -C If FACT = 'E', then AF is an output argument and on exit -C the leading N-by-N part of this array contains the factors -C L and U from the factorization A = P*L*U of the -C equilibrated matrix A (see the description of A for the -C form of the equilibrated matrix). -C -C LDAF (input) INTEGER -C The leading dimension of the array AF. LDAF >= max(1,N). -C -C IPIV (input or output) INTEGER array, dimension (N) -C If FACT = 'F', then IPIV is an input argument and on entry -C it must contain the pivot indices from the factorization -C A = P*L*U as computed by DGETRF; row i of the matrix was -C interchanged with row IPIV(i). -C If FACT = 'N', then IPIV is an output argument and on exit -C it contains the pivot indices from the factorization -C A = P*L*U of the original matrix A. -C If FACT = 'E', then IPIV is an output argument and on exit -C it contains the pivot indices from the factorization -C A = P*L*U of the equilibrated matrix A. -C -C EQUED (input or output) CHARACTER*1 -C Specifies the form of equilibration that was done as -C follows: -C = 'N': No equilibration (always true if FACT = 'N'); -C = 'R': Row equilibration, i.e., A has been premultiplied -C by diag(R); -C = 'C': Column equilibration, i.e., A has been -C postmultiplied by diag(C); -C = 'B': Both row and column equilibration, i.e., A has -C been replaced by diag(R) * A * diag(C). -C EQUED is an input argument if FACT = 'F'; otherwise, it is -C an output argument. -C -C R (input or output) DOUBLE PRECISION array, dimension (N) -C The row scale factors for A. If EQUED = 'R' or 'B', A is -C multiplied on the left by diag(R); if EQUED = 'N' or 'C', -C R is not accessed. R is an input argument if FACT = 'F'; -C otherwise, R is an output argument. If FACT = 'F' and -C EQUED = 'R' or 'B', each element of R must be positive. -C -C C (input or output) DOUBLE PRECISION array, dimension (N) -C The column scale factors for A. If EQUED = 'C' or 'B', -C A is multiplied on the right by diag(C); if EQUED = 'N' -C or 'R', C is not accessed. C is an input argument if -C FACT = 'F'; otherwise, C is an output argument. If -C FACT = 'F' and EQUED = 'C' or 'B', each element of C must -C be positive. -C -C B (input/output) DOUBLE PRECISION array, dimension -C (LDB,NRHS) -C On entry, the leading N-by-NRHS part of this array must -C contain the right-hand side matrix B. -C On exit, -C if EQUED = 'N', B is not modified; -C if TRANS = 'N' and EQUED = 'R' or 'B', the leading -C N-by-NRHS part of this array contains diag(R)*B; -C if TRANS = 'T' or 'C' and EQUED = 'C' or 'B', the leading -C N-by-NRHS part of this array contains diag(C)*B. -C -C LDB INTEGER -C The leading dimension of the array B. LDB >= max(1,N). -C -C X (output) DOUBLE PRECISION array, dimension (LDX,NRHS) -C If INFO = 0 or INFO = N+1, the leading N-by-NRHS part of -C this array contains the solution matrix X to the original -C system of equations. Note that A and B are modified on -C exit if EQUED .NE. 'N', and the solution to the -C equilibrated system is inv(diag(C))*X if TRANS = 'N' and -C EQUED = 'C' or 'B', or inv(diag(R))*X if TRANS = 'T' or -C 'C' and EQUED = 'R' or 'B'. -C -C LDX (input) INTEGER -C The leading dimension of the array X. LDX >= max(1,N). -C -C RCOND (output) DOUBLE PRECISION -C The estimate of the reciprocal condition number of the -C matrix A after equilibration (if done). If RCOND is less -C than the machine precision (in particular, if RCOND = 0), -C the matrix is singular to working precision. This -C condition is indicated by a return code of INFO > 0. -C For efficiency reasons, RCOND is computed only when the -C matrix A is factored, i.e., for FACT = 'N' or 'E'. For -C FACT = 'F', RCOND is not used, but it is assumed that it -C has been computed and checked before the routine call. -C -C FERR (output) DOUBLE PRECISION array, dimension (NRHS) -C The estimated forward error bound for each solution vector -C X(j) (the j-th column of the solution matrix X). -C If XTRUE is the true solution corresponding to X(j), -C FERR(j) is an estimated upper bound for the magnitude of -C the largest element in (X(j) - XTRUE) divided by the -C magnitude of the largest element in X(j). The estimate -C is as reliable as the estimate for RCOND, and is almost -C always a slight overestimate of the true error. -C -C BERR (output) DOUBLE PRECISION array, dimension (NRHS) -C The componentwise relative backward error of each solution -C vector X(j) (i.e., the smallest relative change in -C any element of A or B that makes X(j) an exact solution). -C -C Workspace -C -C IWORK INTEGER array, dimension (N) -C -C DWORK DOUBLE PRECISION array, dimension (4*N) -C On exit, DWORK(1) contains the reciprocal pivot growth -C factor norm(A)/norm(U). The "max absolute element" norm is -C used. If DWORK(1) is much less than 1, then the stability -C of the LU factorization of the (equilibrated) matrix A -C could be poor. This also means that the solution X, -C condition estimator RCOND, and forward error bound FERR -C could be unreliable. If factorization fails with -C 0 < INFO <= N, then DWORK(1) contains the reciprocal pivot -C growth factor for the leading INFO columns of A. -C -C Error Indicator -C -C INFO INTEGER -C = 0: successful exit; -C < 0: if INFO = -i, the i-th argument had an illegal -C value; -C > 0: if INFO = i, and i is -C <= N: U(i,i) is exactly zero. The factorization -C has been completed, but the factor U is -C exactly singular, so the solution and error -C bounds could not be computed. RCOND = 0 is -C returned. -C = N+1: U is nonsingular, but RCOND is less than -C machine precision, meaning that the matrix is -C singular to working precision. Nevertheless, -C the solution and error bounds are computed -C because there are a number of situations -C where the computed solution can be more -C accurate than the value of RCOND would -C suggest. -C The positive values for INFO are set only when the -C matrix A is factored, i.e., for FACT = 'N' or 'E'. -C -C METHOD -C -C The following steps are performed: -C -C 1. If FACT = 'E', real scaling factors are computed to equilibrate -C the system: -C -C TRANS = 'N': diag(R)*A*diag(C) *inv(diag(C))*X = diag(R)*B -C TRANS = 'T': (diag(R)*A*diag(C))**T *inv(diag(R))*X = diag(C)*B -C TRANS = 'C': (diag(R)*A*diag(C))**H *inv(diag(R))*X = diag(C)*B -C -C Whether or not the system will be equilibrated depends on the -C scaling of the matrix A, but if equilibration is used, A is -C overwritten by diag(R)*A*diag(C) and B by diag(R)*B -C (if TRANS='N') or diag(C)*B (if TRANS = 'T' or 'C'). -C -C 2. If FACT = 'N' or 'E', the LU decomposition is used to factor -C the matrix A (after equilibration if FACT = 'E') as -C A = P * L * U, -C where P is a permutation matrix, L is a unit lower triangular -C matrix, and U is upper triangular. -C -C 3. If some U(i,i)=0, so that U is exactly singular, then the -C routine returns with INFO = i. Otherwise, the factored form -C of A is used to estimate the condition number of the matrix A. -C If the reciprocal of the condition number is less than machine -C precision, INFO = N+1 is returned as a warning, but the routine -C still goes on to solve for X and compute error bounds as -C described below. -C -C 4. The system of equations is solved for X using the factored form -C of A. -C -C 5. Iterative refinement is applied to improve the computed -C solution matrix and calculate error bounds and backward error -C estimates for it. -C -C 6. If equilibration was used, the matrix X is premultiplied by -C diag(C) (if TRANS = 'N') or diag(R) (if TRANS = 'T' or 'C') so -C that it solves the original system before equilibration. -C -C REFERENCES -C -C [1] Anderson, E., Bai, Z., Bischof, C., Demmel, J., Dongarra, J., -C Du Croz, J., Greenbaum, A., Hammarling, S., McKenney, A., -C Ostrouchov, S., Sorensen, D. -C LAPACK Users' Guide: Second Edition, SIAM, Philadelphia, 1995. -C -C FURTHER COMMENTS -C -C This is a simplified version of the LAPACK Library routine DGESVX, -C useful when several sets of matrix equations with the same -C coefficient matrix A and/or A' should be solved. -C -C NUMERICAL ASPECTS -C 3 -C The algorithm requires 0(N ) operations. -C -C CONTRIBUTORS -C -C V. Sima, Research Institute for Informatics, Bucharest, Apr. 1999. -C -C REVISIONS -C -C - -C -C KEYWORDS -C -C Condition number, matrix algebra, matrix operations. -C -C ****************************************************************** -C -C .. Parameters .. - DOUBLE PRECISION ZERO, ONE - PARAMETER ( ZERO = 0.0D0, ONE = 1.0D0 ) -C .. Scalar Arguments .. - CHARACTER EQUED, FACT, TRANS - INTEGER INFO, LDA, LDAF, LDB, LDX, N, NRHS - DOUBLE PRECISION RCOND -C .. -C .. Array Arguments .. - INTEGER IPIV( * ), IWORK( * ) - DOUBLE PRECISION A( LDA, * ), AF( LDAF, * ), B( LDB, * ), - $ BERR( * ), C( * ), DWORK( * ), FERR( * ), - $ R( * ), X( LDX, * ) -C .. -C .. Local Scalars .. - LOGICAL COLEQU, EQUIL, NOFACT, NOTRAN, ROWEQU - CHARACTER NORM - INTEGER I, INFEQU, J - DOUBLE PRECISION AMAX, ANORM, BIGNUM, COLCND, RCMAX, RCMIN, - $ ROWCND, RPVGRW, SMLNUM -C .. -C .. External Functions .. - LOGICAL LSAME - DOUBLE PRECISION DLAMCH, DLANGE, DLANTR - EXTERNAL LSAME, DLAMCH, DLANGE, DLANTR -C .. -C .. External Subroutines .. - EXTERNAL DGECON, DGEEQU, DGERFS, DGETRF, DGETRS, DLACPY, - $ DLAQGE, XERBLA -C .. -C .. Intrinsic Functions .. - INTRINSIC MAX, MIN -C .. -C .. Save Statement .. - SAVE RPVGRW -C .. -C .. Executable Statements .. -C - INFO = 0 - NOFACT = LSAME( FACT, 'N' ) - EQUIL = LSAME( FACT, 'E' ) - NOTRAN = LSAME( TRANS, 'N' ) - IF( NOFACT .OR. EQUIL ) THEN - EQUED = 'N' - ROWEQU = .FALSE. - COLEQU = .FALSE. - ELSE - ROWEQU = LSAME( EQUED, 'R' ) .OR. LSAME( EQUED, 'B' ) - COLEQU = LSAME( EQUED, 'C' ) .OR. LSAME( EQUED, 'B' ) - SMLNUM = DLAMCH( 'Safe minimum' ) - BIGNUM = ONE / SMLNUM - END IF -C -C Test the input parameters. -C - IF( .NOT.NOFACT .AND. .NOT.EQUIL .AND. .NOT.LSAME( FACT, 'F' ) ) - $ THEN - INFO = -1 - ELSE IF( .NOT.NOTRAN .AND. .NOT.LSAME( TRANS, 'T' ) .AND. .NOT. - $ LSAME( TRANS, 'C' ) ) THEN - INFO = -2 - ELSE IF( N.LT.0 ) THEN - INFO = -3 - ELSE IF( NRHS.LT.0 ) THEN - INFO = -4 - ELSE IF( LDA.LT.MAX( 1, N ) ) THEN - INFO = -6 - ELSE IF( LDAF.LT.MAX( 1, N ) ) THEN - INFO = -8 - ELSE IF( LSAME( FACT, 'F' ) .AND. .NOT. - $ ( ROWEQU .OR. COLEQU .OR. LSAME( EQUED, 'N' ) ) ) THEN - INFO = -10 - ELSE - IF( ROWEQU ) THEN - RCMIN = BIGNUM - RCMAX = ZERO - DO 10 J = 1, N - RCMIN = MIN( RCMIN, R( J ) ) - RCMAX = MAX( RCMAX, R( J ) ) - 10 CONTINUE - IF( RCMIN.LE.ZERO ) THEN - INFO = -11 - ELSE IF( N.GT.0 ) THEN - ROWCND = MAX( RCMIN, SMLNUM ) / MIN( RCMAX, BIGNUM ) - ELSE - ROWCND = ONE - END IF - END IF - IF( COLEQU .AND. INFO.EQ.0 ) THEN - RCMIN = BIGNUM - RCMAX = ZERO - DO 20 J = 1, N - RCMIN = MIN( RCMIN, C( J ) ) - RCMAX = MAX( RCMAX, C( J ) ) - 20 CONTINUE - IF( RCMIN.LE.ZERO ) THEN - INFO = -12 - ELSE IF( N.GT.0 ) THEN - COLCND = MAX( RCMIN, SMLNUM ) / MIN( RCMAX, BIGNUM ) - ELSE - COLCND = ONE - END IF - END IF - IF( INFO.EQ.0 ) THEN - IF( LDB.LT.MAX( 1, N ) ) THEN - INFO = -14 - ELSE IF( LDX.LT.MAX( 1, N ) ) THEN - INFO = -16 - END IF - END IF - END IF -C - IF( INFO.NE.0 ) THEN - CALL XERBLA( 'MB02PD', -INFO ) - RETURN - END IF -C - IF( EQUIL ) THEN -C -C Compute row and column scalings to equilibrate the matrix A. -C - CALL DGEEQU( N, N, A, LDA, R, C, ROWCND, COLCND, AMAX, INFEQU ) - IF( INFEQU.EQ.0 ) THEN -C -C Equilibrate the matrix. -C - CALL DLAQGE( N, N, A, LDA, R, C, ROWCND, COLCND, AMAX, - $ EQUED ) - ROWEQU = LSAME( EQUED, 'R' ) .OR. LSAME( EQUED, 'B' ) - COLEQU = LSAME( EQUED, 'C' ) .OR. LSAME( EQUED, 'B' ) - END IF - END IF -C -C Scale the right hand side. -C - IF( NOTRAN ) THEN - IF( ROWEQU ) THEN - DO 40 J = 1, NRHS - DO 30 I = 1, N - B( I, J ) = R( I )*B( I, J ) - 30 CONTINUE - 40 CONTINUE - END IF - ELSE IF( COLEQU ) THEN - DO 60 J = 1, NRHS - DO 50 I = 1, N - B( I, J ) = C( I )*B( I, J ) - 50 CONTINUE - 60 CONTINUE - END IF -C - IF( NOFACT .OR. EQUIL ) THEN -C -C Compute the LU factorization of A. -C - CALL DLACPY( 'Full', N, N, A, LDA, AF, LDAF ) - CALL DGETRF( N, N, AF, LDAF, IPIV, INFO ) -C -C Return if INFO is non-zero. -C - IF( INFO.NE.0 ) THEN - IF( INFO.GT.0 ) THEN -C -C Compute the reciprocal pivot growth factor of the -C leading rank-deficient INFO columns of A. -C - RPVGRW = DLANTR( 'M', 'U', 'N', INFO, INFO, AF, LDAF, - $ DWORK ) - IF( RPVGRW.EQ.ZERO ) THEN - RPVGRW = ONE - ELSE - RPVGRW = DLANGE( 'M', N, INFO, A, LDA, DWORK ) / - $ RPVGRW - END IF - DWORK( 1 ) = RPVGRW - RCOND = ZERO - END IF - RETURN - END IF -C -C Compute the norm of the matrix A and the -C reciprocal pivot growth factor RPVGRW. -C - IF( NOTRAN ) THEN - NORM = '1' - ELSE - NORM = 'I' - END IF - ANORM = DLANGE( NORM, N, N, A, LDA, DWORK ) - RPVGRW = DLANTR( 'M', 'U', 'N', N, N, AF, LDAF, DWORK ) - IF( RPVGRW.EQ.ZERO ) THEN - RPVGRW = ONE - ELSE - RPVGRW = DLANGE( 'M', N, N, A, LDA, DWORK ) / RPVGRW - END IF -C -C Compute the reciprocal of the condition number of A. -C - CALL DGECON( NORM, N, AF, LDAF, ANORM, RCOND, DWORK, IWORK, - $ INFO ) -C -C Set INFO = N+1 if the matrix is singular to working precision. -C - IF( RCOND.LT.DLAMCH( 'Epsilon' ) ) - $ INFO = N + 1 - END IF -C -C Compute the solution matrix X. -C - CALL DLACPY( 'Full', N, NRHS, B, LDB, X, LDX ) - CALL DGETRS( TRANS, N, NRHS, AF, LDAF, IPIV, X, LDX, INFO ) -C -C Use iterative refinement to improve the computed solution and -C compute error bounds and backward error estimates for it. -C - CALL DGERFS( TRANS, N, NRHS, A, LDA, AF, LDAF, IPIV, B, LDB, X, - $ LDX, FERR, BERR, DWORK, IWORK, INFO ) -C -C Transform the solution matrix X to a solution of the original -C system. -C - IF( NOTRAN ) THEN - IF( COLEQU ) THEN - DO 80 J = 1, NRHS - DO 70 I = 1, N - X( I, J ) = C( I )*X( I, J ) - 70 CONTINUE - 80 CONTINUE - DO 90 J = 1, NRHS - FERR( J ) = FERR( J ) / COLCND - 90 CONTINUE - END IF - ELSE IF( ROWEQU ) THEN - DO 110 J = 1, NRHS - DO 100 I = 1, N - X( I, J ) = R( I )*X( I, J ) - 100 CONTINUE - 110 CONTINUE - DO 120 J = 1, NRHS - FERR( J ) = FERR( J ) / ROWCND - 120 CONTINUE - END IF -C - DWORK( 1 ) = RPVGRW - RETURN -C -C *** Last line of MB02PD *** - END diff --git a/mex/sources/libslicot/MB02QD.f b/mex/sources/libslicot/MB02QD.f deleted file mode 100644 index 610c25043..000000000 --- a/mex/sources/libslicot/MB02QD.f +++ /dev/null @@ -1,502 +0,0 @@ - SUBROUTINE MB02QD( JOB, INIPER, M, N, NRHS, RCOND, SVLMAX, A, LDA, - $ B, LDB, Y, JPVT, RANK, SVAL, DWORK, LDWORK, - $ INFO ) -C -C SLICOT RELEASE 5.0. -C -C Copyright (c) 2002-2009 NICONET e.V. -C -C This program is free software: you can redistribute it and/or -C modify it under the terms of the GNU General Public License as -C published by the Free Software Foundation, either version 2 of -C the License, or (at your option) any later version. -C -C This program is distributed in the hope that it will be useful, -C but WITHOUT ANY WARRANTY; without even the implied warranty of -C MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the -C GNU General Public License for more details. -C -C You should have received a copy of the GNU General Public License -C along with this program. If not, see -C . -C -C PURPOSE -C -C To compute a solution, optionally corresponding to specified free -C elements, to a real linear least squares problem: -C -C minimize || A * X - B || -C -C using a complete orthogonal factorization of the M-by-N matrix A, -C which may be rank-deficient. -C -C Several right hand side vectors b and solution vectors x can be -C handled in a single call; they are stored as the columns of the -C M-by-NRHS right hand side matrix B and the N-by-NRHS solution -C matrix X. -C -C ARGUMENTS -C -C Mode Parameters -C -C JOB CHARACTER*1 -C Specifies whether or not a standard least squares solution -C must be computed, as follows: -C = 'L': Compute a standard least squares solution (Y = 0); -C = 'F': Compute a solution with specified free elements -C (given in Y). -C -C INIPER CHARACTER*1 -C Specifies whether an initial column permutation, defined -C by JPVT, must be performed, as follows: -C = 'P': Perform an initial column permutation; -C = 'N': Do not perform an initial column permutation. -C -C Input/Output Parameters -C -C M (input) INTEGER -C The number of rows of the matrix A. M >= 0. -C -C N (input) INTEGER -C The number of columns of the matrix A. N >= 0. -C -C NRHS (input) INTEGER -C The number of right hand sides, i.e., the number of -C columns of the matrices B and X. NRHS >= 0. -C -C RCOND (input) DOUBLE PRECISION -C RCOND is used to determine the effective rank of A, which -C is defined as the order of the largest leading triangular -C submatrix R11 in the QR factorization with pivoting of A, -C whose estimated condition number is less than 1/RCOND. -C 0 <= RCOND <= 1. -C -C SVLMAX (input) DOUBLE PRECISION -C If A is a submatrix of another matrix C, and the rank -C decision should be related to that matrix, then SVLMAX -C should be an estimate of the largest singular value of C -C (for instance, the Frobenius norm of C). If this is not -C the case, the input value SVLMAX = 0 should work. -C SVLMAX >= 0. -C -C A (input/output) DOUBLE PRECISION array, dimension (LDA,N) -C On entry, the leading M-by-N part of this array must -C contain the given matrix A. -C On exit, the leading M-by-N part of this array contains -C details of its complete orthogonal factorization: -C the leading RANK-by-RANK upper triangular part contains -C the upper triangular factor T11 (see METHOD); -C the elements below the diagonal, with the entries 2 to -C min(M,N)+1 of the array DWORK, represent the orthogonal -C matrix Q as a product of min(M,N) elementary reflectors -C (see METHOD); -C the elements of the subarray A(1:RANK,RANK+1:N), with the -C next RANK entries of the array DWORK, represent the -C orthogonal matrix Z as a product of RANK elementary -C reflectors (see METHOD). -C -C LDA INTEGER -C The leading dimension of the array A. LDA >= max(1,M). -C -C B (input/output) DOUBLE PRECISION array, dimension -C (LDB,NRHS) -C On entry, the leading M-by-NRHS part of this array must -C contain the right hand side matrix B. -C On exit, the leading N-by-NRHS part of this array contains -C the solution matrix X. -C If M >= N and RANK = N, the residual sum-of-squares for -C the solution in the i-th column is given by the sum of -C squares of elements N+1:M in that column. -C If NRHS = 0, this array is not referenced, and the routine -C returns the effective rank of A, and its QR factorization. -C -C LDB INTEGER -C The leading dimension of the array B. LDB >= max(1,M,N). -C -C Y (input) DOUBLE PRECISION array, dimension ( N*NRHS ) -C If JOB = 'F', the elements Y(1:(N-RANK)*NRHS) are used as -C free elements in computing the solution (see METHOD). -C The remaining elements are not referenced. -C If JOB = 'L', or NRHS = 0, this array is not referenced. -C -C JPVT (input/output) INTEGER array, dimension (N) -C On entry with INIPER = 'P', if JPVT(i) <> 0, the i-th -C column of A is an initial column, otherwise it is a free -C column. Before the QR factorization of A, all initial -C columns are permuted to the leading positions; only the -C remaining free columns are moved as a result of column -C pivoting during the factorization. -C If INIPER = 'N', JPVT need not be set on entry. -C On exit, if JPVT(i) = k, then the i-th column of A*P -C was the k-th column of A. -C -C RANK (output) INTEGER -C The effective rank of A, i.e., the order of the submatrix -C R11. This is the same as the order of the submatrix T11 -C in the complete orthogonal factorization of A. -C -C SVAL (output) DOUBLE PRECISION array, dimension ( 3 ) -C The estimates of some of the singular values of the -C triangular factor R11: -C SVAL(1): largest singular value of R(1:RANK,1:RANK); -C SVAL(2): smallest singular value of R(1:RANK,1:RANK); -C SVAL(3): smallest singular value of R(1:RANK+1,1:RANK+1), -C if RANK < MIN( M, N ), or of R(1:RANK,1:RANK), -C otherwise. -C If the triangular factorization is a rank-revealing one -C (which will be the case if the leading columns were well- -C conditioned), then SVAL(1) will also be an estimate for -C the largest singular value of A, and SVAL(2) and SVAL(3) -C will be estimates for the RANK-th and (RANK+1)-st singular -C values of A, respectively. -C By examining these values, one can confirm that the rank -C is well defined with respect to the chosen value of RCOND. -C The ratio SVAL(1)/SVAL(2) is an estimate of the condition -C number of R(1:RANK,1:RANK). -C -C Workspace -C -C DWORK DOUBLE PRECISION array, dimension LDWORK -C On exit, if INFO = 0, DWORK(1) returns the optimal value -C of LDWORK, and the entries 2 to min(M,N) + RANK + 1 -C contain the scalar factors of the elementary reflectors -C used in the complete orthogonal factorization of A. -C Among the entries 2 to min(M,N) + 1, only the first RANK -C elements are useful, if INIPER = 'N'. -C -C LDWORK INTEGER -C The length of the array DWORK. -C LDWORK >= max( min(M,N)+3*N+1, 2*min(M,N)+NRHS ) -C For optimum performance LDWORK should be larger. -C -C Error indicator -C -C INFO INTEGER -C = 0: successful exit; -C < 0: if INFO = -i, the i-th argument had an illegal -C value. -C -C METHOD -C -C If INIPER = 'P', the routine first computes a QR factorization -C with column pivoting: -C A * P = Q * [ R11 R12 ] -C [ 0 R22 ] -C with R11 defined as the largest leading submatrix whose estimated -C condition number is less than 1/RCOND. The order of R11, RANK, -C is the effective rank of A. -C If INIPER = 'N', the effective rank is estimated during a -C truncated QR factorization (with column pivoting) process, and -C the submatrix R22 is not upper triangular, but full and of small -C norm. (See SLICOT Library routines MB03OD or MB03OY, respectively, -C for further details.) -C -C Then, R22 is considered to be negligible, and R12 is annihilated -C by orthogonal transformations from the right, arriving at the -C complete orthogonal factorization: -C A * P = Q * [ T11 0 ] * Z -C [ 0 0 ] -C The solution is then -C X = P * Z' [ inv(T11)*Q1'*B ] -C [ Y ] -C where Q1 consists of the first RANK columns of Q, and Y contains -C free elements (if JOB = 'F'), or is zero (if JOB = 'L'). -C -C NUMERICAL ASPECTS -C -C The algorithm is backward stable. -C -C FURTHER COMMENTS -C -C Significant gain in efficiency is possible for small-rank problems -C using truncated QR factorization (option INIPER = 'N'). -C -C CONTRIBUTORS -C -C P.Hr. Petkov, Technical University of Sofia, Oct. 1998, -C modification of the LAPACK routine DGELSX. -C V. Sima, Katholieke Universiteit Leuven, Jan. 1999, SLICOT Library -C version. -C -C REVISIONS -C -C V. Sima, Research Institute for Informatics, Bucharest, Mar. 2005. -C -C KEYWORDS -C -C Least squares problems, QR factorization. -C -C ****************************************************************** -C - DOUBLE PRECISION ZERO, ONE, DONE, NTDONE - PARAMETER ( ZERO = 0.0D0, ONE = 1.0D0, DONE = ZERO, - $ NTDONE = ONE ) -C .. -C .. Scalar Arguments .. - CHARACTER INIPER, JOB - INTEGER INFO, LDA, LDB, LDWORK, M, N, NRHS, RANK - DOUBLE PRECISION RCOND, SVLMAX -C .. -C .. Array Arguments .. - INTEGER JPVT( * ) - DOUBLE PRECISION A( LDA, * ), B( LDB, * ), DWORK( * ), - $ SVAL( 3 ), Y ( * ) -C .. -C .. Local Scalars .. - LOGICAL LEASTS, PERMUT - INTEGER I, IASCL, IBSCL, J, K, MAXWRK, MINWRK, MN - DOUBLE PRECISION ANRM, BIGNUM, BNRM, SMLNUM, T1, T2 -C .. -C .. External Functions .. - LOGICAL LSAME - DOUBLE PRECISION DLAMCH, DLANGE - EXTERNAL DLAMCH, DLANGE, LSAME -C .. -C .. External Subroutines .. - EXTERNAL DLABAD, DLACPY, DLASCL, DLASET, DORMQR, DORMRZ, - $ DTRSM, DTZRZF, MB03OD, MB03OY, XERBLA -C .. -C .. Intrinsic Functions .. - INTRINSIC INT, MAX, MIN -C .. -C .. Executable Statements .. -C - MN = MIN( M, N ) - LEASTS = LSAME( JOB, 'L' ) - PERMUT = LSAME( INIPER, 'P' ) -C -C Test the input scalar arguments. -C - INFO = 0 - MINWRK = MAX( MN + 3*N + 1, 2*MN + NRHS ) - IF( .NOT. ( LEASTS .OR. LSAME( JOB, 'F' ) ) ) THEN - INFO = -1 - ELSE IF( .NOT. ( PERMUT .OR. LSAME( INIPER, 'N' ) ) ) THEN - INFO = -2 - ELSE IF( M.LT.0 ) THEN - INFO = -3 - ELSE IF( N.LT.0 ) THEN - INFO = -4 - ELSE IF( NRHS.LT.0 ) THEN - INFO = -5 - ELSE IF( RCOND.LT.ZERO .OR. RCOND.GT.ONE ) THEN - INFO = -6 - ELSE IF( SVLMAX.LT.ZERO ) THEN - INFO = -7 - ELSE IF( LDA.LT.MAX( 1, M ) ) THEN - INFO = -9 - ELSE IF( LDB.LT.MAX( 1, M, N ) ) THEN - INFO = -11 - ELSE IF( LDWORK.LT.MINWRK ) THEN - INFO = -17 - END IF -C - IF( INFO.NE.0 ) THEN - CALL XERBLA( 'MB02QD', -INFO ) - RETURN - END IF -C -C Quick return if possible. -C - IF( MN.EQ.0 ) THEN - RANK = 0 - DWORK( 1 ) = ONE - RETURN - END IF -C -C Get machine parameters. -C - SMLNUM = DLAMCH( 'Safe minimum' ) / DLAMCH( 'Precision' ) - BIGNUM = ONE / SMLNUM - CALL DLABAD( SMLNUM, BIGNUM ) -C -C Scale A, B if max entries outside range [SMLNUM,BIGNUM]. -C - ANRM = DLANGE( 'M', M, N, A, LDA, DWORK ) - IASCL = 0 - IF( ANRM.GT.ZERO .AND. ANRM.LT.SMLNUM ) THEN -C -C Scale matrix norm up to SMLNUM. -C - CALL DLASCL( 'G', 0, 0, ANRM, SMLNUM, M, N, A, LDA, INFO ) - IASCL = 1 - ELSE IF( ANRM.GT.BIGNUM ) THEN -C -C Scale matrix norm down to BIGNUM. -C - CALL DLASCL( 'G', 0, 0, ANRM, BIGNUM, M, N, A, LDA, INFO ) - IASCL = 2 - ELSE IF( ANRM.EQ.ZERO ) THEN -C -C Matrix all zero. Return zero solution. -C - IF( NRHS.GT.0 ) - $ CALL DLASET( 'Full', MAX( M, N ), NRHS, ZERO, ZERO, B, LDB ) - RANK = 0 - DWORK( 1 ) = ONE - RETURN - END IF -C - IF( NRHS.GT.0 ) THEN - BNRM = DLANGE( 'M', M, NRHS, B, LDB, DWORK ) - IBSCL = 0 - IF( BNRM.GT.ZERO .AND. BNRM.LT.SMLNUM ) THEN -C -C Scale matrix norm up to SMLNUM. -C - CALL DLASCL( 'G', 0, 0, BNRM, SMLNUM, M, NRHS, B, LDB, - $ INFO ) - IBSCL = 1 - ELSE IF( BNRM.GT.BIGNUM ) THEN -C -C Scale matrix norm down to BIGNUM. -C - CALL DLASCL( 'G', 0, 0, BNRM, BIGNUM, M, NRHS, B, LDB, - $ INFO ) - IBSCL = 2 - END IF - END IF -C -C Compute a rank-revealing QR factorization of A and estimate its -C effective rank using incremental condition estimation: -C A * P = Q * R. -C Workspace need min(M,N)+3*N+1; -C prefer min(M,N)+2*N+N*NB. -C Details of Householder transformations stored in DWORK(1:MN). -C (Note: Comments in the code beginning "Workspace:" describe the -C minimal amount of workspace needed at that point in the code, -C as well as the preferred amount for good performance. -C NB refers to the optimal block size for the immediately -C following subroutine, as returned by ILAENV.) -C - MAXWRK = MINWRK - IF( PERMUT ) THEN - CALL MB03OD( 'Q', M, N, A, LDA, JPVT, RCOND, SVLMAX, - $ DWORK( 1 ), RANK, SVAL, DWORK( MN+1 ), LDWORK-MN, - $ INFO ) - MAXWRK = MAX( MAXWRK, INT( DWORK( MN+1 ) ) + MN ) - ELSE - CALL MB03OY( M, N, A, LDA, RCOND, SVLMAX, RANK, SVAL, JPVT, - $ DWORK( 1 ), DWORK( MN+1 ), INFO ) - END IF -C -C Logically partition R = [ R11 R12 ] -C [ 0 R22 ], -C where R11 = R(1:RANK,1:RANK). -C -C [R11,R12] = [ T11, 0 ] * Z. -C -C Details of Householder transformations stored in DWORK(MN+1:2*MN). -C Workspace need 3*min(M,N); -C prefer 2*min(M,N)+min(M,N)*NB. -C - IF( RANK.LT.N ) THEN - CALL DTZRZF( RANK, N, A, LDA, DWORK( MN+1 ), DWORK( 2*MN+1 ), - $ LDWORK-2*MN, INFO ) - MAXWRK = MAX( MAXWRK, INT( DWORK( 2*MN+1 ) ) + 2*MN ) - END IF -C - IF( NRHS.GT.0 ) THEN -C -C B(1:M,1:NRHS) := Q' * B(1:M,1:NRHS). -C -C Workspace: need 2*min(M,N)+NRHS; -C prefer min(M,N)+NRHS*NB. -C - CALL DORMQR( 'Left', 'Transpose', M, NRHS, MN, A, LDA, - $ DWORK( 1 ), B, LDB, DWORK( 2*MN+1 ), LDWORK-2*MN, - $ INFO ) - MAXWRK = MAX( MAXWRK, INT( DWORK( 2*MN+1 ) ) + 2*MN ) -C -C B(1:RANK,1:NRHS) := inv(T11) * B(1:RANK,1:NRHS). -C - CALL DTRSM( 'Left', 'Upper', 'No transpose', 'Non-unit', RANK, - $ NRHS, ONE, A, LDA, B, LDB ) -C - IF( RANK.LT.N ) THEN -C -C Set B(RANK+1:N,1:NRHS). -C - IF( LEASTS ) THEN - CALL DLASET( 'Full', N-RANK, NRHS, ZERO, ZERO, - $ B(RANK+1,1), LDB ) - ELSE - CALL DLACPY( 'Full', N-RANK, NRHS, Y, N-RANK, - $ B(RANK+1,1), LDB ) - END IF -C -C B(1:N,1:NRHS) := Z' * B(1:N,1:NRHS). -C -C Workspace need 2*min(M,N)+NRHS; -C prefer 2*min(M,N)+NRHS*NB. -C - CALL DORMRZ( 'Left', 'Transpose', N, NRHS, RANK, N-RANK, A, - $ LDA, DWORK( MN+1 ), B, LDB, DWORK( 2*MN+1 ), - $ LDWORK-2*MN, INFO ) - MAXWRK = MAX( MAXWRK, INT( DWORK( 2*MN+1 ) ) + 2*MN ) - END IF -C -C Additional workspace: NRHS. -C -C B(1:N,1:NRHS) := P * B(1:N,1:NRHS). -C - DO 50 J = 1, NRHS - DO 20 I = 1, N - DWORK( 2*MN+I ) = NTDONE - 20 CONTINUE - DO 40 I = 1, N - IF( DWORK( 2*MN+I ).EQ.NTDONE ) THEN - IF( JPVT( I ).NE.I ) THEN - K = I - T1 = B( K, J ) - T2 = B( JPVT( K ), J ) - 30 CONTINUE - B( JPVT( K ), J ) = T1 - DWORK( 2*MN+K ) = DONE - T1 = T2 - K = JPVT( K ) - T2 = B( JPVT( K ), J ) - IF( JPVT( K ).NE.I ) - $ GO TO 30 - B( I, J ) = T1 - DWORK( 2*MN+K ) = DONE - END IF - END IF - 40 CONTINUE - 50 CONTINUE -C -C Undo scaling for B. -C - IF( IBSCL.EQ.1 ) THEN - CALL DLASCL( 'G', 0, 0, SMLNUM, BNRM, N, NRHS, B, LDB, - $ INFO ) - ELSE IF( IBSCL.EQ.2 ) THEN - CALL DLASCL( 'G', 0, 0, BIGNUM, BNRM, N, NRHS, B, LDB, - $ INFO ) - END IF - END IF -C -C Undo scaling for A. -C - IF( IASCL.EQ.1 ) THEN - IF( NRHS.GT.0 ) - $ CALL DLASCL( 'G', 0, 0, ANRM, SMLNUM, N, NRHS, B, LDB, - $ INFO ) - CALL DLASCL( 'U', 0, 0, SMLNUM, ANRM, RANK, RANK, A, LDA, - $ INFO ) - ELSE IF( IASCL.EQ.2 ) THEN - IF( NRHS.GT.0 ) - $ CALL DLASCL( 'G', 0, 0, ANRM, BIGNUM, N, NRHS, B, LDB, - $ INFO ) - CALL DLASCL( 'U', 0, 0, BIGNUM, ANRM, RANK, RANK, A, LDA, - $ INFO ) - END IF -C - DO 60 I = MN + RANK, 1, -1 - DWORK( I+1 ) = DWORK( I ) - 60 CONTINUE -C - DWORK( 1 ) = MAXWRK - RETURN -C *** Last line of MB02QD *** - END diff --git a/mex/sources/libslicot/MB02QY.f b/mex/sources/libslicot/MB02QY.f deleted file mode 100644 index 329f54d46..000000000 --- a/mex/sources/libslicot/MB02QY.f +++ /dev/null @@ -1,339 +0,0 @@ - SUBROUTINE MB02QY( M, N, NRHS, RANK, A, LDA, JPVT, B, LDB, TAU, - $ DWORK, LDWORK, INFO ) -C -C SLICOT RELEASE 5.0. -C -C Copyright (c) 2002-2009 NICONET e.V. -C -C This program is free software: you can redistribute it and/or -C modify it under the terms of the GNU General Public License as -C published by the Free Software Foundation, either version 2 of -C the License, or (at your option) any later version. -C -C This program is distributed in the hope that it will be useful, -C but WITHOUT ANY WARRANTY; without even the implied warranty of -C MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the -C GNU General Public License for more details. -C -C You should have received a copy of the GNU General Public License -C along with this program. If not, see -C . -C -C PURPOSE -C -C To determine the minimum-norm solution to a real linear least -C squares problem: -C -C minimize || A * X - B ||, -C -C using the rank-revealing QR factorization of a real general -C M-by-N matrix A, computed by SLICOT Library routine MB03OD. -C -C ARGUMENTS -C -C Input/Output Parameters -C -C M (input) INTEGER -C The number of rows of the matrices A and B. M >= 0. -C -C N (input) INTEGER -C The number of columns of the matrix A. N >= 0. -C -C NRHS (input) INTEGER -C The number of columns of the matrix B. NRHS >= 0. -C -C RANK (input) INTEGER -C The effective rank of A, as returned by SLICOT Library -C routine MB03OD. min(M,N) >= RANK >= 0. -C -C A (input/output) DOUBLE PRECISION array, dimension -C ( LDA, N ) -C On entry, the leading min(M,N)-by-N upper trapezoidal -C part of this array contains the triangular factor R, as -C returned by SLICOT Library routine MB03OD. The strict -C lower trapezoidal part of A is not referenced. -C On exit, if RANK < N, the leading RANK-by-RANK upper -C triangular part of this array contains the upper -C triangular matrix R of the complete orthogonal -C factorization of A, and the submatrix (1:RANK,RANK+1:N) -C of this array, with the array TAU, represent the -C orthogonal matrix Z (of the complete orthogonal -C factorization of A), as a product of RANK elementary -C reflectors. -C On exit, if RANK = N, this array is unchanged. -C -C LDA INTEGER -C The leading dimension of the array A. LDA >= max(1,M). -C -C JPVT (input) INTEGER array, dimension ( N ) -C The recorded permutations performed by SLICOT Library -C routine MB03OD; if JPVT(i) = k, then the i-th column -C of A*P was the k-th column of the original matrix A. -C -C B (input/output) DOUBLE PRECISION array, dimension -C ( LDB, NRHS ) -C On entry, if NRHS > 0, the leading M-by-NRHS part of -C this array must contain the matrix B (corresponding to -C the transformed matrix A, returned by SLICOT Library -C routine MB03OD). -C On exit, if NRHS > 0, the leading N-by-NRHS part of this -C array contains the solution matrix X. -C If M >= N and RANK = N, the residual sum-of-squares -C for the solution in the i-th column is given by the sum -C of squares of elements N+1:M in that column. -C If NRHS = 0, the array B is not referenced. -C -C LDB INTEGER -C The leading dimension of the array B. -C LDB >= max(1,M,N), if NRHS > 0. -C LDB >= 1, if NRHS = 0. -C -C TAU (output) DOUBLE PRECISION array, dimension ( min(M,N) ) -C The scalar factors of the elementary reflectors. -C If RANK = N, the array TAU is not referenced. -C -C Workspace -C -C DWORK DOUBLE PRECISION array, dimension ( LDWORK ) -C On exit, if INFO = 0, DWORK(1) returns the optimal value -C of LDWORK. -C -C LDWORK INTEGER -C The length of the array DWORK. -C LDWORK >= max( 1, N, NRHS ). -C For good performance, LDWORK should sometimes be larger. -C -C Error Indicator -C -C INFO INTEGER -C = 0: successful exit; -C < 0: if INFO = -i, the i-th argument had an illegal -C value. -C -C METHOD -C -C The routine uses a QR factorization with column pivoting: -C -C A * P = Q * R = Q * [ R11 R12 ], -C [ 0 R22 ] -C -C where R11 is an upper triangular submatrix of estimated rank -C RANK, the effective rank of A. The submatrix R22 can be -C considered as negligible. -C -C If RANK < N, then R12 is annihilated by orthogonal -C transformations from the right, arriving at the complete -C orthogonal factorization: -C -C A * P = Q * [ T11 0 ] * Z. -C [ 0 0 ] -C -C The minimum-norm solution is then -C -C X = P * Z' [ inv(T11)*Q1'*B ], -C [ 0 ] -C -C where Q1 consists of the first RANK columns of Q. -C -C The input data for MB02QY are the transformed matrices Q' * A -C (returned by SLICOT Library routine MB03OD) and Q' * B. -C Matrix Q is not needed. -C -C NUMERICAL ASPECTS -C -C The implemented method is numerically stable. -C -C CONTRIBUTOR -C -C V. Sima, Research Institute for Informatics, Bucharest, Aug. 1999. -C -C REVISIONS -C -C - -C -C KEYWORDS -C -C Least squares solutions; QR decomposition. -C -C ****************************************************************** -C -C .. Parameters .. - DOUBLE PRECISION ZERO, ONE - PARAMETER ( ZERO = 0.0D0, ONE = 1.0D0 ) -C .. Scalar Arguments .. - INTEGER INFO, LDA, LDB, LDWORK, M, N, NRHS, RANK -C .. Array Arguments .. - INTEGER JPVT( * ) - DOUBLE PRECISION A( LDA, * ), B( LDB, * ), DWORK( * ), TAU( * ) -C .. Local Scalars .. - INTEGER I, IASCL, IBSCL, J, MN - DOUBLE PRECISION ANRM, BIGNUM, BNRM, MAXWRK, SMLNUM -C .. External Functions .. - DOUBLE PRECISION DLAMCH, DLANGE, DLANTR - EXTERNAL DLAMCH, DLANGE, DLANTR -C .. External Subroutines .. - EXTERNAL DCOPY, DLABAD, DLASCL, DLASET, DORMRZ, DTRSM, - $ DTZRZF, XERBLA -C .. Intrinsic Functions .. - INTRINSIC DBLE, MAX, MIN -C .. -C .. Executable Statements .. -C - MN = MIN( M, N ) -C -C Test the input scalar arguments. -C - INFO = 0 - IF( M.LT.0 ) THEN - INFO = -1 - ELSE IF( N.LT.0 ) THEN - INFO = -2 - ELSE IF( NRHS.LT.0 ) THEN - INFO = -3 - ELSE IF( RANK.LT.0 .OR. RANK.GT.MN ) THEN - INFO = -4 - ELSE IF( LDA.LT.MAX( 1, M ) ) THEN - INFO = -6 - ELSE IF( LDB.LT.1 .OR. ( NRHS.GT.0 .AND. LDB.LT.MAX( M, N ) ) ) - $ THEN - INFO = -9 - ELSE IF( LDWORK.LT.MAX( 1, N, NRHS ) ) THEN - INFO = -12 - END IF -C - IF( INFO.NE.0 ) THEN - CALL XERBLA( 'MB02QY', -INFO ) - RETURN - END IF -C -C Quick return if possible. -C - IF( MIN( MN, NRHS ).EQ.0 ) THEN - DWORK( 1 ) = ONE - RETURN - END IF -C -C Logically partition R = [ R11 R12 ], -C [ 0 R22 ] -C -C where R11 = R(1:RANK,1:RANK). If RANK = N, let T11 = R11. -C - MAXWRK = DBLE( N ) - IF( RANK.LT.N ) THEN -C -C Get machine parameters. -C - SMLNUM = DLAMCH( 'Safe minimum' ) / DLAMCH( 'Precision' ) - BIGNUM = ONE / SMLNUM - CALL DLABAD( SMLNUM, BIGNUM ) -C -C Scale A, B if max entries outside range [SMLNUM,BIGNUM]. -C - ANRM = DLANTR( 'MaxNorm', 'Upper', 'Non-unit', RANK, N, A, LDA, - $ DWORK ) - IASCL = 0 - IF( ANRM.GT.ZERO .AND. ANRM.LT.SMLNUM ) THEN -C -C Scale matrix norm up to SMLNUM. -C - CALL DLASCL( 'Upper', 0, 0, ANRM, SMLNUM, RANK, N, A, LDA, - $ INFO ) - IASCL = 1 - ELSE IF( ANRM.GT.BIGNUM ) THEN -C -C Scale matrix norm down to BIGNUM. -C - CALL DLASCL( 'Upper', 0, 0, ANRM, BIGNUM, RANK, N, A, LDA, - $ INFO ) - IASCL = 2 - ELSE IF( ANRM.EQ.ZERO ) THEN -C -C Matrix all zero. Return zero solution. -C - CALL DLASET( 'Full', N, NRHS, ZERO, ZERO, B, LDB ) - DWORK( 1 ) = ONE - RETURN - END IF -C - BNRM = DLANGE( 'MaxNorm', M, NRHS, B, LDB, DWORK ) - IBSCL = 0 - IF( BNRM.GT.ZERO .AND. BNRM.LT.SMLNUM ) THEN -C -C Scale matrix norm up to SMLNUM. -C - CALL DLASCL( 'General', 0, 0, BNRM, SMLNUM, M, NRHS, B, LDB, - $ INFO ) - IBSCL = 1 - ELSE IF( BNRM.GT.BIGNUM ) THEN -C -C Scale matrix norm down to BIGNUM. -C - CALL DLASCL( 'General', 0, 0, BNRM, BIGNUM, M, NRHS, B, LDB, - $ INFO ) - IBSCL = 2 - END IF -C -C [R11,R12] = [ T11, 0 ] * Z. -C Details of Householder rotations are stored in TAU. -C Workspace need RANK, prefer RANK*NB. -C - CALL DTZRZF( RANK, N, A, LDA, TAU, DWORK, LDWORK, INFO ) - MAXWRK = MAX( MAXWRK, DWORK( 1 ) ) - END IF -C -C B(1:RANK,1:NRHS) := inv(T11) * B(1:RANK,1:NRHS). -C - CALL DTRSM( 'Left', 'Upper', 'No transpose', 'Non-unit', RANK, - $ NRHS, ONE, A, LDA, B, LDB ) -C - IF( RANK.LT.N ) THEN -C - CALL DLASET( 'Full', N-RANK, NRHS, ZERO, ZERO, B( RANK+1, 1 ), - $ LDB ) -C -C B(1:N,1:NRHS) := Z' * B(1:N,1:NRHS). -C Workspace need NRHS, prefer NRHS*NB. -C - CALL DORMRZ( 'Left', 'Transpose', N, NRHS, RANK, N-RANK, A, - $ LDA, TAU, B, LDB, DWORK, LDWORK, INFO ) - MAXWRK = MAX( MAXWRK, DWORK( 1 ) ) -C -C Undo scaling. -C - IF( IASCL.EQ.1 ) THEN - CALL DLASCL( 'General', 0, 0, ANRM, SMLNUM, N, NRHS, B, LDB, - $ INFO ) - CALL DLASCL( 'Upper', 0, 0, SMLNUM, ANRM, RANK, RANK, A, - $ LDA, INFO ) - ELSE IF( IASCL.EQ.2 ) THEN - CALL DLASCL( 'General', 0, 0, ANRM, BIGNUM, N, NRHS, B, LDB, - $ INFO ) - CALL DLASCL( 'Upper', 0, 0, BIGNUM, ANRM, RANK, RANK, A, - $ LDA, INFO ) - END IF - IF( IBSCL.EQ.1 ) THEN - CALL DLASCL( 'General', 0, 0, SMLNUM, BNRM, N, NRHS, B, LDB, - $ INFO ) - ELSE IF( IBSCL.EQ.2 ) THEN - CALL DLASCL( 'General', 0, 0, BIGNUM, BNRM, N, NRHS, B, LDB, - $ INFO ) - END IF - END IF -C -C B(1:N,1:NRHS) := P * B(1:N,1:NRHS). -C Workspace N. -C - DO 20 J = 1, NRHS -C - DO 10 I = 1, N - DWORK( JPVT( I ) ) = B( I, J ) - 10 CONTINUE -C - CALL DCOPY( N, DWORK, 1, B( 1, J ), 1 ) - 20 CONTINUE -C - DWORK( 1 ) = MAXWRK - RETURN -C -C *** Last line of MB02QY *** - END diff --git a/mex/sources/libslicot/MB02RD.f b/mex/sources/libslicot/MB02RD.f deleted file mode 100644 index d524e7f9b..000000000 --- a/mex/sources/libslicot/MB02RD.f +++ /dev/null @@ -1,197 +0,0 @@ - SUBROUTINE MB02RD( TRANS, N, NRHS, H, LDH, IPIV, B, LDB, INFO ) -C -C SLICOT RELEASE 5.0. -C -C Copyright (c) 2002-2009 NICONET e.V. -C -C This program is free software: you can redistribute it and/or -C modify it under the terms of the GNU General Public License as -C published by the Free Software Foundation, either version 2 of -C the License, or (at your option) any later version. -C -C This program is distributed in the hope that it will be useful, -C but WITHOUT ANY WARRANTY; without even the implied warranty of -C MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the -C GNU General Public License for more details. -C -C You should have received a copy of the GNU General Public License -C along with this program. If not, see -C . -C -C PURPOSE -C -C To solve a system of linear equations -C H * X = B or H' * X = B -C with an upper Hessenberg N-by-N matrix H using the LU -C factorization computed by MB02SD. -C -C ARGUMENTS -C -C Mode Parameters -C -C TRANS CHARACTER*1 -C Specifies the form of the system of equations: -C = 'N': H * X = B (No transpose) -C = 'T': H'* X = B (Transpose) -C = 'C': H'* X = B (Conjugate transpose = Transpose) -C -C Input/Output Parameters -C -C N (input) INTEGER -C The order of the matrix H. N >= 0. -C -C NRHS (input) INTEGER -C The number of right hand sides, i.e., the number of -C columns of the matrix B. NRHS >= 0. -C -C H (input) DOUBLE PRECISION array, dimension (LDH,N) -C The factors L and U from the factorization H = P*L*U -C as computed by MB02SD. -C -C LDH INTEGER -C The leading dimension of the array H. LDH >= max(1,N). -C -C IPIV (input) INTEGER array, dimension (N) -C The pivot indices from MB02SD; for 1<=i<=N, row i of the -C matrix was interchanged with row IPIV(i). -C -C B (input/output) DOUBLE PRECISION array, dimension -C (LDB,NRHS) -C On entry, the right hand side matrix B. -C On exit, the solution matrix X. -C -C LDB INTEGER -C The leading dimension of the array B. LDB >= max(1,N). -C -C Error Indicator -C -C INFO (output) INTEGER -C = 0: successful exit; -C < 0: if INFO = -i, the i-th argument had an illegal -C value. -C -C METHOD -C -C The routine uses the factorization -C H = P * L * U -C where P is a permutation matrix, L is lower triangular with unit -C diagonal elements (and one nonzero subdiagonal), and U is upper -C triangular. -C -C REFERENCES -C -C - -C -C NUMERICAL ASPECTS -C 2 -C The algorithm requires 0( N x NRHS ) operations. -C -C CONTRIBUTOR -C -C V. Sima, Katholieke Univ. Leuven, Belgium, June 1998. -C -C REVISIONS -C -C - -C -C KEYWORDS -C -C Hessenberg form, matrix algebra. -C -C ****************************************************************** -C -C .. Parameters .. - DOUBLE PRECISION ONE - PARAMETER ( ONE = 1.0D+0 ) -C .. Scalar Arguments .. - CHARACTER TRANS - INTEGER INFO, LDB, LDH, N, NRHS -C .. -C .. Array Arguments .. - INTEGER IPIV( * ) - DOUBLE PRECISION B( LDB, * ), H( LDH, * ) -C .. Local Scalars .. - LOGICAL NOTRAN - INTEGER J, JP -C .. External Functions .. - LOGICAL LSAME - EXTERNAL LSAME -C .. External Subroutines .. - EXTERNAL DAXPY, DSWAP, DTRSM, XERBLA -C .. Intrinsic Functions .. - INTRINSIC MAX -C .. Executable Statements .. -C -C Test the input parameters. -C - INFO = 0 - NOTRAN = LSAME( TRANS, 'N' ) - IF( .NOT.NOTRAN .AND. .NOT.LSAME( TRANS, 'T' ) .AND. .NOT. - $ LSAME( TRANS, 'C' ) ) THEN - INFO = -1 - ELSE IF( N.LT.0 ) THEN - INFO = -2 - ELSE IF( NRHS.LT.0 ) THEN - INFO = -3 - ELSE IF( LDH.LT.MAX( 1, N ) ) THEN - INFO = -5 - ELSE IF( LDB.LT.MAX( 1, N ) ) THEN - INFO = -8 - END IF - IF( INFO.NE.0 ) THEN - CALL XERBLA( 'MB02RD', -INFO ) - RETURN - END IF -C -C Quick return if possible. -C - IF( N.EQ.0 .OR. NRHS.EQ.0 ) - $ RETURN -C - IF( NOTRAN ) THEN -C -C Solve H * X = B. -C -C Solve L * X = B, overwriting B with X. -C -C L is represented as a product of permutations and unit lower -C triangular matrices L = P(1) * L(1) * ... * P(n-1) * L(n-1), -C where each transformation L(i) is a rank-one modification of -C the identity matrix. -C - DO 10 J = 1, N - 1 - JP = IPIV( J ) - IF( JP.NE.J ) - $ CALL DSWAP( NRHS, B( JP, 1 ), LDB, B( J, 1 ), LDB ) - CALL DAXPY( NRHS, -H( J+1, J ), B( J, 1 ), LDB, B( J+1, 1 ), - $ LDB ) - 10 CONTINUE -C -C Solve U * X = B, overwriting B with X. -C - CALL DTRSM( 'Left', 'Upper', 'No transpose', 'Non-unit', N, - $ NRHS, ONE, H, LDH, B, LDB ) -C - ELSE -C -C Solve H' * X = B. -C -C Solve U' * X = B, overwriting B with X. -C - CALL DTRSM( 'Left', 'Upper', 'Transpose', 'Non-unit', N, NRHS, - $ ONE, H, LDH, B, LDB ) -C -C Solve L' * X = B, overwriting B with X. -C - DO 20 J = N - 1, 1, -1 - CALL DAXPY( NRHS, -H( J+1, J ), B( J+1, 1 ), LDB, B( J, 1 ), - $ LDB ) - JP = IPIV( J ) - IF( JP.NE.J ) - $ CALL DSWAP( NRHS, B( JP, 1 ), LDB, B( J, 1 ), LDB ) - 20 CONTINUE - END IF -C - RETURN -C *** Last line of MB02RD *** - END diff --git a/mex/sources/libslicot/MB02RZ.f b/mex/sources/libslicot/MB02RZ.f deleted file mode 100644 index a82be52be..000000000 --- a/mex/sources/libslicot/MB02RZ.f +++ /dev/null @@ -1,216 +0,0 @@ - SUBROUTINE MB02RZ( TRANS, N, NRHS, H, LDH, IPIV, B, LDB, INFO ) -C -C SLICOT RELEASE 5.0. -C -C Copyright (c) 2002-2009 NICONET e.V. -C -C This program is free software: you can redistribute it and/or -C modify it under the terms of the GNU General Public License as -C published by the Free Software Foundation, either version 2 of -C the License, or (at your option) any later version. -C -C This program is distributed in the hope that it will be useful, -C but WITHOUT ANY WARRANTY; without even the implied warranty of -C MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the -C GNU General Public License for more details. -C -C You should have received a copy of the GNU General Public License -C along with this program. If not, see -C . -C -C PURPOSE -C -C To solve a system of linear equations -C H * X = B, H' * X = B or H**H * X = B -C with a complex upper Hessenberg N-by-N matrix H using the LU -C factorization computed by MB02SZ. -C -C ARGUMENTS -C -C Mode Parameters -C -C TRANS CHARACTER*1 -C Specifies the form of the system of equations: -C = 'N': H * X = B (No transpose) -C = 'T': H'* X = B (Transpose) -C = 'C': H**H * X = B (Conjugate transpose) -C -C Input/Output Parameters -C -C N (input) INTEGER -C The order of the matrix H. N >= 0. -C -C NRHS (input) INTEGER -C The number of right hand sides, i.e., the number of -C columns of the matrix B. NRHS >= 0. -C -C H (input) COMPLEX*16 array, dimension (LDH,N) -C The factors L and U from the factorization H = P*L*U -C as computed by MB02SZ. -C -C LDH INTEGER -C The leading dimension of the array H. LDH >= max(1,N). -C -C IPIV (input) INTEGER array, dimension (N) -C The pivot indices from MB02SZ; for 1<=i<=N, row i of the -C matrix was interchanged with row IPIV(i). -C -C B (input/output) COMPLEX*16 array, dimension (LDB,NRHS) -C On entry, the right hand side matrix B. -C On exit, the solution matrix X. -C -C LDB INTEGER -C The leading dimension of the array B. LDB >= max(1,N). -C -C INFO (output) INTEGER -C = 0: successful exit; -C < 0: if INFO = -i, the i-th argument had an illegal -C value. -C -C METHOD -C -C The routine uses the factorization -C H = P * L * U -C where P is a permutation matrix, L is lower triangular with unit -C diagonal elements (and one nonzero subdiagonal), and U is upper -C triangular. -C -C REFERENCES -C -C - -C -C NUMERICAL ASPECTS -C 2 -C The algorithm requires 0( N x NRHS ) complex operations. -C -C CONTRIBUTOR -C -C Release 3.0: V. Sima, Katholieke Univ. Leuven, Belgium, Dec. 1996. -C Supersedes Release 2.0 routine TB01FW by A.J. Laub, University of -C Southern California, United States of America, May 1980. -C -C REVISIONS -C -C - -C -C KEYWORDS -C -C Frequency response, Hessenberg form, matrix algebra. -C -C ****************************************************************** -C -C .. Parameters .. - COMPLEX*16 ONE - PARAMETER ( ONE = ( 1.0D+0, 0.0D+0 ) ) -C .. Scalar Arguments .. - CHARACTER TRANS - INTEGER INFO, LDB, LDH, N, NRHS -C .. -C .. Array Arguments .. - INTEGER IPIV( * ) - COMPLEX*16 B( LDB, * ), H( LDH, * ) -C .. Local Scalars .. - LOGICAL NOTRAN - INTEGER J, JP -C .. External Functions .. - LOGICAL LSAME - EXTERNAL LSAME -C .. External Subroutines .. - EXTERNAL XERBLA, ZAXPY, ZSWAP, ZTRSM -C .. Intrinsic Functions .. - INTRINSIC DCONJG, MAX -C .. Executable Statements .. -C -C Test the input parameters. -C - INFO = 0 - NOTRAN = LSAME( TRANS, 'N' ) - IF( .NOT.NOTRAN .AND. .NOT.LSAME( TRANS, 'T' ) .AND. .NOT. - $ LSAME( TRANS, 'C' ) ) THEN - INFO = -1 - ELSE IF( N.LT.0 ) THEN - INFO = -2 - ELSE IF( NRHS.LT.0 ) THEN - INFO = -3 - ELSE IF( LDH.LT.MAX( 1, N ) ) THEN - INFO = -5 - ELSE IF( LDB.LT.MAX( 1, N ) ) THEN - INFO = -8 - END IF - IF( INFO.NE.0 ) THEN - CALL XERBLA( 'MB02RZ', -INFO ) - RETURN - END IF -C -C Quick return if possible. -C - IF( N.EQ.0 .OR. NRHS.EQ.0 ) - $ RETURN -C - IF( NOTRAN ) THEN -C -C Solve H * X = B. -C -C Solve L * X = B, overwriting B with X. -C -C L is represented as a product of permutations and unit lower -C triangular matrices L = P(1) * L(1) * ... * P(n-1) * L(n-1), -C where each transformation L(i) is a rank-one modification of -C the identity matrix. -C - DO 10 J = 1, N - 1 - JP = IPIV( J ) - IF( JP.NE.J ) - $ CALL ZSWAP( NRHS, B( JP, 1 ), LDB, B( J, 1 ), LDB ) - CALL ZAXPY( NRHS, -H( J+1, J ), B( J, 1 ), LDB, B( J+1, 1 ), - $ LDB ) - 10 CONTINUE -C -C Solve U * X = B, overwriting B with X. -C - CALL ZTRSM( 'Left', 'Upper', 'No transpose', 'Non-unit', N, - $ NRHS, ONE, H, LDH, B, LDB ) -C - ELSE IF( LSAME( TRANS, 'T' ) ) THEN -C -C Solve H' * X = B. -C -C Solve U' * X = B, overwriting B with X. -C - CALL ZTRSM( 'Left', 'Upper', TRANS, 'Non-unit', N, NRHS, ONE, - $ H, LDH, B, LDB ) -C -C Solve L' * X = B, overwriting B with X. -C - DO 20 J = N - 1, 1, -1 - CALL ZAXPY( NRHS, -H( J+1, J ), B( J+1, 1 ), LDB, B( J, 1 ), - $ LDB ) - JP = IPIV( J ) - IF( JP.NE.J ) - $ CALL ZSWAP( NRHS, B( JP, 1 ), LDB, B( J, 1 ), LDB ) - 20 CONTINUE -C - ELSE -C -C Solve H**H * X = B. -C -C Solve U**H * X = B, overwriting B with X. -C - CALL ZTRSM( 'Left', 'Upper', TRANS, 'Non-unit', N, NRHS, ONE, - $ H, LDH, B, LDB ) -C -C Solve L**H * X = B, overwriting B with X. -C - DO 30 J = N - 1, 1, -1 - CALL ZAXPY( NRHS, -DCONJG( H( J+1, J ) ), B( J+1, 1 ), LDB, - $ B( J, 1 ), LDB ) - JP = IPIV( J ) - IF( JP.NE.J ) - $ CALL ZSWAP( NRHS, B( JP, 1 ), LDB, B( J, 1 ), LDB ) - 30 CONTINUE -C - END IF -C - RETURN -C *** Last line of MB02RZ *** - END diff --git a/mex/sources/libslicot/MB02SD.f b/mex/sources/libslicot/MB02SD.f deleted file mode 100644 index 2c72554ee..000000000 --- a/mex/sources/libslicot/MB02SD.f +++ /dev/null @@ -1,164 +0,0 @@ - SUBROUTINE MB02SD( N, H, LDH, IPIV, INFO ) -C -C SLICOT RELEASE 5.0. -C -C Copyright (c) 2002-2009 NICONET e.V. -C -C This program is free software: you can redistribute it and/or -C modify it under the terms of the GNU General Public License as -C published by the Free Software Foundation, either version 2 of -C the License, or (at your option) any later version. -C -C This program is distributed in the hope that it will be useful, -C but WITHOUT ANY WARRANTY; without even the implied warranty of -C MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the -C GNU General Public License for more details. -C -C You should have received a copy of the GNU General Public License -C along with this program. If not, see -C . -C -C PURPOSE -C -C To compute an LU factorization of an n-by-n upper Hessenberg -C matrix H using partial pivoting with row interchanges. -C -C ARGUMENTS -C -C Input/Output Parameters -C -C N (input) INTEGER -C The order of the matrix H. N >= 0. -C -C H (input/output) DOUBLE PRECISION array, dimension (LDH,N) -C On entry, the n-by-n upper Hessenberg matrix to be -C factored. -C On exit, the factors L and U from the factorization -C H = P*L*U; the unit diagonal elements of L are not stored, -C and L is lower bidiagonal. -C -C LDH INTEGER -C The leading dimension of the array H. LDH >= max(1,N). -C -C IPIV (output) INTEGER array, dimension (N) -C The pivot indices; for 1 <= i <= N, row i of the matrix -C was interchanged with row IPIV(i). -C -C Error Indicator -C -C INFO INTEGER -C = 0: successful exit; -C < 0: if INFO = -i, the i-th argument had an illegal -C value; -C > 0: if INFO = i, U(i,i) is exactly zero. The -C factorization has been completed, but the factor U -C is exactly singular, and division by zero will occur -C if it is used to solve a system of equations. -C -C METHOD -C -C The factorization has the form -C H = P * L * U -C where P is a permutation matrix, L is lower triangular with unit -C diagonal elements (and one nonzero subdiagonal), and U is upper -C triangular. -C -C This is the right-looking Level 1 BLAS version of the algorithm -C (adapted after DGETF2). -C -C REFERENCES -C -C - -C -C NUMERICAL ASPECTS -C 2 -C The algorithm requires 0( N ) operations. -C -C CONTRIBUTOR -C -C V. Sima, Katholieke Univ. Leuven, Belgium, June 1998. -C -C REVISIONS -C -C V. Sima, Research Institute for Informatics, Bucharest, Oct. 2000, -C Jan. 2005. -C -C KEYWORDS -C -C Hessenberg form, matrix algebra. -C -C ****************************************************************** -C -C .. Parameters .. - DOUBLE PRECISION ZERO - PARAMETER ( ZERO = 0.0D+0 ) -C .. Scalar Arguments .. - INTEGER INFO, LDH, N -C .. Array Arguments .. - INTEGER IPIV(*) - DOUBLE PRECISION H(LDH,*) -C .. Local Scalars .. - INTEGER J, JP -C .. External Subroutines .. - EXTERNAL DAXPY, DSWAP, XERBLA -C .. Intrinsic Functions .. - INTRINSIC ABS, MAX -C .. -C .. Executable Statements .. -C -C Check the scalar input parameters. -C - INFO = 0 - IF( N.LT.0 ) THEN - INFO = -1 - ELSE IF( LDH.LT.MAX( 1, N ) ) THEN - INFO = -3 - END IF - IF( INFO.NE.0 ) THEN - CALL XERBLA( 'MB02SD', -INFO ) - RETURN - END IF -C -C Quick return if possible. -C - IF( N.EQ.0 ) - $ RETURN -C - DO 10 J = 1, N -C -C Find pivot and test for singularity. -C - JP = J - IF ( J.LT.N ) THEN - IF ( ABS( H( J+1, J ) ).GT.ABS( H( J, J ) ) ) - $ JP = J + 1 - END IF - IPIV( J ) = JP - IF( H( JP, J ).NE.ZERO ) THEN -C -C Apply the interchange to columns J:N. -C - IF( JP.NE.J ) - $ CALL DSWAP( N-J+1, H( J, J ), LDH, H( JP, J ), LDH ) -C -C Compute element J+1 of J-th column. -C - IF( J.LT.N ) - $ H( J+1, J ) = H( J+1, J )/H( J, J ) -C - ELSE IF( INFO.EQ.0 ) THEN -C - INFO = J - END IF -C - IF( J.LT.N ) THEN -C -C Update trailing submatrix. -C - CALL DAXPY( N-J, -H( J+1, J ), H( J, J+1 ), LDH, - $ H( J+1, J+1 ), LDH ) - END IF - 10 CONTINUE - RETURN -C *** Last line of MB02SD *** - END diff --git a/mex/sources/libslicot/MB02SZ.f b/mex/sources/libslicot/MB02SZ.f deleted file mode 100644 index 4643a9189..000000000 --- a/mex/sources/libslicot/MB02SZ.f +++ /dev/null @@ -1,169 +0,0 @@ - SUBROUTINE MB02SZ( N, H, LDH, IPIV, INFO ) -C -C SLICOT RELEASE 5.0. -C -C Copyright (c) 2002-2009 NICONET e.V. -C -C This program is free software: you can redistribute it and/or -C modify it under the terms of the GNU General Public License as -C published by the Free Software Foundation, either version 2 of -C the License, or (at your option) any later version. -C -C This program is distributed in the hope that it will be useful, -C but WITHOUT ANY WARRANTY; without even the implied warranty of -C MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the -C GNU General Public License for more details. -C -C You should have received a copy of the GNU General Public License -C along with this program. If not, see -C . -C -C PURPOSE -C -C To compute an LU factorization of a complex n-by-n upper -C Hessenberg matrix H using partial pivoting with row interchanges. -C -C ARGUMENTS -C -C Input/Output Parameters -C -C N (input) INTEGER -C The order of the matrix H. N >= 0. -C -C H (input/output) COMPLEX*16 array, dimension (LDH,N) -C On entry, the n-by-n upper Hessenberg matrix to be -C factored. -C On exit, the factors L and U from the factorization -C H = P*L*U; the unit diagonal elements of L are not stored, -C and L is lower bidiagonal. -C -C LDH INTEGER -C The leading dimension of the array H. LDH >= max(1,N). -C -C IPIV (output) INTEGER array, dimension (N) -C The pivot indices; for 1 <= i <= N, row i of the matrix -C was interchanged with row IPIV(i). -C -C Error Indicator -C -C INFO INTEGER -C = 0: successful exit; -C < 0: if INFO = -i, the i-th argument had an illegal -C value; -C > 0: if INFO = i, U(i,i) is exactly zero. The -C factorization has been completed, but the factor U -C is exactly singular, and division by zero will occur -C if it is used to solve a system of equations. -C -C METHOD -C -C The factorization has the form -C H = P * L * U -C where P is a permutation matrix, L is lower triangular with unit -C diagonal elements (and one nonzero subdiagonal), and U is upper -C triangular. -C -C This is the right-looking Level 2 BLAS version of the algorithm -C (adapted after ZGETF2). -C -C REFERENCES -C -C - -C -C NUMERICAL ASPECTS -C 2 -C The algorithm requires 0( N ) complex operations. -C -C CONTRIBUTOR -C -C Release 3.0: V. Sima, Katholieke Univ. Leuven, Belgium, Dec. 1996. -C Supersedes Release 2.0 routine TB01FX by A.J. Laub, University of -C Southern California, United States of America, May 1980. -C -C REVISIONS -C -C V. Sima, Research Institute for Informatics, Bucharest, Oct. 2000, -C Jan. 2005. -C -C KEYWORDS -C -C Frequency response, Hessenberg form, matrix algebra. -C -C ****************************************************************** -C -C .. Parameters .. - COMPLEX*16 ZERO - PARAMETER ( ZERO = ( 0.0D+0, 0.0D+0 ) ) -C .. Scalar Arguments .. - INTEGER INFO, LDH, N -C .. Array Arguments .. - INTEGER IPIV(*) - COMPLEX*16 H(LDH,*) -C .. Local Scalars .. - INTEGER J, JP -C .. External Functions .. - DOUBLE PRECISION DCABS1 - EXTERNAL DCABS1 -C .. External Subroutines .. - EXTERNAL XERBLA, ZAXPY, ZSWAP -C .. Intrinsic Functions .. - INTRINSIC MAX -C .. -C .. Executable Statements .. -C -C Check the scalar input parameters. -C - INFO = 0 - IF( N.LT.0 ) THEN - INFO = -1 - ELSE IF( LDH.LT.MAX( 1, N ) ) THEN - INFO = -3 - END IF - IF( INFO.NE.0 ) THEN - CALL XERBLA( 'MB02SZ', -INFO ) - RETURN - END IF -C -C Quick return if possible. -C - IF( N.EQ.0 ) - $ RETURN -C - DO 10 J = 1, N -C -C Find pivot and test for singularity. -C - JP = J - IF ( J.LT.N ) THEN - IF ( DCABS1( H( J+1, J ) ).GT.DCABS1( H( J, J ) ) ) - $ JP = J + 1 - END IF - IPIV( J ) = JP - IF( H( JP, J ).NE.ZERO ) THEN -C -C Apply the interchange to columns J:N. -C - IF( JP.NE.J ) - $ CALL ZSWAP( N-J+1, H( J, J ), LDH, H( JP, J ), LDH ) -C -C Compute element J+1 of J-th column. -C - IF( J.LT.N ) - $ H( J+1, J ) = H( J+1, J )/H( J, J ) -C - ELSE IF( INFO.EQ.0 ) THEN -C - INFO = J - END IF -C - IF( J.LT.N ) THEN -C -C Update trailing submatrix. -C - CALL ZAXPY( N-J, -H( J+1, J ), H( J, J+1 ), LDH, - $ H( J+1, J+1 ), LDH ) - END IF - 10 CONTINUE - RETURN -C *** Last line of MB02SZ *** - END diff --git a/mex/sources/libslicot/MB02TD.f b/mex/sources/libslicot/MB02TD.f deleted file mode 100644 index 865ffbf39..000000000 --- a/mex/sources/libslicot/MB02TD.f +++ /dev/null @@ -1,236 +0,0 @@ - SUBROUTINE MB02TD( NORM, N, HNORM, H, LDH, IPIV, RCOND, IWORK, - $ DWORK, INFO ) -C -C SLICOT RELEASE 5.0. -C -C Copyright (c) 2002-2009 NICONET e.V. -C -C This program is free software: you can redistribute it and/or -C modify it under the terms of the GNU General Public License as -C published by the Free Software Foundation, either version 2 of -C the License, or (at your option) any later version. -C -C This program is distributed in the hope that it will be useful, -C but WITHOUT ANY WARRANTY; without even the implied warranty of -C MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the -C GNU General Public License for more details. -C -C You should have received a copy of the GNU General Public License -C along with this program. If not, see -C . -C -C PURPOSE -C -C To estimate the reciprocal of the condition number of an upper -C Hessenberg matrix H, in either the 1-norm or the infinity-norm, -C using the LU factorization computed by MB02SD. -C -C ARGUMENTS -C -C Mode Parameters -C -C NORM CHARACTER*1 -C Specifies whether the 1-norm condition number or the -C infinity-norm condition number is required: -C = '1' or 'O': 1-norm; -C = 'I': Infinity-norm. -C -C Input/Output Parameters -C -C N (input) INTEGER -C The order of the matrix H. N >= 0. -C -C HNORM (input) DOUBLE PRECISION -C If NORM = '1' or 'O', the 1-norm of the original matrix H. -C If NORM = 'I', the infinity-norm of the original matrix H. -C -C H (input) DOUBLE PRECISION array, dimension (LDH,N) -C The factors L and U from the factorization H = P*L*U -C as computed by MB02SD. -C -C LDH INTEGER -C The leading dimension of the array H. LDH >= max(1,N). -C -C IPIV (input) INTEGER array, dimension (N) -C The pivot indices; for 1 <= i <= N, row i of the matrix -C was interchanged with row IPIV(i). -C -C RCOND (output) DOUBLE PRECISION -C The reciprocal of the condition number of the matrix H, -C computed as RCOND = 1/(norm(H) * norm(inv(H))). -C -C Workspace -C -C IWORK DOUBLE PRECISION array, dimension (N) -C -C DWORK DOUBLE PRECISION array, dimension (3*N) -C -C Error Indicator -C -C INFO INTEGER -C = 0: successful exit; -C < 0: if INFO = -i, the i-th argument had an illegal -C value. -C -C METHOD -C -C An estimate is obtained for norm(inv(H)), and the reciprocal of -C the condition number is computed as -C RCOND = 1 / ( norm(H) * norm(inv(H)) ). -C -C REFERENCES -C -C - -C -C NUMERICAL ASPECTS -C 2 -C The algorithm requires 0( N ) operations. -C -C CONTRIBUTOR -C -C V. Sima, Katholieke Univ. Leuven, Belgium, June 1998. -C -C REVISIONS -C -C - -C -C KEYWORDS -C -C Hessenberg form, matrix algebra. -C -C ****************************************************************** -C -C .. Parameters .. - DOUBLE PRECISION ONE, ZERO - PARAMETER ( ONE = 1.0D+0, ZERO = 0.0D+0 ) -C .. Scalar Arguments .. - CHARACTER NORM - INTEGER INFO, LDH, N - DOUBLE PRECISION HNORM, RCOND -C .. -C .. Array Arguments .. - INTEGER IPIV( * ), IWORK( * ) - DOUBLE PRECISION DWORK( * ), H( LDH, * ) -C .. Local Scalars .. - LOGICAL ONENRM - CHARACTER NORMIN - INTEGER IX, J, JP, KASE, KASE1 -C - DOUBLE PRECISION HINVNM, SCALE, SMLNUM, T -C .. -C .. External Functions .. - LOGICAL LSAME - INTEGER IDAMAX - DOUBLE PRECISION DLAMCH - EXTERNAL DLAMCH, IDAMAX, LSAME -C .. -C .. External Subroutines .. - EXTERNAL DLACON, DLATRS, DRSCL, XERBLA -C .. -C .. Intrinsic Functions .. - INTRINSIC ABS, MAX -C .. -C .. Executable Statements .. -C -C Test the input parameters. -C - INFO = 0 - ONENRM = NORM.EQ.'1' .OR. LSAME( NORM, 'O' ) - IF( .NOT.ONENRM .AND. .NOT.LSAME( NORM, 'I' ) ) THEN - INFO = -1 - ELSE IF( N.LT.0 ) THEN - INFO = -2 - ELSE IF( HNORM.LT.ZERO ) THEN - INFO = -3 - ELSE IF( LDH.LT.MAX( 1, N ) ) THEN - INFO = -5 - END IF - IF( INFO.NE.0 ) THEN - CALL XERBLA( 'MB02TD', -INFO ) - RETURN - END IF -C -C Quick return if possible. -C - RCOND = ZERO - IF( N.EQ.0 ) THEN - RCOND = ONE - RETURN - ELSE IF( HNORM.EQ.ZERO ) THEN - RETURN - END IF -C - SMLNUM = DLAMCH( 'Safe minimum' ) -C -C Estimate the norm of inv(H). -C - HINVNM = ZERO - NORMIN = 'N' - IF( ONENRM ) THEN - KASE1 = 1 - ELSE - KASE1 = 2 - END IF - KASE = 0 - 10 CONTINUE - CALL DLACON( N, DWORK( N+1 ), DWORK, IWORK, HINVNM, KASE ) - IF( KASE.NE.0 ) THEN - IF( KASE.EQ.KASE1 ) THEN -C -C Multiply by inv(L). -C - DO 20 J = 1, N - 1 - JP = IPIV( J ) - T = DWORK( JP ) - IF( JP.NE.J ) THEN - DWORK( JP ) = DWORK( J ) - DWORK( J ) = T - END IF - DWORK( J+1 ) = DWORK( J+1 ) - T * H( J+1, J ) - 20 CONTINUE -C -C Multiply by inv(U). -C - CALL DLATRS( 'Upper', 'No transpose', 'Non-unit', NORMIN, N, - $ H, LDH, DWORK, SCALE, DWORK( 2*N+1 ), INFO ) - ELSE -C -C Multiply by inv(U'). -C - CALL DLATRS( 'Upper', 'Transpose', 'Non-unit', NORMIN, N, H, - $ LDH, DWORK, SCALE, DWORK( 2*N+1 ), INFO ) -C -C Multiply by inv(L'). -C - DO 30 J = N - 1, 1, -1 - DWORK( J ) = DWORK( J ) - H( J+1, J ) * DWORK( J+1 ) - JP = IPIV( J ) - IF( JP.NE.J ) THEN - T = DWORK( JP ) - DWORK( JP ) = DWORK( J ) - DWORK( J ) = T - END IF - 30 CONTINUE - END IF -C -C Divide X by 1/SCALE if doing so will not cause overflow. -C - NORMIN = 'Y' - IF( SCALE.NE.ONE ) THEN - IX = IDAMAX( N, DWORK, 1 ) - IF( SCALE.LT.ABS( DWORK( IX ) )*SMLNUM .OR. SCALE.EQ.ZERO - $ ) GO TO 40 - CALL DRSCL( N, SCALE, DWORK, 1 ) - END IF - GO TO 10 - END IF -C -C Compute the estimate of the reciprocal condition number. -C - IF( HINVNM.NE.ZERO ) - $ RCOND = ( ONE / HINVNM ) / HNORM -C - 40 CONTINUE - RETURN -C *** Last line of MB02TD *** - END diff --git a/mex/sources/libslicot/MB02TZ.f b/mex/sources/libslicot/MB02TZ.f deleted file mode 100644 index 8cc434d75..000000000 --- a/mex/sources/libslicot/MB02TZ.f +++ /dev/null @@ -1,247 +0,0 @@ - SUBROUTINE MB02TZ( NORM, N, HNORM, H, LDH, IPIV, RCOND, DWORK, - $ ZWORK, INFO ) -C -C SLICOT RELEASE 5.0. -C -C Copyright (c) 2002-2009 NICONET e.V. -C -C This program is free software: you can redistribute it and/or -C modify it under the terms of the GNU General Public License as -C published by the Free Software Foundation, either version 2 of -C the License, or (at your option) any later version. -C -C This program is distributed in the hope that it will be useful, -C but WITHOUT ANY WARRANTY; without even the implied warranty of -C MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the -C GNU General Public License for more details. -C -C You should have received a copy of the GNU General Public License -C along with this program. If not, see -C . -C -C PURPOSE -C -C To estimate the reciprocal of the condition number of a complex -C upper Hessenberg matrix H, in either the 1-norm or the -C infinity-norm, using the LU factorization computed by MB02SZ. -C -C ARGUMENTS -C -C Mode Parameters -C -C NORM CHARACTER*1 -C Specifies whether the 1-norm condition number or the -C infinity-norm condition number is required: -C = '1' or 'O': 1-norm; -C = 'I': Infinity-norm. -C -C Input/Output Parameters -C -C N (input) INTEGER -C The order of the matrix H. N >= 0. -C -C HNORM (input) DOUBLE PRECISION -C If NORM = '1' or 'O', the 1-norm of the original matrix H. -C If NORM = 'I', the infinity-norm of the original matrix H. -C -C H (input) COMPLEX*16 array, dimension (LDH,N) -C The factors L and U from the factorization H = P*L*U -C as computed by MB02SZ. -C -C LDH INTEGER -C The leading dimension of the array H. LDH >= max(1,N). -C -C IPIV (input) INTEGER array, dimension (N) -C The pivot indices; for 1 <= i <= N, row i of the matrix -C was interchanged with row IPIV(i). -C -C RCOND (output) DOUBLE PRECISION -C The reciprocal of the condition number of the matrix H, -C computed as RCOND = 1/(norm(H) * norm(inv(H))). -C -C Workspace -C -C DWORK DOUBLE PRECISION array, dimension (N) -C -C ZWORK COMPLEX*16 array, dimension (2*N) -C -C Error Indicator -C -C INFO INTEGER -C = 0: successful exit; -C < 0: if INFO = -i, the i-th argument had an illegal -C value. -C -C METHOD -C -C An estimate is obtained for norm(inv(H)), and the reciprocal of -C the condition number is computed as -C RCOND = 1 / ( norm(H) * norm(inv(H)) ). -C -C REFERENCES -C -C - -C -C NUMERICAL ASPECTS -C 2 -C The algorithm requires 0( N ) complex operations. -C -C CONTRIBUTOR -C -C Release 3.0: V. Sima, Katholieke Univ. Leuven, Belgium, Dec. 1996. -C Supersedes Release 2.0 routine TB01FY by A.J. Laub, University of -C Southern California, United States of America, May 1980. -C -C REVISIONS -C -C V. Sima, Research Institute for Informatics, Bucharest, Feb. 2005. -C -C KEYWORDS -C -C Frequency response, Hessenberg form, matrix algebra. -C -C ****************************************************************** -C -C .. Parameters .. - DOUBLE PRECISION ONE, ZERO - PARAMETER ( ONE = 1.0D+0, ZERO = 0.0D+0 ) -C .. Scalar Arguments .. - CHARACTER NORM - INTEGER INFO, LDH, N - DOUBLE PRECISION HNORM, RCOND -C .. -C .. Array Arguments .. - INTEGER IPIV(*) - DOUBLE PRECISION DWORK( * ) - COMPLEX*16 H( LDH, * ), ZWORK( * ) -C .. Local Scalars .. - LOGICAL ONENRM - CHARACTER NORMIN - INTEGER IX, J, JP, KASE, KASE1 -C - DOUBLE PRECISION HINVNM, SCALE, SMLNUM - COMPLEX*16 T, ZDUM -C .. -C .. External Functions .. - LOGICAL LSAME - INTEGER IZAMAX - DOUBLE PRECISION DLAMCH - EXTERNAL DLAMCH, IZAMAX, LSAME -C .. -C .. External Subroutines .. - EXTERNAL XERBLA, ZDRSCL, ZLACON, ZLATRS -C .. -C .. Intrinsic Functions .. - INTRINSIC ABS, DBLE, DCONJG, DIMAG, MAX -C .. -C .. Statement Functions .. - DOUBLE PRECISION CABS1 -C .. -C .. Statement Function definitions .. - CABS1( ZDUM ) = ABS( DBLE( ZDUM ) ) + ABS( DIMAG( ZDUM ) ) -C .. -C .. Executable Statements .. -C -C Test the input parameters. -C - INFO = 0 - ONENRM = NORM.EQ.'1' .OR. LSAME( NORM, 'O' ) - IF( .NOT.ONENRM .AND. .NOT.LSAME( NORM, 'I' ) ) THEN - INFO = -1 - ELSE IF( N.LT.0 ) THEN - INFO = -2 - ELSE IF( HNORM.LT.ZERO ) THEN - INFO = -3 - ELSE IF( LDH.LT.MAX( 1, N ) ) THEN - INFO = -5 - END IF - IF( INFO.NE.0 ) THEN - CALL XERBLA( 'MB02TZ', -INFO ) - RETURN - END IF -C -C Quick return if possible. -C - RCOND = ZERO - IF( N.EQ.0 ) THEN - RCOND = ONE - RETURN - ELSE IF( HNORM.EQ.ZERO ) THEN - RETURN - END IF -C - SMLNUM = DLAMCH( 'Safe minimum' ) -C -C Estimate the norm of inv(H). -C - HINVNM = ZERO - NORMIN = 'N' - IF( ONENRM ) THEN - KASE1 = 1 - ELSE - KASE1 = 2 - END IF - KASE = 0 - 10 CONTINUE - CALL ZLACON( N, ZWORK( N+1 ), ZWORK, HINVNM, KASE ) - IF( KASE.NE.0 ) THEN - IF( KASE.EQ.KASE1 ) THEN -C -C Multiply by inv(L). -C - DO 20 J = 1, N - 1 - JP = IPIV( J ) - T = ZWORK( JP ) - IF( JP.NE.J ) THEN - ZWORK( JP ) = ZWORK( J ) - ZWORK( J ) = T - END IF - ZWORK( J+1 ) = ZWORK( J+1 ) - T * H( J+1, J ) - 20 CONTINUE -C -C Multiply by inv(U). -C - CALL ZLATRS( 'Upper', 'No transpose', 'Non-unit', NORMIN, N, - $ H, LDH, ZWORK, SCALE, DWORK, INFO ) - ELSE -C -C Multiply by inv(U'). -C - CALL ZLATRS( 'Upper', 'Conjugate transpose', 'Non-unit', - $ NORMIN, N, H, LDH, ZWORK, SCALE, DWORK, INFO ) -C -C Multiply by inv(L'). -C - DO 30 J = N - 1, 1, -1 - ZWORK( J ) = ZWORK( J ) - - $ DCONJG( H( J+1, J ) ) * ZWORK( J+1 ) - JP = IPIV( J ) - IF( JP.NE.J ) THEN - T = ZWORK( JP ) - ZWORK( JP ) = ZWORK( J ) - ZWORK( J ) = T - END IF - 30 CONTINUE - END IF -C -C Divide X by 1/SCALE if doing so will not cause overflow. -C - NORMIN = 'Y' - IF( SCALE.NE.ONE ) THEN - IX = IZAMAX( N, ZWORK, 1 ) - IF( SCALE.LT.CABS1( ZWORK( IX ) )*SMLNUM .OR. SCALE.EQ.ZERO - $ ) GO TO 40 - CALL ZDRSCL( N, SCALE, ZWORK, 1 ) - END IF - GO TO 10 - END IF -C -C Compute the estimate of the reciprocal condition number. -C - IF( HINVNM.NE.ZERO ) - $ RCOND = ( ONE / HINVNM ) / HNORM -C - 40 CONTINUE - RETURN -C *** Last line of MB02TZ *** - END diff --git a/mex/sources/libslicot/MB02UD.f b/mex/sources/libslicot/MB02UD.f deleted file mode 100644 index 101c7426e..000000000 --- a/mex/sources/libslicot/MB02UD.f +++ /dev/null @@ -1,624 +0,0 @@ - SUBROUTINE MB02UD( FACT, SIDE, TRANS, JOBP, M, N, ALPHA, RCOND, - $ RANK, R, LDR, Q, LDQ, SV, B, LDB, RP, LDRP, - $ DWORK, LDWORK, INFO ) -C -C SLICOT RELEASE 5.0. -C -C Copyright (c) 2002-2009 NICONET e.V. -C -C This program is free software: you can redistribute it and/or -C modify it under the terms of the GNU General Public License as -C published by the Free Software Foundation, either version 2 of -C the License, or (at your option) any later version. -C -C This program is distributed in the hope that it will be useful, -C but WITHOUT ANY WARRANTY; without even the implied warranty of -C MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the -C GNU General Public License for more details. -C -C You should have received a copy of the GNU General Public License -C along with this program. If not, see -C . -C -C PURPOSE -C -C To compute the minimum norm least squares solution of one of the -C following linear systems -C -C op(R)*X = alpha*B, (1) -C X*op(R) = alpha*B, (2) -C -C where alpha is a real scalar, op(R) is either R or its transpose, -C R', R is an L-by-L real upper triangular matrix, B is an M-by-N -C real matrix, and L = M for (1), or L = N for (2). Singular value -C decomposition, R = Q*S*P', is used, assuming that R is rank -C deficient. -C -C ARGUMENTS -C -C Mode Parameters -C -C FACT CHARACTER*1 -C Specifies whether R has been previously factored or not, -C as follows: -C = 'F': R has been factored and its rank and singular -C value decomposition, R = Q*S*P', are available; -C = 'N': R has not been factored and its singular value -C decomposition, R = Q*S*P', should be computed. -C -C SIDE CHARACTER*1 -C Specifies whether op(R) appears on the left or right -C of X as follows: -C = 'L': Solve op(R)*X = alpha*B (op(R) is on the left); -C = 'R': Solve X*op(R) = alpha*B (op(R) is on the right). -C -C TRANS CHARACTER*1 -C Specifies the form of op(R) to be used as follows: -C = 'N': op(R) = R; -C = 'T': op(R) = R'; -C = 'C': op(R) = R'. -C -C JOBP CHARACTER*1 -C Specifies whether or not the pseudoinverse of R is to be -C computed or it is available as follows: -C = 'P': Compute pinv(R), if FACT = 'N', or -C use pinv(R), if FACT = 'F'; -C = 'N': Do not compute or use pinv(R). -C -C Input/Output Parameters -C -C M (input) INTEGER -C The number of rows of the matrix B. M >= 0. -C -C N (input) INTEGER -C The number of columns of the matrix B. N >= 0. -C -C ALPHA (input) DOUBLE PRECISION -C The scalar alpha. When alpha is zero then B need not be -C set before entry. -C -C RCOND (input) DOUBLE PRECISION -C RCOND is used to determine the effective rank of R. -C Singular values of R satisfying Sv(i) <= RCOND*Sv(1) are -C treated as zero. If RCOND <= 0, then EPS is used instead, -C where EPS is the relative machine precision (see LAPACK -C Library routine DLAMCH). RCOND <= 1. -C RCOND is not used if FACT = 'F'. -C -C RANK (input or output) INTEGER -C The rank of matrix R. -C RANK is an input parameter when FACT = 'F', and an output -C parameter when FACT = 'N'. L >= RANK >= 0. -C -C R (input/output) DOUBLE PRECISION array, dimension (LDR,L) -C On entry, if FACT = 'F', the leading L-by-L part of this -C array must contain the L-by-L orthogonal matrix P' from -C singular value decomposition, R = Q*S*P', of the matrix R; -C if JOBP = 'P', the first RANK rows of P' are assumed to be -C scaled by inv(S(1:RANK,1:RANK)). -C On entry, if FACT = 'N', the leading L-by-L upper -C triangular part of this array must contain the upper -C triangular matrix R. -C On exit, if INFO = 0, the leading L-by-L part of this -C array contains the L-by-L orthogonal matrix P', with its -C first RANK rows scaled by inv(S(1:RANK,1:RANK)), when -C JOBP = 'P'. -C -C LDR INTEGER -C The leading dimension of array R. LDR >= MAX(1,L). -C -C Q (input or output) DOUBLE PRECISION array, dimension -C (LDQ,L) -C On entry, if FACT = 'F', the leading L-by-L part of this -C array must contain the L-by-L orthogonal matrix Q from -C singular value decomposition, R = Q*S*P', of the matrix R. -C If FACT = 'N', this array need not be set on entry, and -C on exit, if INFO = 0, the leading L-by-L part of this -C array contains the orthogonal matrix Q. -C -C LDQ INTEGER -C The leading dimension of array Q. LDQ >= MAX(1,L). -C -C SV (input or output) DOUBLE PRECISION array, dimension (L) -C On entry, if FACT = 'F', the first RANK entries of this -C array must contain the reciprocal of the largest RANK -C singular values of the matrix R, and the last L-RANK -C entries of this array must contain the remaining singular -C values of R sorted in descending order. -C If FACT = 'N', this array need not be set on input, and -C on exit, if INFO = 0, the first RANK entries of this array -C contain the reciprocal of the largest RANK singular values -C of the matrix R, and the last L-RANK entries of this array -C contain the remaining singular values of R sorted in -C descending order. -C -C B (input/output) DOUBLE PRECISION array, dimension (LDB,N) -C On entry, if ALPHA <> 0, the leading M-by-N part of this -C array must contain the matrix B. -C On exit, if INFO = 0 and RANK > 0, the leading M-by-N part -C of this array contains the M-by-N solution matrix X. -C -C LDB INTEGER -C The leading dimension of array B. LDB >= MAX(1,M). -C -C RP (input or output) DOUBLE PRECISION array, dimension -C (LDRP,L) -C On entry, if FACT = 'F', JOBP = 'P', and RANK > 0, the -C leading L-by-L part of this array must contain the L-by-L -C matrix pinv(R), the Moore-Penrose pseudoinverse of R. -C On exit, if FACT = 'N', JOBP = 'P', and RANK > 0, the -C leading L-by-L part of this array contains the L-by-L -C matrix pinv(R), the Moore-Penrose pseudoinverse of R. -C If JOBP = 'N', this array is not referenced. -C -C LDRP INTEGER -C The leading dimension of array RP. -C LDRP >= MAX(1,L), if JOBP = 'P'. -C LDRP >= 1, if JOBP = 'N'. -C -C Workspace -C -C DWORK DOUBLE PRECISION array, dimension (LDWORK) -C On exit, if INFO = 0, DWORK(1) returns the optimal LDWORK; -C if INFO = i, 1 <= i <= L, then DWORK(2:L) contain the -C unconverged superdiagonal elements of an upper bidiagonal -C matrix D whose diagonal is in SV (not necessarily sorted). -C D satisfies R = Q*D*P', so it has the same singular -C values as R, and singular vectors related by Q and P'. -C -C LDWORK INTEGER -C The length of the array DWORK. -C LDWORK >= MAX(1,L), if FACT = 'F'; -C LDWORK >= MAX(1,5*L), if FACT = 'N'. -C For optimum performance LDWORK should be larger than -C MAX(1,L,M*N), if FACT = 'F'; -C MAX(1,5*L,M*N), if FACT = 'N'. -C -C Error Indicator -C -C INFO INTEGER -C = 0: successful exit; -C < 0: if INFO = -i, the i-th argument had an illegal -C value; -C > 0: if INFO = i, i = 1:L, the SVD algorithm has failed -C to converge. In this case INFO specifies how many -C superdiagonals did not converge (see the description -C of DWORK); this failure is not likely to occur. -C -C METHOD -C -C The L-by-L upper triangular matrix R is factored as R = Q*S*P', -C if FACT = 'N', using SLICOT Library routine MB03UD, where Q and P -C are L-by-L orthogonal matrices and S is an L-by-L diagonal matrix -C with non-negative diagonal elements, SV(1), SV(2), ..., SV(L), -C ordered decreasingly. Then, the effective rank of R is estimated, -C and matrix (or matrix-vector) products and scalings are used to -C compute X. If FACT = 'F', only matrix (or matrix-vector) products -C and scalings are performed. -C -C FURTHER COMMENTS -C -C Option JOBP = 'P' should be used only if the pseudoinverse is -C really needed. Usually, it is possible to avoid the use of -C pseudoinverse, by computing least squares solutions. -C The routine uses BLAS 3 calculations if LDWORK >= M*N, and BLAS 2 -C calculations, otherwise. No advantage of any additional workspace -C larger than L is taken for matrix products, but the routine can -C be called repeatedly for chunks of columns of B, if LDWORK < M*N. -C -C CONTRIBUTOR -C -C V. Sima, Research Institute of Informatics, Bucharest, Oct. 1999. -C -C REVISIONS -C -C V. Sima, Feb. 2000. -C -C KEYWORDS -C -C Bidiagonalization, orthogonal transformation, singular value -C decomposition, singular values, triangular form. -C -C ****************************************************************** -C -C .. Parameters .. - DOUBLE PRECISION ONE, ZERO - PARAMETER ( ONE = 1.0D0, ZERO = 0.0D0 ) -C .. Scalar Arguments .. - CHARACTER FACT, JOBP, SIDE, TRANS - INTEGER INFO, LDB, LDQ, LDR, LDRP, LDWORK, M, N, RANK - DOUBLE PRECISION ALPHA, RCOND -C .. Array Arguments .. - DOUBLE PRECISION B(LDB,*), DWORK(*), Q(LDQ,*), R(LDR,*), - $ RP(LDRP,*), SV(*) -C .. Local Scalars .. - LOGICAL LEFT, NFCT, PINV, TRAN - CHARACTER*1 NTRAN - INTEGER I, L, MAXWRK, MINWRK, MN - DOUBLE PRECISION TOLL -C .. External Functions .. - LOGICAL LSAME - INTEGER ILAENV - DOUBLE PRECISION DLAMCH - EXTERNAL DLAMCH, ILAENV, LSAME -C .. External Subroutines .. - EXTERNAL DCOPY, DGEMM, DGEMV, DLACPY, DLASET, MB01SD, - $ MB03UD, XERBLA -C .. Intrinsic Functions .. - INTRINSIC MAX, MIN -C .. Executable Statements .. -C -C Check the input scalar arguments. -C - INFO = 0 - NFCT = LSAME( FACT, 'N' ) - LEFT = LSAME( SIDE, 'L' ) - PINV = LSAME( JOBP, 'P' ) - TRAN = LSAME( TRANS, 'T' ) .OR. LSAME( TRANS, 'C' ) - IF( LEFT ) THEN - L = M - ELSE - L = N - END IF - MN = M*N - IF( .NOT.NFCT .AND. .NOT.LSAME( FACT, 'F' ) ) THEN - INFO = -1 - ELSE IF( .NOT.LEFT .AND. .NOT.LSAME( SIDE, 'R' ) ) THEN - INFO = -2 - ELSE IF( .NOT.TRAN .AND. .NOT.LSAME( TRANS, 'N' ) ) THEN - INFO = -3 - ELSE IF( .NOT.PINV .AND. .NOT.LSAME( JOBP, 'N' ) ) THEN - INFO = -4 - ELSE IF( M.LT.0 ) THEN - INFO = -5 - ELSE IF( N.LT.0 ) THEN - INFO = -6 - ELSE IF( NFCT .AND. RCOND.GT.ONE ) THEN - INFO = -8 - ELSE IF( .NOT.NFCT .AND. ( RANK.LT.ZERO .OR. RANK.GT.L ) ) THEN - INFO = -9 - ELSE IF( LDR.LT.MAX( 1, L ) ) THEN - INFO = -11 - ELSE IF( LDQ.LT.MAX( 1, L ) ) THEN - INFO = -13 - ELSE IF( LDB.LT.MAX( 1, M ) ) THEN - INFO = -16 - ELSE IF( LDRP.LT.1 .OR. ( PINV .AND. LDRP.LT.L ) ) THEN - INFO = -18 - END IF -C -C Compute workspace -C (Note: Comments in the code beginning "Workspace:" describe the -C minimal amount of workspace needed at that point in the code, -C as well as the preferred amount for good performance. -C NB refers to the optimal block size for the immediately following -C subroutine, as returned by ILAENV.) -C - MINWRK = 1 - IF( INFO.EQ.0 .AND. LDWORK.GE.1 .AND. L.GT.0 ) THEN - MINWRK = MAX( 1, L ) - MAXWRK = MAX( MINWRK, MN ) - IF( NFCT ) THEN - MAXWRK = MAX( MAXWRK, 3*L+2*L* - $ ILAENV( 1, 'DGEBRD', ' ', L, L, -1, -1 ) ) - MAXWRK = MAX( MAXWRK, 3*L+L* - $ ILAENV( 1, 'DORGBR', 'Q', L, L, L, -1 ) ) - MAXWRK = MAX( MAXWRK, 3*L+L* - $ ILAENV( 1, 'DORGBR', 'P', L, L, L, -1 ) ) - MINWRK = MAX( 1, 5*L ) - MAXWRK = MAX( MAXWRK, MINWRK ) - END IF - END IF -C - IF( LDWORK.LT.MINWRK ) THEN - INFO = -20 - END IF - IF( INFO.NE.0 ) THEN - CALL XERBLA( 'MB02UD', -INFO ) - RETURN - END IF -C -C Quick return if possible. -C - IF( L.EQ.0 ) THEN - IF( NFCT ) - $ RANK = 0 - DWORK(1) = ONE - RETURN - END IF -C - IF( NFCT ) THEN -C -C Compute the SVD of R, R = Q*S*P'. -C Matrix Q is computed in the array Q, and P' overwrites R. -C Workspace: need 5*L; -C prefer larger. -C - CALL MB03UD( 'Vectors', 'Vectors', L, R, LDR, Q, LDQ, SV, - $ DWORK, LDWORK, INFO ) - IF ( INFO.NE.0 ) - $ RETURN -C -C Use the default tolerance, if required. -C - TOLL = RCOND - IF( TOLL.LE.ZERO ) - $ TOLL = DLAMCH( 'Precision' ) - TOLL = MAX( TOLL*SV(1), DLAMCH( 'Safe minimum' ) ) -C -C Estimate the rank of R. -C - DO 10 I = 1, L - IF ( TOLL.GT.SV(I) ) - $ GO TO 20 - 10 CONTINUE -C - I = L + 1 - 20 CONTINUE - RANK = I - 1 -C - DO 30 I = 1, RANK - SV(I) = ONE / SV(I) - 30 CONTINUE -C - IF( PINV .AND. RANK.GT.0 ) THEN -C -C Compute pinv(S)'*P' in R. -C - CALL MB01SD( 'Row scaling', RANK, L, R, LDR, SV, SV ) -C -C Compute pinv(R) = P*pinv(S)*Q' in RP. -C - CALL DGEMM( 'Transpose', 'Transpose', L, L, RANK, ONE, R, - $ LDR, Q, LDQ, ZERO, RP, LDRP ) - END IF - END IF -C -C Return if min(M,N) = 0 or RANK = 0. -C - IF( MIN( M, N ).EQ.0 .OR. RANK.EQ.0 ) THEN - DWORK(1) = MAXWRK - RETURN - END IF -C -C Set X = 0 if alpha = 0. -C - IF( ALPHA.EQ.ZERO ) THEN - CALL DLASET( 'Full', M, N, ZERO, ZERO, B, LDB ) - DWORK(1) = MAXWRK - RETURN - END IF -C - IF( PINV ) THEN -C - IF( LEFT ) THEN -C -C Compute alpha*op(pinv(R))*B in workspace and save it in B. -C Workspace: need M (BLAS 2); -C prefer M*N (BLAS 3). -C - IF( LDWORK.GE.MN ) THEN - CALL DGEMM( TRANS, 'NoTranspose', M, N, M, ALPHA, - $ RP, LDRP, B, LDB, ZERO, DWORK, M ) - CALL DLACPY( 'Full', M, N, DWORK, M, B, LDB ) - ELSE -C - DO 40 I = 1, N - CALL DGEMV( TRANS, M, M, ALPHA, RP, LDRP, B(1,I), 1, - $ ZERO, DWORK, 1 ) - CALL DCOPY( M, DWORK, 1, B(1,I), 1 ) - 40 CONTINUE -C - END IF - ELSE -C -C Compute alpha*B*op(pinv(R)) in workspace and save it in B. -C Workspace: need N (BLAS 2); -C prefer M*N (BLAS 3). -C - IF( LDWORK.GE.MN ) THEN - CALL DGEMM( 'NoTranspose', TRANS, M, N, N, ALPHA, B, LDB, - $ RP, LDRP, ZERO, DWORK, M ) - CALL DLACPY( 'Full', M, N, DWORK, M, B, LDB ) - ELSE -C - IF( TRAN ) THEN - NTRAN = 'N' - ELSE - NTRAN = 'T' - END IF -C - DO 50 I = 1, M - CALL DGEMV( NTRAN, N, N, ALPHA, RP, LDRP, B(I,1), LDB, - $ ZERO, DWORK, 1 ) - CALL DCOPY( N, DWORK, 1, B(I,1), LDB ) - 50 CONTINUE -C - END IF - END IF -C - ELSE -C - IF( LEFT ) THEN -C -C Compute alpha*P*pinv(S)*Q'*B or alpha*Q*pinv(S)'*P'*B. -C Workspace: need M (BLAS 2); -C prefer M*N (BLAS 3). -C - IF( LDWORK.GE.MN ) THEN - IF( TRAN ) THEN -C -C Compute alpha*P'*B in workspace. -C - CALL DGEMM( 'NoTranspose', 'NoTranspose', M, N, M, - $ ALPHA, R, LDR, B, LDB, ZERO, DWORK, M ) -C -C Compute alpha*pinv(S)'*P'*B. -C - CALL MB01SD( 'Row scaling', RANK, N, DWORK, M, SV, - $ SV ) -C -C Compute alpha*Q*pinv(S)'*P'*B. -C - CALL DGEMM( 'NoTranspose', 'NoTranspose', M, N, RANK, - $ ONE, Q, LDQ, DWORK, M, ZERO, B, LDB ) - ELSE -C -C Compute alpha*Q'*B in workspace. -C - CALL DGEMM( 'Transpose', 'NoTranspose', M, N, M, - $ ALPHA, Q, LDQ, B, LDB, ZERO, DWORK, M ) -C -C Compute alpha*pinv(S)*Q'*B. -C - CALL MB01SD( 'Row scaling', RANK, N, DWORK, M, SV, - $ SV ) -C -C Compute alpha*P*pinv(S)*Q'*B. -C - CALL DGEMM( 'Transpose', 'NoTranspose', M, N, RANK, - $ ONE, R, LDR, DWORK, M, ZERO, B, LDB ) - END IF - ELSE - IF( TRAN ) THEN -C -C Compute alpha*P'*B in B using workspace. -C - DO 60 I = 1, N - CALL DGEMV( 'NoTranspose', M, M, ALPHA, R, LDR, - $ B(1,I), 1, ZERO, DWORK, 1 ) - CALL DCOPY( M, DWORK, 1, B(1,I), 1 ) - 60 CONTINUE -C -C Compute alpha*pinv(S)'*P'*B. -C - CALL MB01SD( 'Row scaling', RANK, N, B, LDB, SV, SV ) -C -C Compute alpha*Q*pinv(S)'*P'*B in B using workspace. -C - DO 70 I = 1, N - CALL DGEMV( 'NoTranspose', M, RANK, ONE, Q, LDQ, - $ B(1,I), 1, ZERO, DWORK, 1 ) - CALL DCOPY( M, DWORK, 1, B(1,I), 1 ) - 70 CONTINUE - ELSE -C -C Compute alpha*Q'*B in B using workspace. -C - DO 80 I = 1, N - CALL DGEMV( 'Transpose', M, M, ALPHA, Q, LDQ, - $ B(1,I), 1, ZERO, DWORK, 1 ) - CALL DCOPY( M, DWORK, 1, B(1,I), 1 ) - 80 CONTINUE -C -C Compute alpha*pinv(S)*Q'*B. -C - CALL MB01SD( 'Row scaling', RANK, N, B, LDB, SV, SV ) -C -C Compute alpha*P*pinv(S)*Q'*B in B using workspace. -C - DO 90 I = 1, N - CALL DGEMV( 'Transpose', RANK, M, ONE, R, LDR, - $ B(1,I), 1, ZERO, DWORK, 1 ) - CALL DCOPY( M, DWORK, 1, B(1,I), 1 ) - 90 CONTINUE - END IF - END IF - ELSE -C -C Compute alpha*B*P*pinv(S)*Q' or alpha*B*Q*pinv(S)'*P'. -C Workspace: need N (BLAS 2); -C prefer M*N (BLAS 3). -C - IF( LDWORK.GE.MN ) THEN - IF( TRAN ) THEN -C -C Compute alpha*B*Q in workspace. -C - CALL DGEMM( 'NoTranspose', 'NoTranspose', M, N, N, - $ ALPHA, B, LDB, Q, LDQ, ZERO, DWORK, M ) -C -C Compute alpha*B*Q*pinv(S)'. -C - CALL MB01SD( 'Column scaling', M, RANK, DWORK, M, SV, - $ SV ) -C -C Compute alpha*B*Q*pinv(S)'*P' in B. -C - CALL DGEMM( 'NoTranspose', 'NoTranspose', M, N, RANK, - $ ONE, DWORK, M, R, LDR, ZERO, B, LDB ) - ELSE -C -C Compute alpha*B*P in workspace. -C - CALL DGEMM( 'NoTranspose', 'Transpose', M, N, N, - $ ALPHA, B, LDB, R, LDR, ZERO, DWORK, M ) -C -C Compute alpha*B*P*pinv(S). -C - CALL MB01SD( 'Column scaling', M, RANK, DWORK, M, SV, - $ SV ) -C -C Compute alpha*B*P*pinv(S)*Q' in B. -C - CALL DGEMM( 'NoTranspose', 'Transpose', M, N, RANK, - $ ONE, DWORK, M, Q, LDQ, ZERO, B, LDB ) - END IF - ELSE - IF( TRAN ) THEN -C -C Compute alpha*B*Q in B using workspace. -C - DO 100 I = 1, M - CALL DGEMV( 'Transpose', N, N, ALPHA, Q, LDQ, - $ B(I,1), LDB, ZERO, DWORK, 1 ) - CALL DCOPY( N, DWORK, 1, B(I,1), LDB ) - 100 CONTINUE -C -C Compute alpha*B*Q*pinv(S)'. -C - CALL MB01SD( 'Column scaling', M, RANK, B, LDB, SV, - $ SV ) -C -C Compute alpha*B*Q*pinv(S)'*P' in B using workspace. -C - DO 110 I = 1, M - CALL DGEMV( 'Transpose', RANK, N, ONE, R, LDR, - $ B(I,1), LDB, ZERO, DWORK, 1 ) - CALL DCOPY( N, DWORK, 1, B(I,1), LDB ) - 110 CONTINUE -C - ELSE -C -C Compute alpha*B*P in B using workspace. -C - DO 120 I = 1, M - CALL DGEMV( 'NoTranspose', N, N, ALPHA, R, LDR, - $ B(I,1), LDB, ZERO, DWORK, 1 ) - CALL DCOPY( N, DWORK, 1, B(I,1), LDB ) - 120 CONTINUE -C -C Compute alpha*B*P*pinv(S). -C - CALL MB01SD( 'Column scaling', M, RANK, B, LDB, SV, - $ SV ) -C -C Compute alpha*B*P*pinv(S)*Q' in B using workspace. -C - DO 130 I = 1, M - CALL DGEMV( 'NoTranspose', N, RANK, ONE, Q, LDQ, - $ B(I,1), LDB, ZERO, DWORK, 1 ) - CALL DCOPY( N, DWORK, 1, B(I,1), LDB ) - 130 CONTINUE - END IF - END IF - END IF - END IF -C -C Return optimal workspace in DWORK(1). -C - DWORK(1) = MAXWRK -C - RETURN -C *** Last line of MB02UD *** - END diff --git a/mex/sources/libslicot/MB02UU.f b/mex/sources/libslicot/MB02UU.f deleted file mode 100644 index 649cc5139..000000000 --- a/mex/sources/libslicot/MB02UU.f +++ /dev/null @@ -1,162 +0,0 @@ - SUBROUTINE MB02UU( N, A, LDA, RHS, IPIV, JPIV, SCALE ) -C -C SLICOT RELEASE 5.0. -C -C Copyright (c) 2002-2009 NICONET e.V. -C -C This program is free software: you can redistribute it and/or -C modify it under the terms of the GNU General Public License as -C published by the Free Software Foundation, either version 2 of -C the License, or (at your option) any later version. -C -C This program is distributed in the hope that it will be useful, -C but WITHOUT ANY WARRANTY; without even the implied warranty of -C MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the -C GNU General Public License for more details. -C -C You should have received a copy of the GNU General Public License -C along with this program. If not, see -C . -C -C PURPOSE -C -C To solve for x in A * x = scale * RHS, using the LU factorization -C of the N-by-N matrix A computed by SLICOT Library routine MB02UV. -C The factorization has the form A = P * L * U * Q, where P and Q -C are permutation matrices, L is unit lower triangular and U is -C upper triangular. -C -C ARGUMENTS -C -C Input/Output Parameters -C -C N (input) INTEGER -C The order of the matrix A. -C -C A (input) DOUBLE PRECISION array, dimension (LDA, N) -C The leading N-by-N part of this array must contain -C the LU part of the factorization of the matrix A computed -C by SLICOT Library routine MB02UV: A = P * L * U * Q. -C -C LDA INTEGER -C The leading dimension of the array A. LDA >= max(1, N). -C -C RHS (input/output) DOUBLE PRECISION array, dimension (N) -C On entry, this array must contain the right hand side -C of the system. -C On exit, this array contains the solution of the system. -C -C IPIV (input) INTEGER array, dimension (N) -C The pivot indices; for 1 <= i <= N, row i of the -C matrix has been interchanged with row IPIV(i). -C -C JPIV (input) INTEGER array, dimension (N) -C The pivot indices; for 1 <= j <= N, column j of the -C matrix has been interchanged with column JPIV(j). -C -C SCALE (output) DOUBLE PRECISION -C The scale factor, chosen 0 < SCALE <= 1 to prevent -C overflow in the solution. -C -C FURTHER COMMENTS -C -C In the interest of speed, this routine does not check the input -C for errors. It should only be used if the order of the matrix A -C is very small. -C -C CONTRIBUTOR -C -C Bo Kagstrom and P. Poromaa, Univ. of Umea, Sweden, Nov. 1993. -C -C REVISIONS -C -C April 1998 (T. Penzl). -C Sep. 1998 (V. Sima). -C -C ****************************************************************** -C -C .. Parameters .. - DOUBLE PRECISION ONE, TWO - PARAMETER ( ONE = 1.0D+0, TWO = 2.0D+0 ) -C .. Scalar Arguments .. - INTEGER LDA, N - DOUBLE PRECISION SCALE -C .. Array Arguments .. - INTEGER IPIV( * ), JPIV( * ) - DOUBLE PRECISION A( LDA, * ), RHS( * ) -C .. Local Scalars .. - INTEGER I, IP, J - DOUBLE PRECISION BIGNUM, EPS, FACTOR, SMLNUM, TEMP -C .. External Functions .. - INTEGER IDAMAX - DOUBLE PRECISION DLAMCH - EXTERNAL DLAMCH, IDAMAX -C .. External Subroutines .. - EXTERNAL DAXPY, DLABAD, DSCAL -C .. Intrinsic Functions .. - INTRINSIC ABS, DBLE, MAX -C .. Executable Statements .. -C -C Set constants to control owerflow. -C - EPS = DLAMCH( 'Precision' ) - SMLNUM = DLAMCH( 'Safe minimum' ) / EPS - BIGNUM = ONE / SMLNUM - CALL DLABAD( SMLNUM, BIGNUM ) -C -C Apply permutations IPIV to RHS. -C - DO 20 I = 1, N - 1 - IP = IPIV(I) - IF ( IP.NE.I ) THEN - TEMP = RHS(I) - RHS(I) = RHS(IP) - RHS(IP) = TEMP - ENDIF - 20 CONTINUE -C -C Solve for L part. -C - DO 40 I = 1, N - 1 - CALL DAXPY( N-I, -RHS(I), A(I+1, I), 1, RHS(I+1), 1 ) - 40 CONTINUE -C -C Solve for U part. -C -C Check for scaling. -C - FACTOR = TWO * DBLE( N ) - I = 1 - 60 CONTINUE - IF ( ( FACTOR * SMLNUM ) * ABS( RHS(I) ) .LE. ABS( A(I, I) ) ) - $ THEN - I = I + 1 - IF ( I .LE. N ) GO TO 60 - SCALE = ONE - ELSE - SCALE = ( ONE / FACTOR ) / ABS( RHS( IDAMAX( N, RHS, 1 ) ) ) - CALL DSCAL( N, SCALE, RHS, 1 ) - END IF -C - DO 100 I = N, 1, -1 - TEMP = ONE / A(I, I) - RHS(I) = RHS(I) * TEMP - DO 80 J = I + 1, N - RHS(I) = RHS(I) - RHS(J) * ( A(I, J) * TEMP ) - 80 CONTINUE - 100 CONTINUE -C -C Apply permutations JPIV to the solution (RHS). -C - DO 120 I = N - 1, 1, -1 - IP = JPIV(I) - IF ( IP.NE.I ) THEN - TEMP = RHS(I) - RHS(I) = RHS(IP) - RHS(IP) = TEMP - ENDIF - 120 CONTINUE -C - RETURN -C *** Last line of MB02UU *** - END diff --git a/mex/sources/libslicot/MB02UV.f b/mex/sources/libslicot/MB02UV.f deleted file mode 100644 index 61e5bbc73..000000000 --- a/mex/sources/libslicot/MB02UV.f +++ /dev/null @@ -1,195 +0,0 @@ - SUBROUTINE MB02UV( N, A, LDA, IPIV, JPIV, INFO ) -C -C SLICOT RELEASE 5.0. -C -C Copyright (c) 2002-2009 NICONET e.V. -C -C This program is free software: you can redistribute it and/or -C modify it under the terms of the GNU General Public License as -C published by the Free Software Foundation, either version 2 of -C the License, or (at your option) any later version. -C -C This program is distributed in the hope that it will be useful, -C but WITHOUT ANY WARRANTY; without even the implied warranty of -C MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the -C GNU General Public License for more details. -C -C You should have received a copy of the GNU General Public License -C along with this program. If not, see -C . -C -C PURPOSE -C -C To compute an LU factorization, using complete pivoting, of the -C N-by-N matrix A. The factorization has the form A = P * L * U * Q, -C where P and Q are permutation matrices, L is lower triangular with -C unit diagonal elements and U is upper triangular. -C -C ARGUMENTS -C -C Input/Output Parameters -C -C N (input) INTEGER -C The order of the matrix A. -C -C A (input/output) DOUBLE PRECISION array, dimension (LDA, N) -C On entry, the leading N-by-N part of this array must -C contain the matrix A to be factored. -C On exit, the leading N-by-N part of this array contains -C the factors L and U from the factorization A = P*L*U*Q; -C the unit diagonal elements of L are not stored. If U(k, k) -C appears to be less than SMIN, U(k, k) is given the value -C of SMIN, giving a nonsingular perturbed system. -C -C LDA INTEGER -C The leading dimension of the array A. LDA >= max(1, N). -C -C IPIV (output) INTEGER array, dimension (N) -C The pivot indices; for 1 <= i <= N, row i of the -C matrix has been interchanged with row IPIV(i). -C -C JPIV (output) INTEGER array, dimension (N) -C The pivot indices; for 1 <= j <= N, column j of the -C matrix has been interchanged with column JPIV(j). -C -C Error indicator -C -C INFO INTEGER -C = 0: successful exit; -C = k: U(k, k) is likely to produce owerflow if one tries -C to solve for x in Ax = b. So U is perturbed to get -C a nonsingular system. This is a warning. -C -C FURTHER COMMENTS -C -C In the interests of speed, this routine does not check the input -C for errors. It should only be used to factorize matrices A of -C very small order. -C -C CONTRIBUTOR -C -C Bo Kagstrom and Peter Poromaa, Univ. of Umea, Sweden, Nov. 1993. -C -C REVISIONS -C -C April 1998 (T. Penzl). -C Sep. 1998 (V. Sima). -C March 1999 (V. Sima). -C March 2004 (V. Sima). -C -C ****************************************************************** -C -C .. Parameters .. - DOUBLE PRECISION ZERO, ONE - PARAMETER ( ZERO = 0.0D+0, ONE = 1.0D+0 ) -C .. Scalar Arguments .. - INTEGER INFO, LDA, N -C .. Array Arguments .. - INTEGER IPIV( * ), JPIV( * ) - DOUBLE PRECISION A( LDA, * ) -C .. Local Scalars .. - INTEGER I, IP, IPV, JP, JPV - DOUBLE PRECISION BIGNUM, EPS, SMIN, SMLNUM, XMAX -C .. External Functions .. - DOUBLE PRECISION DLAMCH - EXTERNAL DLAMCH -C .. External Subroutines .. - EXTERNAL DGER, DLABAD, DSCAL, DSWAP -C .. Intrinsic Functions .. - INTRINSIC ABS, MAX -C .. Executable Statements .. -C -C Set constants to control owerflow. - - INFO = 0 - EPS = DLAMCH( 'Precision' ) - SMLNUM = DLAMCH( 'Safe minimum' ) / EPS - BIGNUM = ONE / SMLNUM - CALL DLABAD( SMLNUM, BIGNUM ) -C -C Find max element in matrix A. -C - IPV = 1 - JPV = 1 - XMAX = ZERO - DO 40 JP = 1, N - DO 20 IP = 1, N - IF ( ABS( A(IP, JP) ) .GT. XMAX ) THEN - XMAX = ABS( A(IP, JP) ) - IPV = IP - JPV = JP - ENDIF - 20 CONTINUE - 40 CONTINUE - SMIN = MAX( EPS * XMAX, SMLNUM ) -C -C Swap rows. -C - IF ( IPV .NE. 1 ) CALL DSWAP( N, A(IPV, 1), LDA, A(1, 1), LDA ) - IPIV(1) = IPV -C -C Swap columns. -C - IF ( JPV .NE. 1 ) CALL DSWAP( N, A(1, JPV), 1, A(1, 1), 1 ) - JPIV(1) = JPV -C -C Check for singularity. -C - IF ( ABS( A(1, 1) ) .LT. SMIN ) THEN - INFO = 1 - A(1, 1) = SMIN - ENDIF - IF ( N.GT.1 ) THEN - CALL DSCAL( N - 1, ONE / A(1, 1), A(2, 1), 1 ) - CALL DGER( N - 1, N - 1, -ONE, A(2, 1), 1, A(1, 2), LDA, - $ A(2, 2), LDA ) - ENDIF -C -C Factorize the rest of A with complete pivoting. -C Set pivots less than SMIN to SMIN. -C - DO 100 I = 2, N - 1 -C -C Find max element in remaining matrix. -C - IPV = I - JPV = I - XMAX = ZERO - DO 80 JP = I, N - DO 60 IP = I, N - IF ( ABS( A(IP, JP) ) .GT. XMAX ) THEN - XMAX = ABS( A(IP, JP) ) - IPV = IP - JPV = JP - ENDIF - 60 CONTINUE - 80 CONTINUE -C -C Swap rows. -C - IF ( IPV .NE. I ) CALL DSWAP( N, A(IPV, 1), LDA, A(I, 1), LDA ) - IPIV(I) = IPV -C -C Swap columns. -C - IF ( JPV .NE. I ) CALL DSWAP( N, A(1, JPV), 1, A(1, I), 1 ) - JPIV(I) = JPV -C -C Check for almost singularity. -C - IF ( ABS( A(I, I) ) .LT. SMIN ) THEN - INFO = I - A(I, I) = SMIN - ENDIF - CALL DSCAL( N - I, ONE / A(I, I), A(I + 1, I), 1 ) - CALL DGER( N - I, N - I, -ONE, A(I + 1, I), 1, A(I, I + 1), - $ LDA, A(I + 1, I + 1), LDA ) - 100 CONTINUE - IF ( ABS( A(N, N) ) .LT. SMIN ) THEN - INFO = N - A(N, N) = SMIN - ENDIF -C - RETURN -C *** Last line of MB02UV *** - END diff --git a/mex/sources/libslicot/MB02VD.f b/mex/sources/libslicot/MB02VD.f deleted file mode 100644 index 5896d2349..000000000 --- a/mex/sources/libslicot/MB02VD.f +++ /dev/null @@ -1,187 +0,0 @@ - SUBROUTINE MB02VD( TRANS, M, N, A, LDA, IPIV, B, LDB, INFO ) -C -C SLICOT RELEASE 5.0. -C -C Copyright (c) 2002-2009 NICONET e.V. -C -C This program is free software: you can redistribute it and/or -C modify it under the terms of the GNU General Public License as -C published by the Free Software Foundation, either version 2 of -C the License, or (at your option) any later version. -C -C This program is distributed in the hope that it will be useful, -C but WITHOUT ANY WARRANTY; without even the implied warranty of -C MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the -C GNU General Public License for more details. -C -C You should have received a copy of the GNU General Public License -C along with this program. If not, see -C . -C -C PURPOSE -C -C To compute the solution to a real system of linear equations -C X * op(A) = B, -C where op(A) is either A or its transpose, A is an N-by-N matrix, -C and X and B are M-by-N matrices. -C The LU decomposition with partial pivoting and row interchanges, -C A = P * L * U, is used, where P is a permutation matrix, L is unit -C lower triangular, and U is upper triangular. -C -C ARGUMENTS -C -C Mode Parameters -C -C TRANS CHARACTER*1 -C Specifies the form of op(A) to be used as follows: -C = 'N': op(A) = A; -C = 'T': op(A) = A'; -C = 'C': op(A) = A'. -C -C Input/Output Parameters -C -C M (input) INTEGER -C The number of rows of the matrix B. M >= 0. -C -C N (input) INTEGER -C The number of columns of the matrix B, and the order of -C the matrix A. N >= 0. -C -C A (input/output) DOUBLE PRECISION array, dimension (LDA,N) -C On entry, the leading N-by-N part of this array must -C contain the coefficient matrix A. -C On exit, the leading N-by-N part of this array contains -C the factors L and U from the factorization A = P*L*U; -C the unit diagonal elements of L are not stored. -C -C LDA INTEGER -C The leading dimension of the array A. LDA >= MAX(1,N). -C -C IPIV (output) INTEGER array, dimension (N) -C The pivot indices that define the permutation matrix P; -C row i of the matrix was interchanged with row IPIV(i). -C -C B (input/output) DOUBLE PRECISION array, dimension (LDB,N) -C On entry, the leading M-by-N part of this array must -C contain the right hand side matrix B. -C On exit, if INFO = 0, the leading M-by-N part of this -C array contains the solution matrix X. -C -C LDB (input) INTEGER -C The leading dimension of the array B. LDB >= max(1,M). -C -C INFO (output) INTEGER -C = 0: successful exit; -C < 0: if INFO = -i, the i-th argument had an illegal -C value; -C > 0: if INFO = i, U(i,i) is exactly zero. The -C factorization has been completed, but the factor U -C is exactly singular, so the solution could not be -C computed. -C -C METHOD -C -C The LU decomposition with partial pivoting and row interchanges is -C used to factor A as -C A = P * L * U, -C where P is a permutation matrix, L is unit lower triangular, and -C U is upper triangular. The factored form of A is then used to -C solve the system of equations X * A = B or X * A' = B. -C -C FURTHER COMMENTS -C -C This routine enables to solve the system X * A = B or X * A' = B -C as easily and efficiently as possible; it is similar to the LAPACK -C Library routine DGESV, which solves A * X = B. -C -C CONTRIBUTOR -C -C V. Sima, Research Institute for Informatics, Bucharest, Mar. 2000. -C -C REVISIONS -C -C - -C -C KEYWORDS -C -C Elementary matrix operations, linear algebra. -C -C ****************************************************************** -C -C .. Parameters .. - DOUBLE PRECISION ONE - PARAMETER ( ONE = 1.0D0 ) -C .. Scalar Arguments .. - CHARACTER TRANS - INTEGER INFO, LDA, LDB, M, N -C .. -C .. Array Arguments .. - INTEGER IPIV( * ) - DOUBLE PRECISION A( LDA, * ), B( LDB, * ) -C .. -C .. Local Scalars .. - LOGICAL TRAN -C .. -C .. External Functions .. - LOGICAL LSAME - EXTERNAL LSAME -C .. -C .. External Subroutines .. - EXTERNAL DGETRF, DTRSM, MA02GD, XERBLA -C .. -C .. Intrinsic Functions .. - INTRINSIC MAX -C .. -C .. Executable Statements .. -C -C Test the scalar input parameters. -C - INFO = 0 - TRAN = LSAME( TRANS, 'T' ) .OR. LSAME( TRANS, 'C' ) -C - IF( .NOT.TRAN .AND. .NOT.LSAME( TRANS, 'N' ) ) THEN - INFO = -1 - ELSE IF( M.LT.0 ) THEN - INFO = -2 - ELSE IF( N.LT.0 ) THEN - INFO = -3 - ELSE IF( LDA.LT.MAX( 1, N ) ) THEN - INFO = -5 - ELSE IF( LDB.LT.MAX( 1, M ) ) THEN - INFO = -8 - END IF -C - IF( INFO.NE.0 ) THEN - CALL XERBLA( 'MB02VD', -INFO ) - RETURN - END IF -C -C Compute the LU factorization of A. -C - CALL DGETRF( N, N, A, LDA, IPIV, INFO ) -C - IF( INFO.EQ.0 ) THEN - IF( TRAN ) THEN -C -C Compute X = B * A**(-T). -C - CALL MA02GD( M, B, LDB, 1, N, IPIV, 1 ) - CALL DTRSM( 'Right', 'Lower', 'Transpose', 'Unit', M, N, - $ ONE, A, LDA, B, LDB ) - CALL DTRSM( 'Right', 'Upper', 'Transpose', 'NonUnit', M, - $ N, ONE, A, LDA, B, LDB ) - ELSE -C -C Compute X = B * A**(-1). -C - CALL DTRSM( 'Right', 'Upper', 'NoTranspose', 'NonUnit', M, - $ N, ONE, A, LDA, B, LDB ) - CALL DTRSM( 'Right', 'Lower', 'NoTranspose', 'Unit', M, N, - $ ONE, A, LDA, B, LDB ) - CALL MA02GD( M, B, LDB, 1, N, IPIV, -1 ) - END IF - END IF - RETURN -C -C *** Last line of MB02VD *** - END diff --git a/mex/sources/libslicot/MB02WD.f b/mex/sources/libslicot/MB02WD.f deleted file mode 100644 index 59816e037..000000000 --- a/mex/sources/libslicot/MB02WD.f +++ /dev/null @@ -1,458 +0,0 @@ - SUBROUTINE MB02WD( FORM, F, N, IPAR, LIPAR, DPAR, LDPAR, ITMAX, - $ A, LDA, B, INCB, X, INCX, TOL, DWORK, LDWORK, - $ IWARN, INFO ) -C -C SLICOT RELEASE 5.0. -C -C Copyright (c) 2002-2009 NICONET e.V. -C -C This program is free software: you can redistribute it and/or -C modify it under the terms of the GNU General Public License as -C published by the Free Software Foundation, either version 2 of -C the License, or (at your option) any later version. -C -C This program is distributed in the hope that it will be useful, -C but WITHOUT ANY WARRANTY; without even the implied warranty of -C MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the -C GNU General Public License for more details. -C -C You should have received a copy of the GNU General Public License -C along with this program. If not, see -C . -C -C PURPOSE -C -C To solve the system of linear equations Ax = b, with A symmetric, -C positive definite, or, in the implicit form, f(A, x) = b, where -C y = f(A, x) is a symmetric positive definite linear mapping -C from x to y, using the conjugate gradient (CG) algorithm without -C preconditioning. -C -C ARGUMENTS -C -C Mode Parameters -C -C FORM CHARACTER*1 -C Specifies the form of the system of equations, as -C follows: -C = 'U' : Ax = b, the upper triagular part of A is used; -C = 'L' : Ax = b, the lower triagular part of A is used; -C = 'F' : the implicit, function form, f(A, x) = b. -C -C Function Parameters -C -C F EXTERNAL -C If FORM = 'F', then F is a subroutine which calculates the -C value of f(A, x), for given A and x. -C If FORM <> 'F', then F is not called. -C -C F must have the following interface: -C -C SUBROUTINE F( N, IPAR, LIPAR, DPAR, LDPAR, A, LDA, X, -C $ INCX, DWORK, LDWORK, INFO ) -C -C where -C -C N (input) INTEGER -C The dimension of the vector x. N >= 0. -C -C IPAR (input) INTEGER array, dimension (LIPAR) -C The integer parameters describing the structure of -C the matrix A. -C -C LIPAR (input) INTEGER -C The length of the array IPAR. LIPAR >= 0. -C -C DPAR (input) DOUBLE PRECISION array, dimension (LDPAR) -C The real parameters needed for solving the -C problem. -C -C LDPAR (input) INTEGER -C The length of the array DPAR. LDPAR >= 0. -C -C A (input) DOUBLE PRECISION array, dimension -C (LDA, NC), where NC is the number of columns. -C The leading NR-by-NC part of this array must -C contain the (compressed) representation of the -C matrix A, where NR is the number of rows of A -C (function of IPAR entries). -C -C LDA (input) INTEGER -C The leading dimension of the array A. -C LDA >= MAX(1,NR). -C -C X (input/output) DOUBLE PRECISION array, dimension -C (1+(N-1)*INCX) -C On entry, this incremented array must contain the -C vector x. -C On exit, this incremented array contains the value -C of the function f, y = f(A, x). -C -C INCX (input) INTEGER -C The increment for the elements of X. INCX > 0. -C -C DWORK DOUBLE PRECISION array, dimension (LDWORK) -C The workspace array for subroutine F. -C -C LDWORK (input) INTEGER -C The size of the array DWORK (as large as needed -C in the subroutine F). -C -C INFO INTEGER -C Error indicator, set to a negative value if an -C input scalar argument is erroneous, and to -C positive values for other possible errors in the -C subroutine F. The LAPACK Library routine XERBLA -C should be used in conjunction with negative INFO. -C INFO must be zero if the subroutine finished -C successfully. -C -C Parameters marked with "(input)" must not be changed. -C -C Input/Output Parameters -C -C N (input) INTEGER -C The dimension of the vector x. N >= 0. -C If FORM = 'U' or FORM = 'L', N is also the number of rows -C and columns of the matrix A. -C -C IPAR (input) INTEGER array, dimension (LIPAR) -C If FORM = 'F', the integer parameters describing the -C structure of the matrix A. -C This parameter is ignored if FORM = 'U' or FORM = 'L'. -C -C LIPAR (input) INTEGER -C The length of the array IPAR. LIPAR >= 0. -C -C DPAR (input) DOUBLE PRECISION array, dimension (LDPAR) -C If FORM = 'F', the real parameters needed for solving -C the problem. -C This parameter is ignored if FORM = 'U' or FORM = 'L'. -C -C LDPAR (input) INTEGER -C The length of the array DPAR. LDPAR >= 0. -C -C ITMAX (input) INTEGER -C The maximal number of iterations to do. ITMAX >= 0. -C -C A (input) DOUBLE PRECISION array, -C dimension (LDA, NC), if FORM = 'F', -C dimension (LDA, N), otherwise. -C If FORM = 'F', the leading NR-by-NC part of this array -C must contain the (compressed) representation of the -C matrix A, where NR and NC are the number of rows and -C columns, respectively, of the matrix A. The array A is -C not referenced by this routine itself, except in the -C calls to the routine F. -C If FORM <> 'F', the leading N-by-N part of this array -C must contain the matrix A, assumed to be symmetric; -C only the triangular part specified by FORM is referenced. -C -C LDA (input) INTEGER -C The leading dimension of array A. -C LDA >= MAX(1,NR), if FORM = 'F'; -C LDA >= MAX(1,N), if FORM = 'U' or FORM = 'L'. -C -C B (input) DOUBLE PRECISION array, dimension (1+(N-1)*INCB) -C The incremented vector b. -C -C INCB (input) INTEGER -C The increment for the elements of B. INCB > 0. -C -C X (input/output) DOUBLE PRECISION array, dimension -C (1+(N-1)*INCX) -C On entry, this incremented array must contain an initial -C approximation of the solution. If an approximation is not -C known, setting all elements of x to zero is recommended. -C On exit, this incremented array contains the computed -C solution x of the system of linear equations. -C -C INCX (input) INTEGER -C The increment for the elements of X. INCX > 0. -C -C Tolerances -C -C TOL DOUBLE PRECISION -C If TOL > 0, absolute tolerance for the iterative process. -C The algorithm will stop if || Ax - b ||_2 <= TOL. Since -C it is advisable to use a relative tolerance, say TOLER, -C TOL should be chosen as TOLER*|| b ||_2. -C If TOL <= 0, a default relative tolerance, -C TOLDEF = N*EPS*|| b ||_2, is used, where EPS is the -C machine precision (see LAPACK Library routine DLAMCH). -C -C Workspace -C -C DWORK DOUBLE PRECISION array, dimension (LDWORK) -C On exit, if INFO = 0, DWORK(1) returns the number of -C iterations performed and DWORK(2) returns the remaining -C residual, || Ax - b ||_2. -C -C LDWORK INTEGER -C The length of the array DWORK. -C LDWORK >= MAX(2,3*N + DWORK(F)), if FORM = 'F', -C where DWORK(F) is the workspace needed by F; -C LDWORK >= MAX(2,3*N), if FORM = 'U' or FORM = 'L'. -C -C Warning Indicator -C -C IWARN INTEGER -C = 0: no warning; -C = 1: the algorithm finished after ITMAX > 0 iterations, -C without achieving the desired precision TOL; -C = 2: ITMAX is zero; in this case, DWORK(2) is not set. -C -C Error Indicator -C -C INFO INTEGER -C = 0: successful exit; -C < 0: if INFO = -i, the i-th argument had an illegal -C value; -C > 0: if INFO = i, then F returned with INFO = i. -C -C METHOD -C -C The following CG iteration is used for solving Ax = b: -C -C Start: q(0) = r(0) = Ax - b -C -C < q(k), r(k) > -C ALPHA(k) = - ---------------- -C < q(k), Aq(k) > -C x(k+1) = x(k) - ALPHA(k) * q(k) -C r(k+1) = r(k) - ALPHA(k) * Aq(k) -C < r(k+1), r(k+1) > -C BETA(k) = -------------------- -C < r(k) , r(k) > -C q(k+1) = r(k+1) + BETA(k) * q(k) -C -C where <.,.> denotes the scalar product. -C -C REFERENCES -C -C [1] Golub, G.H. and van Loan, C.F. -C Matrix Computations. Third Edition. -C M. D. Johns Hopkins University Press, Baltimore, pp. 520-528, -C 1996. -C -C [2] Luenberger, G. -C Introduction to Linear and Nonlinear Programming. -C Addison-Wesley, Reading, MA, p.187, York, 1973. -C -C NUMERICAL ASPECTS -C -C Since the residuals are orthogonal in the scalar product -C = y'Ax, the algorithm is theoretically finite. But rounding -C errors cause a loss of orthogonality, so a finite termination -C cannot be guaranteed. However, one can prove [2] that -C -C || x-x_k ||_A := sqrt( (x-x_k)' * A * (x-x_k) ) -C -C sqrt( kappa_2(A) ) - 1 -C <= 2 || x-x_0 ||_A * ------------------------ , -C sqrt( kappa_2(A) ) + 1 -C -C where kappa_2 is the condition number. -C -C The approximate number of floating point operations is -C (k*(N**2 + 15*N) + N**2 + 3*N)/2, if FORM <> 'F', -C k*(f + 7*N) + f, if FORM = 'F', -C where k is the number of CG iterations performed, and f is the -C number of floating point operations required by the subroutine F. -C -C CONTRIBUTORS -C -C A. Riedel, R. Schneider, Chemnitz University of Technology, -C Oct. 2000, during a stay at University of Twente, NL. -C -C REVISIONS -C -C V. Sima, Research Institute for Informatics, Bucharest, Mar. 2001, -C March, 2002. -C -C KEYWORDS -C -C Conjugate gradients, convergence, linear system of equations, -C matrix operations. -C -C ****************************************************************** -C -C .. Parameters .. - DOUBLE PRECISION ZERO, ONE - PARAMETER ( ZERO = 0.0D0, ONE = 1.0D0 ) -C .. Scalar Arguments .. - CHARACTER FORM - INTEGER INCB, INCX, INFO, ITMAX, IWARN, LDA, LDPAR, - $ LDWORK, LIPAR, N - DOUBLE PRECISION TOL -C .. Array Arguments .. - DOUBLE PRECISION A(LDA,*), B(*), DPAR(*), DWORK(*), X(*) - INTEGER IPAR(*) -C .. Local Scalars .. - DOUBLE PRECISION ALPHA, BETA, RES, RESOLD, TOLDEF - INTEGER AQ, DWLEFT, K, R - LOGICAL MAT -C .. External Functions .. - DOUBLE PRECISION DDOT, DLAMCH, DNRM2 - LOGICAL LSAME - EXTERNAL DDOT, DLAMCH, DNRM2, LSAME -C .. External Subroutines .. - EXTERNAL DAXPY, DCOPY, DSCAL, DSYMV, F, XERBLA -C .. Intrinsic Functions .. - INTRINSIC MAX -C .. -C .. Executable Statements .. -C -C Decode the scalar input parameters. -C - MAT = LSAME( FORM, 'U' ) .OR. LSAME( FORM, 'L' ) -C -C Check the scalar input parameters. -C - IWARN = 0 - INFO = 0 - IF( .NOT.( MAT .OR. LSAME( FORM, 'F' ) ) ) THEN - INFO = -1 - ELSEIF ( N.LT.0 ) THEN - INFO = -3 - ELSEIF ( .NOT. MAT .AND. LIPAR.LT.0 ) THEN - INFO = -5 - ELSEIF ( .NOT. MAT .AND. LDPAR.LT.0 ) THEN - INFO = -7 - ELSEIF ( ITMAX.LT.0 ) THEN - INFO = -8 - ELSEIF ( LDA.LT.1 .OR. ( MAT .AND. LDA.LT.N ) ) THEN - INFO = -10 - ELSEIF ( INCB.LE.0 ) THEN - INFO = -12 - ELSEIF ( INCX.LE.0 ) THEN - INFO = -14 - ELSEIF ( LDWORK.LT.MAX( 2, 3*N ) ) THEN - INFO = -17 - ENDIF -C -C Return if there are illegal arguments. -C - IF( INFO.NE.0 ) THEN - CALL XERBLA( 'MB02WD', -INFO ) - RETURN - ENDIF -C -C Quick return if possible. -C - IF ( N.EQ.0 ) THEN - DWORK(1) = ZERO - DWORK(2) = ZERO - RETURN - ENDIF -C - IF ( ITMAX.EQ.0 ) THEN - DWORK(1) = ZERO - IWARN = 2 - RETURN - ENDIF -C -C Set default tolerance, if needed. -C - TOLDEF = TOL - IF ( TOLDEF.LE.ZERO ) - $ TOLDEF = DBLE( N )*DLAMCH( 'Epsilon' )*DNRM2( N, B, INCB ) -C -C Initialize local variables. -C - K = 0 -C -C Vector q is stored in DWORK(1), A*q or f(A, q) in DWORK(AQ), -C and r in DWORK(R). The workspace for F starts in DWORK(DWLEFT). -C - AQ = N + 1 - R = N + AQ - DWLEFT = N + R -C -C Prepare the first iteration, initialize r and q. -C - IF ( MAT ) THEN - CALL DCOPY( N, B, INCB, DWORK(R), 1 ) - CALL DSYMV( FORM, N, ONE, A, LDA, X, INCX, -ONE, DWORK(R), 1 ) - ELSE - CALL DCOPY( N, X, INCX, DWORK(R), 1 ) - CALL F( N, IPAR, LIPAR, DPAR, LDPAR, A, LDA, DWORK(R), 1, - $ DWORK(DWLEFT), LDWORK-DWLEFT+1, INFO ) - IF ( INFO.NE.0 ) - $ RETURN - CALL DAXPY( N, -ONE, B, INCB, DWORK(R), 1 ) - ENDIF - CALL DCOPY( N, DWORK(R), 1, DWORK, 1 ) -C - RES = DNRM2( N, DWORK(R), 1 ) -C -C Do nothing if x is already the solution. -C - IF ( RES.LE.TOLDEF ) GOTO 20 -C -C Begin of the iteration loop. -C -C WHILE ( RES.GT.TOLDEF .AND. K.LE.ITMAX ) DO - 10 CONTINUE -C -C Calculate A*q or f(A, q). -C - IF ( MAT ) THEN - CALL DSYMV( FORM, N, ONE, A, LDA, DWORK, 1, ZERO, DWORK(AQ), - $ 1 ) - ELSE - CALL DCOPY( N, DWORK, 1, DWORK(AQ), 1 ) - CALL F( N, IPAR, LIPAR, DPAR, LDPAR, A, LDA, DWORK(AQ), 1, - $ DWORK(DWLEFT), LDWORK-DWLEFT+1, INFO ) - IF ( INFO.NE.0 ) - $ RETURN - ENDIF -C -C Calculate ALPHA(k). -C - ALPHA = DDOT( N, DWORK, 1, DWORK(R), 1 ) / - $ DDOT( N, DWORK, 1, DWORK(AQ), 1 ) -C -C x(k+1) = x(k) - ALPHA(k)*q(k). -C - CALL DAXPY( N, -ALPHA, DWORK, 1, X, INCX ) -C -C r(k+1) = r(k) - ALPHA(k)*(A*q(k)). -C - CALL DAXPY( N, -ALPHA, DWORK(AQ), 1, DWORK(R), 1 ) -C -C Save RES and calculate a new RES. -C - RESOLD = RES - RES = DNRM2( N, DWORK(R), 1 ) -C -C Exit if tolerance is reached. -C - IF ( RES.LE.TOLDEF ) GOTO 20 -C -C Calculate BETA(k). -C - BETA = ( RES/RESOLD )**2 -C -C q(k+1) = r(k+1) + BETA(k)*q(k). -C - CALL DSCAL( N, BETA, DWORK, 1 ) - CALL DAXPY( N, ONE, DWORK(R), 1, DWORK, 1 ) -C -C End of the iteration loop. -C - K = K + 1 - IF ( K.LT.ITMAX ) GOTO 10 -C END WHILE 10 -C -C Tolerance was not reached! -C - IWARN = 1 -C - 20 CONTINUE -C - DWORK(1) = K - DWORK(2) = RES -C -C *** Last line of MB02WD *** - END diff --git a/mex/sources/libslicot/MB02XD.f b/mex/sources/libslicot/MB02XD.f deleted file mode 100644 index 0575a907a..000000000 --- a/mex/sources/libslicot/MB02XD.f +++ /dev/null @@ -1,409 +0,0 @@ - SUBROUTINE MB02XD( FORM, STOR, UPLO, F, M, N, NRHS, IPAR, LIPAR, - $ DPAR, LDPAR, A, LDA, B, LDB, ATA, LDATA, DWORK, - $ LDWORK, INFO ) -C -C SLICOT RELEASE 5.0. -C -C Copyright (c) 2002-2009 NICONET e.V. -C -C This program is free software: you can redistribute it and/or -C modify it under the terms of the GNU General Public License as -C published by the Free Software Foundation, either version 2 of -C the License, or (at your option) any later version. -C -C This program is distributed in the hope that it will be useful, -C but WITHOUT ANY WARRANTY; without even the implied warranty of -C MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the -C GNU General Public License for more details. -C -C You should have received a copy of the GNU General Public License -C along with this program. If not, see -C . -C -C PURPOSE -C -C To solve a set of systems of linear equations, A'*A*X = B, or, -C in the implicit form, f(A)*X = B, with A'*A or f(A) positive -C definite, using symmetric Gaussian elimination. -C -C ARGUMENTS -C -C Mode Parameters -C -C FORM CHARACTER*1 -C Specifies the form in which the matrix A is provided, as -C follows: -C = 'S' : standard form, the matrix A is given; -C = 'F' : the implicit, function form f(A) is provided. -C If FORM = 'F', then the routine F is called to compute the -C matrix A'*A. -C -C STOR CHARACTER*1 -C Specifies the storage scheme for the symmetric -C matrix A'*A, as follows: -C = 'F' : full storage is used; -C = 'P' : packed storage is used. -C -C UPLO CHARACTER*1 -C Specifies which part of the matrix A'*A is stored, as -C follows: -C = 'U' : the upper triagular part is stored; -C = 'L' : the lower triagular part is stored. -C -C Function Parameters -C -C F EXTERNAL -C If FORM = 'F', then F is a subroutine which calculates the -C value of f(A) = A'*A, for given A. -C If FORM = 'S', then F is not called. -C -C F must have the following interface: -C -C SUBROUTINE F( STOR, UPLO, N, IPAR, LIPAR, DPAR, LDPAR, A, -C $ LDA, ATA, LDATA, DWORK, LDWORK, INFO ) -C -C where -C -C STOR (input) CHARACTER*1 -C Specifies the storage scheme for the symmetric -C matrix A'*A, as follows: -C = 'F' : full storage is used; -C = 'P' : packed storage is used. -C -C UPLO (input) CHARACTER*1 -C Specifies which part of the matrix A'*A is stored, -C as follows: -C = 'U' : the upper triagular part is stored; -C = 'L' : the lower triagular part is stored. -C -C N (input) INTEGER -C The order of the matrix A'*A. N >= 0. -C -C IPAR (input) INTEGER array, dimension (LIPAR) -C The integer parameters describing the structure of -C the matrix A. -C -C LIPAR (input) INTEGER -C The length of the array IPAR. LIPAR >= 0. -C -C DPAR (input) DOUBLE PRECISION array, dimension (LDPAR) -C The real parameters needed for solving the -C problem. -C -C LDPAR (input) INTEGER -C The length of the array DPAR. LDPAR >= 0. -C -C A (input) DOUBLE PRECISION array, dimension -C (LDA, NC), where NC is the number of columns. -C The leading NR-by-NC part of this array must -C contain the (compressed) representation of the -C matrix A, where NR is the number of rows of A -C (function of IPAR entries). -C -C LDA (input) INTEGER -C The leading dimension of the array A. -C LDA >= MAX(1,NR). -C -C ATA (output) DOUBLE PRECISION array, -C dimension (LDATA,N), if STOR = 'F', -C dimension (N*(N+1)/2), if STOR = 'P'. -C The leading N-by-N (if STOR = 'F'), or N*(N+1)/2 -C (if STOR = 'P') part of this array contains the -C upper or lower triangle of the matrix A'*A, -C depending on UPLO = 'U', or UPLO = 'L', -C respectively, stored either as a two-dimensional, -C or one-dimensional array, depending on STOR. -C -C LDATA (input) INTEGER -C The leading dimension of the array ATA. -C LDATA >= MAX(1,N), if STOR = 'F'. -C LDATA >= 1, if STOR = 'P'. -C -C DWORK DOUBLE PRECISION array, dimension (LDWORK) -C The workspace array for subroutine F. -C -C LDWORK (input) INTEGER -C The size of the array DWORK (as large as needed -C in the subroutine F). -C -C INFO INTEGER -C Error indicator, set to a negative value if an -C input scalar argument is erroneous, and to -C positive values for other possible errors in the -C subroutine F. The LAPACK Library routine XERBLA -C should be used in conjunction with negative INFO. -C INFO must be zero if the subroutine finished -C successfully. -C -C Parameters marked with "(input)" must not be changed. -C -C Input/Output Parameters -C -C M (input) INTEGER -C The number of rows of the matrix A. M >= 0. -C -C N (input) INTEGER -C The order of the matrix A'*A, the number of columns of the -C matrix A, and the number of rows of the matrix X. N >= 0. -C -C NRHS (input) INTEGER -C The number of columns of the matrices B and X. NRHS >= 0. -C -C IPAR (input) INTEGER array, dimension (LIPAR) -C If FORM = 'F', the integer parameters describing the -C structure of the matrix A. -C This parameter is ignored if FORM = 'S'. -C -C LIPAR (input) INTEGER -C The length of the array IPAR. LIPAR >= 0. -C -C DPAR (input) DOUBLE PRECISION array, dimension (LDPAR) -C If FORM = 'F', the real parameters needed for solving -C the problem. -C This parameter is ignored if FORM = 'S'. -C -C LDPAR (input) INTEGER -C The length of the array DPAR. LDPAR >= 0. -C -C A (input) DOUBLE PRECISION array, -C dimension (LDA, N), if FORM = 'S', -C dimension (LDA, NC), if FORM = 'F', where NC is -C the number of columns. -C If FORM = 'S', the leading M-by-N part of this array -C must contain the matrix A. -C If FORM = 'F', the leading NR-by-NC part of this array -C must contain an appropriate representation of matrix A, -C where NR is the number of rows. -C If FORM = 'F', this array is not referenced by this -C routine itself, except in the call to the routine F. -C -C LDA INTEGER -C The leading dimension of array A. -C LDA >= MAX(1,M), if FORM = 'S'; -C LDA >= MAX(1,NR), if FORM = 'F'. -C -C B (input/output) DOUBLE PRECISION array, dimension -C (LDB, NRHS) -C On entry, the leading N-by-NRHS part of this array must -C contain the right hand side matrix B. -C On exit, if INFO = 0 and M (or NR) is nonzero, the leading -C N-by-NRHS part of this array contains the solution X of -C the set of systems of linear equations A'*A*X = B or -C f(A)*X = B. If M (or NR) is zero, then B is unchanged. -C -C LDB INTEGER -C The leading dimension of array B. LDB >= MAX(1,N). -C -C ATA (output) DOUBLE PRECISION array, -C dimension (LDATA,N), if STOR = 'F', -C dimension (N*(N+1)/2), if STOR = 'P'. -C The leading N-by-N (if STOR = 'F'), or N*(N+1)/2 (if -C STOR = 'P') part of this array contains the upper or lower -C triangular Cholesky factor of the matrix A'*A, depending -C on UPLO = 'U', or UPLO = 'L', respectively, stored either -C as a two-dimensional, or one-dimensional array, depending -C on STOR. -C -C LDATA INTEGER -C The leading dimension of the array ATA. -C LDATA >= MAX(1,N), if STOR = 'F'. -C LDATA >= 1, if STOR = 'P'. -C -C Workspace -C -C DWORK DOUBLE PRECISION array, dimension (LDWORK) -C -C LDWORK INTEGER -C The length of the array DWORK. -C -C Error Indicator -C -C INFO INTEGER -C = 0: successful exit; -C < 0: if INFO = -i, the i-th argument had an illegal -C value; -C > 0: if INFO = i, then the (i,i) element of the -C triangular factor of the matrix A'*A is exactly -C zero (the matrix A'*A is exactly singular); -C if INFO = j > n, then F returned with INFO = j-n. -C -C METHOD -C -C The matrix A'*A is built either directly (if FORM = 'S'), or -C implicitly, by calling the routine F. Then, A'*A is Cholesky -C factored and its factor is used to solve the set of systems of -C linear equations, A'*A*X = B. -C -C REFERENCES -C -C [1] Golub, G.H. and van Loan, C.F. -C Matrix Computations. Third Edition. -C M. D. Johns Hopkins University Press, Baltimore, 1996. -C -C [2] Anderson, E., Bai, Z., Bischof, C., Blackford, Demmel, J., -C Dongarra, J., Du Croz, J., Greenbaum, A., Hammarling, S., -C McKenney, A., Sorensen, D. -C LAPACK Users' Guide: Third Edition, SIAM, Philadelphia, 1999. -C -C NUMERICAL ASPECTS -C -C For speed, this routine does not check for near singularity of the -C matrix A'*A. If the matrix A is nearly rank deficient, then the -C computed X could be inaccurate. Estimates of the reciprocal -C condition numbers of the matrices A and A'*A can be obtained -C using LAPACK routines DGECON and DPOCON (DPPCON), respectively. -C -C The approximate number of floating point operations is -C (M+3)*N**2/2 + N**3/6 + NRHS*N**2, if FORM = 'S', -C f + N**3/6 + NRHS*N**2, if FORM = 'F', -C where M is the number of rows of A, and f is the number of -C floating point operations required by the subroutine F. -C -C CONTRIBUTORS -C -C V. Sima, Research Institute for Informatics, Bucharest, Mar. 2001. -C -C REVISIONS -C -C V. Sima, Mar. 2002. -C -C KEYWORDS -C -C Linear system of equations, matrix operations. -C -C ****************************************************************** -C -C .. Parameters .. - DOUBLE PRECISION ZERO, ONE - PARAMETER ( ZERO = 0.0D0, ONE = 1.0D0 ) -C .. Scalar Arguments .. - CHARACTER FORM, STOR, UPLO - INTEGER INFO, LDA, LDATA, LDB, LDPAR, LDWORK, LIPAR, M, - $ N, NRHS -C .. Array Arguments .. - DOUBLE PRECISION A(LDA,*), ATA(*), B(LDB,*), DPAR(*), DWORK(*) - INTEGER IPAR(*) -C .. Local Scalars .. - INTEGER IERR, J, J1 - LOGICAL FULL, MAT, UPPER -C .. External Functions .. - LOGICAL LSAME - EXTERNAL LSAME -C .. External Subroutines .. - EXTERNAL DGEMV, DPOTRF, DPOTRS, DPPTRF, DPPTRS, DSYRK, F, - $ XERBLA -C .. Intrinsic Functions .. - INTRINSIC MAX -C .. -C .. Executable Statements .. -C -C Decode the scalar input parameters. -C - MAT = LSAME( FORM, 'S' ) - FULL = LSAME( STOR, 'F' ) - UPPER = LSAME( UPLO, 'U' ) -C -C Check the scalar input parameters. -C - INFO = 0 - IF( .NOT.( MAT .OR. LSAME( FORM, 'F' ) ) ) THEN - INFO = -1 - ELSEIF ( .NOT.( FULL .OR. LSAME( STOR, 'P' ) ) ) THEN - INFO = -2 - ELSEIF ( .NOT.( UPPER .OR. LSAME( UPLO, 'L' ) ) ) THEN - INFO = -3 - ELSEIF ( M.LT.0 ) THEN - INFO = -5 - ELSEIF ( N.LT.0 ) THEN - INFO = -6 - ELSEIF ( NRHS.LT.0 ) THEN - INFO = -7 - ELSEIF ( .NOT. MAT .AND. LIPAR.LT.0 ) THEN - INFO = -9 - ELSEIF ( .NOT. MAT .AND. LDPAR.LT.0 ) THEN - INFO = -11 - ELSEIF ( LDA.LT.1 .OR. ( MAT .AND. LDA.LT.M ) ) THEN - INFO = -13 - ELSEIF ( LDB.LT.MAX( 1, N ) ) THEN - INFO = -15 - ELSEIF ( LDATA.LT.1 .OR. ( FULL .AND. LDATA.LT.N ) ) THEN - INFO = -17 - ENDIF -C -C Return if there are illegal arguments. -C - IF( INFO.NE.0 ) THEN - CALL XERBLA( 'MB02XD', -INFO ) - RETURN - ENDIF -C -C Quick return if possible. -C - IF ( N.EQ.0 .OR. ( MAT .AND. M.EQ.0 ) ) - $ RETURN -C -C Build a triangle of the matrix A'*A. -C - IF ( MAT ) THEN -C -C Matrix A is given in the usual form. -C - IF ( FULL ) THEN - CALL DSYRK( UPLO, 'Transpose', N, M, ONE, A, LDA, ZERO, - $ ATA, LDATA ) - ELSEIF ( UPPER ) THEN - J1 = 1 -C - DO 10 J = 1, N - CALL DGEMV( 'Transpose', M, J, ONE, A, LDA, A(1,J), 1, - $ ZERO, ATA(J1), 1 ) - J1 = J1 + J - 10 CONTINUE -C - ELSE - J1 = 1 -C - DO 20 J = 1, N - CALL DGEMV( 'Transpose', M, N-J+1, ONE, A(1,J), LDA, - $ A(1,J), 1, ZERO, ATA(J1), 1 ) - J1 = J1 + N - J + 1 - 20 CONTINUE -C - ENDIF -C - ELSE -C -C Implicit form, A'*A = f(A). -C - CALL F( STOR, UPLO, N, IPAR, LIPAR, DPAR, LDPAR, A, LDA, ATA, - $ LDATA, DWORK, LDWORK, IERR ) - IF ( IERR.NE.0 ) THEN - INFO = N + IERR - RETURN - ENDIF -C - ENDIF -C -C Factor the matrix A'*A. -C - IF ( FULL ) THEN - CALL DPOTRF( UPLO, N, ATA, LDATA, IERR ) - ELSE - CALL DPPTRF( UPLO, N, ATA, IERR ) - ENDIF -C - IF ( IERR.NE.0 ) THEN - INFO = IERR - RETURN - ENDIF -C -C Solve the set of linear systems. -C - IF ( FULL ) THEN - CALL DPOTRS( UPLO, N, NRHS, ATA, LDATA, B, LDB, IERR ) - ELSE - CALL DPPTRS( UPLO, N, NRHS, ATA, B, LDB, IERR ) - ENDIF -C -C *** Last line of MB02XD *** - END diff --git a/mex/sources/libslicot/MB02YD.f b/mex/sources/libslicot/MB02YD.f deleted file mode 100644 index 981af1f03..000000000 --- a/mex/sources/libslicot/MB02YD.f +++ /dev/null @@ -1,371 +0,0 @@ - SUBROUTINE MB02YD( COND, N, R, LDR, IPVT, DIAG, QTB, RANK, X, TOL, - $ DWORK, LDWORK, INFO ) -C -C SLICOT RELEASE 5.0. -C -C Copyright (c) 2002-2009 NICONET e.V. -C -C This program is free software: you can redistribute it and/or -C modify it under the terms of the GNU General Public License as -C published by the Free Software Foundation, either version 2 of -C the License, or (at your option) any later version. -C -C This program is distributed in the hope that it will be useful, -C but WITHOUT ANY WARRANTY; without even the implied warranty of -C MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the -C GNU General Public License for more details. -C -C You should have received a copy of the GNU General Public License -C along with this program. If not, see -C . -C -C PURPOSE -C -C To determine a vector x which solves the system of linear -C equations -C -C A*x = b , D*x = 0 , -C -C in the least squares sense, where A is an m-by-n matrix, -C D is an n-by-n diagonal matrix, and b is an m-vector. -C It is assumed that a QR factorization, with column pivoting, of A -C is available, that is, A*P = Q*R, where P is a permutation matrix, -C Q has orthogonal columns, and R is an upper triangular matrix -C with diagonal elements of nonincreasing magnitude. -C The routine needs the full upper triangle of R, the permutation -C matrix P, and the first n components of Q'*b (' denotes the -C transpose). The system A*x = b, D*x = 0, is then equivalent to -C -C R*z = Q'*b , P'*D*P*z = 0 , (1) -C -C where x = P*z. If this system does not have full rank, then a -C least squares solution is obtained. On output, MB02YD also -C provides an upper triangular matrix S such that -C -C P'*(A'*A + D*D)*P = S'*S . -C -C The system (1) is equivalent to S*z = c , where c contains the -C first n components of the vector obtained by applying to -C [ (Q'*b)' 0 ]' the transformations which triangularized -C [ R' P'*D*P ]', getting S. -C -C ARGUMENTS -C -C Mode Parameters -C -C COND CHARACTER*1 -C Specifies whether the condition of the matrix S should be -C estimated, as follows: -C = 'E' : use incremental condition estimation and store -C the numerical rank of S in RANK; -C = 'N' : do not use condition estimation, but check the -C diagonal entries of S for zero values; -C = 'U' : use the rank already stored in RANK. -C -C Input/Output Parameters -C -C N (input) INTEGER -C The order of the matrix R. N >= 0. -C -C R (input/output) DOUBLE PRECISION array, dimension (LDR, N) -C On entry, the leading N-by-N upper triangular part of this -C array must contain the upper triangular matrix R. -C On exit, the full upper triangle is unaltered, and the -C strict lower triangle contains the strict upper triangle -C (transposed) of the upper triangular matrix S. -C -C LDR INTEGER -C The leading dimension of array R. LDR >= MAX(1,N). -C -C IPVT (input) INTEGER array, dimension (N) -C This array must define the permutation matrix P such that -C A*P = Q*R. Column j of P is column IPVT(j) of the identity -C matrix. -C -C DIAG (input) DOUBLE PRECISION array, dimension (N) -C This array must contain the diagonal elements of the -C matrix D. -C -C QTB (input) DOUBLE PRECISION array, dimension (N) -C This array must contain the first n elements of the -C vector Q'*b. -C -C RANK (input or output) INTEGER -C On entry, if COND = 'U', this parameter must contain the -C (numerical) rank of the matrix S. -C On exit, if COND = 'E' or 'N', this parameter contains -C the numerical rank of the matrix S, estimated according -C to the value of COND. -C -C X (output) DOUBLE PRECISION array, dimension (N) -C This array contains the least squares solution of the -C system A*x = b, D*x = 0. -C -C Tolerances -C -C TOL DOUBLE PRECISION -C If COND = 'E', the tolerance to be used for finding the -C rank of the matrix S. If the user sets TOL > 0, then the -C given value of TOL is used as a lower bound for the -C reciprocal condition number; a (sub)matrix whose -C estimated condition number is less than 1/TOL is -C considered to be of full rank. If the user sets TOL <= 0, -C then an implicitly computed, default tolerance, defined by -C TOLDEF = N*EPS, is used instead, where EPS is the machine -C precision (see LAPACK Library routine DLAMCH). -C This parameter is not relevant if COND = 'U' or 'N'. -C -C Workspace -C -C DWORK DOUBLE PRECISION array, dimension (LDWORK) -C On exit, the first N elements of this array contain the -C diagonal elements of the upper triangular matrix S, and -C the next N elements contain the solution z. -C -C LDWORK INTEGER -C The length of the array DWORK. -C LDWORK >= 4*N, if COND = 'E'; -C LDWORK >= 2*N, if COND <> 'E'. -C -C Error Indicator -C -C INFO INTEGER -C = 0: successful exit; -C < 0: if INFO = -i, the i-th argument had an illegal -C value. -C -C METHOD -C -C Standard plane rotations are used to annihilate the elements of -C the diagonal matrix D, updating the upper triangular matrix R -C and the first n elements of the vector Q'*b. A basic least squares -C solution is computed. -C -C REFERENCES -C -C [1] More, J.J., Garbow, B.S, and Hillstrom, K.E. -C User's Guide for MINPACK-1. -C Applied Math. Division, Argonne National Laboratory, Argonne, -C Illinois, Report ANL-80-74, 1980. -C -C NUMERICAL ASPECTS -C 2 -C The algorithm requires 0(N ) operations and is backward stable. -C -C FURTHER COMMENTS -C -C This routine is a LAPACK-based modification of QRSOLV from the -C MINPACK package [1], and with optional condition estimation. -C The option COND = 'U' is useful when dealing with several -C right-hand side vectors. -C -C CONTRIBUTORS -C -C V. Sima, Research Institute for Informatics, Bucharest, Dec. 2001. -C -C REVISIONS -C -C V. Sima, Research Institute for Informatics, Bucharest, Mar. 2005. -C -C KEYWORDS -C -C Linear system of equations, matrix operations, plane rotations. -C -C ****************************************************************** -C -C .. Parameters .. - DOUBLE PRECISION ZERO, SVLMAX - PARAMETER ( ZERO = 0.0D0, SVLMAX = 0.0D0 ) -C .. Scalar Arguments .. - CHARACTER COND - INTEGER INFO, LDR, LDWORK, N, RANK - DOUBLE PRECISION TOL -C .. Array Arguments .. - INTEGER IPVT(*) - DOUBLE PRECISION DIAG(*), DWORK(*), QTB(*), R(LDR,*), X(*) -C .. Local Scalars .. - DOUBLE PRECISION CS, QTBPJ, SN, TEMP, TOLDEF - INTEGER I, J, K, L - LOGICAL ECOND, NCOND, UCOND -C .. Local Arrays .. - DOUBLE PRECISION DUM(3) -C .. External Functions .. - DOUBLE PRECISION DLAMCH - LOGICAL LSAME - EXTERNAL DLAMCH, LSAME -C .. External Subroutines .. - EXTERNAL DCOPY, DLARTG, DROT, DSWAP, MB03OD, XERBLA -C .. Intrinsic Functions .. - INTRINSIC DBLE, MAX -C .. -C .. Executable Statements .. -C -C Check the scalar input parameters. -C - ECOND = LSAME( COND, 'E' ) - NCOND = LSAME( COND, 'N' ) - UCOND = LSAME( COND, 'U' ) - INFO = 0 - IF( .NOT.( ECOND .OR. NCOND .OR. UCOND ) ) THEN - INFO = -1 - ELSEIF( N.LT.0 ) THEN - INFO = -2 - ELSEIF ( LDR.LT.MAX( 1, N ) ) THEN - INFO = -4 - ELSEIF ( UCOND .AND. ( RANK.LT.0 .OR. RANK.GT.N ) ) THEN - INFO = -8 - ELSEIF ( LDWORK.LT.2*N .OR. ( ECOND .AND. LDWORK.LT.4*N ) ) THEN - INFO = -12 - ENDIF -C -C Return if there are illegal arguments. -C - IF( INFO.NE.0 ) THEN - CALL XERBLA( 'MB02YD', -INFO ) - RETURN - ENDIF -C -C Quick return if possible. -C - IF ( N.EQ.0 ) THEN - IF ( .NOT.UCOND ) - $ RANK = 0 - RETURN - END IF -C -C Copy R and Q'*b to preserve input and initialize S. -C In particular, save the diagonal elements of R in X. -C - DO 20 J = 1, N - X(J) = R(J,J) - DO 10 I = J, N - R(I,J) = R(J,I) - 10 CONTINUE - 20 CONTINUE -C - CALL DCOPY( N, QTB, 1, DWORK(N+1), 1 ) -C -C Eliminate the diagonal matrix D using Givens rotations. -C - DO 50 J = 1, N -C -C Prepare the row of D to be eliminated, locating the -C diagonal element using P from the QR factorization. -C - L = IPVT(J) - IF ( DIAG(L).NE.ZERO ) THEN - QTBPJ = ZERO - DWORK(J) = DIAG(L) -C - DO 30 K = J + 1, N - DWORK(K) = ZERO - 30 CONTINUE -C -C The transformations to eliminate the row of D modify only -C a single element of Q'*b beyond the first n, which is -C initially zero. -C - DO 40 K = J, N -C -C Determine a Givens rotation which eliminates the -C appropriate element in the current row of D. -C - IF ( DWORK(K).NE.ZERO ) THEN -C - CALL DLARTG( R(K,K), DWORK(K), CS, SN, TEMP ) -C -C Compute the modified diagonal element of R and -C the modified elements of (Q'*b,0). -C Accumulate the tranformation in the row of S. -C - TEMP = CS*DWORK(N+K) + SN*QTBPJ - QTBPJ = -SN*DWORK(N+K) + CS*QTBPJ - DWORK(N+K) = TEMP - CALL DROT( N-K+1, R(K,K), 1, DWORK(K), 1, CS, SN ) -C - END IF - 40 CONTINUE -C - END IF -C -C Store the diagonal element of S and, if COND <> 'E', restore -C the corresponding diagonal element of R. -C - DWORK(J) = R(J,J) - IF ( .NOT.ECOND ) - $ R(J,J) = X(J) - 50 CONTINUE -C -C Solve the triangular system for z. If the system is singular, -C then obtain a least squares solution. -C - IF ( ECOND ) THEN - TOLDEF = TOL - IF ( TOLDEF.LE.ZERO ) THEN -C -C Use the default tolerance in rank determination. -C - TOLDEF = DBLE( N )*DLAMCH( 'Epsilon' ) - END IF -C -C Interchange the strict upper and lower triangular parts of R. -C - DO 60 J = 2, N - CALL DSWAP( J-1, R(1,J), 1, R(J,1), LDR ) - 60 CONTINUE -C -C Estimate the reciprocal condition number of S and set the rank. -C Additional workspace: 2*N. -C - CALL MB03OD( 'No QR', N, N, R, LDR, IPVT, TOLDEF, SVLMAX, - $ DWORK, RANK, DUM, DWORK(2*N+1), LDWORK-2*N, - $ INFO ) - R(1,1) = X(1) -C -C Restore the strict upper and lower triangular parts of R. -C - DO 70 J = 2, N - CALL DSWAP( J-1, R(1,J), 1, R(J,1), LDR ) - R(J,J) = X(J) - 70 CONTINUE -C - ELSEIF ( NCOND ) THEN -C -C Determine rank(S) by checking zero diagonal entries. -C - RANK = N -C - DO 80 J = 1, N - IF ( DWORK(J).EQ.ZERO .AND. RANK.EQ.N ) - $ RANK = J - 1 - 80 CONTINUE -C - END IF -C - DUM(1) = ZERO - IF ( RANK.LT.N ) - $ CALL DCOPY( N-RANK, DUM, 0, DWORK(N+RANK+1), 1 ) -C -C Solve S*z = c using back substitution. -C - DO 100 J = RANK, 1, -1 - TEMP = ZERO -C - DO 90 I = J + 1, RANK - TEMP = TEMP + R(I,J)*DWORK(N+I) - 90 CONTINUE -C - DWORK(N+J) = ( DWORK(N+J) - TEMP )/DWORK(J) - 100 CONTINUE -C -C Permute the components of z back to components of x. -C - DO 110 J = 1, N - L = IPVT(J) - X(L) = DWORK(N+J) - 110 CONTINUE -C - RETURN -C -C *** Last line of MB02YD *** - END diff --git a/mex/sources/libslicot/MB03MD.f b/mex/sources/libslicot/MB03MD.f deleted file mode 100644 index 7f47657fd..000000000 --- a/mex/sources/libslicot/MB03MD.f +++ /dev/null @@ -1,343 +0,0 @@ - SUBROUTINE MB03MD( N, L, THETA, Q, E, Q2, E2, PIVMIN, TOL, RELTOL, - $ IWARN, INFO ) -C -C SLICOT RELEASE 5.0. -C -C Copyright (c) 2002-2009 NICONET e.V. -C -C This program is free software: you can redistribute it and/or -C modify it under the terms of the GNU General Public License as -C published by the Free Software Foundation, either version 2 of -C the License, or (at your option) any later version. -C -C This program is distributed in the hope that it will be useful, -C but WITHOUT ANY WARRANTY; without even the implied warranty of -C MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the -C GNU General Public License for more details. -C -C You should have received a copy of the GNU General Public License -C along with this program. If not, see -C . -C -C PURPOSE -C -C To compute an upper bound THETA using a bisection method such that -C the bidiagonal matrix -C -C |q(1) e(1) 0 ... 0 | -C | 0 q(2) e(2) . | -C J = | . . | -C | . e(N-1)| -C | 0 ... ... q(N) | -C -C has precisely L singular values less than or equal to THETA plus -C a given tolerance TOL. -C -C This routine is mainly intended to be called only by other SLICOT -C routines. -C -C ARGUMENTS -C -C Input/Output Parameters -C -C N (input) INTEGER -C The order of the bidiagonal matrix J. N >= 0. -C -C L (input/output) INTEGER -C On entry, L must contain the number of singular values -C of J which must be less than or equal to the upper bound -C computed by the routine. 0 <= L <= N. -C On exit, L may be increased if the L-th smallest singular -C value of J has multiplicity greater than 1. In this case, -C L is increased by the number of singular values of J which -C are larger than its L-th smallest one and approach the -C L-th smallest singular value of J within a distance less -C than TOL. -C If L has been increased, then the routine returns with -C IWARN set to 1. -C -C THETA (input/output) DOUBLE PRECISION -C On entry, THETA must contain an initial estimate for the -C upper bound to be computed. If THETA < 0.0 on entry, then -C one of the following default values is used. -C If L = 0, THETA is set to 0.0 irrespective of the input -C value of THETA; if L = 1, then THETA is taken as -C MIN(ABS(Q(i))), for i = 1,2,...,N; otherwise, THETA is -C taken as ABS(Q(N-L+1)). -C On exit, THETA contains the computed upper bound such that -C the bidiagonal matrix J has precisely L singular values -C less than or equal to THETA + TOL. -C -C Q (input) DOUBLE PRECISION array, dimension (N) -C This array must contain the diagonal elements q(1), -C q(2),...,q(N) of the bidiagonal matrix J. That is, -C Q(i) = J(i,i) for i = 1,2,...,N. -C -C E (input) DOUBLE PRECISION array, dimension (N-1) -C This array must contain the superdiagonal elements -C e(1),e(2),...,e(N-1) of the bidiagonal matrix J. That is, -C E(k) = J(k,k+1) for k = 1,2,...,N-1. -C -C Q2 (input) DOUBLE PRECISION array, dimension (N) -C This array must contain the squares of the diagonal -C elements q(1),q(2),...,q(N) of the bidiagonal matrix J. -C That is, Q2(i) = J(i,i)**2 for i = 1,2,...,N. -C -C E2 (input) DOUBLE PRECISION array, dimension (N-1) -C This array must contain the squares of the superdiagonal -C elements e(1),e(2),...,e(N-1) of the bidiagonal matrix J. -C That is, E2(k) = J(k,k+1)**2 for k = 1,2,...,N-1. -C -C PIVMIN (input) DOUBLE PRECISION -C The minimum absolute value of a "pivot" in the Sturm -C sequence loop. -C PIVMIN >= max( max( |q(i)|, |e(k)| )**2*sf_min, sf_min ), -C where i = 1,2,...,N, k = 1,2,...,N-1, and sf_min is at -C least the smallest number that can divide one without -C overflow (see LAPACK Library routine DLAMCH). -C Note that this condition is not checked by the routine. -C -C Tolerances -C -C TOL DOUBLE PRECISION -C This parameter defines the multiplicity of singular values -C by considering all singular values within an interval of -C length TOL as coinciding. TOL is used in checking how many -C singular values are less than or equal to THETA. Also in -C computing an appropriate upper bound THETA by a bisection -C method, TOL is used as a stopping criterion defining the -C minimum (absolute) subinterval width. TOL >= 0. -C -C RELTOL DOUBLE PRECISION -C This parameter specifies the minimum relative width of an -C interval. When an interval is narrower than TOL, or than -C RELTOL times the larger (in magnitude) endpoint, then it -C is considered to be sufficiently small and bisection has -C converged. -C RELTOL >= BASE * EPS, where BASE is machine radix and EPS -C is machine precision (see LAPACK Library routine DLAMCH). -C -C Warning Indicator -C -C IWARN INTEGER -C = 0: no warnings; -C = 1: if the value of L has been increased as the L-th -C smallest singular value of J coincides with the -C (L+1)-th smallest one. -C -C Error Indicator -C -C INFO INTEGER -C = 0: successful exit; -C < 0: if INFO = -i, the i-th argument had an illegal -C value. -C -C METHOD -C -C Let s(i), i = 1,2,...,N, be the N non-negative singular values of -C the bidiagonal matrix J arranged so that s(1) >= ... >= s(N) >= 0. -C The routine then computes an upper bound T such that s(N-L) > T >= -C s(N-L+1) as follows (see [2]). -C First, if the initial estimate of THETA is not specified by the -C user then the routine initialises THETA to be an estimate which -C is close to the requested value of THETA if s(N-L) >> s(N-L+1). -C Second, a bisection method (see [1, 8.5]) is used which generates -C a sequence of shrinking intervals [Y,Z] such that either THETA in -C [Y,Z] was found (so that J has L singular values less than or -C equal to THETA), or -C -C (number of s(i) <= Y) < L < (number of s(i) <= Z). -C -C This bisection method is applied to an associated 2N-by-2N -C symmetric tridiagonal matrix T" whose eigenvalues (see [1]) are -C given by s(1),s(2),...,s(N),-s(1),-s(2),...,-s(N). One of the -C starting values for the bisection method is the initial value of -C THETA. If this value is an upper bound, then the initial lower -C bound is set to zero, else the initial upper bound is computed -C from the Gershgorin Circle Theorem [1, Theorem 7.2-1], applied to -C T". The computation of the "number of s(i) <= Y (or Z)" is -C achieved by calling SLICOT Library routine MB03ND, which applies -C Sylvester's Law of Inertia or equivalently Sturm sequences -C [1, 8.5] to the associated matrix T". If -C -C Z - Y <= MAX( TOL, PIVMIN, RELTOL*MAX( ABS( Y ), ABS( Z ) ) ) -C -C at some stage of the bisection method, then at least two singular -C values of J lie in the interval [Y,Z] within a distance less than -C TOL from each other. In this case, s(N-L) and s(N-L+1) are assumed -C to coincide, the upper bound T is set to the value of Z, the value -C of L is increased and IWARN is set to 1. -C -C REFERENCES -C -C [1] Golub, G.H. and Van Loan, C.F. -C Matrix Computations. -C The Johns Hopkins University Press, Baltimore, Maryland, 1983. -C -C [2] Van Huffel, S. and Vandewalle, J. -C The Partial Total Least Squares Algorithm. -C J. Comput. and Appl. Math., 21, pp. 333-341, 1988. -C -C NUMERICAL ASPECTS -C -C None. -C -C CONTRIBUTOR -C -C Release 3.0: V. Sima, Katholieke Univ. Leuven, Belgium, Apr. 1997. -C Supersedes Release 2.0 routine MB03AD by S. Van Huffel, Katholieke -C University, Leuven, Belgium. -C -C REVISIONS -C -C June 16, 1997, Oct. 26, 2003. -C -C KEYWORDS -C -C Bidiagonal matrix, singular values. -C -C ****************************************************************** -C -C .. Parameters .. - DOUBLE PRECISION ZERO, TWO - PARAMETER ( ZERO = 0.0D0, TWO = 2.0D0 ) - DOUBLE PRECISION FUDGE - PARAMETER ( FUDGE = TWO ) -C .. Scalar Arguments .. - INTEGER INFO, IWARN, L, N - DOUBLE PRECISION PIVMIN, RELTOL, THETA, TOL -C .. Array Arguments .. - DOUBLE PRECISION E(*), E2(*), Q(*), Q2(*) -C .. Local Scalars .. - INTEGER I, NUM, NUMZ - DOUBLE PRECISION H, TH, Y, Z -C .. External Functions .. - INTEGER MB03ND - DOUBLE PRECISION DLAMCH, MB03MY - EXTERNAL DLAMCH, MB03MY, MB03ND -C .. External Subroutines .. - EXTERNAL XERBLA -C .. Intrinsic Functions .. - INTRINSIC ABS, DBLE, MAX -C .. Executable Statements .. -C -C Test some input scalar arguments. -C - IWARN = 0 - INFO = 0 - IF( N.LT.0 ) THEN - INFO = -1 - ELSE IF( L.LT.0 .OR. L.GT.N ) THEN - INFO = -2 - END IF -C - IF ( INFO.NE.0 ) THEN -C -C Error return. -C - CALL XERBLA( 'MB03MD', -INFO ) - RETURN - END IF -C -C Quick return if possible. -C - IF ( N.EQ.0 ) - $ RETURN -C -C Step 1: initialisation of THETA. -C ----------------------- - IF ( L.EQ.0 ) THETA = ZERO - IF ( THETA.LT.ZERO ) THEN - IF ( L.EQ.1 ) THEN -C -C An upper bound which is close if S(N-1) >> S(N): -C - THETA = MB03MY( N, Q, 1 ) - IF ( N.EQ.1 ) - $ RETURN - ELSE -C -C An experimentally established estimate which is good if -C S(N-L) >> S(N-L+1): -C - THETA = ABS( Q(N-L+1) ) - END IF - END IF -C -C Step 2: Check quality of initial estimate THETA. -C --------------------------------------- - NUM = MB03ND( N, THETA, Q2, E2, PIVMIN, INFO ) - IF ( NUM.EQ.L ) - $ RETURN -C -C Step 3: initialisation starting values for bisection method. -C --------------------------------------------------- -C Let S(i), i=1,...,N, be the singular values of J in decreasing -C order. Then, the computed Y and Z will be such that -C (number of S(i) <= Y) < L < (number of S(i) <= Z). -C - IF ( NUM.LT.L ) THEN - TH = ABS( Q(1) ) - Z = ZERO - Y = THETA - NUMZ = N -C - DO 20 I = 1, N - 1 - H = ABS( Q(I+1) ) - Z = MAX( MAX( TH, H ) + ABS( E(I) ), Z ) - TH = H - 20 CONTINUE -C -C Widen the Gershgorin interval a bit for machines with sloppy -C arithmetic. -C - Z = Z + FUDGE*ABS( Z )*DLAMCH( 'Epsilon' )*DBLE( N ) - $ + FUDGE*PIVMIN - ELSE - Z = THETA - Y = ZERO - NUMZ = NUM - END IF -C -C Step 4: Bisection method for finding the upper bound on the L -C smallest singular values of the bidiagonal. -C ------------------------------------------ -C A sequence of subintervals [Y,Z] is produced such that -C (number of S(i) <= Y) < L < (number of S(i) <= Z). -C NUM : number of S(i) <= TH, -C NUMZ: number of S(i) <= Z. -C -C WHILE ( ( NUM .NE. L ) .AND. -C ( ( Z-Y ) .GT. MAX( TOL, PIVMIN, RELTOL*ABS( Z ) ) ) ) DO - 40 IF ( ( NUM.NE.L ) .AND. - $ ( ABS( Z-Y ).GT.MAX( TOL, PIVMIN, - $ RELTOL*MAX( ABS( Y ), ABS( Z ) ) ) ) ) - $ THEN - TH = ( Y + Z )/TWO - NUM = MB03ND( N, TH, Q2, E2, PIVMIN, INFO ) - IF ( NUM.LT.L ) THEN - Y = TH - ELSE - Z = TH - NUMZ = NUM - END IF - GO TO 40 - END IF -C END WHILE 40 -C -C If NUM <> L and ( Z - Y ) <= TOL, then at least two singular -C values of J lie in the interval [Y,Z] within a distance less than -C TOL from each other. S(N-L) and S(N-L+1) are then assumed to -C coincide. L is increased, and a warning is given. -C - IF ( NUM.NE.L ) THEN - L = NUMZ - THETA = Z - IWARN = 1 - ELSE - THETA = TH - END IF -C - RETURN -C *** Last line of MB03MD *** - END diff --git a/mex/sources/libslicot/MB03MY.f b/mex/sources/libslicot/MB03MY.f deleted file mode 100644 index cee355e8a..000000000 --- a/mex/sources/libslicot/MB03MY.f +++ /dev/null @@ -1,91 +0,0 @@ - DOUBLE PRECISION FUNCTION MB03MY( NX, X, INCX ) -C -C SLICOT RELEASE 5.0. -C -C Copyright (c) 2002-2009 NICONET e.V. -C -C This program is free software: you can redistribute it and/or -C modify it under the terms of the GNU General Public License as -C published by the Free Software Foundation, either version 2 of -C the License, or (at your option) any later version. -C -C This program is distributed in the hope that it will be useful, -C but WITHOUT ANY WARRANTY; without even the implied warranty of -C MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the -C GNU General Public License for more details. -C -C You should have received a copy of the GNU General Public License -C along with this program. If not, see -C . -C -C PURPOSE -C -C To compute the absolute minimal value of NX elements in an array. -C The function returns the value zero if NX < 1. -C -C ARGUMENTS -C -C NX (input) INTEGER -C The number of elements in X to be examined. -C -C X (input) DOUBLE PRECISION array, dimension (NX * INCX) -C The one-dimensional array of which the absolute minimal -C value of the elements is to be computed. -C This array is not referenced if NX < 1. -C -C INCX (input) INTEGER -C The increment to be taken in the array X, defining the -C distance between two consecutive elements. INCX >= 1. -C INCX = 1, if all elements are contiguous in memory. -C -C NUMERICAL ASPECTS -C -C None. -C -C CONTRIBUTOR -C -C Release 3.0: V. Sima, Katholieke Univ. Leuven, Belgium, Mar. 1997. -C Supersedes Release 2.0 routine MB03AZ by S. Van Huffel, Katholieke -C University, Leuven, Belgium. -C -C REVISIONS -C -C June 16, 1997. -C -C KEYWORDS -C -C None. -C -C ****************************************************************** -C -C .. Parameters .. - DOUBLE PRECISION ZERO - PARAMETER ( ZERO = 0.0D0 ) -C .. Scalar Arguments .. - INTEGER INCX, NX -C .. Array Arguments .. - DOUBLE PRECISION X(*) -C .. Local Scalars .. - INTEGER I - DOUBLE PRECISION DX -C .. Intrinsic Functions .. - INTRINSIC ABS -C .. Executable Statements .. -C -C Quick return if possible. -C - IF ( NX.LE.0 ) THEN - MB03MY = ZERO - RETURN - END IF -C - MB03MY = ABS( X(1) ) -C - DO 20 I = 1+INCX, NX*INCX, INCX - DX = ABS( X(I) ) - IF ( DX.LT.MB03MY ) MB03MY = DX - 20 CONTINUE -C - RETURN -C *** Last line of MB03MY *** - END diff --git a/mex/sources/libslicot/MB03ND.f b/mex/sources/libslicot/MB03ND.f deleted file mode 100644 index c681c2e53..000000000 --- a/mex/sources/libslicot/MB03ND.f +++ /dev/null @@ -1,217 +0,0 @@ - INTEGER FUNCTION MB03ND( N, THETA, Q2, E2, PIVMIN, INFO ) -C -C SLICOT RELEASE 5.0. -C -C Copyright (c) 2002-2009 NICONET e.V. -C -C This program is free software: you can redistribute it and/or -C modify it under the terms of the GNU General Public License as -C published by the Free Software Foundation, either version 2 of -C the License, or (at your option) any later version. -C -C This program is distributed in the hope that it will be useful, -C but WITHOUT ANY WARRANTY; without even the implied warranty of -C MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the -C GNU General Public License for more details. -C -C You should have received a copy of the GNU General Public License -C along with this program. If not, see -C . -C -C PURPOSE -C -C To find the number of singular values of the bidiagonal matrix -C -C |q(1) e(1) . ... 0 | -C | 0 q(2) e(2) . | -C J = | . . | -C | . e(N-1)| -C | 0 ... ... 0 q(N) | -C -C which are less than or equal to a given bound THETA. -C -C This routine is intended to be called only by other SLICOT -C routines. -C -C ARGUMENTS -C -C Input/Output Parameters -C -C N (input) INTEGER -C The order of the bidiagonal matrix J. N >= 0. -C -C THETA (input) DOUBLE PRECISION -C Given bound. -C Note: If THETA < 0.0 on entry, then MB03ND is set to 0 -C as the singular values of J are non-negative. -C -C Q2 (input) DOUBLE PRECISION array, dimension (N) -C This array must contain the squares of the diagonal -C elements q(1),q(2),...,q(N) of the bidiagonal matrix J. -C That is, Q2(i) = J(i,i)**2 for i = 1,2,...,N. -C -C E2 (input) DOUBLE PRECISION array, dimension (N-1) -C This array must contain the squares of the superdiagonal -C elements e(1),e(2),...,e(N-1) of the bidiagonal matrix J. -C That is, E2(k) = J(k,k+1)**2 for k = 1,2,...,N-1. -C -C PIVMIN (input) DOUBLE PRECISION -C The minimum absolute value of a "pivot" in the Sturm -C sequence loop. -C PIVMIN >= max( max( |q(i)|, |e(k)| )**2*sf_min, sf_min ), -C where i = 1,2,...,N, k = 1,2,...,N-1, and sf_min is at -C least the smallest number that can divide one without -C overflow (see LAPACK Library routine DLAMCH). -C Note that this condition is not checked by the routine. -C -C Error Indicator -C -C INFO INTEGER -C = 0: successful exit; -C < 0: if INFO = -i, the i-th argument had an illegal -C value. -C -C METHOD -C -C The computation of the number of singular values s(i) of J which -C are less than or equal to THETA is based on applying Sylvester's -C Law of Inertia, or equivalently, Sturm sequences [1,p.52] to the -C unreduced symmetric tridiagonal matrices associated with J as -C follows. Let T be the following 2N-by-2N symmetric matrix -C associated with J: -C -C | 0 J'| -C T = | |. -C | J 0 | -C -C (The eigenvalues of T are given by s(1),s(2),...,s(N),-s(1),-s(2), -C ...,-s(N)). Then, by permuting the rows and columns of T into the -C order 1, N+1, 2, N+2, ..., N, 2N it follows that T is orthogonally -C similar to the tridiagonal matrix T" with zeros on its diagonal -C and q(1), e(1), q(2), e(2), ..., e(N-1), q(N) on its offdiagonals -C [3,4]. If q(1),q(2),...,q(N) and e(1),e(2),...,e(N-1) are nonzero, -C Sylvester's Law of Inertia may be applied directly to T". -C Otherwise, T" is block diagonal and each diagonal block (which is -C then unreduced) must be analysed separately by applying -C Sylvester's Law of Inertia. -C -C REFERENCES -C -C [1] Parlett, B.N. -C The Symmetric Eigenvalue Problem. -C Prentice Hall, Englewood Cliffs, New Jersey, 1980. -C -C [2] Demmel, J. and Kahan, W. -C Computing Small Singular Values of Bidiagonal Matrices with -C Guaranteed High Relative Accuracy. -C Technical Report, Courant Inst., New York, March 1988. -C -C [3] Van Huffel, S. and Vandewalle, J. -C The Partial Total Least-Squares Algorithm. -C J. Comput. and Appl. Math., 21, pp. 333-341, 1988. -C -C [4] Golub, G.H. and Kahan, W. -C Calculating the Singular Values and Pseudo-inverse of a -C Matrix. -C SIAM J. Numer. Anal., Ser. B, 2, pp. 205-224, 1965. -C -C [5] Demmel, J.W., Dhillon, I. and Ren, H. -C On the Correctness of Parallel Bisection in Floating Point. -C Computer Science Division Technical Report UCB//CSD-94-805, -C University of California, Berkeley, CA 94720, March 1994. -C -C NUMERICAL ASPECTS -C -C The singular values s(i) could also be obtained with the use of -C the symmetric tridiagonal matrix T = J'J, whose eigenvalues are -C the squared singular values of J [4,p.213]. However, the method -C actually used by the routine is more accurate and equally -C efficient (see [2]). -C -C To avoid overflow, matrix J should be scaled so that its largest -C element is no greater than overflow**(1/2) * underflow**(1/4) -C in absolute value (and not much smaller than that, for maximal -C accuracy). -C -C With respect to accuracy the following condition holds (see [2]): -C -C If the established value is denoted by p, then at least p -C singular values of J are less than or equal to -C THETA/(1 - (3 x N - 1.5) x EPS) and no more than p singular values -C are less than or equal to -C THETA x (1 - (6 x N-2) x EPS)/(1 - (3 x N - 1.5) x EPS). -C -C CONTRIBUTOR -C -C Release 3.0: V. Sima, Katholieke Univ. Leuven, Belgium, Apr. 1997. -C Supersedes Release 2.0 routine MB03BD by S. Van Huffel, Katholieke -C University, Leuven, Belgium. -C -C REVISIONS -C -C July 10, 1997. -C -C KEYWORDS -C -C Bidiagonal matrix, singular values. -C -C ****************************************************************** -C -C .. Parameters .. - DOUBLE PRECISION ZERO - PARAMETER ( ZERO = 0.0D0 ) -C .. Scalar Arguments .. - INTEGER INFO, N - DOUBLE PRECISION PIVMIN, THETA -C .. Array Arguments .. - DOUBLE PRECISION E2(*), Q2(*) -C .. Local Scalars .. - INTEGER J, NUMEIG - DOUBLE PRECISION R, T -C .. External Subroutines .. - EXTERNAL XERBLA -C .. Intrinsic Functions .. - INTRINSIC ABS -C .. Executable Statements .. -C -C Test the input scalar arguments. PIVMIN is not checked. -C - INFO = 0 - IF( N.LT.0 ) THEN - INFO = -1 -C -C Error return. -C - CALL XERBLA( 'MB03ND', -INFO ) - RETURN - END IF -C -C Quick return if possible. -C - IF ( N.EQ.0 .OR. THETA.LT.ZERO ) THEN - MB03ND = 0 - RETURN - END IF -C - NUMEIG = N - T = -THETA - R = T - IF ( ABS( R ).LT.PIVMIN ) R = -PIVMIN -C - DO 20 J = 1, N - 1 - R = T - Q2(J)/R - IF ( ABS( R ).LT.PIVMIN ) R = -PIVMIN - IF ( R.GT.ZERO ) NUMEIG = NUMEIG - 1 - R = T - E2(J)/R - IF ( ABS( R ).LT.PIVMIN ) R = -PIVMIN - IF ( R.GT.ZERO ) NUMEIG = NUMEIG - 1 - 20 CONTINUE -C - R = T - Q2(N)/R - IF ( ABS( R ).LT.PIVMIN ) R = -PIVMIN - IF ( R.GT.ZERO ) NUMEIG = NUMEIG - 1 - MB03ND = NUMEIG -C - RETURN -C *** Last line of MB03ND *** - END diff --git a/mex/sources/libslicot/MB03NY.f b/mex/sources/libslicot/MB03NY.f deleted file mode 100644 index a6efae588..000000000 --- a/mex/sources/libslicot/MB03NY.f +++ /dev/null @@ -1,208 +0,0 @@ - DOUBLE PRECISION FUNCTION MB03NY( N, OMEGA, A, LDA, S, DWORK, - $ LDWORK, CWORK, LCWORK, INFO ) -C -C SLICOT RELEASE 5.0. -C -C Copyright (c) 2002-2009 NICONET e.V. -C -C This program is free software: you can redistribute it and/or -C modify it under the terms of the GNU General Public License as -C published by the Free Software Foundation, either version 2 of -C the License, or (at your option) any later version. -C -C This program is distributed in the hope that it will be useful, -C but WITHOUT ANY WARRANTY; without even the implied warranty of -C MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the -C GNU General Public License for more details. -C -C You should have received a copy of the GNU General Public License -C along with this program. If not, see -C . -C -C PURPOSE -C -C To compute the smallest singular value of A - jwI. -C -C FUNCTION VALUE -C -C MB03NY DOUBLE PRECISION -C The smallest singular value of A - jwI (if INFO = 0). -C If N = 0, the function value is set to zero. -C -C ARGUMENTS -C -C Input/Output Parameters -C -C N (input) INTEGER -C The order of the the matrix A. N >= 0. -C -C OMEGA (input) DOUBLE PRECISION -C The constant factor of A - jwI. -C -C A (input/workspace) DOUBLE PRECISION array, dimension -C (LDA,N) -C On entry, the leading N-by-N part of this array must -C contain the matrix A. -C On exit, if OMEGA = 0, the contents of this array are -C destroyed. Otherwise, this array is unchanged. -C -C LDA INTEGER -C The leading dimension of array A. LDA >= MAX(1,N). -C -C S (output) DOUBLE PRECISION array, dimension (N) -C The singular values of A - jwI in decreasing order. -C -C Workspace -C -C DWORK DOUBLE PRECISION array, dimension (LDWORK) -C On exit, if INFO = 0, DWORK(1) returns the optimal value -C of LDWORK. -C -C LDWORK INTEGER -C The length of the array DWORK. LDWORK >= MAX( 1, 5*N ). -C For optimum performance LDWORK should be larger. -C -C CWORK COMPLEX*16 array, dimension (LCWORK) -C On exit, if INFO = 0 and OMEGA <> 0, CWORK(1) returns the -C optimal value of LCWORK. -C If OMEGA is zero, this array is not referenced. -C -C LCWORK INTEGER -C The length of the array CWORK. -C LCWORK >= 1, if OMEGA = 0; -C LCWORK >= MAX( 1, N*N+3*N ), if OMEGA <> 0. -C For optimum performance LCWORK should be larger. -C -C Error Indicator -C -C INFO INTEGER -C = 0: successful exit; -C < 0: if INFO = -i, the i-th argument had an illegal -C value; -C = 2: The SVD algorithm (in either LAPACK Library routine -C DGESVD or ZGESVD) fails to converge; this error is -C very rare. -C -C METHOD -C -C This procedure simply constructs the matrix A - jwI, and calls -C ZGESVD if w is not zero, or DGESVD if w = 0. -C -C FURTHER COMMENTS -C -C This routine is not very efficient because it computes all -C singular values, but it is very accurate. The routine is intended -C to be called only from the SLICOT Library routine AB13FD. -C -C CONTRIBUTOR -C -C R. Byers, the routine SIGMIN (January, 1995). -C -C REVISIONS -C -C Release 4.0: V. Sima, Katholieke Univ. Leuven, Belgium, Dec. 1999. -C -C REVISIONS -C -C Oct. 2001, V. Sima, Research Institute for Informatics, Bucharest. -C Apr. 2002, V. Sima. -C -C KEYWORDS -C -C singular values. -C -C ****************************************************************** -C -C .. Parameters .. - DOUBLE PRECISION ZERO, ONE - PARAMETER ( ZERO = 0.0D0, ONE = 1.0D0 ) - COMPLEX*16 CONE, RTMONE - PARAMETER ( CONE = ( 1.0D0, 0.0D0 ), - $ RTMONE = ( 0.0D0, 1.0D0 ) ) -C .. Scalar Arguments .. - INTEGER INFO, LCWORK, LDA, LDWORK, N - DOUBLE PRECISION OMEGA -C .. Array Arguments .. - DOUBLE PRECISION A(LDA,*), DWORK(*), S(*) - COMPLEX*16 CWORK(*) -C .. Local Scalars .. - INTEGER I, IC, J -C .. Local Arrays .. - DOUBLE PRECISION DUMMY(1,1) - COMPLEX*16 ZDUMMY(1,1) -C .. External Subroutines .. - EXTERNAL DGESVD, XERBLA, ZGESVD -C .. Intrinsic Functions .. - INTRINSIC DBLE, MAX -C .. Executable Statements .. -C -C Test the input scalar arguments. -C - INFO = 0 -C - IF( N.LT.0 ) THEN - INFO = -1 - ELSE IF( LDA.LT.MAX( 1, N ) ) THEN - INFO = -4 - ELSE IF( LDWORK.LT.MAX( 1, 5*N ) ) THEN - INFO = -7 - ELSE IF( LCWORK.LT.1 .OR. ( OMEGA.NE.ZERO .AND. - $ LCWORK.LT.N*N + 3*N ) ) THEN - INFO = -9 - END IF -C - IF ( INFO.NE.0 ) THEN -C -C Error return. -C - CALL XERBLA( 'MB03NY', -INFO ) - RETURN - END IF -C -C Quick return if possible. -C - IF ( N.EQ.0 ) THEN - MB03NY = ZERO - DWORK(1) = ONE - IF ( OMEGA.NE.ZERO ) - $ CWORK(1) = CONE - RETURN - END IF -C - IF ( OMEGA.EQ.ZERO ) THEN -C -C OMEGA = 0 allows real SVD. -C - CALL DGESVD( 'No vectors', 'No vectors', N, N, A, N, S, DUMMY, - $ 1, DUMMY, 1, DWORK, LDWORK, INFO ) - IF ( INFO.NE.0 ) THEN - INFO = 2 - RETURN - END IF - ELSE -C -C General case, that is complex SVD. -C - IC = 1 - DO 20 J = 1, N - DO 10 I = 1, N - CWORK(IC) = A(I,J) - IC = IC + 1 - 10 CONTINUE - CWORK((J-1)*N+J) = CWORK((J-1)*N+J) - OMEGA * RTMONE - 20 CONTINUE - CALL ZGESVD( 'No vectors', 'No vectors', N, N, CWORK, N, S, - $ ZDUMMY, 1, ZDUMMY, 1, CWORK(N*N+1), LCWORK-N*N, - $ DWORK, INFO ) - IF ( INFO.NE.0 ) THEN - INFO = 2 - RETURN - END IF - CWORK(1) = CWORK(N*N+1) + DBLE( N*N ) * CONE - DWORK(1) = DBLE( 5*N ) - END IF -C - MB03NY = S(N) -C -C *** Last line of MB03NY *** - END diff --git a/mex/sources/libslicot/MB03OD.f b/mex/sources/libslicot/MB03OD.f deleted file mode 100644 index 71cb43d66..000000000 --- a/mex/sources/libslicot/MB03OD.f +++ /dev/null @@ -1,306 +0,0 @@ - SUBROUTINE MB03OD( JOBQR, M, N, A, LDA, JPVT, RCOND, SVLMAX, TAU, - $ RANK, SVAL, DWORK, LDWORK, INFO ) -C -C SLICOT RELEASE 5.0. -C -C Copyright (c) 2002-2009 NICONET e.V. -C -C This program is free software: you can redistribute it and/or -C modify it under the terms of the GNU General Public License as -C published by the Free Software Foundation, either version 2 of -C the License, or (at your option) any later version. -C -C This program is distributed in the hope that it will be useful, -C but WITHOUT ANY WARRANTY; without even the implied warranty of -C MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the -C GNU General Public License for more details. -C -C You should have received a copy of the GNU General Public License -C along with this program. If not, see -C . -C -C PURPOSE -C -C To compute (optionally) a rank-revealing QR factorization of a -C real general M-by-N matrix A, which may be rank-deficient, -C and estimate its effective rank using incremental condition -C estimation. -C -C The routine uses a QR factorization with column pivoting: -C A * P = Q * R, where R = [ R11 R12 ], -C [ 0 R22 ] -C with R11 defined as the largest leading submatrix whose estimated -C condition number is less than 1/RCOND. The order of R11, RANK, -C is the effective rank of A. -C -C MB03OD does not perform any scaling of the matrix A. -C -C ARGUMENTS -C -C Mode Parameters -C -C JOBQR CHARACTER*1 -C = 'Q': Perform a QR factorization with column pivoting; -C = 'N': Do not perform the QR factorization (but assume -C that it has been done outside). -C -C Input/Output Parameters -C -C M (input) INTEGER -C The number of rows of the matrix A. M >= 0. -C -C N (input) INTEGER -C The number of columns of the matrix A. N >= 0. -C -C A (input/output) DOUBLE PRECISION array, dimension -C ( LDA, N ) -C On entry with JOBQR = 'Q', the leading M by N part of this -C array must contain the given matrix A. -C On exit with JOBQR = 'Q', the leading min(M,N) by N upper -C triangular part of A contains the triangular factor R, -C and the elements below the diagonal, with the array TAU, -C represent the orthogonal matrix Q as a product of -C min(M,N) elementary reflectors. -C On entry and on exit with JOBQR = 'N', the leading -C min(M,N) by N upper triangular part of A contains the -C triangular factor R, as determined by the QR factorization -C with pivoting. The elements below the diagonal of A are -C not referenced. -C -C LDA INTEGER -C The leading dimension of the array A. LDA >= max(1,M). -C -C JPVT (input/output) INTEGER array, dimension ( N ) -C On entry with JOBQR = 'Q', if JPVT(i) <> 0, the i-th -C column of A is an initial column, otherwise it is a free -C column. Before the QR factorization of A, all initial -C columns are permuted to the leading positions; only the -C remaining free columns are moved as a result of column -C pivoting during the factorization. For rank determination -C it is preferable that all columns be free. -C On exit with JOBQR = 'Q', if JPVT(i) = k, then the i-th -C column of A*P was the k-th column of A. -C Array JPVT is not referenced when JOBQR = 'N'. -C -C RCOND (input) DOUBLE PRECISION -C RCOND is used to determine the effective rank of A, which -C is defined as the order of the largest leading triangular -C submatrix R11 in the QR factorization with pivoting of A, -C whose estimated condition number is less than 1/RCOND. -C RCOND >= 0. -C NOTE that when SVLMAX > 0, the estimated rank could be -C less than that defined above (see SVLMAX). -C -C SVLMAX (input) DOUBLE PRECISION -C If A is a submatrix of another matrix B, and the rank -C decision should be related to that matrix, then SVLMAX -C should be an estimate of the largest singular value of B -C (for instance, the Frobenius norm of B). If this is not -C the case, the input value SVLMAX = 0 should work. -C SVLMAX >= 0. -C -C TAU (output) DOUBLE PRECISION array, dimension ( MIN( M, N ) ) -C On exit with JOBQR = 'Q', the leading min(M,N) elements of -C TAU contain the scalar factors of the elementary -C reflectors. -C Array TAU is not referenced when JOBQR = 'N'. -C -C RANK (output) INTEGER -C The effective (estimated) rank of A, i.e. the order of -C the submatrix R11. -C -C SVAL (output) DOUBLE PRECISION array, dimension ( 3 ) -C The estimates of some of the singular values of the -C triangular factor R: -C SVAL(1): largest singular value of R(1:RANK,1:RANK); -C SVAL(2): smallest singular value of R(1:RANK,1:RANK); -C SVAL(3): smallest singular value of R(1:RANK+1,1:RANK+1), -C if RANK < MIN( M, N ), or of R(1:RANK,1:RANK), -C otherwise. -C If the triangular factorization is a rank-revealing one -C (which will be the case if the leading columns were well- -C conditioned), then SVAL(1) will also be an estimate for -C the largest singular value of A, and SVAL(2) and SVAL(3) -C will be estimates for the RANK-th and (RANK+1)-st singular -C values of A, respectively. -C By examining these values, one can confirm that the rank -C is well defined with respect to the chosen value of RCOND. -C The ratio SVAL(1)/SVAL(2) is an estimate of the condition -C number of R(1:RANK,1:RANK). -C -C Workspace -C -C DWORK DOUBLE PRECISION array, dimension ( LDWORK ) -C On exit, if INFO = 0, DWORK(1) returns the optimal value -C of LDWORK. -C -C LDWORK INTEGER -C The length of the array DWORK. -C LDWORK >= 3*N + 1, if JOBQR = 'Q'; -C LDWORK >= max( 1, 2*min( M, N ) ), if JOBQR = 'N'. -C For good performance when JOBQR = 'Q', LDWORK should be -C larger. Specifically, LDWORK >= 2*N + ( N + 1 )*NB, where -C NB is the optimal block size for the LAPACK Library -C routine DGEQP3. -C -C Error Indicator -C -C INFO INTEGER -C = 0: successful exit -C < 0: if INFO = -i, the i-th argument had an illegal -C value. -C -C METHOD -C -C The routine computes or uses a QR factorization with column -C pivoting of A, A * P = Q * R, with R defined above, and then -C finds the largest leading submatrix whose estimated condition -C number is less than 1/RCOND, taking the possible positive value of -C SVLMAX into account. This is performed using the LAPACK -C incremental condition estimation scheme and a slightly modified -C rank decision test. -C -C CONTRIBUTOR -C -C V. Sima, Katholieke Univ. Leuven, Belgium, Nov. 1996. -C -C REVISIONS -C -C V. Sima, Research Institute for Informatics, Bucharest, Mar. 2005. -C -C ****************************************************************** -C -C .. Parameters .. - INTEGER IMAX, IMIN - PARAMETER ( IMAX = 1, IMIN = 2 ) - DOUBLE PRECISION ZERO, ONE - PARAMETER ( ZERO = 0.0D0, ONE = 1.0D0 ) -C .. Scalar Arguments .. - CHARACTER JOBQR - INTEGER INFO, LDA, LDWORK, M, N, RANK - DOUBLE PRECISION RCOND, SVLMAX -C .. Array Arguments .. - INTEGER JPVT( * ) - DOUBLE PRECISION A( LDA, * ), SVAL( 3 ), TAU( * ), DWORK( * ) -C .. Local Scalars .. - LOGICAL LJOBQR - INTEGER I, ISMAX, ISMIN, MAXWRK, MINWRK, MN - DOUBLE PRECISION C1, C2, S1, S2, SMAX, SMAXPR, SMIN, SMINPR -C .. -C .. External Functions .. - LOGICAL LSAME - EXTERNAL LSAME -C .. External Subroutines .. - EXTERNAL DGEQP3, DLAIC1, XERBLA -C .. Intrinsic Functions .. - INTRINSIC ABS, INT, MAX, MIN -C .. -C .. Executable Statements .. -C - LJOBQR = LSAME( JOBQR, 'Q' ) - MN = MIN( M, N ) - ISMIN = 1 - ISMAX = MN + 1 - IF( LJOBQR ) THEN - MINWRK = 3*N + 1 - ELSE - MINWRK = MAX( 1, 2*MN ) - END IF - MAXWRK = MINWRK -C -C Test the input scalar arguments. -C - INFO = 0 - IF( .NOT.LJOBQR .AND. .NOT.LSAME( JOBQR, 'N' ) ) THEN - INFO = -1 - ELSE IF( M.LT.0 ) THEN - INFO = -2 - ELSE IF( N.LT.0 ) THEN - INFO = -3 - ELSE IF( LDA.LT.MAX( 1, M ) ) THEN - INFO = -5 - ELSE IF( RCOND.LT.ZERO ) THEN - INFO = -7 - ELSE IF( SVLMAX.LT.ZERO ) THEN - INFO = -8 - ELSE IF( LDWORK.LT.MINWRK ) THEN - INFO = -13 - END IF -C - IF( INFO.NE.0 ) THEN - CALL XERBLA( 'MB03OD', -INFO ) - RETURN - END IF -C -C Quick return if possible -C - IF( MN.EQ.0 ) THEN - RANK = 0 - SVAL( 1 ) = ZERO - SVAL( 2 ) = ZERO - SVAL( 3 ) = ZERO - DWORK( 1 ) = ONE - RETURN - END IF -C - IF ( LJOBQR ) THEN -C -C Compute QR factorization with column pivoting of A: -C A * P = Q * R -C Workspace need 3*N + 1; -C prefer 2*N + (N+1)*NB. -C Details of Householder rotations stored in TAU. -C - CALL DGEQP3( M, N, A, LDA, JPVT, TAU, DWORK, LDWORK, INFO ) - MAXWRK = MAX( MAXWRK, INT( DWORK(1) ) ) - END IF -C -C Determine RANK using incremental condition estimation -C - DWORK( ISMIN ) = ONE - DWORK( ISMAX ) = ONE - SMAX = ABS( A( 1, 1 ) ) - SMIN = SMAX - IF( SMAX.EQ.ZERO .OR. SVLMAX*RCOND.GT.SMAX ) THEN - RANK = 0 - SVAL( 1 ) = SMAX - SVAL( 2 ) = ZERO - SVAL( 3 ) = ZERO - ELSE - RANK = 1 - SMINPR = SMIN -C - 10 CONTINUE - IF( RANK.LT.MN ) THEN - I = RANK + 1 - CALL DLAIC1( IMIN, RANK, DWORK( ISMIN ), SMIN, A( 1, I ), - $ A( I, I ), SMINPR, S1, C1 ) - CALL DLAIC1( IMAX, RANK, DWORK( ISMAX ), SMAX, A( 1, I ), - $ A( I, I ), SMAXPR, S2, C2 ) -C - IF( SVLMAX*RCOND.LE.SMAXPR ) THEN - IF( SVLMAX*RCOND.LE.SMINPR ) THEN - IF( SMAXPR*RCOND.LE.SMINPR ) THEN - DO 20 I = 1, RANK - DWORK( ISMIN+I-1 ) = S1*DWORK( ISMIN+I-1 ) - DWORK( ISMAX+I-1 ) = S2*DWORK( ISMAX+I-1 ) - 20 CONTINUE - DWORK( ISMIN+RANK ) = C1 - DWORK( ISMAX+RANK ) = C2 - SMIN = SMINPR - SMAX = SMAXPR - RANK = RANK + 1 - GO TO 10 - END IF - END IF - END IF - END IF - SVAL( 1 ) = SMAX - SVAL( 2 ) = SMIN - SVAL( 3 ) = SMINPR - END IF -C - DWORK( 1 ) = MAXWRK - RETURN -C *** Last line of MB03OD *** - END diff --git a/mex/sources/libslicot/MB03OY.f b/mex/sources/libslicot/MB03OY.f deleted file mode 100644 index e39734d55..000000000 --- a/mex/sources/libslicot/MB03OY.f +++ /dev/null @@ -1,388 +0,0 @@ - SUBROUTINE MB03OY( M, N, A, LDA, RCOND, SVLMAX, RANK, SVAL, JPVT, - $ TAU, DWORK, INFO ) -C -C SLICOT RELEASE 5.0. -C -C Copyright (c) 2002-2009 NICONET e.V. -C -C This program is free software: you can redistribute it and/or -C modify it under the terms of the GNU General Public License as -C published by the Free Software Foundation, either version 2 of -C the License, or (at your option) any later version. -C -C This program is distributed in the hope that it will be useful, -C but WITHOUT ANY WARRANTY; without even the implied warranty of -C MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the -C GNU General Public License for more details. -C -C You should have received a copy of the GNU General Public License -C along with this program. If not, see -C . -C -C PURPOSE -C -C To compute a rank-revealing QR factorization of a real general -C M-by-N matrix A, which may be rank-deficient, and estimate its -C effective rank using incremental condition estimation. -C -C The routine uses a truncated QR factorization with column pivoting -C [ R11 R12 ] -C A * P = Q * R, where R = [ ], -C [ 0 R22 ] -C with R11 defined as the largest leading upper triangular submatrix -C whose estimated condition number is less than 1/RCOND. The order -C of R11, RANK, is the effective rank of A. Condition estimation is -C performed during the QR factorization process. Matrix R22 is full -C (but of small norm), or empty. -C -C MB03OY does not perform any scaling of the matrix A. -C -C ARGUMENTS -C -C Input/Output Parameters -C -C M (input) INTEGER -C The number of rows of the matrix A. M >= 0. -C -C N (input) INTEGER -C The number of columns of the matrix A. N >= 0. -C -C A (input/output) DOUBLE PRECISION array, dimension -C ( LDA, N ) -C On entry, the leading M-by-N part of this array must -C contain the given matrix A. -C On exit, the leading RANK-by-RANK upper triangular part -C of A contains the triangular factor R11, and the elements -C below the diagonal in the first RANK columns, with the -C array TAU, represent the orthogonal matrix Q as a product -C of RANK elementary reflectors. -C The remaining N-RANK columns contain the result of the -C QR factorization process used. -C -C LDA INTEGER -C The leading dimension of the array A. LDA >= max(1,M). -C -C RCOND (input) DOUBLE PRECISION -C RCOND is used to determine the effective rank of A, which -C is defined as the order of the largest leading triangular -C submatrix R11 in the QR factorization with pivoting of A, -C whose estimated condition number is less than 1/RCOND. -C 0 <= RCOND <= 1. -C NOTE that when SVLMAX > 0, the estimated rank could be -C less than that defined above (see SVLMAX). -C -C SVLMAX (input) DOUBLE PRECISION -C If A is a submatrix of another matrix B, and the rank -C decision should be related to that matrix, then SVLMAX -C should be an estimate of the largest singular value of B -C (for instance, the Frobenius norm of B). If this is not -C the case, the input value SVLMAX = 0 should work. -C SVLMAX >= 0. -C -C RANK (output) INTEGER -C The effective (estimated) rank of A, i.e., the order of -C the submatrix R11. -C -C SVAL (output) DOUBLE PRECISION array, dimension ( 3 ) -C The estimates of some of the singular values of the -C triangular factor R: -C SVAL(1): largest singular value of R(1:RANK,1:RANK); -C SVAL(2): smallest singular value of R(1:RANK,1:RANK); -C SVAL(3): smallest singular value of R(1:RANK+1,1:RANK+1), -C if RANK < MIN( M, N ), or of R(1:RANK,1:RANK), -C otherwise. -C If the triangular factorization is a rank-revealing one -C (which will be the case if the leading columns were well- -C conditioned), then SVAL(1) will also be an estimate for -C the largest singular value of A, and SVAL(2) and SVAL(3) -C will be estimates for the RANK-th and (RANK+1)-st singular -C values of A, respectively. -C By examining these values, one can confirm that the rank -C is well defined with respect to the chosen value of RCOND. -C The ratio SVAL(1)/SVAL(2) is an estimate of the condition -C number of R(1:RANK,1:RANK). -C -C JPVT (output) INTEGER array, dimension ( N ) -C If JPVT(i) = k, then the i-th column of A*P was the k-th -C column of A. -C -C TAU (output) DOUBLE PRECISION array, dimension ( MIN( M, N ) ) -C The leading RANK elements of TAU contain the scalar -C factors of the elementary reflectors. -C -C Workspace -C -C DWORK DOUBLE PRECISION array, dimension ( 3*N-1 ) -C -C Error Indicator -C -C INFO INTEGER -C = 0: successful exit; -C < 0: if INFO = -i, the i-th argument had an illegal -C value. -C -C METHOD -C -C The routine computes a truncated QR factorization with column -C pivoting of A, A * P = Q * R, with R defined above, and, -C during this process, finds the largest leading submatrix whose -C estimated condition number is less than 1/RCOND, taking the -C possible positive value of SVLMAX into account. This is performed -C using the LAPACK incremental condition estimation scheme and a -C slightly modified rank decision test. The factorization process -C stops when RANK has been determined. -C -C The matrix Q is represented as a product of elementary reflectors -C -C Q = H(1) H(2) . . . H(k), where k = rank <= min(m,n). -C -C Each H(i) has the form -C -C H = I - tau * v * v' -C -C where tau is a real scalar, and v is a real vector with -C v(1:i-1) = 0 and v(i) = 1; v(i+1:m) is stored on exit in -C A(i+1:m,i), and tau in TAU(i). -C -C The matrix P is represented in jpvt as follows: If -C jpvt(j) = i -C then the jth column of P is the ith canonical unit vector. -C -C REFERENCES -C -C [1] Bischof, C.H. and P. Tang. -C Generalizing Incremental Condition Estimation. -C LAPACK Working Notes 32, Mathematics and Computer Science -C Division, Argonne National Laboratory, UT, CS-91-132, -C May 1991. -C -C [2] Bischof, C.H. and P. Tang. -C Robust Incremental Condition Estimation. -C LAPACK Working Notes 33, Mathematics and Computer Science -C Division, Argonne National Laboratory, UT, CS-91-133, -C May 1991. -C -C NUMERICAL ASPECTS -C -C The algorithm is backward stable. -C -C CONTRIBUTOR -C -C V. Sima, Katholieke Univ. Leuven, Belgium, Feb. 1998. -C -C REVISIONS -C -C V. Sima, Research Institute for Informatics, Bucharest, Jan. 2009. -C -C KEYWORDS -C -C Eigenvalue problem, matrix operations, orthogonal transformation, -C singular values. -C -C ****************************************************************** -C -C .. Parameters .. - INTEGER IMAX, IMIN - PARAMETER ( IMAX = 1, IMIN = 2 ) - DOUBLE PRECISION ZERO, ONE, P05 - PARAMETER ( ZERO = 0.0D0, ONE = 1.0D0, P05 = 0.05D0 ) -C .. Scalar Arguments .. - INTEGER INFO, LDA, M, N, RANK - DOUBLE PRECISION RCOND, SVLMAX -C .. Array Arguments .. - INTEGER JPVT( * ) - DOUBLE PRECISION A( LDA, * ), DWORK( * ), SVAL( 3 ), TAU( * ) -C .. -C .. Local Scalars .. - INTEGER I, ISMAX, ISMIN, ITEMP, J, MN, PVT - DOUBLE PRECISION AII, C1, C2, S1, S2, SMAX, SMAXPR, SMIN, - $ SMINPR, TEMP, TEMP2 -C .. -C .. External Functions .. - INTEGER IDAMAX - DOUBLE PRECISION DNRM2 - EXTERNAL DNRM2, IDAMAX -C .. External Subroutines .. - EXTERNAL DLAIC1, DLARF, DLARFG, DSCAL, DSWAP, XERBLA -C .. Intrinsic Functions .. - INTRINSIC ABS, MAX, MIN, SQRT -C .. -C .. Executable Statements .. -C -C Test the input scalar arguments. -C - INFO = 0 - IF( M.LT.0 ) THEN - INFO = -1 - ELSE IF( N.LT.0 ) THEN - INFO = -2 - ELSE IF( LDA.LT.MAX( 1, M ) ) THEN - INFO = -4 - ELSE IF( RCOND.LT.ZERO .OR. RCOND.GT.ONE ) THEN - INFO = -5 - ELSE IF( SVLMAX.LT.ZERO ) THEN - INFO = -6 - END IF -C - IF( INFO.NE.0 ) THEN - CALL XERBLA( 'MB03OY', -INFO ) - RETURN - END IF -C -C Quick return if possible. -C - MN = MIN( M, N ) - IF( MN.EQ.0 ) THEN - RANK = 0 - SVAL( 1 ) = ZERO - SVAL( 2 ) = ZERO - SVAL( 3 ) = ZERO - RETURN - END IF -C - ISMIN = 1 - ISMAX = ISMIN + N -C -C Initialize partial column norms and pivoting vector. The first n -C elements of DWORK store the exact column norms. The already used -C leading part is then overwritten by the condition estimator. -C - DO 10 I = 1, N - DWORK( I ) = DNRM2( M, A( 1, I ), 1 ) - DWORK( N+I ) = DWORK( I ) - JPVT( I ) = I - 10 CONTINUE -C -C Compute factorization and determine RANK using incremental -C condition estimation. -C - RANK = 0 -C - 20 CONTINUE - IF( RANK.LT.MN ) THEN - I = RANK + 1 -C -C Determine ith pivot column and swap if necessary. -C - PVT = ( I-1 ) + IDAMAX( N-I+1, DWORK( I ), 1 ) -C - IF( PVT.NE.I ) THEN - CALL DSWAP( M, A( 1, PVT ), 1, A( 1, I ), 1 ) - ITEMP = JPVT( PVT ) - JPVT( PVT ) = JPVT( I ) - JPVT( I ) = ITEMP - DWORK( PVT ) = DWORK( I ) - DWORK( N+PVT ) = DWORK( N+I ) - END IF -C -C Save A(I,I) and generate elementary reflector H(i). -C - IF( I.LT.M ) THEN - AII = A( I, I ) - CALL DLARFG( M-I+1, A( I, I ), A( I+1, I ), 1, TAU( I ) ) - ELSE - TAU( M ) = ZERO - END IF -C - IF( RANK.EQ.0 ) THEN -C -C Initialize; exit if matrix is zero (RANK = 0). -C - SMAX = ABS( A( 1, 1 ) ) - IF ( SMAX.EQ.ZERO ) THEN - SVAL( 1 ) = ZERO - SVAL( 2 ) = ZERO - SVAL( 3 ) = ZERO - RETURN - END IF - SMIN = SMAX - SMAXPR = SMAX - SMINPR = SMIN - C1 = ONE - C2 = ONE - ELSE -C -C One step of incremental condition estimation. -C - CALL DLAIC1( IMIN, RANK, DWORK( ISMIN ), SMIN, A( 1, I ), - $ A( I, I ), SMINPR, S1, C1 ) - CALL DLAIC1( IMAX, RANK, DWORK( ISMAX ), SMAX, A( 1, I ), - $ A( I, I ), SMAXPR, S2, C2 ) - END IF -C - IF( SVLMAX*RCOND.LE.SMAXPR ) THEN - IF( SVLMAX*RCOND.LE.SMINPR ) THEN - IF( SMAXPR*RCOND.LE.SMINPR ) THEN -C -C Continue factorization, as rank is at least RANK. -C - IF( I.LT.N ) THEN -C -C Apply H(i) to A(i:m,i+1:n) from the left. -C - AII = A( I, I ) - A( I, I ) = ONE - CALL DLARF( 'Left', M-I+1, N-I, A( I, I ), 1, - $ TAU( I ), A( I, I+1 ), LDA, - $ DWORK( 2*N+1 ) ) - A( I, I ) = AII - END IF -C -C Update partial column norms. -C - DO 30 J = I + 1, N - IF( DWORK( J ).NE.ZERO ) THEN - TEMP = ONE - - $ ( ABS( A( I, J ) ) / DWORK( J ) )**2 - TEMP = MAX( TEMP, ZERO ) - TEMP2 = ONE + P05*TEMP* - $ ( DWORK( J ) / DWORK( N+J ) )**2 - IF( TEMP2.EQ.ONE ) THEN - IF( M-I.GT.0 ) THEN - DWORK( J ) = DNRM2( M-I, A( I+1, J ), 1 ) - DWORK( N+J ) = DWORK( J ) - ELSE - DWORK( J ) = ZERO - DWORK( N+J ) = ZERO - END IF - ELSE - DWORK( J ) = DWORK( J )*SQRT( TEMP ) - END IF - END IF - 30 CONTINUE -C - DO 40 I = 1, RANK - DWORK( ISMIN+I-1 ) = S1*DWORK( ISMIN+I-1 ) - DWORK( ISMAX+I-1 ) = S2*DWORK( ISMAX+I-1 ) - 40 CONTINUE -C - DWORK( ISMIN+RANK ) = C1 - DWORK( ISMAX+RANK ) = C2 - SMIN = SMINPR - SMAX = SMAXPR - RANK = RANK + 1 - GO TO 20 - END IF - END IF - END IF - END IF -C -C Restore the changed part of the (RANK+1)-th column and set SVAL. -C - IF ( RANK.LT.N ) THEN - IF ( I.LT.M ) THEN - CALL DSCAL( M-I, -A( I, I )*TAU( I ), A( I+1, I ), 1 ) - A( I, I ) = AII - END IF - END IF - IF ( RANK.EQ.0 ) THEN - SMIN = ZERO - SMINPR = ZERO - END IF - SVAL( 1 ) = SMAX - SVAL( 2 ) = SMIN - SVAL( 3 ) = SMINPR -C - RETURN -C *** Last line of MB03OY *** - END diff --git a/mex/sources/libslicot/MB03PD.f b/mex/sources/libslicot/MB03PD.f deleted file mode 100644 index 5dae93666..000000000 --- a/mex/sources/libslicot/MB03PD.f +++ /dev/null @@ -1,339 +0,0 @@ - SUBROUTINE MB03PD( JOBRQ, M, N, A, LDA, JPVT, RCOND, SVLMAX, TAU, - $ RANK, SVAL, DWORK, INFO ) -C -C SLICOT RELEASE 5.0. -C -C Copyright (c) 2002-2009 NICONET e.V. -C -C This program is free software: you can redistribute it and/or -C modify it under the terms of the GNU General Public License as -C published by the Free Software Foundation, either version 2 of -C the License, or (at your option) any later version. -C -C This program is distributed in the hope that it will be useful, -C but WITHOUT ANY WARRANTY; without even the implied warranty of -C MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the -C GNU General Public License for more details. -C -C You should have received a copy of the GNU General Public License -C along with this program. If not, see -C . -C -C PURPOSE -C -C To compute (optionally) a rank-revealing RQ factorization of a -C real general M-by-N matrix A, which may be rank-deficient, -C and estimate its effective rank using incremental condition -C estimation. -C -C The routine uses an RQ factorization with row pivoting: -C P * A = R * Q, where R = [ R11 R12 ], -C [ 0 R22 ] -C with R22 defined as the largest trailing submatrix whose estimated -C condition number is less than 1/RCOND. The order of R22, RANK, -C is the effective rank of A. -C -C MB03PD does not perform any scaling of the matrix A. -C -C ARGUMENTS -C -C Mode Parameters -C -C JOBRQ CHARACTER*1 -C = 'R': Perform an RQ factorization with row pivoting; -C = 'N': Do not perform the RQ factorization (but assume -C that it has been done outside). -C -C Input/Output Parameters -C -C M (input) INTEGER -C The number of rows of the matrix A. M >= 0. -C -C N (input) INTEGER -C The number of columns of the matrix A. N >= 0. -C -C A (input/output) DOUBLE PRECISION array, dimension -C ( LDA, N ) -C On entry with JOBRQ = 'R', the leading M-by-N part of this -C array must contain the given matrix A. -C On exit with JOBRQ = 'R', -C if M <= N, the upper triangle of the subarray -C A(1:M,N-M+1:N) contains the M-by-M upper triangular -C matrix R; -C if M >= N, the elements on and above the (M-N)-th -C subdiagonal contain the M-by-N upper trapezoidal matrix R; -C the remaining elements, with the array TAU, represent the -C orthogonal matrix Q as a product of min(M,N) elementary -C reflectors (see METHOD). -C On entry and on exit with JOBRQ = 'N', -C if M <= N, the upper triangle of the subarray -C A(1:M,N-M+1:N) must contain the M-by-M upper triangular -C matrix R; -C if M >= N, the elements on and above the (M-N)-th -C subdiagonal must contain the M-by-N upper trapezoidal -C matrix R; -C the remaining elements are not referenced. -C -C LDA INTEGER -C The leading dimension of the array A. LDA >= max(1,M). -C -C JPVT (input/output) INTEGER array, dimension ( M ) -C On entry with JOBRQ = 'R', if JPVT(i) <> 0, the i-th row -C of A is a final row, otherwise it is a free row. Before -C the RQ factorization of A, all final rows are permuted -C to the trailing positions; only the remaining free rows -C are moved as a result of row pivoting during the -C factorization. For rank determination it is preferable -C that all rows be free. -C On exit with JOBRQ = 'R', if JPVT(i) = k, then the i-th -C row of P*A was the k-th row of A. -C Array JPVT is not referenced when JOBRQ = 'N'. -C -C RCOND (input) DOUBLE PRECISION -C RCOND is used to determine the effective rank of A, which -C is defined as the order of the largest trailing triangular -C submatrix R22 in the RQ factorization with pivoting of A, -C whose estimated condition number is less than 1/RCOND. -C RCOND >= 0. -C NOTE that when SVLMAX > 0, the estimated rank could be -C less than that defined above (see SVLMAX). -C -C SVLMAX (input) DOUBLE PRECISION -C If A is a submatrix of another matrix B, and the rank -C decision should be related to that matrix, then SVLMAX -C should be an estimate of the largest singular value of B -C (for instance, the Frobenius norm of B). If this is not -C the case, the input value SVLMAX = 0 should work. -C SVLMAX >= 0. -C -C TAU (output) DOUBLE PRECISION array, dimension ( MIN( M, N ) ) -C On exit with JOBRQ = 'R', the leading min(M,N) elements of -C TAU contain the scalar factors of the elementary -C reflectors. -C Array TAU is not referenced when JOBRQ = 'N'. -C -C RANK (output) INTEGER -C The effective (estimated) rank of A, i.e. the order of -C the submatrix R22. -C -C SVAL (output) DOUBLE PRECISION array, dimension ( 3 ) -C The estimates of some of the singular values of the -C triangular factor R: -C SVAL(1): largest singular value of -C R(M-RANK+1:M,N-RANK+1:N); -C SVAL(2): smallest singular value of -C R(M-RANK+1:M,N-RANK+1:N); -C SVAL(3): smallest singular value of R(M-RANK:M,N-RANK:N), -C if RANK < MIN( M, N ), or of -C R(M-RANK+1:M,N-RANK+1:N), otherwise. -C If the triangular factorization is a rank-revealing one -C (which will be the case if the trailing rows were well- -C conditioned), then SVAL(1) will also be an estimate for -C the largest singular value of A, and SVAL(2) and SVAL(3) -C will be estimates for the RANK-th and (RANK+1)-st singular -C values of A, respectively. -C By examining these values, one can confirm that the rank -C is well defined with respect to the chosen value of RCOND. -C The ratio SVAL(1)/SVAL(2) is an estimate of the condition -C number of R(M-RANK+1:M,N-RANK+1:N). -C -C Workspace -C -C DWORK DOUBLE PRECISION array, dimension ( LDWORK ) -C where LDWORK = max( 1, 3*M ), if JOBRQ = 'R'; -C LDWORK = max( 1, 3*min( M, N ) ), if JOBRQ = 'N'. -C -C Error Indicator -C -C INFO INTEGER -C = 0: successful exit -C < 0: if INFO = -i, the i-th argument had an illegal -C value. -C -C METHOD -C -C The routine computes or uses an RQ factorization with row -C pivoting of A, P * A = R * Q, with R defined above, and then -C finds the largest trailing submatrix whose estimated condition -C number is less than 1/RCOND, taking the possible positive value of -C SVLMAX into account. This is performed using an adaptation of the -C LAPACK incremental condition estimation scheme and a slightly -C modified rank decision test. -C -C The matrix Q is represented as a product of elementary reflectors -C -C Q = H(1) H(2) . . . H(k), where k = min(m,n). -C -C Each H(i) has the form -C -C H = I - tau * v * v' -C -C where tau is a real scalar, and v is a real vector with -C v(n-k+i+1:n) = 0 and v(n-k+i) = 1; v(1:n-k+i-1) is stored on exit -C in A(m-k+i,1:n-k+i-1), and tau in TAU(i). -C -C The matrix P is represented in jpvt as follows: If -C jpvt(j) = i -C then the jth row of P is the ith canonical unit vector. -C -C REFERENCES -C -C [1] Bischof, C.H. and P. Tang. -C Generalizing Incremental Condition Estimation. -C LAPACK Working Notes 32, Mathematics and Computer Science -C Division, Argonne National Laboratory, UT, CS-91-132, -C May 1991. -C -C [2] Bischof, C.H. and P. Tang. -C Robust Incremental Condition Estimation. -C LAPACK Working Notes 33, Mathematics and Computer Science -C Division, Argonne National Laboratory, UT, CS-91-133, -C May 1991. -C -C NUMERICAL ASPECTS -C -C The algorithm is backward stable. -C -C CONTRIBUTOR -C -C V. Sima, Katholieke Univ. Leuven, Belgium, Nov. 1996. -C -C REVISIONS -C -C Nov. 1997 -C -C KEYWORDS -C -C Eigenvalue problem, matrix operations, orthogonal transformation, -C singular values. -C -C ****************************************************************** -C -C .. Parameters .. - INTEGER IMAX, IMIN - PARAMETER ( IMAX = 1, IMIN = 2 ) - DOUBLE PRECISION ZERO, ONE - PARAMETER ( ZERO = 0.0D0, ONE = 1.0D0 ) -C .. Scalar Arguments .. - CHARACTER JOBRQ - INTEGER INFO, LDA, M, N, RANK - DOUBLE PRECISION RCOND, SVLMAX -C .. Array Arguments .. - INTEGER JPVT( * ) - DOUBLE PRECISION A( LDA, * ), SVAL( 3 ), TAU( * ), DWORK( * ) -C .. Local Scalars .. - LOGICAL LJOBRQ - INTEGER I, ISMAX, ISMIN, JWORK, MN - DOUBLE PRECISION C1, C2, S1, S2, SMAX, SMAXPR, SMIN, SMINPR -C .. -C .. External Functions .. - LOGICAL LSAME - EXTERNAL LSAME -C .. External Subroutines .. - EXTERNAL DCOPY, DLAIC1, MB04GD, XERBLA -C .. Intrinsic Functions .. - INTRINSIC ABS, MAX, MIN -C .. -C .. Executable Statements .. -C - LJOBRQ = LSAME( JOBRQ, 'R' ) - MN = MIN( M, N ) -C -C Test the input scalar arguments. -C - INFO = 0 - IF( .NOT.LJOBRQ .AND. .NOT.LSAME( JOBRQ, 'N' ) ) THEN - INFO = -1 - ELSE IF( M.LT.0 ) THEN - INFO = -2 - ELSE IF( N.LT.0 ) THEN - INFO = -3 - ELSE IF( LDA.LT.MAX( 1, M ) ) THEN - INFO = -5 - ELSE IF( RCOND.LT.ZERO ) THEN - INFO = -7 - ELSE IF( SVLMAX.LT.ZERO ) THEN - INFO = -8 - END IF -C - IF( INFO.NE.0 ) THEN - CALL XERBLA( 'MB03PD', -INFO ) - RETURN - END IF -C -C Quick return if possible. -C - IF( MN.EQ.0 ) THEN - RANK = 0 - SVAL( 1 ) = ZERO - SVAL( 2 ) = ZERO - SVAL( 3 ) = ZERO - RETURN - END IF -C - IF ( LJOBRQ ) THEN -C -C Compute RQ factorization with row pivoting of A: -C P * A = R * Q -C Workspace 3*M. Details of Householder rotations stored in TAU. -C - CALL MB04GD( M, N, A, LDA, JPVT, TAU, DWORK( 1 ), INFO ) - END IF -C -C Determine RANK using incremental condition estimation. -C Workspace 3*min(M,N). -C - SMAX = ABS( A( M, N ) ) - IF( SMAX.EQ.ZERO .OR. SVLMAX*RCOND.GT.SMAX ) THEN - RANK = 0 - SVAL( 1 ) = SMAX - SVAL( 2 ) = ZERO - SVAL( 3 ) = ZERO - ELSE - ISMIN = MN - ISMAX = 2*MN - JWORK = ISMAX + 1 - DWORK( ISMIN ) = ONE - DWORK( ISMAX ) = ONE - RANK = 1 - SMIN = SMAX - SMINPR = SMIN -C - 10 CONTINUE - IF( RANK.LT.MN ) THEN - CALL DCOPY ( RANK, A( M-RANK, N-RANK+1 ), LDA, - $ DWORK( JWORK ), 1 ) - CALL DLAIC1( IMIN, RANK, DWORK( ISMIN ), SMIN, - $ DWORK( JWORK ), A( M-RANK, N-RANK ), SMINPR, - $ S1, C1 ) - CALL DLAIC1( IMAX, RANK, DWORK( ISMAX ), SMAX, - $ DWORK( JWORK ), A( M-RANK, N-RANK ), SMAXPR, - $ S2, C2 ) -C - IF( SVLMAX*RCOND.LE.SMAXPR ) THEN - IF( SVLMAX*RCOND.LE.SMINPR ) THEN - IF( SMAXPR*RCOND.LE.SMINPR ) THEN - DO 20 I = 1, RANK - DWORK( ISMIN+I-1 ) = S1*DWORK( ISMIN+I-1 ) - DWORK( ISMAX+I-1 ) = S2*DWORK( ISMAX+I-1 ) - 20 CONTINUE - ISMIN = ISMIN - 1 - ISMAX = ISMAX - 1 - DWORK( ISMIN ) = C1 - DWORK( ISMAX ) = C2 - SMIN = SMINPR - SMAX = SMAXPR - RANK = RANK + 1 - GO TO 10 - END IF - END IF - END IF - END IF - SVAL( 1 ) = SMAX - SVAL( 2 ) = SMIN - SVAL( 3 ) = SMINPR - END IF -C - RETURN -C *** Last line of MB03PD *** - END diff --git a/mex/sources/libslicot/MB03PY.f b/mex/sources/libslicot/MB03PY.f deleted file mode 100644 index d0c7d0ca2..000000000 --- a/mex/sources/libslicot/MB03PY.f +++ /dev/null @@ -1,392 +0,0 @@ - SUBROUTINE MB03PY( M, N, A, LDA, RCOND, SVLMAX, RANK, SVAL, JPVT, - $ TAU, DWORK, INFO ) -C -C SLICOT RELEASE 5.0. -C -C Copyright (c) 2002-2009 NICONET e.V. -C -C This program is free software: you can redistribute it and/or -C modify it under the terms of the GNU General Public License as -C published by the Free Software Foundation, either version 2 of -C the License, or (at your option) any later version. -C -C This program is distributed in the hope that it will be useful, -C but WITHOUT ANY WARRANTY; without even the implied warranty of -C MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the -C GNU General Public License for more details. -C -C You should have received a copy of the GNU General Public License -C along with this program. If not, see -C . -C -C PURPOSE -C -C To compute a rank-revealing RQ factorization of a real general -C M-by-N matrix A, which may be rank-deficient, and estimate its -C effective rank using incremental condition estimation. -C -C The routine uses a truncated RQ factorization with row pivoting: -C [ R11 R12 ] -C P * A = R * Q, where R = [ ], -C [ 0 R22 ] -C with R22 defined as the largest trailing upper triangular -C submatrix whose estimated condition number is less than 1/RCOND. -C The order of R22, RANK, is the effective rank of A. Condition -C estimation is performed during the RQ factorization process. -C Matrix R11 is full (but of small norm), or empty. -C -C MB03PY does not perform any scaling of the matrix A. -C -C ARGUMENTS -C -C Input/Output Parameters -C -C M (input) INTEGER -C The number of rows of the matrix A. M >= 0. -C -C N (input) INTEGER -C The number of columns of the matrix A. N >= 0. -C -C A (input/output) DOUBLE PRECISION array, dimension -C ( LDA, N ) -C On entry, the leading M-by-N part of this array must -C contain the given matrix A. -C On exit, the upper triangle of the subarray -C A(M-RANK+1:M,N-RANK+1:N) contains the RANK-by-RANK upper -C triangular matrix R22; the remaining elements in the last -C RANK rows, with the array TAU, represent the orthogonal -C matrix Q as a product of RANK elementary reflectors -C (see METHOD). The first M-RANK rows contain the result -C of the RQ factorization process used. -C -C LDA INTEGER -C The leading dimension of the array A. LDA >= max(1,M). -C -C RCOND (input) DOUBLE PRECISION -C RCOND is used to determine the effective rank of A, which -C is defined as the order of the largest trailing triangular -C submatrix R22 in the RQ factorization with pivoting of A, -C whose estimated condition number is less than 1/RCOND. -C 0 <= RCOND <= 1. -C NOTE that when SVLMAX > 0, the estimated rank could be -C less than that defined above (see SVLMAX). -C -C SVLMAX (input) DOUBLE PRECISION -C If A is a submatrix of another matrix B, and the rank -C decision should be related to that matrix, then SVLMAX -C should be an estimate of the largest singular value of B -C (for instance, the Frobenius norm of B). If this is not -C the case, the input value SVLMAX = 0 should work. -C SVLMAX >= 0. -C -C RANK (output) INTEGER -C The effective (estimated) rank of A, i.e., the order of -C the submatrix R22. -C -C SVAL (output) DOUBLE PRECISION array, dimension ( 3 ) -C The estimates of some of the singular values of the -C triangular factor R: -C SVAL(1): largest singular value of -C R(M-RANK+1:M,N-RANK+1:N); -C SVAL(2): smallest singular value of -C R(M-RANK+1:M,N-RANK+1:N); -C SVAL(3): smallest singular value of R(M-RANK:M,N-RANK:N), -C if RANK < MIN( M, N ), or of -C R(M-RANK+1:M,N-RANK+1:N), otherwise. -C If the triangular factorization is a rank-revealing one -C (which will be the case if the trailing rows were well- -C conditioned), then SVAL(1) will also be an estimate for -C the largest singular value of A, and SVAL(2) and SVAL(3) -C will be estimates for the RANK-th and (RANK+1)-st singular -C values of A, respectively. -C By examining these values, one can confirm that the rank -C is well defined with respect to the chosen value of RCOND. -C The ratio SVAL(1)/SVAL(2) is an estimate of the condition -C number of R(M-RANK+1:M,N-RANK+1:N). -C -C JPVT (output) INTEGER array, dimension ( M ) -C If JPVT(i) = k, then the i-th row of P*A was the k-th row -C of A. -C -C TAU (output) DOUBLE PRECISION array, dimension ( MIN( M, N ) ) -C The trailing RANK elements of TAU contain the scalar -C factors of the elementary reflectors. -C -C Workspace -C -C DWORK DOUBLE PRECISION array, dimension ( 3*M-1 ) -C -C Error Indicator -C -C INFO INTEGER -C = 0: successful exit; -C < 0: if INFO = -i, the i-th argument had an illegal -C value. -C -C METHOD -C -C The routine computes a truncated RQ factorization with row -C pivoting of A, P * A = R * Q, with R defined above, and, -C during this process, finds the largest trailing submatrix whose -C estimated condition number is less than 1/RCOND, taking the -C possible positive value of SVLMAX into account. This is performed -C using an adaptation of the LAPACK incremental condition estimation -C scheme and a slightly modified rank decision test. The -C factorization process stops when RANK has been determined. -C -C The matrix Q is represented as a product of elementary reflectors -C -C Q = H(k-rank+1) H(k-rank+2) . . . H(k), where k = min(m,n). -C -C Each H(i) has the form -C -C H = I - tau * v * v' -C -C where tau is a real scalar, and v is a real vector with -C v(n-k+i+1:n) = 0 and v(n-k+i) = 1; v(1:n-k+i-1) is stored on exit -C in A(m-k+i,1:n-k+i-1), and tau in TAU(i). -C -C The matrix P is represented in jpvt as follows: If -C jpvt(j) = i -C then the jth row of P is the ith canonical unit vector. -C -C REFERENCES -C -C [1] Bischof, C.H. and P. Tang. -C Generalizing Incremental Condition Estimation. -C LAPACK Working Notes 32, Mathematics and Computer Science -C Division, Argonne National Laboratory, UT, CS-91-132, -C May 1991. -C -C [2] Bischof, C.H. and P. Tang. -C Robust Incremental Condition Estimation. -C LAPACK Working Notes 33, Mathematics and Computer Science -C Division, Argonne National Laboratory, UT, CS-91-133, -C May 1991. -C -C NUMERICAL ASPECTS -C -C The algorithm is backward stable. -C -C CONTRIBUTOR -C -C V. Sima, Katholieke Univ. Leuven, Belgium, Feb. 1998. -C -C REVISIONS -C -C V. Sima, Research Institute for Informatics, Bucharest, Oct. 2001, -C Jan. 2009. -C -C KEYWORDS -C -C Eigenvalue problem, matrix operations, orthogonal transformation, -C singular values. -C -C ****************************************************************** -C -C .. Parameters .. - INTEGER IMAX, IMIN - PARAMETER ( IMAX = 1, IMIN = 2 ) - DOUBLE PRECISION ZERO, ONE, P05 - PARAMETER ( ZERO = 0.0D+0, ONE = 1.0D+0, P05 = 0.05D+0 ) -C .. Scalar Arguments .. - INTEGER INFO, LDA, M, N, RANK - DOUBLE PRECISION RCOND, SVLMAX -C .. Array Arguments .. - INTEGER JPVT( * ) - DOUBLE PRECISION A( LDA, * ), DWORK( * ), SVAL( 3 ), TAU( * ) -C .. Local Scalars .. - INTEGER I, ISMAX, ISMIN, ITEMP, J, JWORK, K, MKI, NKI, - $ PVT - DOUBLE PRECISION AII, C1, C2, S1, S2, SMAX, SMAXPR, SMIN, - $ SMINPR, TEMP, TEMP2 -C .. -C .. External Functions .. - INTEGER IDAMAX - DOUBLE PRECISION DNRM2 - EXTERNAL DNRM2, IDAMAX -C .. -C .. External Subroutines .. - EXTERNAL DCOPY, DLAIC1, DLARF, DLARFG, DSCAL, DSWAP, - $ XERBLA -C .. -C .. Intrinsic Functions .. - INTRINSIC ABS, MAX, MIN, SQRT -C .. -C .. Executable Statements .. -C -C Test the input scalar arguments. -C - INFO = 0 - IF( M.LT.0 ) THEN - INFO = -1 - ELSE IF( N.LT.0 ) THEN - INFO = -2 - ELSE IF( LDA.LT.MAX( 1, M ) ) THEN - INFO = -4 - ELSE IF( RCOND.LT.ZERO .OR. RCOND.GT.ONE ) THEN - INFO = -5 - ELSE IF( SVLMAX.LT.ZERO ) THEN - INFO = -6 - END IF -C - IF( INFO.NE.0 ) THEN - CALL XERBLA( 'MB03PY', -INFO ) - RETURN - END IF -C -C Quick return if possible. -C - K = MIN( M, N ) - IF( K.EQ.0 ) THEN - RANK = 0 - SVAL( 1 ) = ZERO - SVAL( 2 ) = ZERO - SVAL( 3 ) = ZERO - RETURN - END IF -C - ISMIN = M - ISMAX = ISMIN + M - JWORK = ISMAX + 1 -C -C Initialize partial row norms and pivoting vector. The first m -C elements of DWORK store the exact row norms. The already used -C trailing part is then overwritten by the condition estimator. -C - DO 10 I = 1, M - DWORK( I ) = DNRM2( N, A( I, 1 ), LDA ) - DWORK( M+I ) = DWORK( I ) - JPVT( I ) = I - 10 CONTINUE -C -C Compute factorization and determine RANK using incremental -C condition estimation. -C - RANK = 0 -C - 20 CONTINUE - IF( RANK.LT.K ) THEN - I = K - RANK -C -C Determine ith pivot row and swap if necessary. -C - MKI = M - RANK - NKI = N - RANK - PVT = IDAMAX( MKI, DWORK, 1 ) -C - IF( PVT.NE.MKI ) THEN - CALL DSWAP( N, A( PVT, 1 ), LDA, A( MKI, 1 ), LDA ) - ITEMP = JPVT( PVT ) - JPVT( PVT ) = JPVT( MKI ) - JPVT( MKI ) = ITEMP - DWORK( PVT ) = DWORK( MKI ) - DWORK( M+PVT ) = DWORK( M+MKI ) - END IF -C - IF( NKI.GT.1 ) THEN -C -C Save A(m-k+i,n-k+i) and generate elementary reflector H(i) -C to annihilate A(m-k+i,1:n-k+i-1), k = min(m,n). -C - AII = A( MKI, NKI ) - CALL DLARFG( NKI, A( MKI, NKI ), A( MKI, 1 ), LDA, TAU( I ) - $ ) - END IF -C - IF( RANK.EQ.0 ) THEN -C -C Initialize; exit if matrix is zero (RANK = 0). -C - SMAX = ABS( A( M, N ) ) - IF ( SMAX.EQ.ZERO ) THEN - SVAL( 1 ) = ZERO - SVAL( 2 ) = ZERO - SVAL( 3 ) = ZERO - RETURN - END IF - SMIN = SMAX - SMAXPR = SMAX - SMINPR = SMIN - C1 = ONE - C2 = ONE - ELSE -C -C One step of incremental condition estimation. -C - CALL DCOPY ( RANK, A( MKI, NKI+1 ), LDA, DWORK( JWORK ), 1 ) - CALL DLAIC1( IMIN, RANK, DWORK( ISMIN ), SMIN, - $ DWORK( JWORK ), A( MKI, NKI ), SMINPR, S1, C1 ) - CALL DLAIC1( IMAX, RANK, DWORK( ISMAX ), SMAX, - $ DWORK( JWORK ), A( MKI, NKI ), SMAXPR, S2, C2 ) - END IF -C - IF( SVLMAX*RCOND.LE.SMAXPR ) THEN - IF( SVLMAX*RCOND.LE.SMINPR ) THEN - IF( SMAXPR*RCOND.LE.SMINPR ) THEN -C - IF( MKI.GT.1 ) THEN -C -C Continue factorization, as rank is at least RANK. -C Apply H(i) to A(1:m-k+i-1,1:n-k+i) from the right. -C - AII = A( MKI, NKI ) - A( MKI, NKI ) = ONE - CALL DLARF( 'Right', MKI-1, NKI, A( MKI, 1 ), LDA, - $ TAU( I ), A, LDA, DWORK( JWORK ) ) - A( MKI, NKI ) = AII -C -C Update partial row norms. -C - DO 30 J = 1, MKI - 1 - IF( DWORK( J ).NE.ZERO ) THEN - TEMP = ONE - - $ ( ABS( A( J, NKI ) )/DWORK( J ) )**2 - TEMP = MAX( TEMP, ZERO ) - TEMP2 = ONE + P05*TEMP* - $ ( DWORK( J ) / DWORK( M+J ) )**2 - IF( TEMP2.EQ.ONE ) THEN - DWORK( J ) = DNRM2( NKI-1, A( J, 1 ), - $ LDA ) - DWORK( M+J ) = DWORK( J ) - ELSE - DWORK( J ) = DWORK( J )*SQRT( TEMP ) - END IF - END IF - 30 CONTINUE -C - END IF -C - DO 40 I = 1, RANK - DWORK( ISMIN+I-1 ) = S1*DWORK( ISMIN+I-1 ) - DWORK( ISMAX+I-1 ) = S2*DWORK( ISMAX+I-1 ) - 40 CONTINUE -C - IF( RANK.GT.0 ) THEN - ISMIN = ISMIN - 1 - ISMAX = ISMAX - 1 - END IF - DWORK( ISMIN ) = C1 - DWORK( ISMAX ) = C2 - SMIN = SMINPR - SMAX = SMAXPR - RANK = RANK + 1 - GO TO 20 - END IF - END IF - END IF - END IF -C -C Restore the changed part of the (M-RANK)-th row and set SVAL. -C - IF ( RANK.LT.K .AND. NKI.GT.1 ) THEN - CALL DSCAL( NKI-1, -A( MKI, NKI )*TAU( I ), A( MKI, 1 ), LDA ) - A( MKI, NKI ) = AII - END IF - SVAL( 1 ) = SMAX - SVAL( 2 ) = SMIN - SVAL( 3 ) = SMINPR -C - RETURN -C *** Last line of MB03PY *** - END diff --git a/mex/sources/libslicot/MB03QD.f b/mex/sources/libslicot/MB03QD.f deleted file mode 100644 index d94eed1bb..000000000 --- a/mex/sources/libslicot/MB03QD.f +++ /dev/null @@ -1,316 +0,0 @@ - SUBROUTINE MB03QD( DICO, STDOM, JOBU, N, NLOW, NSUP, ALPHA, - $ A, LDA, U, LDU, NDIM, DWORK, INFO ) -C -C SLICOT RELEASE 5.0. -C -C Copyright (c) 2002-2009 NICONET e.V. -C -C This program is free software: you can redistribute it and/or -C modify it under the terms of the GNU General Public License as -C published by the Free Software Foundation, either version 2 of -C the License, or (at your option) any later version. -C -C This program is distributed in the hope that it will be useful, -C but WITHOUT ANY WARRANTY; without even the implied warranty of -C MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the -C GNU General Public License for more details. -C -C You should have received a copy of the GNU General Public License -C along with this program. If not, see -C . -C -C PURPOSE -C -C To reorder the diagonal blocks of a principal submatrix of an -C upper quasi-triangular matrix A together with their eigenvalues by -C constructing an orthogonal similarity transformation UT. -C After reordering, the leading block of the selected submatrix of A -C has eigenvalues in a suitably defined domain of interest, usually -C related to stability/instability in a continuous- or discrete-time -C sense. -C -C ARGUMENTS -C -C Mode Parameters -C -C DICO CHARACTER*1 -C Specifies the type of the spectrum separation to be -C performed as follows: -C = 'C': continuous-time sense; -C = 'D': discrete-time sense. -C -C STDOM CHARACTER*1 -C Specifies whether the domain of interest is of stability -C type (left part of complex plane or inside of a circle) -C or of instability type (right part of complex plane or -C outside of a circle) as follows: -C = 'S': stability type domain; -C = 'U': instability type domain. -C -C JOBU CHARACTER*1 -C Indicates how the performed orthogonal transformations UT -C are accumulated, as follows: -C = 'I': U is initialized to the unit matrix and the matrix -C UT is returned in U; -C = 'U': the given matrix U is updated and the matrix U*UT -C is returned in U. -C -C Input/Output Parameters -C -C N (input) INTEGER -C The order of the matrices A and U. N >= 1. -C -C NLOW, (input) INTEGER -C NSUP NLOW and NSUP specify the boundary indices for the rows -C and columns of the principal submatrix of A whose diagonal -C blocks are to be reordered. 1 <= NLOW <= NSUP <= N. -C -C ALPHA (input) DOUBLE PRECISION -C The boundary of the domain of interest for the eigenvalues -C of A. If DICO = 'C', ALPHA is the boundary value for the -C real parts of eigenvalues, while for DICO = 'D', -C ALPHA >= 0 represents the boundary value for the moduli of -C eigenvalues. -C -C A (input/output) DOUBLE PRECISION array, dimension (LDA,N) -C On entry, the leading N-by-N part of this array must -C contain a matrix in a real Schur form whose 1-by-1 and -C 2-by-2 diagonal blocks between positions NLOW and NSUP -C are to be reordered. -C On exit, the leading N-by-N part contains the ordered -C real Schur matrix UT' * A * UT with the elements below the -C first subdiagonal set to zero. -C The leading NDIM-by-NDIM part of the principal submatrix -C D = A(NLOW:NSUP,NLOW:NSUP) has eigenvalues in the domain -C of interest and the trailing part of this submatrix has -C eigenvalues outside the domain of interest. -C The domain of interest for lambda(D), the eigenvalues of -C D, is defined by the parameters ALPHA, DICO and STDOM as -C follows: -C For DICO = 'C': -C Real(lambda(D)) < ALPHA if STDOM = 'S'; -C Real(lambda(D)) > ALPHA if STDOM = 'U'. -C For DICO = 'D': -C Abs(lambda(D)) < ALPHA if STDOM = 'S'; -C Abs(lambda(D)) > ALPHA if STDOM = 'U'. -C -C LDA INTEGER -C The leading dimension of array A. LDA >= N. -C -C U (input/output) DOUBLE PRECISION array, dimension (LDU,N) -C On entry with JOBU = 'U', the leading N-by-N part of this -C array must contain a transformation matrix (e.g. from a -C previous call to this routine). -C On exit, if JOBU = 'U', the leading N-by-N part of this -C array contains the product of the input matrix U and the -C orthogonal matrix UT used to reorder the diagonal blocks -C of A. -C On exit, if JOBU = 'I', the leading N-by-N part of this -C array contains the matrix UT of the performed orthogonal -C transformations. -C Array U need not be set on entry if JOBU = 'I'. -C -C LDU INTEGER -C The leading dimension of array U. LDU >= N. -C -C NDIM (output) INTEGER -C The number of eigenvalues of the selected principal -C submatrix lying inside the domain of interest. -C If NLOW = 1, NDIM is also the dimension of the invariant -C subspace corresponding to the eigenvalues of the leading -C NDIM-by-NDIM submatrix. In this case, if U is the -C orthogonal transformation matrix used to compute and -C reorder the real Schur form of A, its first NDIM columns -C form an orthonormal basis for the above invariant -C subspace. -C -C Workspace -C -C DWORK DOUBLE PRECISION array, dimension (N) -C -C Error Indicator -C -C INFO INTEGER -C = 0: successful exit; -C < 0: if INFO = -i, the i-th argument had an illegal -C value; -C = 1: A(NLOW,NLOW-1) is nonzero, i.e. A(NLOW,NLOW) is not -C the leading element of a 1-by-1 or 2-by-2 diagonal -C block of A, or A(NSUP+1,NSUP) is nonzero, i.e. -C A(NSUP,NSUP) is not the bottom element of a 1-by-1 -C or 2-by-2 diagonal block of A; -C = 2: two adjacent blocks are too close to swap (the -C problem is very ill-conditioned). -C -C METHOD -C -C Given an upper quasi-triangular matrix A with 1-by-1 or 2-by-2 -C diagonal blocks, the routine reorders its diagonal blocks along -C with its eigenvalues by performing an orthogonal similarity -C transformation UT' * A * UT. The column transformation UT is also -C performed on the given (initial) transformation U (resulted from -C a possible previous step or initialized as the identity matrix). -C After reordering, the eigenvalues inside the region specified by -C the parameters ALPHA, DICO and STDOM appear at the top of -C the selected diagonal block between positions NLOW and NSUP. -C In other words, lambda(A(NLOW:NSUP,NLOW:NSUP)) are ordered such -C that lambda(A(NLOW:NLOW+NDIM-1,NLOW:NLOW+NDIM-1)) are inside and -C lambda(A(NLOW+NDIM:NSUP,NLOW+NDIM:NSUP)) are outside the domain -C of interest. If NLOW = 1, the first NDIM columns of U*UT span the -C corresponding invariant subspace of A. -C -C REFERENCES -C -C [1] Stewart, G.W. -C HQR3 and EXCHQZ: FORTRAN subroutines for calculating and -C ordering the eigenvalues of a real upper Hessenberg matrix. -C ACM TOMS, 2, pp. 275-280, 1976. -C -C NUMERICAL ASPECTS -C 3 -C The algorithm requires less than 4*N operations. -C -C CONTRIBUTOR -C -C A. Varga, German Aerospace Center, DLR Oberpfaffenhofen, -C April 1998. Based on the RASP routine SEOR1. -C -C KEYWORDS -C -C Eigenvalues, invariant subspace, orthogonal transformation, real -C Schur form, similarity transformation. -C -C ****************************************************************** -C -C .. Parameters .. - DOUBLE PRECISION ONE, ZERO - PARAMETER ( ONE = 1.0D0, ZERO = 0.0D0 ) -C .. Scalar Arguments .. - CHARACTER DICO, JOBU, STDOM - INTEGER INFO, LDA, LDU, N, NDIM, NLOW, NSUP - DOUBLE PRECISION ALPHA -C .. Array Arguments .. - DOUBLE PRECISION A(LDA,*), DWORK(*), U(LDU,*) -C .. Local Scalars .. - LOGICAL DISCR, LSTDOM - INTEGER IB, L, LM1, NUP - DOUBLE PRECISION E1, E2, TLAMBD -C .. External Functions .. - LOGICAL LSAME - DOUBLE PRECISION DLAPY2 - EXTERNAL DLAPY2, LSAME -C .. External Subroutines .. - EXTERNAL DLASET, DTREXC, MB03QY, XERBLA -C .. Intrinsic Functions .. - INTRINSIC ABS -C .. Executable Statements .. -C - INFO = 0 - DISCR = LSAME( DICO, 'D' ) - LSTDOM = LSAME( STDOM, 'S' ) -C -C Check input scalar arguments. -C - IF( .NOT. ( LSAME( DICO, 'C' ) .OR. DISCR ) ) THEN - INFO = -1 - ELSE IF( .NOT. ( LSTDOM .OR. LSAME( STDOM, 'U' ) ) ) THEN - INFO = -2 - ELSE IF( .NOT. ( LSAME( JOBU, 'I' ) .OR. - $ LSAME( JOBU, 'U' ) ) ) THEN - INFO = -3 - ELSE IF( N.LT.1 ) THEN - INFO = -4 - ELSE IF( NLOW.LT.1 ) THEN - INFO = -5 - ELSE IF( NLOW.GT.NSUP .OR. NSUP.GT.N ) THEN - INFO = -6 - ELSE IF( DISCR .AND. ALPHA.LT.ZERO ) THEN - INFO = -7 - ELSE IF( LDA.LT.N ) THEN - INFO = -9 - ELSE IF( LDU.LT.N ) THEN - INFO = -11 - END IF -C - IF( INFO.NE.0 ) THEN -C -C Error return. -C - CALL XERBLA( 'MB03QD', -INFO ) - RETURN - END IF -C - IF( NLOW.GT.1 ) THEN - IF( A(NLOW,NLOW-1).NE.ZERO ) INFO = 1 - END IF - IF( NSUP.LT.N ) THEN - IF( A(NSUP+1,NSUP).NE.ZERO ) INFO = 1 - END IF - IF( INFO.NE.0 ) - $ RETURN -C -C Initialize U with an identity matrix if necessary. -C - IF( LSAME( JOBU, 'I' ) ) - $ CALL DLASET( 'Full', N, N, ZERO, ONE, U, LDU ) -C - NDIM = 0 - L = NSUP - NUP = NSUP -C -C NUP is the minimal value such that the submatrix A(i,j) with -C NUP+1 <= i,j <= NSUP contains no eigenvalues inside the domain of -C interest. L is such that all the eigenvalues of the submatrix -C A(i,j) with L+1 <= i,j <= NUP lie inside the domain of interest. -C -C WHILE( L >= NLOW ) DO -C - 10 IF( L.GE.NLOW ) THEN - IB = 1 - IF( L.GT.NLOW ) THEN - LM1 = L - 1 - IF( A(L,LM1).NE.ZERO ) THEN - CALL MB03QY( N, LM1, A, LDA, U, LDU, E1, E2, INFO ) - IF( A(L,LM1).NE.ZERO ) IB = 2 - END IF - END IF - IF( DISCR ) THEN - IF( IB.EQ.1 ) THEN - TLAMBD = ABS( A(L,L) ) - ELSE - TLAMBD = DLAPY2( E1, E2 ) - END IF - ELSE - IF( IB.EQ.1 ) THEN - TLAMBD = A(L,L) - ELSE - TLAMBD = E1 - END IF - END IF - IF( ( LSTDOM .AND. TLAMBD.LT.ALPHA ) .OR. - $ ( .NOT.LSTDOM .AND. TLAMBD.GT.ALPHA ) ) THEN - NDIM = NDIM + IB - L = L - IB - ELSE - IF( NDIM.NE.0 ) THEN - CALL DTREXC( 'V', N, A, LDA, U, LDU, L, NUP, DWORK, - $ INFO ) - IF( INFO.NE.0 ) THEN - INFO = 2 - RETURN - END IF - NUP = NUP - 1 - L = L - 1 - ELSE - NUP = NUP - IB - L = L - IB - END IF - END IF - GO TO 10 - END IF -C -C END WHILE 10 -C - RETURN -C *** Last line of MB03QD *** - END diff --git a/mex/sources/libslicot/MB03QX.f b/mex/sources/libslicot/MB03QX.f deleted file mode 100644 index 26474ba96..000000000 --- a/mex/sources/libslicot/MB03QX.f +++ /dev/null @@ -1,122 +0,0 @@ - SUBROUTINE MB03QX( N, T, LDT, WR, WI, INFO ) -C -C SLICOT RELEASE 5.0. -C -C Copyright (c) 2002-2009 NICONET e.V. -C -C This program is free software: you can redistribute it and/or -C modify it under the terms of the GNU General Public License as -C published by the Free Software Foundation, either version 2 of -C the License, or (at your option) any later version. -C -C This program is distributed in the hope that it will be useful, -C but WITHOUT ANY WARRANTY; without even the implied warranty of -C MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the -C GNU General Public License for more details. -C -C You should have received a copy of the GNU General Public License -C along with this program. If not, see -C . -C -C PURPOSE -C -C To compute the eigenvalues of an upper quasi-triangular matrix. -C -C ARGUMENTS -C -C Input/Output Parameters -C -C N (input) INTEGER -C The order of the matrix T. N >= 0. -C -C T (input) DOUBLE PRECISION array, dimension(LDT,N) -C The upper quasi-triangular matrix T. -C -C LDT INTEGER -C The leading dimension of the array T. LDT >= max(1,N). -C -C WR, WI (output) DOUBLE PRECISION arrays, dimension (N) -C The real and imaginary parts, respectively, of the -C eigenvalues of T. The eigenvalues are stored in the same -C order as on the diagonal of T. If T(i:i+1,i:i+1) is a -C 2-by-2 diagonal block with complex conjugated eigenvalues -C then WI(i) > 0 and WI(i+1) = -WI(i). -C -C Error Indicator -C -C INFO INTEGER -C = 0: successful exit; -C < 0: if INFO = -i, the i-th argument had an illegal -C value. -C -C CONTRIBUTOR -C -C A. Varga, German Aerospace Center, DLR Oberpfaffenhofen, -C March 1998. Based on the RASP routine SEIG. -C -C ****************************************************************** -C .. Parameters .. - DOUBLE PRECISION ZERO - PARAMETER ( ZERO = 0.0D0 ) -C .. Scalar Arguments .. - INTEGER INFO, LDT, N -C .. Array Arguments .. - DOUBLE PRECISION T(LDT, *), WI(*), WR(*) -C .. Local Scalars .. - INTEGER I, I1, INEXT - DOUBLE PRECISION A11, A12, A21, A22, CS, SN -C .. External Subroutines .. - EXTERNAL DLANV2, XERBLA -C .. Intrinsic Functions .. - INTRINSIC MAX -C .. Executable Statements .. -C - INFO = 0 -C -C Test the input scalar arguments. -C - IF( N.LT.0 ) THEN - INFO = -1 - ELSE IF( LDT.LT.MAX( 1, N ) ) THEN - INFO = -3 - END IF -C - IF( INFO.NE.0 ) THEN -C -C Error return. -C - CALL XERBLA( 'MB03QX', -INFO ) - RETURN - END IF -C - INEXT = 1 - DO 10 I = 1, N - IF( I.LT.INEXT ) - $ GO TO 10 - IF( I.NE.N ) THEN - IF( T(I+1,I).NE.ZERO ) THEN -C -C A pair of eigenvalues. -C - INEXT = I + 2 - I1 = I + 1 - A11 = T(I,I) - A12 = T(I,I1) - A21 = T(I1,I) - A22 = T(I1,I1) - CALL DLANV2( A11, A12, A21, A22, WR(I), WI(I), WR(I1), - $ WI(I1), CS, SN ) - GO TO 10 - END IF - END IF -C -C Simple eigenvalue. -C - INEXT = I + 1 - WR(I) = T(I,I) - WI(I) = ZERO - 10 CONTINUE -C - RETURN -C *** Last line of MB03QX *** - END diff --git a/mex/sources/libslicot/MB03QY.f b/mex/sources/libslicot/MB03QY.f deleted file mode 100644 index bf3c8d1ae..000000000 --- a/mex/sources/libslicot/MB03QY.f +++ /dev/null @@ -1,164 +0,0 @@ - SUBROUTINE MB03QY( N, L, A, LDA, U, LDU, E1, E2, INFO ) -C -C SLICOT RELEASE 5.0. -C -C Copyright (c) 2002-2009 NICONET e.V. -C -C This program is free software: you can redistribute it and/or -C modify it under the terms of the GNU General Public License as -C published by the Free Software Foundation, either version 2 of -C the License, or (at your option) any later version. -C -C This program is distributed in the hope that it will be useful, -C but WITHOUT ANY WARRANTY; without even the implied warranty of -C MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the -C GNU General Public License for more details. -C -C You should have received a copy of the GNU General Public License -C along with this program. If not, see -C . -C -C PURPOSE -C -C To compute the eigenvalues of a selected 2-by-2 diagonal block -C of an upper quasi-triangular matrix, to reduce the selected block -C to the standard form and to split the block in the case of real -C eigenvalues by constructing an orthogonal transformation UT. -C This transformation is applied to A (by similarity) and to -C another matrix U from the right. -C -C ARGUMENTS -C -C Input/Output Parameters -C -C N (input) INTEGER -C The order of the matrices A and UT. N >= 2. -C -C L (input) INTEGER -C Specifies the position of the block. 1 <= L < N. -C -C A (input/output) DOUBLE PRECISION array, dimension (LDA,N) -C On entry, the leading N-by-N part of this array must -C contain the upper quasi-triangular matrix A whose -C selected 2-by-2 diagonal block is to be processed. -C On exit, the leading N-by-N part of this array contains -C the upper quasi-triangular matrix A after its selected -C block has been splitt and/or put in the LAPACK standard -C form. -C -C LDA INTEGER -C The leading dimension of array A. LDA >= N. -C -C U (input/output) DOUBLE PRECISION array, dimension (LDU,N) -C On entry, the leading N-by-N part of this array must -C contain a transformation matrix U. -C On exit, the leading N-by-N part of this array contains -C U*UT, where UT is the transformation matrix used to -C split and/or standardize the selected block. -C -C LDU INTEGER -C The leading dimension of array U. LDU >= N. -C -C E1, E2 (output) DOUBLE PRECISION -C E1 and E2 contain either the real eigenvalues or the real -C and positive imaginary parts, respectively, of the complex -C eigenvalues of the selected 2-by-2 diagonal block of A. -C -C Error Indicator -C -C INFO INTEGER -C = 0: successful exit; -C < 0: if INFO = -i, the i-th argument had an illegal -C value. -C -C METHOD -C -C Let A1 = ( A(L,L) A(L,L+1) ) -C ( A(L+1,L) A(L+1,L+1) ) -C be the specified 2-by-2 diagonal block of matrix A. -C If the eigenvalues of A1 are complex, then they are computed and -C stored in E1 and E2, where the real part is stored in E1 and the -C positive imaginary part in E2. The 2-by-2 block is reduced if -C necessary to the standard form, such that A(L,L) = A(L+1,L+1), and -C A(L,L+1) and A(L+1,L) have oposite signs. If the eigenvalues are -C real, the 2-by-2 block is reduced to an upper triangular form such -C that ABS(A(L,L)) >= ABS(A(L+1,L+1)). -C In both cases, an orthogonal rotation U1' is constructed such that -C U1'*A1*U1 has the appropriate form. Let UT be an extension of U1 -C to an N-by-N orthogonal matrix, using identity submatrices. Then A -C is replaced by UT'*A*UT and the contents of array U is U * UT. -C -C CONTRIBUTOR -C -C A. Varga, German Aerospace Center, DLR Oberpfaffenhofen, -C March 1998. Based on the RASP routine SPLITB. -C -C REVISIONS -C -C - -C -C KEYWORDS -C -C Eigenvalues, orthogonal transformation, real Schur form, -C similarity transformation. -C -C ****************************************************************** -C -C .. Parameters .. - DOUBLE PRECISION ZERO - PARAMETER ( ZERO = 0.0D0 ) -C .. Scalar Arguments .. - INTEGER INFO, L, LDA, LDU, N - DOUBLE PRECISION E1, E2 -C .. Array Arguments .. - DOUBLE PRECISION A(LDA,*), U(LDU,*) -C .. Local Scalars .. - INTEGER L1 - DOUBLE PRECISION EW1, EW2, CS, SN -C .. External Subroutines .. - EXTERNAL DLANV2, DROT, XERBLA -C .. Executable Statements .. -C - INFO = 0 -C -C Test the input scalar arguments. -C - IF( N.LT.2 ) THEN - INFO = -1 - ELSE IF( L.LT.1 .OR. L.GE.N ) THEN - INFO = -2 - ELSE IF( LDA.LT.N ) THEN - INFO = -4 - ELSE IF( LDU.LT.N ) THEN - INFO = -6 - END IF -C - IF( INFO.NE.0 ) THEN -C -C Error return. -C - CALL XERBLA( 'MB03QY', -INFO ) - RETURN - END IF -C -C Compute the eigenvalues and the elements of the Givens -C transformation. -C - L1 = L + 1 - CALL DLANV2( A(L,L), A(L,L1), A(L1,L), A(L1,L1), E1, E2, - $ EW1, EW2, CS, SN ) - IF( E2.EQ.ZERO ) E2 = EW1 -C -C Apply the transformation to A. -C - IF( L1.LT.N ) - $ CALL DROT( N-L1, A(L,L1+1), LDA, A(L1,L1+1), LDA, CS, SN ) - CALL DROT( L-1, A(1,L), 1, A(1,L1), 1, CS, SN ) -C -C Accumulate the transformation in U. -C - CALL DROT( N, U(1,L), 1, U(1,L1), 1, CS, SN ) -C - RETURN -C *** Last line of MB03QY *** - END diff --git a/mex/sources/libslicot/MB03RD.f b/mex/sources/libslicot/MB03RD.f deleted file mode 100644 index 9d3910d11..000000000 --- a/mex/sources/libslicot/MB03RD.f +++ /dev/null @@ -1,613 +0,0 @@ - SUBROUTINE MB03RD( JOBX, SORT, N, PMAX, A, LDA, X, LDX, NBLCKS, - $ BLSIZE, WR, WI, TOL, DWORK, INFO ) -C -C SLICOT RELEASE 5.0. -C -C Copyright (c) 2002-2009 NICONET e.V. -C -C This program is free software: you can redistribute it and/or -C modify it under the terms of the GNU General Public License as -C published by the Free Software Foundation, either version 2 of -C the License, or (at your option) any later version. -C -C This program is distributed in the hope that it will be useful, -C but WITHOUT ANY WARRANTY; without even the implied warranty of -C MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the -C GNU General Public License for more details. -C -C You should have received a copy of the GNU General Public License -C along with this program. If not, see -C . -C -C PURPOSE -C -C To reduce a matrix A in real Schur form to a block-diagonal form -C using well-conditioned non-orthogonal similarity transformations. -C The condition numbers of the transformations used for reduction -C are roughly bounded by PMAX*PMAX, where PMAX is a given value. -C The transformations are optionally postmultiplied in a given -C matrix X. The real Schur form is optionally ordered, so that -C clustered eigenvalues are grouped in the same block. -C -C ARGUMENTS -C -C Mode Parameters -C -C JOBX CHARACTER*1 -C Specifies whether or not the transformations are -C accumulated, as follows: -C = 'N': The transformations are not accumulated; -C = 'U': The transformations are accumulated in X (the -C given matrix X is updated). -C -C SORT CHARACTER*1 -C Specifies whether or not the diagonal blocks of the real -C Schur form are reordered, as follows: -C = 'N': The diagonal blocks are not reordered; -C = 'S': The diagonal blocks are reordered before each -C step of reduction, so that clustered eigenvalues -C appear in the same block; -C = 'C': The diagonal blocks are not reordered, but the -C "closest-neighbour" strategy is used instead of -C the standard "closest to the mean" strategy -C (see METHOD); -C = 'B': The diagonal blocks are reordered before each -C step of reduction, and the "closest-neighbour" -C strategy is used (see METHOD). -C -C Input/Output Parameters -C -C N (input) INTEGER -C The order of the matrices A and X. N >= 0. -C -C PMAX (input) DOUBLE PRECISION -C An upper bound for the infinity norm of elementary -C submatrices of the individual transformations used for -C reduction (see METHOD). PMAX >= 1.0D0. -C -C A (input/output) DOUBLE PRECISION array, dimension (LDA,N) -C On entry, the leading N-by-N part of this array must -C contain the matrix A to be block-diagonalized, in real -C Schur form. -C On exit, the leading N-by-N part of this array contains -C the computed block-diagonal matrix, in real Schur -C canonical form. The non-diagonal blocks are set to zero. -C -C LDA INTEGER -C The leading dimension of array A. LDA >= MAX(1,N). -C -C X (input/output) DOUBLE PRECISION array, dimension (LDX,N) -C On entry, if JOBX = 'U', the leading N-by-N part of this -C array must contain a given matrix X. -C On exit, if JOBX = 'U', the leading N-by-N part of this -C array contains the product of the given matrix X and the -C transformation matrix that reduced A to block-diagonal -C form. The transformation matrix is itself a product of -C non-orthogonal similarity transformations having elements -C with magnitude less than or equal to PMAX. -C If JOBX = 'N', this array is not referenced. -C -C LDX INTEGER -C The leading dimension of array X. -C LDX >= 1, if JOBX = 'N'; -C LDX >= MAX(1,N), if JOBX = 'U'. -C -C NBLCKS (output) INTEGER -C The number of diagonal blocks of the matrix A. -C -C BLSIZE (output) INTEGER array, dimension (N) -C The first NBLCKS elements of this array contain the orders -C of the resulting diagonal blocks of the matrix A. -C -C WR, (output) DOUBLE PRECISION arrays, dimension (N) -C WI These arrays contain the real and imaginary parts, -C respectively, of the eigenvalues of the matrix A. -C -C Tolerances -C -C TOL DOUBLE PRECISION -C The tolerance to be used in the ordering of the diagonal -C blocks of the real Schur form matrix. -C If the user sets TOL > 0, then the given value of TOL is -C used as an absolute tolerance: a block i and a temporarily -C fixed block 1 (the first block of the current trailing -C submatrix to be reduced) are considered to belong to the -C same cluster if their eigenvalues satisfy -C -C | lambda_1 - lambda_i | <= TOL. -C -C If the user sets TOL < 0, then the given value of TOL is -C used as a relative tolerance: a block i and a temporarily -C fixed block 1 are considered to belong to the same cluster -C if their eigenvalues satisfy, for j = 1, ..., N, -C -C | lambda_1 - lambda_i | <= | TOL | * max | lambda_j |. -C -C If the user sets TOL = 0, then an implicitly computed, -C default tolerance, defined by TOL = SQRT( SQRT( EPS ) ) -C is used instead, as a relative tolerance, where EPS is -C the machine precision (see LAPACK Library routine DLAMCH). -C If SORT = 'N' or 'C', this parameter is not referenced. -C -C Workspace -C -C DWORK DOUBLE PRECISION array, dimension (N) -C -C Error Indicator -C -C INFO INTEGER -C = 0: successful exit; -C < 0: if INFO = -i, the i-th argument had an illegal -C value. -C -C METHOD -C -C Consider first that SORT = 'N'. Let -C -C ( A A ) -C ( 11 12 ) -C A = ( ), -C ( 0 A ) -C ( 22 ) -C -C be the given matrix in real Schur form, where initially A is the -C 11 -C first diagonal block of dimension 1-by-1 or 2-by-2. An attempt is -C made to compute a transformation matrix X of the form -C -C ( I P ) -C X = ( ) (1) -C ( 0 I ) -C -C (partitioned as A), so that -C -C ( A 0 ) -C -1 ( 11 ) -C X A X = ( ), -C ( 0 A ) -C ( 22 ) -C -C and the elements of P do not exceed the value PMAX in magnitude. -C An adaptation of the standard method for solving Sylvester -C equations [1], which controls the magnitude of the individual -C elements of the computed solution [2], is used to obtain matrix P. -C When this attempt failed, an 1-by-1 (or 2-by-2) diagonal block of -C A , whose eigenvalue(s) is (are) the closest to the mean of those -C 22 -C of A is selected, and moved by orthogonal similarity -C 11 -C transformations in the leading position of A ; the moved diagonal -C 22 -C block is then added to the block A , increasing its order by 1 -C 11 -C (or 2). Another attempt is made to compute a suitable -C transformation matrix X with the new definitions of the blocks A -C 11 -C and A . After a successful transformation matrix X has been -C 22 -C obtained, it postmultiplies the current transformation matrix -C (if JOBX = 'U'), and the whole procedure is repeated for the -C matrix A . -C 22 -C -C When SORT = 'S', the diagonal blocks of the real Schur form are -C reordered before each step of the reduction, so that each cluster -C of eigenvalues, defined as specified in the definition of TOL, -C appears in adjacent blocks. The blocks for each cluster are merged -C together, and the procedure described above is applied to the -C larger blocks. Using the option SORT = 'S' will usually provide -C better efficiency than the standard option (SORT = 'N'), proposed -C in [2], because there could be no or few unsuccessful attempts -C to compute individual transformation matrices X of the form (1). -C However, the resulting dimensions of the blocks are usually -C larger; this could make subsequent calculations less efficient. -C -C When SORT = 'C' or 'B', the procedure is similar to that for -C SORT = 'N' or 'S', respectively, but the block of A whose -C 22 -C eigenvalue(s) is (are) the closest to those of A (not to their -C 11 -C mean) is selected and moved to the leading position of A . This -C 22 -C is called the "closest-neighbour" strategy. -C -C REFERENCES -C -C [1] Bartels, R.H. and Stewart, G.W. T -C Solution of the matrix equation A X + XB = C. -C Comm. A.C.M., 15, pp. 820-826, 1972. -C -C [2] Bavely, C. and Stewart, G.W. -C An Algorithm for Computing Reducing Subspaces by Block -C Diagonalization. -C SIAM J. Numer. Anal., 16, pp. 359-367, 1979. -C -C [3] Demmel, J. -C The Condition Number of Equivalence Transformations that -C Block Diagonalize Matrix Pencils. -C SIAM J. Numer. Anal., 20, pp. 599-610, 1983. -C -C NUMERICAL ASPECTS -C 3 4 -C The algorithm usually requires 0(N ) operations, but 0(N ) are -C possible in the worst case, when all diagonal blocks in the real -C Schur form of A are 1-by-1, and the matrix cannot be diagonalized -C by well-conditioned transformations. -C -C FURTHER COMMENTS -C -C The individual non-orthogonal transformation matrices used in the -C reduction of A to a block-diagonal form have condition numbers -C of the order PMAX*PMAX. This does not guarantee that their product -C is well-conditioned enough. The routine can be easily modified to -C provide estimates for the condition numbers of the clusters of -C eigenvalues. -C -C CONTRIBUTOR -C -C V. Sima, Katholieke Univ. Leuven, Belgium, June 1998. -C Partly based on the RASP routine BDIAG by A. Varga, German -C Aerospace Center, DLR Oberpfaffenhofen. -C -C REVISIONS -C -C V. Sima, Research Institute for Informatics, Bucharest, Apr. 2003. -C -C KEYWORDS -C -C Diagonalization, orthogonal transformation, real Schur form, -C Sylvester equation. -C -C ****************************************************************** -C -C .. Parameters .. - DOUBLE PRECISION ZERO, ONE - PARAMETER ( ZERO = 0.0D0, ONE = 1.0D0 ) -C .. Scalar Arguments .. - CHARACTER JOBX, SORT - INTEGER INFO, LDA, LDX, N, NBLCKS - DOUBLE PRECISION PMAX, TOL -C .. Array Arguments .. - INTEGER BLSIZE(*) - DOUBLE PRECISION A(LDA,*), DWORK(*), WI(*), WR(*), X(LDX,*) -C .. Local Scalars .. - LOGICAL LJOBX, LSORN, LSORS, LSORT - CHARACTER JOBV - INTEGER DA11, DA22, I, IERR, J, K, L, L11, L22, L22M1 - DOUBLE PRECISION C, CAV, D, EDIF, EMAX, RAV, SAFEMN, SC, THRESH -C .. External Functions .. - LOGICAL LSAME - DOUBLE PRECISION DLAMCH, DLAPY2, DNRM2 - EXTERNAL DLAMCH, DLAPY2, DNRM2, LSAME -C .. External Subroutines .. - EXTERNAL DGEMM, DLABAD, DLASET, DSCAL, MA02AD, MB03QX, - $ MB03RX, MB03RY, XERBLA -C .. Intrinsic Functions .. - INTRINSIC ABS, MAX, SQRT -C .. Executable Statements .. -C -C Test the input scalar arguments. -C - INFO = 0 - LJOBX = LSAME( JOBX, 'U' ) - LSORN = LSAME( SORT, 'N' ) - LSORS = LSAME( SORT, 'S' ) - LSORT = LSAME( SORT, 'B' ) .OR. LSORS - IF( .NOT.LJOBX .AND. .NOT.LSAME( JOBX, 'N' ) ) THEN - INFO = -1 - ELSE IF( .NOT.LSORN .AND. .NOT.LSORT .AND. - $ .NOT.LSAME( SORT, 'C' ) ) THEN - INFO = -2 - ELSE IF( N.LT.0 ) THEN - INFO = -3 - ELSE IF( PMAX.LT.ONE ) THEN - INFO = -4 - ELSE IF( LDA.LT.MAX( 1, N ) ) THEN - INFO = -6 - ELSE IF( ( LDX.LT.1 ) .OR. ( LJOBX .AND. LDX.LT.N ) ) THEN - INFO = -8 - END IF -C - IF ( INFO.NE.0 ) THEN -C -C Error return. -C - CALL XERBLA( 'MB03RD', -INFO ) - RETURN - END IF -C -C Quick return if possible. -C - NBLCKS = 0 - IF( N.EQ.0 ) - $ RETURN -C -C Set the "safe" minimum positive number with representable -C reciprocal, and set JOBV parameter for MB03RX routine. -C - SAFEMN = DLAMCH( 'Safe minimum' ) - SC = ONE / SAFEMN - CALL DLABAD( SAFEMN, SC ) - SAFEMN = SAFEMN / DLAMCH( 'Precision' ) - JOBV = JOBX - IF ( LJOBX ) - $ JOBV = 'V' -C -C Compute the eigenvalues of A and set the tolerance for reordering -C the eigenvalues in clusters, if needed. -C - CALL MB03QX( N, A, LDA, WR, WI, INFO ) -C - IF ( LSORT ) THEN - THRESH = ABS( TOL ) - IF ( THRESH.EQ.ZERO ) THEN -C -C Use the default tolerance in ordering the blocks. -C - THRESH = SQRT( SQRT( DLAMCH( 'Epsilon' ) ) ) - END IF -C - IF ( TOL.LE.ZERO ) THEN -C -C Use a relative tolerance. Find max | lambda_j |, j = 1 : N. -C - EMAX = ZERO - L = 1 -C WHILE ( L.LE.N ) DO - 10 IF ( L.LE.N ) THEN - IF ( WI(L).EQ.ZERO ) THEN - EMAX = MAX( EMAX, ABS( WR(L) ) ) - L = L + 1 - ELSE - EMAX = MAX( EMAX, DLAPY2( WR(L), WI(L) ) ) - L = L + 2 - END IF - GO TO 10 - END IF -C END WHILE 10 - THRESH = THRESH * EMAX - END IF - END IF -C -C Define the following submatrices of A: -C A11, the DA11-by-DA11 block in position (L11,L11); -C A22, the DA22-by-DA22 block in position (L22,L22); -C A12, the DA11-by-DA22 block in position (L11,L22); -C A21, the DA22-by-DA11 block in position (L22,L11) (null initially -C and finally). -C The following loop uses L11 as loop variable and try to separate a -C block in position (L11,L11), with possibly clustered eigenvalues, -C separated by the other eigenvalues (in the block A22). -C - L11 = 1 -C WHILE ( L11.LE.N ) DO - 20 IF ( L11.LE.N ) THEN - NBLCKS = NBLCKS + 1 - IF ( WI(L11).EQ.ZERO ) THEN - DA11 = 1 - ELSE - DA11 = 2 - END IF -C - IF ( LSORT ) THEN -C -C The following loop, using K as loop variable, finds the -C blocks whose eigenvalues are close to those of A11 and -C moves these blocks (if any) to the leading position of A22. -C - L22 = L11 + DA11 - K = L22 -C WHILE ( K.LE.N ) DO - 30 IF ( K.LE.N ) THEN - EDIF = DLAPY2( WR(L11) - WR(K), WI(L11) - WI(K) ) - IF ( EDIF.LE.THRESH ) THEN -C -C An 1x1 or a 2x2 block of A22 has been found so that -C -C abs( lambda_1 - lambda_k ) <= THRESH -C -C where lambda_1 and lambda_k denote an eigenvalue -C of A11 and of that block in A22, respectively. -C Try to move that block to the leading position of A22. -C - CALL MB03RX( JOBV, N, L22, K, A, LDA, X, LDX, WR, WI, - $ DWORK ) -C -C Extend A11 with the leading block of A22. -C - IF ( WI(L22).EQ.ZERO ) THEN - DA11 = DA11 + 1 - ELSE - DA11 = DA11 + 2 - END IF - L22 = L11 + DA11 - END IF - IF ( WI(K).EQ.ZERO ) THEN - K = K + 1 - ELSE - K = K + 2 - END IF - GO TO 30 - END IF -C END WHILE 30 - END IF -C -C The following loop uses L22 as loop variable and forms a -C separable DA11-by-DA11 block A11 in position (L11,L11). -C - L22 = L11 + DA11 - L22M1 = L22 - 1 -C WHILE ( L22.LE.N ) DO - 40 IF ( L22.LE.N ) THEN - DA22 = N - L22M1 -C -C Try to separate the block A11 of order DA11 by using a -C well-conditioned similarity transformation. -C -C First save A12' in the block A21. -C - CALL MA02AD( 'Full', DA11, DA22, A(L11,L22), LDA, - $ A(L22,L11), LDA ) -C -C Solve -A11*P + P*A22 = A12. -C - CALL MB03RY( DA11, DA22, PMAX, A(L11,L11), LDA, A(L22,L22), - $ LDA, A(L11,L22), LDA, IERR ) -C - IF ( IERR.EQ.1 ) THEN -C -C The annihilation of A12 failed. Restore A12 and A21. -C - CALL MA02AD( 'Full', DA22, DA11, A(L22,L11), LDA, - $ A(L11,L22), LDA ) - CALL DLASET( 'Full', DA22, DA11, ZERO, ZERO, A(L22,L11), - $ LDA ) -C - IF ( LSORN .OR. LSORS ) THEN -C -C Extend A11 with an 1x1 or 2x2 block of A22 having the -C nearest eigenvalues to the mean of eigenvalues of A11 -C and resume the loop. -C First compute the mean of eigenvalues of A11. -C - RAV = ZERO - CAV = ZERO -C - DO 50 I = L11, L22M1 - RAV = RAV + WR(I) - CAV = CAV + ABS( WI(I) ) - 50 CONTINUE -C - RAV = RAV/DA11 - CAV = CAV/DA11 -C -C Loop to find the eigenvalue of A22 nearest to the -C above computed mean. -C - D = DLAPY2( RAV-WR(L22), CAV-WI(L22) ) - K = L22 - IF ( WI(L22).EQ.ZERO ) THEN - L = L22 + 1 - ELSE - L = L22 + 2 - END IF -C WHILE ( L.LE.N ) DO - 60 IF ( L.LE.N ) THEN - C = DLAPY2( RAV-WR(L), CAV-WI(L) ) - IF ( C.LT.D ) THEN - D = C - K = L - END IF - IF ( WI(L).EQ.ZERO ) THEN - L = L + 1 - ELSE - L = L + 2 - END IF - GO TO 60 - END IF -C END WHILE 60 -C - ELSE -C -C Extend A11 with an 1x1 or 2x2 block of A22 having the -C nearest eigenvalues to the cluster of eigenvalues of -C A11 and resume the loop. -C -C Loop to find the eigenvalue of A22 of minimum distance -C to the cluster. -C - D = SC - L = L22 - K = L22 -C WHILE ( L.LE.N ) DO - 70 IF ( L.LE.N ) THEN - I = L11 -C WHILE ( I.LE.L22M1 ) DO - 80 IF ( I.LE.L22M1 ) THEN - C = DLAPY2( WR(I)-WR(L), WI(I)-WI(L) ) - IF ( C.LT.D ) THEN - D = C - K = L - END IF - IF ( WI(I).EQ.ZERO ) THEN - I = I + 1 - ELSE - I = I + 2 - END IF - GO TO 80 - END IF -C END WHILE 80 - IF ( WI(L).EQ.ZERO ) THEN - L = L + 1 - ELSE - L = L + 2 - END IF - GO TO 70 - END IF -C END WHILE 70 - END IF -C -C Try to move block found to the leading position of A22. -C - CALL MB03RX( JOBV, N, L22, K, A, LDA, X, LDX, WR, WI, - $ DWORK ) -C -C Extend A11 with the leading block of A22. -C - IF ( WI(L22).EQ.ZERO ) THEN - DA11 = DA11 + 1 - ELSE - DA11 = DA11 + 2 - END IF - L22 = L11 + DA11 - L22M1 = L22 - 1 - GO TO 40 - END IF - END IF -C END WHILE 40 -C - IF ( LJOBX ) THEN -C -C Accumulate the transformation in X. -C Only columns L22, ..., N are modified. -C - IF ( L22.LE.N ) - $ CALL DGEMM( 'No transpose', 'No transpose', N, DA22, - $ DA11, ONE, X(1,L11), LDX, A(L11,L22), LDA, - $ ONE, X(1,L22), LDX ) -C -C Scale to unity the (non-zero) columns of X which will be -C no more modified and transform A11 accordingly. -C - DO 90 J = L11, L22M1 - SC = DNRM2( N, X(1,J), 1 ) - IF ( SC.GT.SAFEMN ) THEN - CALL DSCAL( DA11, SC, A(J,L11), LDA ) - SC = ONE/SC - CALL DSCAL( N, SC, X(1,J), 1 ) - CALL DSCAL( DA11, SC, A(L11,J), 1 ) - END IF - 90 CONTINUE -C - END IF - IF ( L22.LE.N ) THEN -C -C Set A12 and A21 to zero. -C - CALL DLASET( 'Full', DA11, DA22, ZERO, ZERO, A(L11,L22), - $ LDA ) - CALL DLASET( 'Full', DA22, DA11, ZERO, ZERO, A(L22,L11), - $ LDA ) - END IF -C -C Store the orders of the diagonal blocks in BLSIZE. -C - BLSIZE(NBLCKS) = DA11 - L11 = L22 - GO TO 20 - END IF -C END WHILE 20 -C - RETURN -C *** Last line of MB03RD *** - END diff --git a/mex/sources/libslicot/MB03RX.f b/mex/sources/libslicot/MB03RX.f deleted file mode 100644 index d7c582db5..000000000 --- a/mex/sources/libslicot/MB03RX.f +++ /dev/null @@ -1,226 +0,0 @@ - SUBROUTINE MB03RX( JOBV, N, KL, KU, A, LDA, X, LDX, WR, WI, - $ DWORK ) -C -C SLICOT RELEASE 5.0. -C -C Copyright (c) 2002-2009 NICONET e.V. -C -C This program is free software: you can redistribute it and/or -C modify it under the terms of the GNU General Public License as -C published by the Free Software Foundation, either version 2 of -C the License, or (at your option) any later version. -C -C This program is distributed in the hope that it will be useful, -C but WITHOUT ANY WARRANTY; without even the implied warranty of -C MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the -C GNU General Public License for more details. -C -C You should have received a copy of the GNU General Public License -C along with this program. If not, see -C . -C -C PURPOSE -C -C To reorder the diagonal blocks of the principal submatrix between -C the indices KL and KU (KU >= KL) of a real Schur form matrix A -C together with their eigenvalues, using orthogonal similarity -C transformations, such that the block specified by KU is moved in -C the position KL. The transformations are optionally postmultiplied -C in a given matrix X. -C -C ARGUMENTS -C -C Mode Parameters -C -C JOBV CHARACTER*1 -C Specifies whether or not the transformations are -C accumulated, as follows: -C = 'N': The transformations are not accumulated; -C = 'V': The transformations are accumulated in X (the -C given matrix X is updated). -C -C Input/Output Parameters -C -C N (input) INTEGER -C The order of the matrices A and X. N >= 0. -C -C KL (input) INTEGER -C The lower boundary index for the rows and columns of the -C principal submatrix of A whose diagonal blocks are to be -C reordered, and also the target position for the block to -C be moved. 1 <= KL <= KU <= N. -C -C KU (input/output) INTEGER -C On entry, KU specifies the upper boundary index for the -C rows and columns of the principal submatrix of A whose -C diagonal blocks are to be reordered, and also the original -C position for the block to be moved. 1 <= KL <= KU <= N. -C On exit, KU specifies the upper boundary index for the -C rows and columns of the principal submatrix of A whose -C diagonal blocks have been reordered. The given value will -C be increased by 1 if the moved block was 2-by-2 and it has -C been replaced by two 1-by-1 blocks. Otherwise, its input -C value is preserved. -C -C A (input/output) DOUBLE PRECISION array, dimension (LDA,N) -C On entry, the leading N-by-N part of this array must -C contain the matrix A in real Schur canonical form. -C On exit, the leading N-by-N part of this array contains -C the ordered real Schur canonical form. -C -C LDA INTEGER -C The leading dimension of array A. LDA >= MAX(1,N). -C -C X (input/output) DOUBLE PRECISION array, dimension (LDX,N) -C On entry, if JOBV = 'V', the leading N-by-N part of this -C array must contain a given matrix X. -C On exit, if JOBV = 'V', the leading N-by-N part of this -C array contains the product of the given matrix X and the -C transformation matrix that performed the reordering of A. -C If JOBV = 'N', this array is not referenced. -C -C LDX INTEGER -C The leading dimension of array X. -C LDX >= 1, if JOBV = 'N'; -C LDX >= MAX(1,N), if JOBV = 'V'. -C -C WR, (input/output) DOUBLE PRECISION arrays, dimension (N) -C WI On entry, these arrays must contain the real and imaginary -C parts, respectively, of the eigenvalues of the matrix A. -C On exit, these arrays contain the real and imaginary -C parts, respectively, of the eigenvalues of the matrix A, -C possibly reordered. -C -C Workspace -C -C DWORK DOUBLE PRECISION array, dimension (N) -C -C METHOD -C -C An attempt is made to move the block in the position (KU,KU) to -C the position (KL,KL) by a sequence of orthogonal similarity -C transformations, each swapping two consecutive blocks. The -C standard algorithm [1], [2] usually succeeds to perform this -C reordering. A failure of this algorithm means that two consecutive -C blocks (one of them being the desired block possibly moved) are -C too close to swap. In such a case, the leading block of the two -C is tried to be moved in the position (KL,KL) and the procedure is -C repeated. -C -C REFERENCES -C -C [1] Stewart, G.W. -C HQR3 and EXCHQZ: FORTRAN subroutines for calculating and -C ordering the eigenvalues of a real upper Hessenberg matrix. -C ACM TOMS, 2, pp. 275-280, 1976. -C -C [2] Anderson, E., Bai, Z., Bischof, C., Demmel, J., Dongarra, J., -C Du Croz, J., Greenbaum, A., Hammarling, S., McKenney, A., -C Ostrouchov, S., and Sorensen, D. -C LAPACK Users' Guide: Second Edition. -C SIAM, Philadelphia, 1995. -C -C NUMERICAL ASPECTS -C -C The algorithm is numerically stable. If some eigenvalues are -C ill-conditioned, their returned values could differ much from -C their input values. -C -C CONTRIBUTOR -C -C V. Sima, Katholieke Univ. Leuven, Belgium, June 1998. -C -C REVISIONS -C -C - -C -C KEYWORDS -C -C Eigenvalue, orthogonal transformation, real Schur form. -C -C ****************************************************************** -C -C .. Parameters .. - DOUBLE PRECISION ZERO - PARAMETER ( ZERO = 0.0D0 ) -C .. Scalar Arguments .. - CHARACTER JOBV - INTEGER KL, KU, LDA, LDX, N -C .. Array Arguments .. - DOUBLE PRECISION A(LDA,*), DWORK(*), WI(*), WR(*), X(LDX,*) -C .. Local Scalars .. - INTEGER IERR, IFST, ILST, L -C .. External Subroutines .. - EXTERNAL DTREXC -C .. Intrinsic Functions .. - INTRINSIC ABS, SQRT -C .. Executable Statements .. -C - IF ( KU.GT.KL ) THEN -C -C Try to move the block in position (KU,KU) to position (KL,KL). -C - IFST = KU -C REPEAT - 10 CONTINUE - ILST = KL - CALL DTREXC( JOBV, N, A, LDA, X, LDX, IFST, ILST, DWORK, IERR ) - IF ( IERR.NE.0 ) THEN -C -C During calculations, two adjacent blocks were too close -C to swap; the desired block cannot be moved further, but the -C block above it is suitable and is tried for moving. The -C number of repeat cycles is usually 1, and at most the number -C of blocks between the current position and the position KL. -C - IFST = ILST - 1 - IF ( IFST.GT.1 ) THEN - IF ( A(IFST,IFST-1).NE.ZERO ) - $ IFST = ILST - 2 - END IF - IF ( ILST.GT.KL ) - $ GO TO 10 - END IF -C UNTIL ( ILST.EQ.KL on output from DTREXC ) -C -C Recompute the eigenvalues for the modified part of A. -C Note that KU must be incremented if the moved block was 2-by-2 -C and it has been replaced by two 1-by-1 blocks. -C - IF ( WI(KU).NE.ZERO ) THEN - IF ( A(KU+1,KU).EQ.ZERO ) - $ KU = KU + 1 - END IF -C - L = KL -C WHILE ( L.LT.KU .OR. ( L.EQ.KU .AND. L.LT.N ) ) DO - 20 IF ( L.LT.KU .OR. ( L.EQ.KU .AND. L.LT.N ) ) THEN - IF ( A(L+1,L).NE.ZERO ) THEN -C -C A 2x2 block. -C - WR(L) = A(L,L) - WR(L+1) = WR(L) - WI(L) = SQRT( ABS( A(L,L+1) ) )* - $ SQRT( ABS( A(L+1,L) ) ) - WI(L+1) = -WI(L) - L = L + 2 - ELSE -C -C An 1x1 block. -C - WR(L) = A(L,L) - WI(L) = ZERO - L = L + 1 - END IF - GO TO 20 - ELSE IF ( L.EQ.N ) THEN - WR(L) = A(L,L) - WI(L) = ZERO - END IF -C END WHILE 20 - END IF -C - RETURN -C *** Last line of MB03RX *** - END diff --git a/mex/sources/libslicot/MB03RY.f b/mex/sources/libslicot/MB03RY.f deleted file mode 100644 index 550083136..000000000 --- a/mex/sources/libslicot/MB03RY.f +++ /dev/null @@ -1,261 +0,0 @@ - SUBROUTINE MB03RY( M, N, PMAX, A, LDA, B, LDB, C, LDC, INFO ) -C -C SLICOT RELEASE 5.0. -C -C Copyright (c) 2002-2009 NICONET e.V. -C -C This program is free software: you can redistribute it and/or -C modify it under the terms of the GNU General Public License as -C published by the Free Software Foundation, either version 2 of -C the License, or (at your option) any later version. -C -C This program is distributed in the hope that it will be useful, -C but WITHOUT ANY WARRANTY; without even the implied warranty of -C MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the -C GNU General Public License for more details. -C -C You should have received a copy of the GNU General Public License -C along with this program. If not, see -C . -C -C PURPOSE -C -C To solve the Sylvester equation -AX + XB = C, where A and B are -C M-by-M and N-by-N matrices, respectively, in real Schur form. -C -C This routine is intended to be called only by SLICOT Library -C routine MB03RD. For efficiency purposes, the computations are -C aborted when the infinity norm of an elementary submatrix of X is -C greater than a given value PMAX. -C -C ARGUMENTS -C -C Input/Output Parameters -C -C M (input) INTEGER -C The order of the matrix A and the number of rows of the -C matrices C and X. M >= 0. -C -C N (input) INTEGER -C The order of the matrix B and the number of columns of the -C matrices C and X. N >= 0. -C -C PMAX (input) DOUBLE PRECISION -C An upper bound for the infinity norm of an elementary -C submatrix of X (see METHOD). -C -C A (input) DOUBLE PRECISION array, dimension (LDA,M) -C The leading M-by-M part of this array must contain the -C matrix A of the Sylvester equation, in real Schur form. -C The elements below the real Schur form are not referenced. -C -C LDA INTEGER -C The leading dimension of array A. LDA >= MAX(1,M). -C -C B (input) DOUBLE PRECISION array, dimension (LDB,N) -C The leading N-by-N part of this array must contain the -C matrix B of the Sylvester equation, in real Schur form. -C The elements below the real Schur form are not referenced. -C -C LDB INTEGER -C The leading dimension of array B. LDB >= MAX(1,N). -C -C C (input/output) DOUBLE PRECISION array, dimension (LDC,N) -C On entry, the leading M-by-N part of this array must -C contain the matrix C of the Sylvester equation. -C On exit, if INFO = 0, the leading M-by-N part of this -C array contains the solution matrix X of the Sylvester -C equation, and each elementary submatrix of X (see METHOD) -C has the infinity norm less than or equal to PMAX. -C On exit, if INFO = 1, the solution matrix X has not been -C computed completely, because an elementary submatrix of X -C had the infinity norm greater than PMAX. Part of the -C matrix C has possibly been overwritten with the -C corresponding part of X. -C -C LDC INTEGER -C The leading dimension of array C. LDC >= MAX(1,M). -C -C Error Indicator -C -C INFO INTEGER -C = 0: successful exit; -C = 1: an elementary submatrix of X had the infinity norm -C greater than the given value PMAX. -C -C METHOD -C -C The routine uses an adaptation of the standard method for solving -C Sylvester equations [1], which controls the magnitude of the -C individual elements of the computed solution [2]. The equation -C -AX + XB = C can be rewritten as -C p l-1 -C -A X + X B = C + sum A X - sum X B -C kk kl kl ll kl i=k+1 ki il j=1 kj jl -C -C for l = 1:q, and k = p:-1:1, where A , B , C , and X , are -C kk ll kl kl -C block submatrices defined by the partitioning induced by the Schur -C form of A and B, and p and q are the numbers of the diagonal -C blocks of A and B, respectively. So, the elementary submatrices of -C X are found block column by block column, starting from the -C bottom. If any such elementary submatrix has the infinity norm -C greater than the given value PMAX, the calculations are ended. -C -C REFERENCES -C -C [1] Bartels, R.H. and Stewart, G.W. T -C Solution of the matrix equation A X + XB = C. -C Comm. A.C.M., 15, pp. 820-826, 1972. -C -C [2] Bavely, C. and Stewart, G.W. -C An Algorithm for Computing Reducing Subspaces by Block -C Diagonalization. -C SIAM J. Numer. Anal., 16, pp. 359-367, 1979. -C -C NUMERICAL ASPECTS -C 2 2 -C The algorithm requires 0(M N + MN ) operations. -C -C FURTHER COMMENTS -C -C Let -C -C ( A C ) ( I X ) -C M = ( ), Y = ( ). -C ( 0 B ) ( 0 I ) -C -C Then -C -C -1 ( A 0 ) -C Y M Y = ( ), -C ( 0 B ) -C -C hence Y is an non-orthogonal transformation matrix which performs -C the reduction of M to a block-diagonal form. Bounding a norm of -C X is equivalent to setting an upper bound to the condition number -C of the transformation matrix Y. -C -C CONTRIBUTOR -C -C V. Sima, Katholieke Univ. Leuven, Belgium, June 1998. -C Based on the RASP routine SYLSM by A. Varga, German Aerospace -C Center, DLR Oberpfaffenhofen. -C -C REVISIONS -C -C - -C -C KEYWORDS -C -C Diagonalization, real Schur form, Sylvester equation. -C -C ****************************************************************** -C -C .. Parameters .. - DOUBLE PRECISION ZERO, ONE - PARAMETER ( ZERO = 0.0D0, ONE = 1.0D0 ) -C .. Scalar Arguments .. - INTEGER INFO, LDA, LDB, LDC, M, N - DOUBLE PRECISION PMAX -C .. Array Arguments .. - DOUBLE PRECISION A(LDA,*), B(LDB,*), C(LDC,*) -C .. Local Scalars .. - INTEGER DK, DL, I, IERR, J, K, KK, KK1, L, LL, LM1 - DOUBLE PRECISION PNORM, SCALE -C .. Local Arrays .. - DOUBLE PRECISION P(4) -C .. External Functions .. - DOUBLE PRECISION DDOT - EXTERNAL DDOT -C .. External Subroutines .. - EXTERNAL DGEMM, DGEMV, DLASY2 -C .. Executable Statements .. -C -C For efficiency reasons, this routine does not check the input -C parameters for errors. -C - INFO = 0 -C -C Column loop indexed by L. -C - L = 1 -C WHILE ( L.LE.N ) DO - 10 IF ( L.LE.N ) THEN - LM1 = L - 1 - DL = 1 - IF ( L.LT.N ) THEN - IF ( B(L+1,L).NE.ZERO ) - $ DL = 2 - ENDIF - LL = LM1 + DL - IF ( LM1.GT.0 ) THEN -C -C Update one (or two) column(s) of C. -C - IF ( DL.EQ.2 ) THEN - CALL DGEMM( 'No transpose', 'No transpose', M, DL, LM1, - $ -ONE, C, LDC, B(1,L), LDB, ONE, C(1,L), LDC ) - ELSE - CALL DGEMV( 'No transpose', M, LM1, -ONE, C, LDC, B(1,L), - $ 1, ONE, C(1,L), 1 ) - END IF - ENDIF -C -C Row loop indexed by KK. -C - KK = M -C WHILE ( KK.GE.1 ) DO - 20 IF ( KK.GE.1 ) THEN - KK1 = KK + 1 - DK = 1 - IF ( KK.GT.1 ) THEN - IF ( A(KK,KK-1).NE.ZERO ) - $ DK = 2 - ENDIF - K = KK1 - DK - IF ( K.LT.M ) THEN -C -C Update an elementary submatrix of C. -C - DO 40 J = L, LL -C - DO 30 I = K, KK - C(I,J) = C(I,J) + - $ DDOT( M-KK, A(I,KK1), LDA, C(KK1,J), 1 ) - 30 CONTINUE -C - 40 CONTINUE -C - ENDIF - CALL DLASY2( .FALSE., .FALSE., -1, DK, DL, A(K,K), LDA, - $ B(L,L), LDB, C(K,L), LDC, SCALE, P, DK, PNORM, - $ IERR ) - IF( SCALE.NE.ONE .OR. PNORM.GT.PMAX ) THEN - INFO = 1 - RETURN - END IF - C(K,L) = -P(1) - IF ( DL.EQ.1 ) THEN - IF ( DK.EQ.2 ) - $ C(KK,L) = -P(2) - ELSE - IF ( DK.EQ.1 ) THEN - C(K,LL) = -P(2) - ELSE - C(KK,L) = -P(2) - C(K,LL) = -P(3) - C(KK,LL) = -P(4) - ENDIF - ENDIF - KK = KK - DK - GO TO 20 - END IF -C END WHILE 20 - L = L + DL - GO TO 10 - END IF -C END WHILE 10 - RETURN -C *** Last line of MB03RY *** - END diff --git a/mex/sources/libslicot/MB03SD.f b/mex/sources/libslicot/MB03SD.f deleted file mode 100644 index 679396e77..000000000 --- a/mex/sources/libslicot/MB03SD.f +++ /dev/null @@ -1,348 +0,0 @@ - SUBROUTINE MB03SD( JOBSCL, N, A, LDA, QG, LDQG, WR, WI, DWORK, - $ LDWORK, INFO ) -C -C SLICOT RELEASE 5.0. -C -C Copyright (c) 2002-2009 NICONET e.V. -C -C This program is free software: you can redistribute it and/or -C modify it under the terms of the GNU General Public License as -C published by the Free Software Foundation, either version 2 of -C the License, or (at your option) any later version. -C -C This program is distributed in the hope that it will be useful, -C but WITHOUT ANY WARRANTY; without even the implied warranty of -C MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the -C GNU General Public License for more details. -C -C You should have received a copy of the GNU General Public License -C along with this program. If not, see -C . -C -C PURPOSE -C -C To compute the eigenvalues of an N-by-N square-reduced Hamiltonian -C matrix -C -C ( A' G' ) -C H' = ( T ). (1) -C ( Q' -A' ) -C -C Here, A' is an N-by-N matrix, and G' and Q' are symmetric N-by-N -C matrices. It is assumed without a check that H' is square- -C reduced, i.e., that -C -C 2 ( A'' G'' ) -C H' = ( T ) with A'' upper Hessenberg. (2) -C ( 0 A'' ) -C -C T 2 -C (Equivalently, Q'A'- A' Q' = 0, A'' = A' + G'Q', and for i > j+1, -C A''(i,j) = 0.) Ordinarily, H' is the output from SLICOT Library -C routine MB04ZD. The eigenvalues of H' are computed as the square -C roots of the eigenvalues of A''. -C -C ARGUMENTS -C -C Mode Parameters -C -C JOBSCL CHARACTER*1 -C Specifies whether or not balancing operations should -C be performed by the LAPACK subroutine DGEBAL on the -C Hessenberg matrix A'' in (2), as follows: -C = 'N': do not use balancing; -C = 'S': do scaling in order to equilibrate the rows -C and columns of A''. -C See LAPACK subroutine DGEBAL and Section METHOD below. -C -C Input/Output Parameters -C -C N (input) INTEGER -C The order of the matrices A, G, and Q. N >= 0. -C -C A (input) DOUBLE PRECISION array, dimension (LDA,N) -C The leading N-by-N part of this array must contain the -C upper left block A' of the square-reduced Hamiltonian -C matrix H' in (1), as produced by SLICOT Library routine -C MB04ZD. -C -C LDA INTEGER -C The leading dimension of the array A. LDA >= MAX(1,N). -C -C QG (input) DOUBLE PRECISION array, dimension (LDQG,N+1) -C The leading N-by-N lower triangular part of this array -C must contain the lower triangle of the lower left -C symmetric block Q' of the square-reduced Hamiltonian -C matrix H' in (1), and the N-by-N upper triangular part of -C the submatrix in the columns 2 to N+1 of this array must -C contain the upper triangle of the upper right symmetric -C block G' of the square-reduced Hamiltonian matrix H' -C in (1), as produced by SLICOT Library routine MB04ZD. -C So, if i >= j, then Q'(i,j) is stored in QG(i,j) and -C G'(i,j) is stored in QG(j,i+1). -C -C LDQG INTEGER -C The leading dimension of the array QG. LDQG >= MAX(1,N). -C -C WR (output) DOUBLE PRECISION array, dimension (N) -C WI (output) DOUBLE PRECISION array, dimension (N) -C The arrays WR and WI contain the real and imaginary parts, -C respectively, of the N eigenvalues of H' with non-negative -C real part. The remaining N eigenvalues are the negatives -C of these eigenvalues. -C Eigenvalues are stored in WR and WI in decreasing order of -C magnitude of the real parts, i.e., WR(I) >= WR(I+1). -C (In particular, an eigenvalue closest to the imaginary -C axis is WR(N)+WI(N)i.) -C In addition, eigenvalues with zero real part are sorted in -C decreasing order of magnitude of imaginary parts. Note -C that non-real eigenvalues with non-zero real part appear -C in complex conjugate pairs, but eigenvalues with zero real -C part do not, in general, appear in complex conjugate -C pairs. -C -C Workspace -C -C DWORK DOUBLE PRECISION array, dimension (LDWORK) -C On exit, if INFO = 0, DWORK(1) returns the optimal value -C of LDWORK. -C -C LDWORK INTEGER -C The dimension of the array DWORK. -C LDWORK >= MAX(1,N*(N+1)). -C For good performance, LDWORK should be larger. -C -C Error Indicator -C -C INFO INTEGER -C = 0: successful exit; -C < 0: if INFO = -i, then the i-th argument had an illegal -C value; -C > 0: if INFO = i, i <= N, then LAPACK subroutine DHSEQR -C failed to converge while computing the i-th -C eigenvalue. -C -C METHOD -C -C The routine forms the upper Hessenberg matrix A'' in (2) and calls -C LAPACK subroutines to calculate its eigenvalues. The eigenvalues -C of H' are the square roots of the eigenvalues of A''. -C -C REFERENCES -C -C [1] Van Loan, C. F. -C A Symplectic Method for Approximating All the Eigenvalues of -C a Hamiltonian Matrix. -C Linear Algebra and its Applications, 61, pp. 233-251, 1984. -C -C [2] Byers, R. -C Hamiltonian and Symplectic Algorithms for the Algebraic -C Riccati Equation. -C Ph. D. Thesis, Cornell University, Ithaca, NY, January 1983. -C -C [3] Benner, P., Byers, R., and Barth, E. -C Fortran 77 Subroutines for Computing the Eigenvalues of -C Hamiltonian Matrices. I: The Square-Reduced Method. -C ACM Trans. Math. Software, 26, 1, pp. 49-77, 2000. -C -C NUMERICAL ASPECTS -C -C The algorithm requires (32/3)*N**3 + O(N**2) floating point -C operations. -C Eigenvalues computed by this subroutine are exact eigenvalues -C of a perturbed Hamiltonian matrix H' + E where -C -C || E || <= c sqrt(eps) || H' ||, -C -C c is a modest constant depending on the dimension N and eps is the -C machine precision. Moreover, if the norm of H' and an eigenvalue -C are of roughly the same magnitude, the computed eigenvalue is -C essentially as accurate as the computed eigenvalue obtained by -C traditional methods. See [1] or [2]. -C -C CONTRIBUTOR -C -C P. Benner, Universitaet Bremen, Germany, and -C R. Byers, University of Kansas, Lawrence, USA. -C Aug. 1998, routine DHAEVS. -C V. Sima, Research Institute for Informatics, Bucharest, Romania, -C Oct. 1998, SLICOT Library version. -C -C REVISIONS -C -C V. Sima, Research Institute for Informatics, Bucharest, Nov. 2002, -C May 2009. -C -C KEYWORDS -C -C Eigenvalues, (square-reduced) Hamiltonian matrix, symplectic -C similarity transformation. -C -C ****************************************************************** -C -C .. Parameters .. - DOUBLE PRECISION ZERO, ONE - PARAMETER ( ZERO = 0.0D0, ONE = 1.0D0 ) -C .. -C .. Scalar Arguments .. - INTEGER INFO, LDA, LDQG, LDWORK, N - CHARACTER JOBSCL -C .. -C .. Array Arguments .. - DOUBLE PRECISION A(LDA,*), DWORK(*), QG(LDQG,*), WI(*), WR(*) -C .. -C .. Local Scalars .. - DOUBLE PRECISION SWAP, X, Y - INTEGER BL, CHUNK, I, IGNORE, IHI, ILO, J, JW, JWORK, M, - $ N2 - LOGICAL BLAS3, BLOCK, SCALE, SORTED -C .. -C .. Local Arrays .. - DOUBLE PRECISION DUMMY(1) -C .. -C .. External Functions .. - LOGICAL LSAME - EXTERNAL LSAME -C .. -C .. External Subroutines .. - EXTERNAL DCOPY, DGEBAL, DGEMM, DHSEQR, DLACPY, DLASET, - $ DSYMM, DSYMV, MA01AD, MA02ED, XERBLA -C .. -C .. Intrinsic Functions .. - INTRINSIC MAX, MIN -C .. -C .. Executable Statements .. -C - INFO = 0 - N2 = N*N - SCALE = LSAME( JOBSCL, 'S' ) - IF ( .NOT. ( SCALE .OR. LSAME( JOBSCL, 'N' ) ) ) THEN - INFO = -1 - ELSE IF( N.LT.0 ) THEN - INFO = -2 - ELSE IF( LDA.LT.MAX( 1, N ) ) THEN - INFO = -4 - ELSE IF( LDQG.LT.MAX( 1, N ) ) THEN - INFO = -6 - ELSE IF( LDWORK.LT.MAX( 1, N2 + N ) ) THEN - INFO = -10 - END IF -C - IF ( INFO.NE.0 ) THEN - CALL XERBLA( 'MB03SD', -INFO ) - RETURN - END IF -C -C Quick return if possible. -C - IF( N.EQ.0 ) THEN - DWORK(1) = ONE - RETURN - END IF -C - CHUNK = ( LDWORK - N2 ) / N - BLOCK = MIN( CHUNK, N ).GT.1 - BLAS3 = CHUNK.GE.N -C - IF ( BLAS3 ) THEN - JWORK = N2 + 1 - ELSE - JWORK = 1 - END IF -C 2 -C Form the matrix A'' = A' + G'Q'. -C - CALL DLACPY( 'Lower', N, N, QG, LDQG, DWORK(JWORK), N ) - CALL MA02ED( 'Lower', N, DWORK(JWORK), N ) -C - IF ( BLAS3 ) THEN -C -C Use BLAS 3 calculation. -C - CALL DSYMM( 'Left', 'Upper', N, N, ONE, QG(1, 2), LDQG, - $ DWORK(JWORK), N, ZERO, DWORK, N ) -C - ELSE IF ( BLOCK ) THEN - JW = N2 + 1 -C -C Use BLAS 3 for as many columns of Q' as possible. -C - DO 10 J = 1, N, CHUNK - BL = MIN( N-J+1, CHUNK ) - CALL DSYMM( 'Left', 'Upper', N, BL, ONE, QG(1, 2), LDQG, - $ DWORK(1+N*(J-1)), N, ZERO, DWORK(JW), N ) - CALL DLACPY( 'Full', N, BL, DWORK(JW), N, DWORK(1+N*(J-1)), - $ N ) - 10 CONTINUE -C - ELSE -C -C Use BLAS 2 calculation. -C - DO 20 J = 1, N - CALL DSYMV( 'Upper', N, ONE, QG(1, 2), LDQG, - $ DWORK(1+N*(J-1)), 1, ZERO, WR, 1 ) - CALL DCOPY( N, WR, 1, DWORK(1+N*(J-1)), 1 ) - 20 CONTINUE -C - END IF -C - CALL DGEMM( 'NoTranspose', 'NoTranspose', N, N, N, ONE, A, LDA, A, - $ LDA, ONE, DWORK, N ) - IF ( SCALE .AND. N.GT.2 ) - $ CALL DLASET( 'Lower', N-2, N-2, ZERO, ZERO, DWORK(3), N ) -C 2 -C Find the eigenvalues of A' + G'Q'. -C - CALL DGEBAL( JOBSCL, N, DWORK, N, ILO, IHI, DWORK(1+N2), IGNORE ) - CALL DHSEQR( 'Eigenvalues', 'NoSchurVectors', N, ILO, IHI, DWORK, - $ N, WR, WI, DUMMY, 1, DWORK(1+N2), N, INFO ) - IF ( INFO.EQ.0 ) THEN -C -C Eigenvalues of H' are the square roots of those computed above. -C - DO 30 I = 1, N - X = WR(I) - Y = WI(I) - CALL MA01AD( X, Y, WR(I), WI(I) ) - 30 CONTINUE -C -C Sort eigenvalues into decreasing order by real part and, for -C eigenvalues with zero real part only, decreasing order of -C imaginary part. (This simple bubble sort preserves the -C relative order of eigenvalues with equal but nonzero real part. -C This ensures that complex conjugate pairs remain -C together.) -C - SORTED = .FALSE. -C - DO 50 M = N, 1, -1 - IF ( SORTED ) GO TO 60 - SORTED = .TRUE. -C - DO 40 I = 1, M - 1 - IF ( ( ( WR(I).LT.WR(I+1) ) .OR. - $ ( ( WR(I).EQ.ZERO ) .AND. ( WR(I+1).EQ.ZERO ) .AND. - $ ( WI(I).LT.WI(I+1) ) ) ) ) THEN - SWAP = WR(I) - WR(I) = WR(I+1) - WR(I+1) = SWAP - SWAP = WI(I) - WI(I) = WI(I+1) - WI(I+1) = SWAP -C - SORTED = .FALSE. -C - END IF - 40 CONTINUE -C - 50 CONTINUE -C - 60 CONTINUE -C - END IF -C - DWORK(1) = 2*N2 - RETURN -C *** Last line of MB03SD *** - END diff --git a/mex/sources/libslicot/MB03TD.f b/mex/sources/libslicot/MB03TD.f deleted file mode 100644 index 05561446d..000000000 --- a/mex/sources/libslicot/MB03TD.f +++ /dev/null @@ -1,641 +0,0 @@ - SUBROUTINE MB03TD( TYP, COMPU, SELECT, LOWER, N, A, LDA, G, LDG, - $ U1, LDU1, U2, LDU2, WR, WI, M, DWORK, LDWORK, - $ INFO ) -C -C SLICOT RELEASE 5.0. -C -C Copyright (c) 2002-2009 NICONET e.V. -C -C This program is free software: you can redistribute it and/or -C modify it under the terms of the GNU General Public License as -C published by the Free Software Foundation, either version 2 of -C the License, or (at your option) any later version. -C -C This program is distributed in the hope that it will be useful, -C but WITHOUT ANY WARRANTY; without even the implied warranty of -C MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the -C GNU General Public License for more details. -C -C You should have received a copy of the GNU General Public License -C along with this program. If not, see -C . -C -C PURPOSE -C -C To reorder a matrix X in skew-Hamiltonian Schur form: -C -C [ A G ] T -C X = [ T ], G = -G, -C [ 0 A ] -C -C or in Hamiltonian Schur form: -C -C [ A G ] T -C X = [ T ], G = G, -C [ 0 -A ] -C -C where A is in upper quasi-triangular form, so that a selected -C cluster of eigenvalues appears in the leading diagonal blocks -C of the matrix A (in X) and the leading columns of [ U1; -U2 ] form -C an orthonormal basis for the corresponding right invariant -C subspace. -C -C If X is skew-Hamiltonian, then each eigenvalue appears twice; one -C copy corresponds to the j-th diagonal element and the other to the -C (n+j)-th diagonal element of X. The logical array LOWER controls -C which copy is to be reordered to the leading part of A. -C -C If X is Hamiltonian then the eigenvalues appear in pairs -C (lambda,-lambda); lambda corresponds to the j-th diagonal -C element and -lambda to the (n+j)-th diagonal element of X. -C The logical array LOWER controls whether lambda or -lambda is to -C be reordered to the leading part of A. -C -C The matrix A must be in Schur canonical form (as returned by the -C LAPACK routine DHSEQR), that is, block upper triangular with -C 1-by-1 and 2-by-2 diagonal blocks; each 2-by-2 diagonal block has -C its diagonal elements equal and its off-diagonal elements of -C opposite sign. -C -C ARGUMENTS -C -C Mode Parameters -C -C TYP CHARACTER*1 -C Specifies the type of the input matrix X: -C = 'S': X is skew-Hamiltonian; -C = 'H': X is Hamiltonian. -C -C COMPU CHARACTER*1 -C = 'U': update the matrices U1 and U2 containing the -C Schur vectors; -C = 'N': do not update U1 and U2. -C -C SELECT (input/output) LOGICAL array, dimension (N) -C SELECT specifies the eigenvalues in the selected cluster. -C To select a real eigenvalue w(j), SELECT(j) must be set -C to .TRUE.. To select a complex conjugate pair of -C eigenvalues w(j) and w(j+1), corresponding to a 2-by-2 -C diagonal block, both SELECT(j) and SELECT(j+1) must be set -C to .TRUE.; a complex conjugate pair of eigenvalues must be -C either both included in the cluster or both excluded. -C -C LOWER (input/output) LOGICAL array, dimension (N) -C LOWER controls which copy of a selected eigenvalue is -C included in the cluster. If SELECT(j) is set to .TRUE. -C for a real eigenvalue w(j); then LOWER(j) must be set to -C .TRUE. if the eigenvalue corresponding to the (n+j)-th -C diagonal element of X is to be reordered to the leading -C part; and LOWER(j) must be set to .FALSE. if the -C eigenvalue corresponding to the j-th diagonal element of -C X is to be reordered to the leading part. Similarly, for -C a complex conjugate pair of eigenvalues w(j) and w(j+1), -C both LOWER(j) and LOWER(j+1) must be set to .TRUE. if the -C eigenvalues corresponding to the (n+j:n+j+1,n+j:n+j+1) -C diagonal block of X are to be reordered to the leading -C part. -C -C Input/Output Parameters -C -C N (input) INTEGER -C The order of the matrix A. N >= 0. -C -C A (input/output) DOUBLE PRECISION array, dimension (LDA,N) -C On entry, the leading N-by-N part of this array must -C contain the upper quasi-triangular matrix A in Schur -C canonical form. -C On exit, the leading N-by-N part of this array contains -C the reordered matrix A, again in Schur canonical form, -C with the selected eigenvalues in the diagonal blocks. -C -C LDA INTEGER -C The leading dimension of the array A. LDA >= MAX(1,N). -C -C G (input/output) DOUBLE PRECISION array, dimension (LDG,N) -C On entry, if TYP = 'S', the leading N-by-N part of this -C array must contain the strictly upper triangular part of -C the skew-symmetric matrix G. The rest of this array is not -C referenced. -C On entry, if TYP = 'H', the leading N-by-N part of this -C array must contain the upper triangular part of the -C symmetric matrix G. The rest of this array is not -C referenced. -C On exit, if TYP = 'S', the leading N-by-N part of this -C array contains the strictly upper triangular part of the -C skew-symmetric matrix G, updated by the orthogonal -C symplectic transformation which reorders X. -C On exit, if TYP = 'H', the leading N-by-N part of this -C array contains the upper triangular part of the symmetric -C matrix G, updated by the orthogonal symplectic -C transformation which reorders X. -C -C LDG INTEGER -C The leading dimension of the array G. LDG >= MAX(1,N). -C -C U1 (input/output) DOUBLE PRECISION array, dimension (LDU1,N) -C On entry, if COMPU = 'U', the leading N-by-N part of this -C array must contain U1, the (1,1) block of an orthogonal -C symplectic matrix U = [ U1, U2; -U2, U1 ]. -C On exit, if COMPU = 'U', the leading N-by-N part of this -C array contains the (1,1) block of the matrix U, -C postmultiplied by the orthogonal symplectic transformation -C which reorders X. The leading M columns of U form an -C orthonormal basis for the specified invariant subspace. -C If COMPU = 'N', this array is not referenced. -C -C LDU1 INTEGER -C The leading dimension of the array U1. -C LDU1 >= MAX(1,N), if COMPU = 'U'; -C LDU1 >= 1, otherwise. -C -C U2 (input/output) DOUBLE PRECISION array, dimension (LDU2,N) -C On entry, if COMPU = 'U', the leading N-by-N part of this -C array must contain U2, the (1,2) block of an orthogonal -C symplectic matrix U = [ U1, U2; -U2, U1 ]. -C On exit, if COMPU = 'U', the leading N-by-N part of this -C array contains the (1,2) block of the matrix U, -C postmultiplied by the orthogonal symplectic transformation -C which reorders X. -C If COMPU = 'N', this array is not referenced. -C -C LDU2 INTEGER -C The leading dimension of the array U2. -C LDU2 >= MAX(1,N), if COMPU = 'U'; -C LDU2 >= 1, otherwise. -C -C WR (output) DOUBLE PRECISION array, dimension (N) -C WI (output) DOUBLE PRECISION array, dimension (N) -C The real and imaginary parts, respectively, of the -C reordered eigenvalues of A. The eigenvalues are stored -C in the same order as on the diagonal of A, with -C WR(i) = A(i,i) and, if A(i:i+1,i:i+1) is a 2-by-2 diagonal -C block, WI(i) > 0 and WI(i+1) = -WI(i). Note that if an -C eigenvalue is sufficiently ill-conditioned, then its value -C may differ significantly from its value before reordering. -C -C M (output) INTEGER -C The dimension of the specified invariant subspace. -C 0 <= M <= N. -C -C Workspace -C -C DWORK DOUBLE PRECISION array, dimension (LDWORK) -C On exit, if INFO = 0, DWORK(1) returns the optimal -C value of LDWORK. -C On exit, if INFO = -18, DWORK(1) returns the minimum -C value of LDWORK. -C -C LDWORK INTEGER -C The length of the array DWORK. LDWORK >= MAX(1,N). -C -C Error Indicator -C -C INFO INTEGER -C = 0: successful exit; -C < 0: if INFO = -i, the i-th argument had an illegal -C value. -C = 1: reordering of X failed because some eigenvalue pairs -C are too close to separate (the problem is very -C ill-conditioned); X may have been partially -C reordered, and WR and WI contain the eigenvalues in -C the same order as in X. -C -C REFERENCES -C -C [1] Bai, Z. and Demmel, J.W. -C On Swapping Diagonal Blocks in Real Schur Form. -C Linear Algebra Appl., 186, pp. 73-95, 1993. -C -C [2] Benner, P., Kressner, D., and Mehrmann, V. -C Skew-Hamiltonian and Hamiltonian Eigenvalue Problems: Theory, -C Algorithms and Applications. Techn. Report, TU Berlin, 2003. -C -C CONTRIBUTORS -C -C D. Kressner, Technical Univ. Berlin, Germany, and -C P. Benner, Technical Univ. Chemnitz, Germany, December 2003. -C -C REVISIONS -C -C V. Sima, May 2008 (SLICOT version of the HAPACK routine DHAORD). -C -C KEYWORDS -C -C Hamiltonian matrix, skew-Hamiltonian matrix, invariant subspace. -C -C ****************************************************************** -C -C .. Parameters .. - DOUBLE PRECISION ZERO, ONE - PARAMETER ( ZERO = 0.0D0, ONE = 1.0D0 ) -C .. Scalar Arguments .. - CHARACTER COMPU, TYP - INTEGER INFO, LDA, LDG, LDU1, LDU2, LDWORK, M, N -C .. Array Arguments .. - LOGICAL LOWER(*), SELECT(*) - DOUBLE PRECISION A(LDA,*), DWORK(*), G(LDG,*), U1(LDU1,*), - $ U2(LDU2,*), WI(*), WR(*) -C .. Local Scalars .. - LOGICAL FLOW, ISHAM, PAIR, SWAP, WANTU - INTEGER HERE, IERR, IFST, ILST, K, KS, NBF, NBL, NBNEXT, - $ WRKMIN -C .. External Functions .. - LOGICAL LSAME - EXTERNAL LSAME -C .. External Subroutines .. - EXTERNAL MB03TS, XERBLA -C .. Intrinsic Functions .. - INTRINSIC DBLE, MAX -C -C .. Executable Statements .. -C -C Decode and check input parameters. -C - ISHAM = LSAME( TYP, 'H' ) - WANTU = LSAME( COMPU, 'U' ) - WRKMIN = MAX( 1, N ) - INFO = 0 - IF ( .NOT.ISHAM .AND. .NOT.LSAME( TYP, 'S' ) ) THEN - INFO = -1 - ELSE IF ( .NOT.WANTU .AND. .NOT.LSAME( COMPU, 'N' ) ) THEN - INFO = -2 - ELSE IF ( N.LT.0 ) THEN - INFO = -5 - ELSE IF ( LDA.LT.MAX( 1, N ) ) THEN - INFO = -7 - ELSE IF ( LDG.LT.MAX( 1, N ) ) THEN - INFO = -9 - ELSE IF ( LDU1.LT.1 .OR. ( WANTU .AND. LDU1.LT.N ) ) THEN - INFO = -11 - ELSE IF ( LDU2.LT.1 .OR. ( WANTU .AND. LDU2.LT.N ) ) THEN - INFO = -13 - ELSE IF ( LDWORK.LT.WRKMIN ) THEN - INFO = -18 - DWORK(1) = DBLE( WRKMIN ) - END IF -C -C Return if there were illegal values. -C - IF ( INFO.NE.0 ) THEN - CALL XERBLA( 'MB03TD', -INFO ) - RETURN - END IF -C -C Set M to the dimension of the specified invariant subspace. -C - M = 0 - PAIR = .FALSE. - DO 10 K = 1, N - IF ( PAIR ) THEN - PAIR = .FALSE. - ELSE - IF ( K.LT.N ) THEN - IF ( A(K+1,K).EQ.ZERO ) THEN - IF ( SELECT(K) ) - $ M = M + 1 - ELSE - PAIR = .TRUE. - IF ( SELECT(K) .OR. SELECT(K+1) ) - $ M = M + 2 - END IF - ELSE - IF ( SELECT(N) ) - $ M = M + 1 - END IF - END IF - 10 CONTINUE -C -C Quick return if possible. -C - IF ( N.EQ.0 ) THEN - DWORK(1) = ONE - RETURN - END IF -C -C Collect the selected blocks at the top-left corner of X. -C - KS = 0 - PAIR = .FALSE. - DO 60 K = 1, N - IF ( PAIR ) THEN - PAIR = .FALSE. - ELSE - SWAP = SELECT(K) - FLOW = LOWER(K) - IF ( K.LT.N ) THEN - IF ( A(K+1,K).NE.ZERO ) THEN - PAIR = .TRUE. - SWAP = SWAP.OR.SELECT(K+1) - FLOW = FLOW.OR.LOWER(K+1) - END IF - END IF -C - IF ( PAIR ) THEN - NBF = 2 - ELSE - NBF = 1 - END IF -C - IF ( SWAP ) THEN - KS = KS + 1 - IF ( FLOW ) THEN -C -C Step 1: Swap the K-th block to position N. -C - IFST = K - ILST = N - NBL = 1 - IF ( ILST.GT.1 ) THEN - IF ( A(ILST,ILST-1).NE.ZERO ) THEN - ILST = ILST - 1 - NBL = 2 - END IF - END IF -C -C Update ILST. -C - IF ( NBF.EQ.2 .AND. NBL.EQ.1 ) - $ ILST = ILST - 1 - IF ( NBF.EQ.1 .AND. NBL.EQ.2 ) - $ ILST = ILST + 1 -C - IF ( ILST.EQ.IFST ) - $ GO TO 30 -C - HERE = IFST -C - 20 CONTINUE -C -C Swap block with next one below. -C - IF ( NBF.EQ.1 .OR. NBF.EQ.2 ) THEN -C -C Current block is either 1-by-1 or 2-by-2. -C - NBNEXT = 1 - IF ( HERE+NBF+1.LE.N ) THEN - IF ( A(HERE+NBF+1,HERE+NBF).NE.ZERO ) - $ NBNEXT = 2 - END IF - CALL MB03TS( ISHAM, WANTU, N, A, LDA, G, LDG, U1, - $ LDU1, U2, LDU2, HERE, NBF, NBNEXT, - $ DWORK, IERR ) - IF ( IERR.NE.0 ) THEN - INFO = 1 - GO TO 70 - END IF - HERE = HERE + NBNEXT -C -C Test if 2-by-2 block breaks into two 1-by-1 blocks. -C - IF ( NBF.EQ.2 ) THEN - IF ( A(HERE+1,HERE).EQ.ZERO ) - $ NBF = 3 - END IF -C - ELSE -C -C Current block consists of two 1-by-1 blocks each of -C which must be swapped individually. -C - NBNEXT = 1 - IF ( HERE+3.LE.N ) THEN - IF ( A(HERE+3,HERE+2).NE.ZERO ) - $ NBNEXT = 2 - END IF - CALL MB03TS( ISHAM, WANTU, N, A, LDA, G, LDG, U1, - $ LDU1, U2, LDU2, HERE+1, 1, NBNEXT, - $ DWORK, IERR ) - IF ( IERR.NE.0 ) THEN - INFO = 1 - GO TO 70 - END IF - IF ( NBNEXT.EQ.1 ) THEN -C -C Swap two 1-by-1 blocks, no problems possible. -C - CALL MB03TS( ISHAM, WANTU, N, A, LDA, G, LDG, - $ U1, LDU1, U2, LDU2, HERE, 1, - $ NBNEXT, DWORK, IERR ) - HERE = HERE + 1 - ELSE -C -C Recompute NBNEXT in case 2 by 2 split. -C - IF ( A(HERE+2,HERE+1).EQ.ZERO ) - $ NBNEXT = 1 - IF ( NBNEXT.EQ.2 ) THEN -C -C 2-by-2 block did not split -C - CALL MB03TS( ISHAM, WANTU, N, A, LDA, G, LDG, - $ U1, LDU1, U2, LDU2, HERE, 1, - $ NBNEXT, DWORK, IERR ) - IF ( IERR.NE.0 ) THEN - INFO = 1 - GO TO 70 - END IF - HERE = HERE + 2 - ELSE -C -C 2-by-2 block did split -C - CALL MB03TS( ISHAM, WANTU, N, A, LDA, G, LDG, - $ U1, LDU1, U2, LDU2, HERE, 1, 1, - $ DWORK, IERR ) - CALL MB03TS( ISHAM, WANTU, N, A, LDA, G, LDG, - $ U1, LDU1, U2, LDU2, HERE+1, 1, - $ 1, DWORK, IERR ) - HERE = HERE + 2 - END IF - END IF - END IF - IF ( HERE.LT.ILST ) - $ GO TO 20 -C - 30 CONTINUE -C -C Step 2: Apply an orthogonal symplectic transformation -C to swap the last blocks in A and -A' (or A'). -C - IF ( NBF.EQ.1 ) THEN -C -C Exchange columns/rows N <-> 2*N. No problems -C possible. -C - CALL MB03TS( ISHAM, WANTU, N, A, LDA, G, LDG, - $ U1, LDU1, U2, LDU2, N, 1, 1, - $ DWORK, IERR ) -C - ELSE IF ( NBF.EQ.2 ) THEN -C -C Swap last block with its equivalent by an -C orthogonal symplectic transformation. -C - CALL MB03TS( ISHAM, WANTU, N, A, LDA, G, LDG, - $ U1, LDU1, U2, LDU2, N-1, 2, 2, - $ DWORK, IERR ) - IF ( IERR.NE.0 ) THEN - INFO = 1 - GO TO 70 - END IF -C -C Test if 2-by-2 block breaks into two 1-by-1 blocks. -C - IF ( A(N-1,N).EQ.ZERO ) - $ NBF = 3 - ELSE -C -C Block did split. Swap (N-1)-th and N-th elements -C consecutively by symplectic generalized -C permutations and one rotation. -C - CALL MB03TS( ISHAM, WANTU, N, A, LDA, G, LDG, U1, - $ LDU1, U2, LDU2, N, 1, 1, DWORK, IERR ) - CALL MB03TS( ISHAM, WANTU, N, A, LDA, G, LDG, U1, - $ LDU1, U2, LDU2, N-1, 1, 1, DWORK, - $ IERR ) - CALL MB03TS( ISHAM, WANTU, N, A, LDA, G, LDG, U1, - $ LDU1, U2, LDU2, N, 1, 1, DWORK, IERR ) - END IF - IFST = N - IF ( PAIR ) - $ IFST = N-1 - ELSE - IFST = K - END IF -C -C Step 3: Swap the K-th / N-th block to position KS. -C - ILST = KS - NBL = 1 - IF ( ILST.GT.1 ) THEN - IF ( A(ILST,ILST-1).NE.ZERO ) THEN - ILST = ILST - 1 - NBL = 2 - END IF - END IF -C - IF ( ILST.EQ.IFST ) - $ GO TO 50 -C - HERE = IFST - 40 CONTINUE -C -C Swap block with next one above. -C - IF ( NBF.EQ.1 .OR. NBF.EQ.2 ) THEN -C -C Current block either 1 by 1 or 2 by 2. -C - NBNEXT = 1 - IF ( HERE.GE.3 ) THEN - IF ( A(HERE-1,HERE-2).NE.ZERO ) - $ NBNEXT = 2 - END IF - CALL MB03TS( ISHAM, WANTU, N, A, LDA, G, LDG, U1, - $ LDU1, U2, LDU2, HERE-NBNEXT, NBNEXT, - $ NBF, DWORK, IERR ) - IF ( IERR.NE.0 ) THEN - INFO = 1 - GO TO 70 - END IF - HERE = HERE - NBNEXT -C -C Test if 2-by-2 block breaks into two 1-by-1 blocks. -C - IF ( NBF.EQ.2 ) THEN - IF ( A(HERE+1,HERE).EQ.ZERO ) - $ NBF = 3 - END IF -C - ELSE -C -C Current block consists of two 1 by 1 blocks each of -C which must be swapped individually. -C - NBNEXT = 1 - IF ( HERE.GE.3 ) THEN - IF ( A(HERE-1,HERE-2).NE.ZERO ) - $ NBNEXT = 2 - END IF - CALL MB03TS( ISHAM, WANTU, N, A, LDA, G, LDG, U1, - $ LDU1, U2, LDU2, HERE-NBNEXT, NBNEXT, - $ 1, DWORK, IERR ) - IF ( IERR.NE.0 ) THEN - INFO = 1 - GO TO 70 - END IF - IF ( NBNEXT.EQ.1 ) THEN -C -C Swap two 1-by-1 blocks, no problems possible. -C - CALL MB03TS( ISHAM, WANTU, N, A, LDA, G, LDG, U1, - $ LDU1, U2, LDU2, HERE, NBNEXT, 1, - $ DWORK, IERR ) - - HERE = HERE - 1 - ELSE -C -C Recompute NBNEXT in case 2-by-2 split. -C - IF ( A(HERE,HERE-1).EQ.ZERO ) - $ NBNEXT = 1 - IF ( NBNEXT.EQ.2 ) THEN -C -C 2-by-2 block did not split -C - CALL MB03TS( ISHAM, WANTU, N, A, LDA, G, LDG, - $ U1, LDU1, U2, LDU2, HERE-1, 2, 1, - $ DWORK, IERR ) - IF ( IERR.NE.0 ) THEN - INFO = 1 - GO TO 70 - END IF - HERE = HERE - 2 - ELSE -C -C 2-by-2 block did split -C - CALL MB03TS( ISHAM, WANTU, N, A, LDA, G, LDG, - $ U1, LDU1, U2, LDU2, HERE, 1, 1, - $ DWORK, IERR ) - CALL MB03TS( ISHAM, WANTU, N, A, LDA, G, LDG, - $ U1, LDU1, U2, LDU2, HERE-1, 1, 1, - $ DWORK, IERR ) - HERE = HERE - 2 - END IF - END IF - END IF -C - IF ( HERE.GT.ILST ) - $ GO TO 40 -C - 50 CONTINUE - IF ( PAIR ) - $ KS = KS + 1 - END IF - END IF - 60 CONTINUE -C - 70 CONTINUE -C -C Store eigenvalues. -C - DO 80 K = 1, N - WR(K) = A(K,K) - WI(K) = ZERO - 80 CONTINUE - DO 90 K = 1, N - 1 - IF ( A(K+1,K).NE.ZERO ) THEN - WI(K) = SQRT( ABS( A(K,K+1) ) )* - $ SQRT( ABS( A(K+1,K) ) ) - WI(K+1) = -WI(K) - END IF - 90 CONTINUE -C - DWORK(1) = DBLE( WRKMIN ) -C - RETURN -C *** Last line of MB03TD *** - END diff --git a/mex/sources/libslicot/MB03TS.f b/mex/sources/libslicot/MB03TS.f deleted file mode 100644 index 202e72f5b..000000000 --- a/mex/sources/libslicot/MB03TS.f +++ /dev/null @@ -1,746 +0,0 @@ - SUBROUTINE MB03TS( ISHAM, WANTU, N, A, LDA, G, LDG, U1, LDU1, U2, - $ LDU2, J1, N1, N2, DWORK, INFO ) -C -C SLICOT RELEASE 5.0. -C -C Copyright (c) 2002-2009 NICONET e.V. -C -C This program is free software: you can redistribute it and/or -C modify it under the terms of the GNU General Public License as -C published by the Free Software Foundation, either version 2 of -C the License, or (at your option) any later version. -C -C This program is distributed in the hope that it will be useful, -C but WITHOUT ANY WARRANTY; without even the implied warranty of -C MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the -C GNU General Public License for more details. -C -C You should have received a copy of the GNU General Public License -C along with this program. If not, see -C . -C -C PURPOSE -C -C To swap diagonal blocks A11 and A22 of order 1 or 2 in the upper -C quasi-triangular matrix A contained in a skew-Hamiltonian matrix -C -C [ A G ] T -C X = [ T ], G = -G, -C [ 0 A ] -C -C or in a Hamiltonian matrix -C -C [ A G ] T -C X = [ T ], G = G. -C [ 0 -A ] -C -C This routine is a modified version of the LAPACK subroutine -C DLAEX2. -C -C The matrix A must be in Schur canonical form (as returned by the -C LAPACK routine DHSEQR), that is, block upper triangular with -C 1-by-1 and 2-by-2 diagonal blocks; each 2-by-2 diagonal block has -C its diagonal elements equal and its off-diagonal elements of -C opposite sign. -C -C ARGUMENTS -C -C Mode Parameters -C -C ISHAM LOGIGAL -C Specifies the type of X: -C = .TRUE.: X is a Hamiltonian matrix; -C = .FALSE.: X is a skew-Hamiltonian matrix. -C -C WANTU LOGIGAL -C = .TRUE.: update the matrices U1 and U2 containing the -C Schur vectors; -C = .FALSE.: do not update U1 and U2. -C -C Input/Output Parameters -C -C N (input) INTEGER -C The order of the matrix A. N >= 0. -C -C A (input/output) DOUBLE PRECISION array, dimension (LDA,N) -C On entry, the leading N-by-N part of this array must -C contain the upper quasi-triangular matrix A, in Schur -C canonical form. -C On exit, the leading N-by-N part of this array contains -C the reordered matrix A, again in Schur canonical form. -C -C LDA INTEGER -C The leading dimension of the array A. LDA >= MAX(1,N). -C -C G (input/output) DOUBLE PRECISION array, dimension (LDG,N) -C On entry, the leading N-by-N part of this array must -C contain the upper triangular part of the symmetric -C matrix G, if ISHAM = .TRUE., or the strictly upper -C triangular part of the skew-symmetric matrix G, otherwise. -C The rest of this array is not referenced. -C On exit, the leading N-by-N part of this array contains -C the upper or strictly upper triangular part of the -C symmetric or skew-symmetric matrix G, respectively, -C updated by the orthogonal transformation which reorders A. -C -C LDG INTEGER -C The leading dimension of the array G. LDG >= MAX(1,N). -C -C U1 (input/output) DOUBLE PRECISION array, dimension (LDU1,N) -C On entry, if WANTU = .TRUE., the leading N-by-N part of -C this array must contain the matrix U1. -C On exit, if WANTU = .TRUE., the leading N-by-N part of -C this array contains U1, postmultiplied by the orthogonal -C transformation which reorders A. See the description in -C the SLICOT subroutine MB03TD for further details. -C If WANTU = .FALSE., this array is not referenced. -C -C LDU1 INTEGER -C The leading dimension of the array U1. -C LDU1 >= MAX(1,N), if WANTU = .TRUE.; -C LDU1 >= 1, otherwise. -C -C U2 (input/output) DOUBLE PRECISION array, dimension (LDU2,N) -C On entry, if WANTU = .TRUE., the leading N-by-N part of -C this array must contain the matrix U2. -C On exit, if WANTU = .TRUE., the leading N-by-N part of -C this array contains U2, postmultiplied by the orthogonal -C transformation which reorders A. -C If WANTU = .FALSE., this array is not referenced. -C -C LDU2 INTEGER -C The leading dimension of the array U2. -C LDU2 >= MAX(1,N), if WANTU = .TRUE.; -C LDU2 >= 1, otherwise. -C -C J1 (input) INTEGER -C The index of the first row of the first block A11. -C If J1+N1 < N, then A11 is swapped with the block starting -C at (J1+N1+1)-th diagonal element. -C If J1+N1 > N, then A11 is the last block in A and swapped -C with -A11', if ISHAM = .TRUE., -C or A11', if ISHAM = .FALSE.. -C -C N1 (input) INTEGER -C The order of the first block A11. N1 = 0, 1 or 2. -C -C N2 (input) INTEGER -C The order of the second block A22. N2 = 0, 1 or 2. -C -C Workspace -C -C DWORK DOUBLE PRECISION array, dimension (N) -C -C Error Indicator -C -C INFO INTEGER -C = 0: successful exit; -C = 1: the transformed matrix A would be too far from Schur -C form; the blocks are not swapped and A, G, U1 and -C U2 are unchanged. -C -C REFERENCES -C -C [1] Bai, Z., and Demmel, J.W. -C On swapping diagonal blocks in real Schur form. -C Linear Algebra Appl., 186, pp. 73-95, 1993. -C -C [2] Benner, P., Kressner, D., and Mehrmann, V. -C Skew-Hamiltonian and Hamiltonian Eigenvalue Problems: Theory, -C Algorithms and Applications. Techn. Report, TU Berlin, 2003. -C -C CONTRIBUTORS -C -C D. Kressner, Technical Univ. Berlin, Germany, and -C P. Benner, Technical Univ. Chemnitz, Germany, December 2003. -C -C REVISIONS -C -C V. Sima, May 2008 (SLICOT version of the HAPACK routine DHAEX2). -C -C ****************************************************************** -C -C .. Parameters .. - DOUBLE PRECISION ZERO, HALF, ONE, TWO, THIRTY, FORTY - PARAMETER ( ZERO = 0.0D+0, HALF = 0.5D+0, ONE = 1.0D+0, - $ TWO = 2.0D+0, THIRTY = 3.0D+1, - $ FORTY = 4.0D+1 ) - INTEGER LDD, LDX - PARAMETER ( LDD = 4, LDX = 2 ) -C .. Scalar Arguments .. - LOGICAL ISHAM, WANTU - INTEGER INFO, J1, LDA, LDG, LDU1, LDU2, N, N1, N2 -C .. Array Arguments .. - DOUBLE PRECISION A(LDA,*), DWORK(*), G(LDG,*), U1(LDU1,*), - $ U2(LDU2,*) -C .. Local Scalars .. - LOGICAL LBLK - INTEGER IERR, J2, J3, J4, K, ND - DOUBLE PRECISION A11, A22, A33, CS, DNORM, EPS, SCALE, SMLNUM, - $ SN, TAU, TAU1, TAU2, TEMP, THRESH, WI1, WI2, - $ WR1, WR2, XNORM -C .. Local Arrays .. - DOUBLE PRECISION D(LDD,4), V(3), V1(3), V2(3), X(LDX,2) -C .. External Functions .. - DOUBLE PRECISION DDOT, DLAMCH, DLANGE - EXTERNAL DDOT, DLAMCH, DLANGE -C .. External Subroutines .. - EXTERNAL DAXPY, DLACPY, DLANV2, DLARFG, DLARFX, DLARTG, - $ DLASET, DLASY2, DROT, DSCAL, DSWAP, DSYMV, - $ DSYR2, MB01MD, MB01ND -C .. Intrinsic Functions .. - INTRINSIC ABS, MAX -C -C .. Executable Statements .. -C - INFO = 0 -C -C Quick return if possible. -C - IF ( N.EQ.0 .OR. N1.EQ.0 .OR. N2.EQ.0 ) - $ RETURN - LBLK = ( J1+N1.GT.N ) -C - J2 = J1 + 1 - J3 = J1 + 2 - J4 = J1 + 3 -C - IF ( LBLK .AND. N1.EQ.1 ) THEN -C - IF ( ISHAM ) THEN - A11 = A(N,N) - CALL DLARTG( G(N,N), -TWO*A11, CS, SN, TEMP ) - CALL DROT( N-1, A(1,N), 1, G(1,N), 1, CS, SN ) - A(N,N) = -A11 - IF ( WANTU ) - $ CALL DROT( N, U1(1,N), 1, U2(1,N), 1, CS, SN ) - ELSE - CALL DSWAP( N-1, A(1,N), 1, G(1,N), 1 ) - CALL DSCAL( N-1, -ONE, A(1,N), 1 ) - IF ( WANTU ) THEN - CALL DSWAP( N, U1(1,N), 1, U2(1,N), 1 ) - CALL DSCAL( N, -ONE, U1(1,N), 1 ) - END IF - END IF -C - ELSE IF ( LBLK .AND. N1.EQ.2 ) THEN -C - IF ( ISHAM ) THEN -C -C Reorder Hamiltonian matrix: -C -C [ A11 G11 ] -C [ T ]. -C [ 0 -A11 ] -C - ND = 4 - CALL DLACPY( 'Full', 2, 2, A(N-1,N-1), LDA, D, LDD ) - CALL DLASET( 'All', 2, 2, ZERO, ZERO, D(3,1), LDD ) - CALL DLACPY( 'Upper', 2, 2, G(N-1,N-1), LDG, D(1,3), LDD ) - D(2,3) = D(1,4) - D(3,3) = -D(1,1) - D(4,3) = -D(1,2) - D(3,4) = -D(2,1) - D(4,4) = -D(2,2) - DNORM = DLANGE( 'Max', ND, ND, D, LDD, DWORK ) -C -C Compute machine-dependent threshold for test for accepting -C swap. -C - EPS = DLAMCH( 'P' ) - SMLNUM = DLAMCH( 'S' ) / EPS - THRESH = MAX( FORTY*EPS*DNORM, SMLNUM ) -C -C Solve A11*X + X*A11' = scale*G11 for X. -C - CALL DLASY2( .FALSE., .FALSE., -1, 2, 2, D, LDD, D(3,3), - $ LDD, D(1,3), LDD, SCALE, X, LDX, XNORM, IERR ) -C -C Compute symplectic QR decomposition of -C -C ( -X11 -X12 ) -C ( -X21 -X22 ). -C ( scale 0 ) -C ( 0 scale ) -C - TEMP = -X(1,1) - CALL DLARTG( TEMP, SCALE, V1(1), V2(1), X(1,1) ) - CALL DLARTG( X(1,1), -X(2,1), V1(2), V2(2), TEMP ) - X(1,2) = -X(1,2) - X(2,2) = -X(2,2) - X(1,1) = ZERO - X(2,1) = SCALE - CALL DROT( 1, X(1,2), 1, X(1,1), 1, V1(1), V2(1) ) - CALL DROT( 1, X(1,2), 1, X(2,2), 1, V1(2), V2(2) ) - CALL DROT( 1, X(1,1), 1, X(2,1), 1, V1(2), V2(2) ) - CALL DLARTG( X(2,2), X(2,1), V1(3), V2(3), TEMP ) -C -C Perform swap provisionally on D. -C - CALL DROT( 4, D(1,1), LDD, D(3,1), LDD, V1(1), V2(1) ) - CALL DROT( 4, D(1,1), LDD, D(2,1), LDD, V1(2), V2(2) ) - CALL DROT( 4, D(3,1), LDD, D(4,1), LDD, V1(2), V2(2) ) - CALL DROT( 4, D(2,1), LDD, D(4,1), LDD, V1(3), V2(3) ) - CALL DROT( 4, D(1,1), 1, D(1,3), 1, V1(1), V2(1) ) - CALL DROT( 4, D(1,1), 1, D(1,2), 1, V1(2), V2(2) ) - CALL DROT( 4, D(1,3), 1, D(1,4), 1, V1(2), V2(2) ) - CALL DROT( 4, D(1,2), 1, D(1,4), 1, V1(3), V2(3) ) -C -C Test whether to reject swap. -C - IF ( MAX( ABS( D(3,1) ), ABS( D(3,2) ), ABS( D(4,1) ), - $ ABS( D(4,2) ) ).GT.THRESH ) GO TO 50 -C - CALL DLACPY( 'All', 2, 2, D(1,1), LDD, A(N-1,N-1), LDA ) - CALL DLACPY( 'Upper', 2, 2, D(1,3), LDD, G(N-1,N-1), LDG ) -C - IF ( N.GT.2 ) THEN - CALL DROT( N-2, A(1,N-1), 1, G(1,N-1), 1, V1(1), V2(1) ) - CALL DROT( N-2, A(1,N-1), 1, A(1,N), 1, V1(2), V2(2) ) - CALL DROT( N-2, G(1,N-1), 1, G(1,N), 1, V1(2), V2(2) ) - CALL DROT( N-2, A(1,N), 1, G(1,N), 1, V1(3), V2(3) ) - END IF -C - IF ( WANTU ) THEN - CALL DROT( N, U1(1,N-1), 1, U2(1,N-1), 1, V1(1), V2(1) ) - CALL DROT( N, U1(1,N-1), 1, U1(1,N), 1, V1(2), V2(2) ) - CALL DROT( N, U2(1,N-1), 1, U2(1,N), 1, V1(2), V2(2) ) - CALL DROT( N, U1(1,N), 1, U2(1,N), 1, V1(3), V2(3) ) - END IF -C - ELSE -C - IF ( ABS( A(N-1,N) ).GT.ABS( A(N,N-1) ) ) THEN - TEMP = G(N-1,N) - CALL DLARTG( TEMP, A(N-1,N), CS, SN, G(N-1,N) ) - SN = -SN - CALL DROT(N-2, A(1,N), 1, G(1,N), 1, CS, SN ) -C - A(N-1,N) = -SN*A(N,N-1) - TEMP = -CS*A(N,N-1) - A(N,N-1) = G(N-1,N) - G(N-1,N) = TEMP - IF ( WANTU ) - $ CALL DROT( N, U1(1,N), 1, U2(1,N), 1, CS, SN ) - CALL DSWAP( N-2, A(1,N-1), 1, G(1,N-1), 1 ) - CALL DSCAL( N-2, -ONE, A(1,N-1), 1 ) - IF ( WANTU ) THEN - CALL DSWAP( N, U1(1,N-1), 1, U2(1,N-1), 1 ) - CALL DSCAL( N, -ONE, U1(1,N-1), 1 ) - END IF - ELSE - TEMP = G(N-1,N) - CALL DLARTG( TEMP, A(N,N-1), CS, SN, G(N-1,N) ) - CALL DROT( N-2, A(1,N-1), 1, G(1,N-1), 1, CS, SN ) - A(N,N-1) = -SN*A(N-1,N) - A(N-1,N) = CS*A(N-1,N) - IF ( WANTU ) - $ CALL DROT( N, U1(1,N-1), 1, U2(1,N-1), 1, CS, SN ) - CALL DSWAP( N-1, A(1,N), 1, G(1,N), 1 ) - CALL DSCAL( N-1, -ONE, A(1,N), 1 ) - IF ( WANTU ) THEN - CALL DSWAP( N, U1(1,N), 1, U2(1,N), 1 ) - CALL DSCAL( N, -ONE, U1(1,N), 1 ) - END IF - END IF - END IF -C -C Standardize new 2-by-2 block. -C - CALL DLANV2( A(N-1,N-1), A(N-1,N), A(N,N-1), - $ A(N,N), WR1, WI1, WR2, WI2, CS, SN ) - CALL DROT( N-2, A(1,N-1), 1, A(1,N), 1, CS, SN ) - IF ( ISHAM ) THEN - TEMP = G(N-1,N) - CALL DROT( N-1, G(1,N-1), 1, G(1,N), 1, CS, SN ) - TAU = CS*TEMP + SN*G(N,N) - G(N,N) = CS*G(N,N) - SN*TEMP - G(N-1,N-1) = CS*G(N-1,N-1) + SN*TAU - CALL DROT( 1, G(N-1,N), LDG, G(N,N), LDG, CS, SN ) - ELSE - CALL DROT( N-2, G(1,N-1), 1, G(1,N), 1, CS, SN ) - END IF - IF ( WANTU ) THEN - CALL DROT( N, U1(1,N-1), 1, U1(1,N), 1, CS, SN ) - CALL DROT( N, U2(1,N-1), 1, U2(1,N), 1, CS, SN ) - END IF -C - ELSE IF ( N1.EQ.1 .AND. N2.EQ.1 ) THEN -C -C Swap two 1-by-1 blocks. -C - A11 = A(J1,J1) - A22 = A(J2,J2) -C -C Determine the transformation to perform the interchange. -C - CALL DLARTG( A(J1,J2), A22-A11, CS, SN, TEMP ) -C -C Apply transformation to the matrix A. -C - IF ( J3.LE.N ) - $ CALL DROT( N-J1-1, A(J1,J3), LDA, A(J2,J3), LDA, CS, SN ) - CALL DROT( J1-1, A(1,J1), 1, A(1,J2), 1, CS, SN ) -C - A(J1,J1) = A22 - A(J2,J2) = A11 -C -C Apply transformation to the matrix G. -C - IF ( ISHAM ) THEN - TEMP = G(J1,J2) - CALL DROT( J1, G(1,J1), 1, G(1,J2), 1, CS, SN ) - TAU = CS*TEMP + SN*G(J2,J2) - G(J2,J2) = CS*G(J2,J2) - SN*TEMP - G(J1,J1) = CS*G(J1,J1) + SN*TAU - CALL DROT( N-J1, G(J1,J2), LDG, G(J2,J2), LDG, CS, SN ) - ELSE - IF ( N.GT.J1+1 ) - $ CALL DROT( N-J1-1, G(J1,J1+2), LDG, G(J2,J1+2), LDG, CS, - $ SN ) - CALL DROT( J1-1, G(1,J1), 1, G(1,J2), 1, CS, SN ) - END IF - IF ( WANTU ) THEN -C -C Accumulate transformation in the matrices U1 and U2. -C - CALL DROT( N, U1(1,J1), 1, U1(1,J2), 1, CS, SN ) - CALL DROT( N, U2(1,J1), 1, U2(1,J2), 1, CS, SN ) - END IF -C - ELSE -C -C Swapping involves at least one 2-by-2 block. -C -C Copy the diagonal block of order N1+N2 to the local array D -C and compute its norm. -C - ND = N1 + N2 - CALL DLACPY( 'Full', ND, ND, A(J1,J1), LDA, D, LDD ) - DNORM = DLANGE( 'Max', ND, ND, D, LDD, DWORK ) -C -C Compute machine-dependent threshold for test for accepting -C swap. -C - EPS = DLAMCH( 'P' ) - SMLNUM = DLAMCH( 'S' ) / EPS - THRESH = MAX( THIRTY*EPS*DNORM, SMLNUM ) -C -C Solve A11*X - X*A22 = scale*A12 for X. -C - CALL DLASY2( .FALSE., .FALSE., -1, N1, N2, D, LDD, - $ D(N1+1,N1+1), LDD, D(1,N1+1), LDD, SCALE, X, LDX, - $ XNORM, IERR ) -C -C Swap the adjacent diagonal blocks. -C - K = N1 + N1 + N2 - 3 - GO TO ( 10, 20, 30 )K -C - 10 CONTINUE -C -C N1 = 1, N2 = 2: generate elementary reflector H so that: -C -C ( scale, X11, X12 ) H = ( 0, 0, * ). -C - V(1) = SCALE - V(2) = X(1,1) - V(3) = X(1,2) - CALL DLARFG( 3, V(3), V, 1, TAU ) - V(3) = ONE - A11 = A(J1,J1) -C -C Perform swap provisionally on diagonal block in D. -C - CALL DLARFX( 'Left', 3, 3, V, TAU, D, LDD, DWORK ) - CALL DLARFX( 'Right', 3, 3, V, TAU, D, LDD, DWORK ) -C -C Test whether to reject swap. -C - IF ( MAX( ABS( D(3,1) ), ABS( D(3,2) ), ABS( D(3,3)-A11 ) ) - $ .GT.THRESH ) GO TO 50 -C -C Accept swap: apply transformation to the entire matrix A. -C - CALL DLARFX( 'Left', 3, N-J1+1, V, TAU, A(J1,J1), LDA, DWORK ) - CALL DLARFX( 'Right', J2, 3, V, TAU, A(1,J1), LDA, DWORK ) -C - A(J3,J1) = ZERO - A(J3,J2) = ZERO - A(J3,J3) = A11 -C -C Apply transformation to G. -C - IF ( ISHAM ) THEN - CALL DLARFX( 'Right', J1-1, 3, V, TAU, G(1,J1), LDG, DWORK ) - CALL DSYMV( 'Upper', 3, TAU, G(J1,J1), LDG, V, 1, ZERO, - $ DWORK, 1 ) - TEMP = -HALF*TAU*DDOT( 3, DWORK, 1, V, 1 ) - CALL DAXPY( 3, TEMP, V, 1, DWORK, 1 ) - CALL DSYR2( 'Upper', 3, -ONE, V, 1, DWORK, 1, - $ G(J1,J1), LDG ) - IF ( N.GT.J1+2 ) - $ CALL DLARFX( 'Left', 3, N-J1-2, V, TAU, G(J1,J1+3), LDG, - $ DWORK ) - ELSE - CALL DLARFX( 'Right', J1-1, 3, V, TAU, G(1,J1), LDG, DWORK ) - CALL MB01MD( 'Upper', 3, TAU, G(J1,J1), LDG, V, 1, ZERO, - $ DWORK, 1 ) - CALL MB01ND( 'Upper', 3, ONE, V, 1, DWORK, 1, G(J1,J1), - $ LDG ) - IF ( N.GT.J1+2 ) - $ CALL DLARFX( 'Left', 3, N-J1-2, V, TAU, G(J1,J1+3), LDG, - $ DWORK ) - END IF -C - IF ( WANTU ) THEN -C -C Accumulate transformation in the matrices U1 and U2. -C - CALL DLARFX( 'R', N, 3, V, TAU, U1(1,J1), LDU1, DWORK ) - CALL DLARFX( 'R', N, 3, V, TAU, U2(1,J1), LDU2, DWORK ) - END IF - GO TO 40 -C - 20 CONTINUE -C -C N1 = 2, N2 = 1: generate elementary reflector H so that: -C -C H ( -X11 ) = ( * ) -C ( -X21 ) = ( 0 ). -C ( scale ) = ( 0 ) -C - V(1) = -X(1,1) - V(2) = -X(2,1) - V(3) = SCALE - CALL DLARFG( 3, V(1), V(2), 1, TAU ) - V(1) = ONE - A33 = A(J3,J3) -C -C Perform swap provisionally on diagonal block in D. -C - CALL DLARFX( 'L', 3, 3, V, TAU, D, LDD, DWORK ) - CALL DLARFX( 'R', 3, 3, V, TAU, D, LDD, DWORK ) -C -C Test whether to reject swap. -C - IF ( MAX( ABS( D(2,1) ), ABS( D(3,1) ), ABS( D(1,1)-A33 ) ) - $ .GT. THRESH ) GO TO 50 -C -C Accept swap: apply transformation to the entire matrix A. -C - CALL DLARFX( 'Right', J3, 3, V, TAU, A(1,J1), LDA, DWORK ) - CALL DLARFX( 'Left', 3, N-J1, V, TAU, A(J1,J2), LDA, DWORK ) -C - A(J1,J1) = A33 - A(J2,J1) = ZERO - A(J3,J1) = ZERO -C -C Apply transformation to G. -C - IF ( ISHAM ) THEN - CALL DLARFX( 'Right', J1-1, 3, V, TAU, G(1,J1), LDG, DWORK ) - CALL DSYMV( 'Upper', 3, TAU, G(J1,J1), LDG, V, 1, ZERO, - $ DWORK, 1 ) - TEMP = -HALF*TAU*DDOT( 3, DWORK, 1, V, 1 ) - CALL DAXPY( 3, TEMP, V, 1, DWORK, 1 ) - CALL DSYR2( 'Upper', 3, -ONE, V, 1, DWORK, 1, G(J1,J1), - $ LDG ) - IF ( N.GT.J1+2 ) - $ CALL DLARFX( 'Left', 3, N-J1-2, V, TAU, G(J1,J1+3), LDG, - $ DWORK ) - ELSE - CALL DLARFX( 'Right', J1-1, 3, V, TAU, G(1,J1), LDG, DWORK ) - CALL MB01MD( 'Upper', 3, TAU, G(J1,J1), LDG, V, 1, ZERO, - $ DWORK, 1 ) - CALL MB01ND( 'Upper', 3, ONE, V, 1, DWORK, 1, G(J1,J1), - $ LDG ) - IF ( N.GT.J1+2 ) - $ CALL DLARFX( 'Left', 3, N-J1-2, V, TAU, G(J1,J1+3), LDG, - $ DWORK ) - END IF -C - IF ( WANTU ) THEN -C -C Accumulate transformation in the matrices U1 and U2. -C - CALL DLARFX( 'R', N, 3, V, TAU, U1(1,J1), LDU1, DWORK ) - CALL DLARFX( 'R', N, 3, V, TAU, U2(1,J1), LDU2, DWORK ) - END IF - GO TO 40 -C - 30 CONTINUE -C -C N1 = 2, N2 = 2: generate elementary reflectors H(1) and H(2) so -C that: -C -C H(2) H(1) ( -X11 -X12 ) = ( * * ) -C ( -X21 -X22 ) ( 0 * ). -C ( scale 0 ) ( 0 0 ) -C ( 0 scale ) ( 0 0 ) -C - V1(1) = -X(1,1) - V1(2) = -X(2,1) - V1(3) = SCALE - CALL DLARFG( 3, V1(1), V1(2), 1, TAU1 ) - V1(1) = ONE -C - TEMP = -TAU1*( X(1,2)+V1(2)*X(2,2) ) - V2(1) = -TEMP*V1(2) - X(2,2) - V2(2) = -TEMP*V1(3) - V2(3) = SCALE - CALL DLARFG( 3, V2(1), V2(2), 1, TAU2 ) - V2(1) = ONE -C -C Perform swap provisionally on diagonal block in D. -C - CALL DLARFX( 'L', 3, 4, V1, TAU1, D, LDD, DWORK ) - CALL DLARFX( 'R', 4, 3, V1, TAU1, D, LDD, DWORK ) - CALL DLARFX( 'L', 3, 4, V2, TAU2, D(2,1), LDD, DWORK ) - CALL DLARFX( 'R', 4, 3, V2, TAU2, D(1,2), LDD, DWORK ) -C -C Test whether to reject swap. -C - IF ( MAX( ABS( D(3,1) ), ABS( D(3,2) ), ABS( D(4,1) ), - $ ABS( D(4,2) ) ).GT.THRESH ) GO TO 50 -C -C Accept swap: apply transformation to the entire matrix A. -C - CALL DLARFX( 'L', 3, N-J1+1, V1, TAU1, A(J1,J1), LDA, DWORK ) - CALL DLARFX( 'R', J4, 3, V1, TAU1, A(1,J1), LDA, DWORK ) - CALL DLARFX( 'L', 3, N-J1+1, V2, TAU2, A(J2,J1), LDA, DWORK ) - CALL DLARFX( 'R', J4, 3, V2, TAU2, A(1,J2), LDA, DWORK ) -C - A(J3,J1) = ZERO - A(J3,J2) = ZERO - A(J4,J1) = ZERO - A(J4,J2) = ZERO -C -C Apply transformation to G. -C - IF ( ISHAM ) THEN - CALL DLARFX( 'Right', J1-1, 3, V1, TAU1, G(1,J1), LDG, - $ DWORK ) - CALL DSYMV( 'Upper', 3, TAU1, G(J1,J1), LDG, V1, 1, ZERO, - $ DWORK, 1 ) - TEMP = -HALF*TAU1*DDOT( 3, DWORK, 1, V1, 1 ) - CALL DAXPY( 3, TEMP, V1, 1, DWORK, 1 ) - CALL DSYR2( 'Upper', 3, -ONE, V1, 1, DWORK, 1, - $ G(J1,J1), LDG ) - IF ( N.GT.J1+2 ) - $ CALL DLARFX( 'Left', 3, N-J1-2, V1, TAU1, G(J1,J1+3), - $ LDG, DWORK ) -C - CALL DLARFX( 'Right', J2-1, 3, V2, TAU2, G(1,J2), LDG, - $ DWORK ) - CALL DSYMV( 'Upper', 3, TAU2, G(J2,J2), LDG, V2, 1, ZERO, - $ DWORK, 1 ) - TEMP = -HALF*TAU2*DDOT( 3, DWORK, 1, V2, 1 ) - CALL DAXPY( 3, TEMP, V2, 1, DWORK, 1 ) - CALL DSYR2( 'Upper', 3, -ONE, V2, 1, DWORK, 1, G(J2,J2), - $ LDG ) - IF ( N.GT.J2+2 ) - $ CALL DLARFX( 'Left', 3, N-J2-2, V2, TAU2, G(J2,J2+3), - $ LDG, DWORK ) - ELSE - CALL DLARFX( 'Right', J1-1, 3, V1, TAU1, G(1,J1), LDG, - $ DWORK ) - CALL MB01MD( 'Upper', 3, TAU1, G(J1,J1), LDG, V1, 1, ZERO, - $ DWORK, 1 ) - CALL MB01ND( 'Upper', 3, ONE, V1, 1, DWORK, 1, G(J1,J1), - $ LDG ) - IF ( N.GT.J1+2 ) - $ CALL DLARFX( 'Left', 3, N-J1-2, V1, TAU1, G(J1,J1+3), - $ LDG, DWORK ) - CALL DLARFX( 'Right', J2-1, 3, V2, TAU2, G(1,J2), LDG, - $ DWORK ) - CALL MB01MD( 'Upper', 3, TAU2, G(J2,J2), LDG, V2, 1, ZERO, - $ DWORK, 1 ) - CALL MB01ND( 'Upper', 3, ONE, V2, 1, DWORK, 1, G(J2,J2), - $ LDG ) - IF ( N.GT.J2+2 ) - $ CALL DLARFX( 'Left', 3, N-J2-2, V2, TAU2, G(J2,J2+3), - $ LDG, DWORK ) - END IF -C - IF ( WANTU ) THEN -C -C Accumulate transformation in the matrices U1 and U2. -C - CALL DLARFX( 'R', N, 3, V1, TAU1, U1(1,J1), LDU1, DWORK ) - CALL DLARFX( 'R', N, 3, V2, TAU2, U1(1,J2), LDU1, DWORK ) - CALL DLARFX( 'R', N, 3, V1, TAU1, U2(1,J1), LDU2, DWORK ) - CALL DLARFX( 'R', N, 3, V2, TAU2, U2(1,J2), LDU2, DWORK ) - END IF -C - 40 CONTINUE -C - IF ( N2.EQ.2 ) THEN -C -C Standardize new 2-by-2 block A11. -C - CALL DLANV2( A(J1,J1), A(J1,J2), A(J2,J1), A(J2,J2), WR1, - $ WI1, WR2, WI2, CS, SN ) - CALL DROT( N-J1-1, A(J1,J1+2), LDA, A(J2,J1+2), LDA, CS, - $ SN ) - CALL DROT( J1-1, A(1,J1), 1, A(1,J2), 1, CS, SN ) - IF ( ISHAM ) THEN - TEMP = G(J1,J2) - CALL DROT( J1, G(1,J1), 1, G(1,J2), 1, CS, SN ) - TAU = CS*TEMP + SN*G(J2,J2) - G(J2,J2) = CS*G(J2,J2) - SN*TEMP - G(J1,J1) = CS*G(J1,J1) + SN*TAU - CALL DROT( N-J1, G(J1,J2), LDG, G(J2,J2), LDG, CS, SN ) - ELSE - IF ( N.GT.J1+1 ) - $ CALL DROT( N-J1-1, G(J1,J1+2), LDG, G(J2,J1+2), LDG, - $ CS, SN ) - CALL DROT( J1-1, G(1,J1), 1, G(1,J2), 1, CS, SN ) - END IF - IF ( WANTU ) THEN - CALL DROT( N, U1(1,J1), 1, U1(1,J2), 1, CS, SN ) - CALL DROT( N, U2(1,J1), 1, U2(1,J2), 1, CS, SN ) - END IF - END IF -C - IF ( N1.EQ.2 ) THEN -C -C Standardize new 2-by-2 block A22. -C - J3 = J1 + N2 - J4 = J3 + 1 - CALL DLANV2( A(J3,J3), A(J3,J4), A(J4,J3), A(J4,J4), WR1, - $ WI1, WR2, WI2, CS, SN ) - IF ( J3+2.LE.N ) - $ CALL DROT( N-J3-1, A(J3,J3+2), LDA, A(J4,J3+2), LDA, CS, - $ SN ) - CALL DROT( J3-1, A(1,J3), 1, A(1,J4), 1, CS, SN ) - IF ( ISHAM ) THEN - TEMP = G(J3,J4) - CALL DROT( J3, G(1,J3), 1, G(1,J4), 1, CS, SN ) - TAU = CS*TEMP + SN*G(J4,J4) - G(J4,J4) = CS*G(J4,J4) - SN*TEMP - G(J3,J3) = CS*G(J3,J3) + SN*TAU - CALL DROT( N-J3, G(J3,J4), LDG, G(J4,J4), LDG, CS, SN ) - ELSE - IF ( N.GT.J3+1 ) - $ CALL DROT( N-J3-1, G(J3,J3+2), LDG, G(J4,J3+2), LDG, - $ CS, SN ) - CALL DROT( J3-1, G(1,J3), 1, G(1,J4), 1, CS, SN ) - END IF - IF ( WANTU ) THEN - CALL DROT( N, U1(1,J3), 1, U1(1,J4), 1, CS, SN ) - CALL DROT( N, U2(1,J3), 1, U2(1,J4), 1, CS, SN ) - END IF - END IF -C - END IF - RETURN -C -C Exit with INFO = 1 if swap was rejected. -C - 50 CONTINUE - INFO = 1 - RETURN -C *** Last line of MB03TS *** - END diff --git a/mex/sources/libslicot/MB03UD.f b/mex/sources/libslicot/MB03UD.f deleted file mode 100644 index 37e6b6bcd..000000000 --- a/mex/sources/libslicot/MB03UD.f +++ /dev/null @@ -1,318 +0,0 @@ - SUBROUTINE MB03UD( JOBQ, JOBP, N, A, LDA, Q, LDQ, SV, DWORK, - $ LDWORK, INFO ) -C -C SLICOT RELEASE 5.0. -C -C Copyright (c) 2002-2009 NICONET e.V. -C -C This program is free software: you can redistribute it and/or -C modify it under the terms of the GNU General Public License as -C published by the Free Software Foundation, either version 2 of -C the License, or (at your option) any later version. -C -C This program is distributed in the hope that it will be useful, -C but WITHOUT ANY WARRANTY; without even the implied warranty of -C MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the -C GNU General Public License for more details. -C -C You should have received a copy of the GNU General Public License -C along with this program. If not, see -C . -C -C PURPOSE -C -C To compute all, or part, of the singular value decomposition of a -C real upper triangular matrix. -C -C The N-by-N upper triangular matrix A is factored as A = Q*S*P', -C where Q and P are N-by-N orthogonal matrices and S is an -C N-by-N diagonal matrix with non-negative diagonal elements, -C SV(1), SV(2), ..., SV(N), ordered such that -C -C SV(1) >= SV(2) >= ... >= SV(N) >= 0. -C -C The columns of Q are the left singular vectors of A, the diagonal -C elements of S are the singular values of A and the columns of P -C are the right singular vectors of A. -C -C Either or both of Q and P' may be requested. -C When P' is computed, it is returned in A. -C -C ARGUMENTS -C -C Mode Parameters -C -C JOBQ CHARACTER*1 -C Specifies whether the user wishes to compute the matrix Q -C of left singular vectors as follows: -C = 'V': Left singular vectors are computed; -C = 'N': No left singular vectors are computed. -C -C JOBP CHARACTER*1 -C Specifies whether the user wishes to compute the matrix P' -C of right singular vectors as follows: -C = 'V': Right singular vectors are computed; -C = 'N': No right singular vectors are computed. -C -C Input/Output Parameters -C -C N (input) INTEGER -C The order of the matrix A. N >= 0. -C -C A (input/output) DOUBLE PRECISION array, dimension (LDA,N) -C On entry, the leading N-by-N upper triangular part of this -C array must contain the upper triangular matrix A. -C On exit, if JOBP = 'V', the leading N-by-N part of this -C array contains the N-by-N orthogonal matrix P'; otherwise -C the N-by-N upper triangular part of A is used as internal -C workspace. The strictly lower triangular part of A is set -C internally to zero before the reduction to bidiagonal form -C is performed. -C -C LDA INTEGER -C The leading dimension of array A. LDA >= MAX(1,N). -C -C Q (output) DOUBLE PRECISION array, dimension (LDQ,N) -C If JOBQ = 'V', the leading N-by-N part of this array -C contains the orthogonal matrix Q. -C If JOBQ = 'N', Q is not referenced. -C -C LDQ INTEGER -C The leading dimension of array Q. -C LDQ >= 1, and when JOBQ = 'V', LDQ >= MAX(1,N). -C -C SV (output) DOUBLE PRECISION array, dimension (N) -C The N singular values of the matrix A, sorted in -C descending order. -C -C Workspace -C -C DWORK DOUBLE PRECISION array, dimension (LDWORK) -C On exit, if INFO = 0, DWORK(1) returns the optimal LDWORK; -C if INFO > 0, DWORK(2:N) contains the unconverged -C superdiagonal elements of an upper bidiagonal matrix B -C whose diagonal is in SV (not necessarily sorted). -C B satisfies A = Q*B*P', so it has the same singular -C values as A, and singular vectors related by Q and P'. -C -C LDWORK INTEGER -C The length of the array DWORK. -C LDWORK >= MAX(1,5*N). -C For optimum performance LDWORK should be larger. -C -C Error Indicator -C -C INFO INTEGER -C = 0: successful exit; -C < 0: if INFO = -i, the i-th argument had an illegal -C value; -C > 0: the QR algorithm has failed to converge. In this -C case INFO specifies how many superdiagonals did not -C converge (see the description of DWORK). -C This failure is not likely to occur. -C -C METHOD -C -C The routine reduces A to bidiagonal form by means of elementary -C reflectors and then uses the QR algorithm on the bidiagonal form. -C -C CONTRIBUTOR -C -C V. Sima, Research Institute of Informatics, Bucharest, and -C A. Varga, German Aerospace Center, DLR Oberpfaffenhofen, -C March 1998. Based on the RASP routine DTRSVD. -C -C REVISIONS -C -C V. Sima, Feb. 2000. -C -C KEYWORDS -C -C Bidiagonalization, orthogonal transformation, singular value -C decomposition, singular values, triangular form. -C -C ****************************************************************** -C -C .. Parameters .. - DOUBLE PRECISION ONE, ZERO - PARAMETER ( ONE = 1.0D0, ZERO = 0.0D0 ) -C .. Scalar Arguments .. - CHARACTER JOBP, JOBQ - INTEGER INFO, LDA, LDQ, LDWORK, N -C .. Array Arguments .. - DOUBLE PRECISION A(LDA,*), DWORK(*), Q(LDQ,*), SV(*) -C .. Local Scalars .. - LOGICAL WANTQ, WANTP - INTEGER I, IE, ISCL, ITAUP, ITAUQ, JWORK, MAXWRK, - $ MINWRK, NCOLP, NCOLQ - DOUBLE PRECISION ANRM, BIGNUM, EPS, SMLNUM -C .. Local Arrays .. - DOUBLE PRECISION DUM(1) -C .. External Functions .. - LOGICAL LSAME - INTEGER ILAENV - DOUBLE PRECISION DLAMCH, DLANTR - EXTERNAL DLAMCH, DLANTR, ILAENV, LSAME -C .. External Subroutines .. - EXTERNAL DBDSQR, DGEBRD, DLACPY, DLASCL, DLASET, DORGBR, - $ XERBLA -C .. Intrinsic Functions .. - INTRINSIC MAX, SQRT -C .. Executable Statements .. -C -C Check the input scalar arguments. -C - INFO = 0 - WANTQ = LSAME( JOBQ, 'V' ) - WANTP = LSAME( JOBP, 'V' ) - MINWRK = 1 - IF( .NOT.WANTQ .AND. .NOT.LSAME( JOBQ, 'N' ) ) THEN - INFO = -1 - ELSE IF( .NOT.WANTP .AND. .NOT.LSAME( JOBP, 'N' ) ) THEN - INFO = -2 - ELSE IF( N.LT.0 ) THEN - INFO = -3 - ELSE IF( LDA.LT.MAX( 1, N ) ) THEN - INFO = -5 - ELSE IF( ( WANTQ .AND. LDQ.LT.MAX( 1, N ) ) .OR. - $ ( .NOT.WANTQ .AND. LDQ.LT.1 ) ) THEN - INFO = -7 - END IF -C -C Compute workspace -C (Note: Comments in the code beginning "Workspace:" describe the -C minimal amount of workspace needed at that point in the code, -C as well as the preferred amount for good performance. -C NB refers to the optimal block size for the immediately following -C subroutine, as returned by ILAENV.) -C - IF( INFO.EQ.0 .AND. LDWORK.GE.1 .AND. N.GT.0 ) THEN - MAXWRK = 3*N+2*N*ILAENV( 1, 'DGEBRD', ' ', N, N, -1, -1 ) - IF( WANTQ ) - $ MAXWRK = MAX( MAXWRK, 3*N+N* - $ ILAENV( 1, 'DORGBR', 'Q', N, N, N, -1 ) ) - IF( WANTP ) - $ MAXWRK = MAX( MAXWRK, 3*N+N* - $ ILAENV( 1, 'DORGBR', 'P', N, N, N, -1 ) ) - MINWRK = 5*N - MAXWRK = MAX( MAXWRK, MINWRK ) - DWORK(1) = MAXWRK - END IF -C - IF( LDWORK.LT.MINWRK ) THEN - INFO = -10 - END IF - IF( INFO.NE.0 ) THEN - CALL XERBLA( 'MB03UD', -INFO ) - RETURN - END IF -C -C Quick return if possible. -C - IF( N.EQ.0 ) THEN - DWORK(1) = ONE - RETURN - END IF -C -C Get machine constants. -C - EPS = DLAMCH( 'P' ) - SMLNUM = SQRT( DLAMCH( 'S' ) ) / EPS - BIGNUM = ONE / SMLNUM -C -C Scale A if max entry outside range [SMLNUM,BIGNUM]. -C - ANRM = DLANTR( 'Max', 'Upper', 'Non-unit', N, N, A, LDA, DUM ) - ISCL = 0 - IF( ANRM.GT.ZERO .AND. ANRM.LT.SMLNUM ) THEN - ISCL = 1 - CALL DLASCL( 'Upper', 0, 0, ANRM, SMLNUM, N, N, A, LDA, INFO ) - ELSE IF( ANRM.GT.BIGNUM ) THEN - ISCL = 1 - CALL DLASCL( 'Upper', 0, 0, ANRM, BIGNUM, N, N, A, LDA, INFO ) - END IF -C -C Zero out below. -C - IF ( N.GT.1 ) - $ CALL DLASET( 'Lower', N-1, N-1, ZERO, ZERO, A(2,1), LDA ) -C -C Find the singular values and optionally the singular vectors -C of the upper triangular matrix A. -C - IE = 1 - ITAUQ = IE + N - ITAUP = ITAUQ + N - JWORK = ITAUP + N -C -C First reduce the matrix to bidiagonal form. The diagonal -C elements will be in SV and the superdiagonals in DWORK(IE). -C (Workspace: need 4*N, prefer 3*N+2*N*NB) -C - CALL DGEBRD( N, N, A, LDA, SV, DWORK(IE), DWORK(ITAUQ), - $ DWORK(ITAUP), DWORK(JWORK), LDWORK-JWORK+1, INFO ) - IF( WANTQ ) THEN -C -C Generate the transformation matrix Q corresponding to the -C left singular vectors. -C (Workspace: need 4*N, prefer 3*N+N*NB) -C - NCOLQ = N - CALL DLACPY( 'Lower', N, N, A, LDA, Q, LDQ ) - CALL DORGBR( 'Q', N, N, N, Q, LDQ, DWORK(ITAUQ), DWORK(JWORK), - $ LDWORK-JWORK+1, INFO ) - ELSE - NCOLQ = 0 - END IF - IF( WANTP ) THEN -C -C Generate the transformation matrix P' corresponding to the -C right singular vectors. -C (Workspace: need 4*N, prefer 3*N+N*NB) -C - NCOLP = N - CALL DORGBR( 'P', N, N, N, A, LDA, DWORK(ITAUP), DWORK(JWORK), - $ LDWORK-JWORK+1, INFO ) - ELSE - NCOLP = 0 - END IF - JWORK = IE + N -C -C Perform bidiagonal QR iteration, to obtain all or part of the -C singular value decomposition of A. -C (Workspace: need 5*N) -C - CALL DBDSQR( 'U', N, NCOLP, NCOLQ, 0, SV, DWORK(IE), A, LDA, - $ Q, LDQ, DUM, 1, DWORK(JWORK), INFO ) -C -C If DBDSQR failed to converge, copy unconverged superdiagonals -C to DWORK(2:N). -C - IF( INFO.NE.0 ) THEN - DO 10 I = N - 1, 1, -1 - DWORK(I+1) = DWORK(I+IE-1) - 10 CONTINUE - END IF -C -C Undo scaling if necessary. -C - IF( ISCL.EQ.1 ) THEN - IF( ANRM.GT.BIGNUM ) - $ CALL DLASCL( 'G', 0, 0, BIGNUM, ANRM, N, 1, SV, N, INFO ) - IF( INFO.NE.0 .AND. ANRM.GT.BIGNUM ) - $ CALL DLASCL( 'G', 0, 0, BIGNUM, ANRM, N-1, 1, DWORK(2), N, - $ INFO ) - IF( ANRM.LT.SMLNUM ) - $ CALL DLASCL( 'G', 0, 0, SMLNUM, ANRM, N, 1, SV, N, INFO ) - IF( INFO.NE.0 .AND. ANRM.LT.SMLNUM ) - $ CALL DLASCL( 'G', 0, 0, SMLNUM, ANRM, N-1, 1, DWORK(2), N, - $ INFO ) - END IF -C -C Return optimal workspace in DWORK(1). -C - DWORK(1) = MAXWRK -C - RETURN -C *** Last line of MB03UD *** - END diff --git a/mex/sources/libslicot/MB03VD.f b/mex/sources/libslicot/MB03VD.f deleted file mode 100644 index 4cf99f6fb..000000000 --- a/mex/sources/libslicot/MB03VD.f +++ /dev/null @@ -1,306 +0,0 @@ - SUBROUTINE MB03VD( N, P, ILO, IHI, A, LDA1, LDA2, TAU, LDTAU, - $ DWORK, INFO ) -C -C SLICOT RELEASE 5.0. -C -C Copyright (c) 2002-2009 NICONET e.V. -C -C This program is free software: you can redistribute it and/or -C modify it under the terms of the GNU General Public License as -C published by the Free Software Foundation, either version 2 of -C the License, or (at your option) any later version. -C -C This program is distributed in the hope that it will be useful, -C but WITHOUT ANY WARRANTY; without even the implied warranty of -C MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the -C GNU General Public License for more details. -C -C You should have received a copy of the GNU General Public License -C along with this program. If not, see -C . -C -C PURPOSE -C -C To reduce a product of p real general matrices A = A_1*A_2*...*A_p -C to upper Hessenberg form, H = H_1*H_2*...*H_p, where H_1 is -C upper Hessenberg, and H_2, ..., H_p are upper triangular, by using -C orthogonal similarity transformations on A, -C -C Q_1' * A_1 * Q_2 = H_1, -C Q_2' * A_2 * Q_3 = H_2, -C ... -C Q_p' * A_p * Q_1 = H_p. -C -C ARGUMENTS -C -C Input/Output Parameters -C -C N (input) INTEGER -C The order of the square matrices A_1, A_2, ..., A_p. -C N >= 0. -C -C P (input) INTEGER -C The number of matrices in the product A_1*A_2*...*A_p. -C P >= 1. -C -C ILO (input) INTEGER -C IHI (input) INTEGER -C It is assumed that all matrices A_j, j = 2, ..., p, are -C already upper triangular in rows and columns 1:ILO-1 and -C IHI+1:N, and A_1 is upper Hessenberg in rows and columns -C 1:ILO-1 and IHI+1:N, with A_1(ILO,ILO-1) = 0 (unless -C ILO = 1), and A_1(IHI+1,IHI) = 0 (unless IHI = N). -C If this is not the case, ILO and IHI should be set to 1 -C and N, respectively. -C 1 <= ILO <= max(1,N); min(ILO,N) <= IHI <= N. -C -C A (input/output) DOUBLE PRECISION array, dimension -C (LDA1,LDA2,P) -C On entry, the leading N-by-N-by-P part of this array must -C contain the matrices of factors to be reduced; -C specifically, A(*,*,j) must contain A_j, j = 1, ..., p. -C On exit, the leading N-by-N upper triangle and the first -C subdiagonal of A(*,*,1) contain the upper Hessenberg -C matrix H_1, and the elements below the first subdiagonal, -C with the first column of the array TAU represent the -C orthogonal matrix Q_1 as a product of elementary -C reflectors. See FURTHER COMMENTS. -C For j > 1, the leading N-by-N upper triangle of A(*,*,j) -C contains the upper triangular matrix H_j, and the elements -C below the diagonal, with the j-th column of the array TAU -C represent the orthogonal matrix Q_j as a product of -C elementary reflectors. See FURTHER COMMENTS. -C -C LDA1 INTEGER -C The first leading dimension of the array A. -C LDA1 >= max(1,N). -C -C LDA2 INTEGER -C The second leading dimension of the array A. -C LDA2 >= max(1,N). -C -C TAU (output) DOUBLE PRECISION array, dimension (LDTAU,P) -C The leading N-1 elements in the j-th column contain the -C scalar factors of the elementary reflectors used to form -C the matrix Q_j, j = 1, ..., P. See FURTHER COMMENTS. -C -C LDTAU INTEGER -C The leading dimension of the array TAU. -C LDTAU >= max(1,N-1). -C -C Workspace -C -C DWORK DOUBLE PRECISION array, dimension (N) -C -C Error Indicator -C -C INFO INTEGER -C = 0: successful exit; -C < 0: if INFO = -i, the i-th argument had an illegal -C value. -C -C METHOD -C -C The algorithm consists in ihi-ilo major steps. In each such -C step i, ilo <= i <= ihi-1, the subdiagonal elements in the i-th -C column of A_j are annihilated using a Householder transformation -C from the left, which is also applied to A_(j-1) from the right, -C for j = p:-1:2. Then, the elements below the subdiagonal of the -C i-th column of A_1 are annihilated, and the Householder -C transformation is also applied to A_p from the right. -C See FURTHER COMMENTS. -C -C REFERENCES -C -C [1] Bojanczyk, A.W., Golub, G. and Van Dooren, P. -C The periodic Schur decomposition: algorithms and applications. -C Proc. of the SPIE Conference (F.T. Luk, Ed.), 1770, pp. 31-42, -C 1992. -C -C [2] Sreedhar, J. and Van Dooren, P. -C Periodic Schur form and some matrix equations. -C Proc. of the Symposium on the Mathematical Theory of Networks -C and Systems (MTNS'93), Regensburg, Germany (U. Helmke, -C R. Mennicken and J. Saurer, Eds.), Vol. 1, pp. 339-362, 1994. -C -C NUMERICAL ASPECTS -C -C The algorithm is numerically stable. -C -C FURTHER COMMENTS -C -C Each matrix Q_j is represented as a product of (ihi-ilo) -C elementary reflectors, -C -C Q_j = H_j(ilo) H_j(ilo+1) . . . H_j(ihi-1). -C -C Each H_j(i), i = ilo, ..., ihi-1, has the form -C -C H_j(i) = I - tau_j * v_j * v_j', -C -C where tau_j is a real scalar, and v_j is a real vector with -C v_j(1:i) = 0, v_j(i+1) = 1 and v_j(ihi+1:n) = 0; v_j(i+2:ihi) -C is stored on exit in A_j(i+2:ihi,i), and tau_j in TAU(i,j). -C -C The contents of A_1 are illustrated by the following example -C for n = 7, ilo = 2, and ihi = 6: -C -C on entry on exit -C -C ( a a a a a a a ) ( a h h h h h a ) -C ( 0 a a a a a a ) ( 0 h h h h h a ) -C ( 0 a a a a a a ) ( 0 h h h h h h ) -C ( 0 a a a a a a ) ( 0 v2 h h h h h ) -C ( 0 a a a a a a ) ( 0 v2 v3 h h h h ) -C ( 0 a a a a a a ) ( 0 v2 v3 v4 h h h ) -C ( 0 0 0 0 0 0 a ) ( 0 0 0 0 0 0 a ) -C -C where a denotes an element of the original matrix A_1, h denotes -C a modified element of the upper Hessenberg matrix H_1, and vi -C denotes an element of the vector defining H_1(i). -C -C The contents of A_j, j > 1, are illustrated by the following -C example for n = 7, ilo = 2, and ihi = 6: -C -C on entry on exit -C -C ( a a a a a a a ) ( a h h h h h a ) -C ( 0 a a a a a a ) ( 0 h h h h h h ) -C ( 0 a a a a a a ) ( 0 v2 h h h h h ) -C ( 0 a a a a a a ) ( 0 v2 v3 h h h h ) -C ( 0 a a a a a a ) ( 0 v2 v3 v4 h h h ) -C ( 0 a a a a a a ) ( 0 v2 v3 v4 v5 h h ) -C ( 0 0 0 0 0 0 a ) ( 0 0 0 0 0 0 a ) -C -C where a denotes an element of the original matrix A_j, h denotes -C a modified element of the upper triangular matrix H_j, and vi -C denotes an element of the vector defining H_j(i). (The element -C (1,2) in A_p is also unchanged for this example.) -C -C Note that for P = 1, the LAPACK Library routine DGEHRD could be -C more efficient on some computer architectures than this routine -C (a BLAS 2 version). -C -C CONTRIBUTOR -C -C V. Sima, Katholieke Univ. Leuven, Belgium, and A. Varga, -C German Aerospace Center, DLR Oberpfaffenhofen, February 1999. -C Partly based on the routine PSHESS by A. Varga -C (DLR Oberpfaffenhofen), November 26, 1995. -C -C REVISIONS -C -C - -C -C KEYWORDS -C -C Hessenberg form, orthogonal transformation, periodic systems, -C similarity transformation, triangular form. -C -C ****************************************************************** -C -C .. Parameters .. - DOUBLE PRECISION ZERO, ONE - PARAMETER ( ZERO = 0.0D+0, ONE = 1.0D+0 ) -C .. -C .. Scalar Arguments .. - INTEGER IHI, ILO, INFO, LDA1, LDA2, LDTAU, N, P -C .. -C .. Array Arguments .. - DOUBLE PRECISION A( LDA1, LDA2, * ), DWORK( * ), TAU( LDTAU, * ) -C .. -C .. Local Scalars .. - INTEGER I, I1, I2, J, NH -C .. -C .. Local Arrays .. - DOUBLE PRECISION DUMMY( 1 ) -C .. -C .. External Subroutines .. - EXTERNAL DCOPY, DLARFG, MB04PY, XERBLA -C .. -C .. Intrinsic Functions .. - INTRINSIC MAX, MIN -C .. -C .. Executable Statements .. -C -C Test the input scalar arguments. -C - INFO = 0 - IF( N.LT.0 ) THEN - INFO = -1 - ELSE IF( P.LT.1 ) THEN - INFO = -2 - ELSE IF( ILO.LT.1 .OR. ILO.GT.MAX( 1, N ) ) THEN - INFO = -3 - ELSE IF( IHI.LT.MIN( ILO, N ) .OR. IHI.GT.N ) THEN - INFO = -4 - ELSE IF( LDA1.LT.MAX( 1, N ) ) THEN - INFO = -6 - ELSE IF( LDA2.LT.MAX( 1, N ) ) THEN - INFO = -7 - ELSE IF( LDTAU.LT.MAX( 1, N-1 ) ) THEN - INFO = -9 - END IF - IF( INFO.NE.0 ) THEN - CALL XERBLA( 'MB03VD', -INFO ) - RETURN - END IF -C -C Quick return if possible. -C - NH = IHI - ILO + 1 - IF ( NH.LE.1 ) - $ RETURN -C - DUMMY( 1 ) = ZERO -C - DO 20 I = ILO, IHI - 1 - I1 = I + 1 - I2 = MIN( I+2, N ) -C - DO 10 J = P, 2, -1 -C -C Set the elements 1:ILO-1 and IHI:N-1 of TAU(*,J) to zero. -C - CALL DCOPY( ILO-1, DUMMY, 0, TAU( 1, J ), 1 ) - IF ( IHI.LT.N ) - $ CALL DCOPY( N-IHI, DUMMY, 0, TAU( IHI, J ), 1 ) -C -C Compute elementary reflector H_j(i) to annihilate -C A_j(i+1:ihi,i). -C - CALL DLARFG( IHI-I+1, A( I, I, J ), A( I1, I, J ), 1, - $ TAU( I, J ) ) -C -C Apply H_j(i) to A_(j-1)(1:ihi,i:ihi) from the right. -C - CALL MB04PY( 'Right', IHI, IHI-I+1, A( I1, I, J ), - $ TAU( I, J ), A( 1, I, J-1 ), LDA1, DWORK ) -C -C Apply H_j(i) to A_j(i:ihi,i+1:n) from the left. -C - CALL MB04PY( 'Left', IHI-I+1, N-I, A( I1, I, J ), - $ TAU( I, J ), A( I, I1, J ), LDA1, DWORK ) - 10 CONTINUE -C -C Compute elementary reflector H_1(i) to annihilate -C A_1(i+2:ihi,i). -C - CALL DLARFG( IHI-I, A( I1, I, 1 ), A( I2, I, 1 ), 1, - $ TAU( I, 1 ) ) -C -C Apply H_1(i) to A_p(1:ihi,i+1:ihi) from the right. -C - CALL MB04PY( 'Right', IHI, IHI-I, A( I2, I, 1 ), TAU( I, 1 ), - $ A( 1, I1, P ), LDA1, DWORK ) -C -C Apply H_1(i) to A_1(i+1:ihi,i+1:n) from the left. -C - CALL MB04PY( 'Left', IHI-I, N-I, A( I2, I, 1 ), TAU( I, 1 ), - $ A( I1, I1, 1 ), LDA1, DWORK ) - 20 CONTINUE -C - RETURN -C -C *** Last line of MB03VD *** - END diff --git a/mex/sources/libslicot/MB03VY.f b/mex/sources/libslicot/MB03VY.f deleted file mode 100644 index 163e77497..000000000 --- a/mex/sources/libslicot/MB03VY.f +++ /dev/null @@ -1,216 +0,0 @@ - SUBROUTINE MB03VY( N, P, ILO, IHI, A, LDA1, LDA2, TAU, LDTAU, - $ DWORK, LDWORK, INFO ) -C -C SLICOT RELEASE 5.0. -C -C Copyright (c) 2002-2009 NICONET e.V. -C -C This program is free software: you can redistribute it and/or -C modify it under the terms of the GNU General Public License as -C published by the Free Software Foundation, either version 2 of -C the License, or (at your option) any later version. -C -C This program is distributed in the hope that it will be useful, -C but WITHOUT ANY WARRANTY; without even the implied warranty of -C MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the -C GNU General Public License for more details. -C -C You should have received a copy of the GNU General Public License -C along with this program. If not, see -C . -C -C PURPOSE -C -C To generate the real orthogonal matrices Q_1, Q_2, ..., Q_p, -C which are defined as the product of ihi-ilo elementary reflectors -C of order n, as returned by SLICOT Library routine MB03VD: -C -C Q_j = H_j(ilo) H_j(ilo+1) . . . H_j(ihi-1). -C -C ARGUMENTS -C -C Input/Output Parameters -C -C N (input) INTEGER -C The order of the matrices Q_1, Q_2, ..., Q_p. N >= 0. -C -C P (input) INTEGER -C The number p of transformation matrices. P >= 1. -C -C ILO (input) INTEGER -C IHI (input) INTEGER -C The values of the indices ilo and ihi, respectively, used -C in the previous call of the SLICOT Library routine MB03VD. -C 1 <= ILO <= max(1,N); min(ILO,N) <= IHI <= N. -C -C A (input/output) DOUBLE PRECISION array, dimension -C (LDA1,LDA2,N) -C On entry, the leading N-by-N strictly lower triangular -C part of A(*,*,j) must contain the vectors which define the -C elementary reflectors used for reducing A_j, as returned -C by SLICOT Library routine MB03VD, j = 1, ..., p. -C On exit, the leading N-by-N part of A(*,*,j) contains the -C N-by-N orthogonal matrix Q_j, j = 1, ..., p. -C -C LDA1 INTEGER -C The first leading dimension of the array A. -C LDA1 >= max(1,N). -C -C LDA2 INTEGER -C The second leading dimension of the array A. -C LDA2 >= max(1,N). -C -C TAU (input) DOUBLE PRECISION array, dimension (LDTAU,P) -C The leading N-1 elements in the j-th column must contain -C the scalar factors of the elementary reflectors used to -C form the matrix Q_j, as returned by SLICOT Library routine -C MB03VD. -C -C LDTAU INTEGER -C The leading dimension of the array TAU. -C LDTAU >= max(1,N-1). -C -C Workspace -C -C DWORK DOUBLE PRECISION array, dimension (LDWORK) -C On exit, if INFO = 0, DWORK(1) returns the optimal value -C of LDWORK. -C -C LDWORK INTEGER -C The length of the array DWORK. LDWORK >= MAX(1,N). -C For optimum performance LDWORK should be larger. -C -C Error Indicator -C -C INFO INTEGER -C = 0: successful exit; -C < 0: if INFO = -i, the i-th argument had an illegal -C value. -C -C METHOD -C -C Each matrix Q_j is generated as the product of the elementary -C reflectors used for reducing A_j. Standard LAPACK routines for -C Hessenberg and QR decompositions are used. -C -C REFERENCES -C -C [1] Bojanczyk, A.W., Golub, G. and Van Dooren, P. -C The periodic Schur decomposition: algorithms and applications. -C Proc. of the SPIE Conference (F.T. Luk, Ed.), 1770, pp. 31-42, -C 1992. -C -C [2] Sreedhar, J. and Van Dooren, P. -C Periodic Schur form and some matrix equations. -C Proc. of the Symposium on the Mathematical Theory of Networks -C and Systems (MTNS'93), Regensburg, Germany (U. Helmke, -C R. Mennicken and J. Saurer, Eds.), Vol. 1, pp. 339-362, 1994. -C -C NUMERICAL ASPECTS -C -C The algorithm is numerically stable. -C -C CONTRIBUTOR -C -C V. Sima, Katholieke Univ. Leuven, Belgium, and A. Varga, -C German Aerospace Center, DLR Oberpfaffenhofen, February 1999. -C Partly based on the routine PSHTR by A. Varga -C (DLR Oberpfaffenhofen), November 26, 1995. -C -C REVISIONS -C -C V. Sima, Research Institute for Informatics, Bucharest, Feb. 2004. -C -C KEYWORDS -C -C Hessenberg form, orthogonal transformation, periodic systems, -C similarity transformation, triangular form. -C -C ****************************************************************** -C -C .. Parameters .. - DOUBLE PRECISION ZERO, ONE - PARAMETER ( ZERO = 0.0D+0, ONE = 1.0D+0 ) -C -C .. Scalar Arguments .. - INTEGER IHI, ILO, INFO, LDA1, LDA2, LDTAU, LDWORK, N, P -C .. -C .. Array Arguments .. - DOUBLE PRECISION A( LDA1, LDA2, * ), DWORK( * ), TAU( LDTAU, * ) -C .. -C .. Local Scalars .. - INTEGER J, NH - DOUBLE PRECISION WRKOPT -C .. -C .. External Subroutines .. - EXTERNAL DLASET, DORGHR, DORGQR, XERBLA -C .. -C .. Intrinsic Functions .. - INTRINSIC MAX, MIN -C .. -C .. Executable Statements .. -C -C Test the input scalar arguments. -C - INFO = 0 - IF( N.LT.0 ) THEN - INFO = -1 - ELSE IF( P.LT.1 ) THEN - INFO = -2 - ELSE IF( ILO.LT.1 .OR. ILO.GT.MAX( 1, N ) ) THEN - INFO = -3 - ELSE IF( IHI.LT.MIN( ILO, N ) .OR. IHI.GT.N ) THEN - INFO = -4 - ELSE IF( LDA1.LT.MAX( 1, N ) ) THEN - INFO = -6 - ELSE IF( LDA2.LT.MAX( 1, N ) ) THEN - INFO = -7 - ELSE IF( LDTAU.LT.MAX( 1, N-1 ) ) THEN - INFO = -9 - END IF - IF( INFO.NE.0 ) THEN - CALL XERBLA( 'MB03VY', -INFO ) - RETURN - END IF -C -C Quick return if possible. -C - IF ( N.EQ.0 ) THEN - DWORK( 1 ) = ONE - RETURN - END IF -C -C Generate the orthogonal matrix Q_1. -C - CALL DORGHR( N, ILO, IHI, A, LDA1, TAU, DWORK, LDWORK, INFO ) - WRKOPT = DWORK( 1 ) -C - NH = IHI - ILO + 1 -C - DO 20 J = 2, P -C -C Generate the orthogonal matrix Q_j. -C Set the first ILO-1 and the last N-IHI rows and columns of Q_j -C to those of the unit matrix. -C - CALL DLASET( 'Full', N, ILO-1, ZERO, ONE, A( 1, 1, J ), LDA1 ) - CALL DLASET( 'Full', ILO-1, NH, ZERO, ZERO, A( 1, ILO, J ), - $ LDA1 ) - IF ( NH.GT.1 ) - $ CALL DORGQR( NH, NH, NH-1, A( ILO, ILO, J ), LDA1, - $ TAU( ILO, J ), DWORK, LDWORK, INFO ) - IF ( IHI.LT.N ) THEN - CALL DLASET( 'Full', N-IHI, NH, ZERO, ZERO, - $ A( IHI+1, ILO, J ), LDA1 ) - CALL DLASET( 'Full', IHI, N-IHI, ZERO, ZERO, - $ A( 1, IHI+1, J ), LDA1 ) - CALL DLASET( 'Full', N-IHI, N-IHI, ZERO, ONE, - $ A( IHI+1, IHI+1, J ), LDA1 ) - END IF - 20 CONTINUE -C - DWORK( 1 ) = MAX( WRKOPT, DWORK( 1 ) ) - RETURN -C -C *** Last line of MB03VY *** - END diff --git a/mex/sources/libslicot/MB03WA.f b/mex/sources/libslicot/MB03WA.f deleted file mode 100644 index 0a800ae0c..000000000 --- a/mex/sources/libslicot/MB03WA.f +++ /dev/null @@ -1,538 +0,0 @@ - SUBROUTINE MB03WA( WANTQ, WANTZ, N1, N2, A, LDA, B, LDB, Q, LDQ, - $ Z, LDZ, INFO ) -C -C SLICOT RELEASE 5.0. -C -C Copyright (c) 2002-2009 NICONET e.V. -C -C This program is free software: you can redistribute it and/or -C modify it under the terms of the GNU General Public License as -C published by the Free Software Foundation, either version 2 of -C the License, or (at your option) any later version. -C -C This program is distributed in the hope that it will be useful, -C but WITHOUT ANY WARRANTY; without even the implied warranty of -C MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the -C GNU General Public License for more details. -C -C You should have received a copy of the GNU General Public License -C along with this program. If not, see -C . -C -C PURPOSE -C -C To swap adjacent diagonal blocks A11*B11 and A22*B22 of size -C 1-by-1 or 2-by-2 in an upper (quasi) triangular matrix product -C A*B by an orthogonal equivalence transformation. -C -C (A, B) must be in periodic real Schur canonical form (as returned -C by SLICOT Library routine MB03XP), i.e., A is block upper -C triangular with 1-by-1 and 2-by-2 diagonal blocks, and B is upper -C triangular. -C -C Optionally, the matrices Q and Z of generalized Schur vectors are -C updated. -C -C Q(in) * A(in) * Z(in)' = Q(out) * A(out) * Z(out)', -C Z(in) * B(in) * Q(in)' = Z(out) * B(out) * Q(out)'. -C -C This routine is largely based on the LAPACK routine DTGEX2 -C developed by Bo Kagstrom and Peter Poromaa. -C -C ARGUMENTS -C -C Mode Parameters -C -C WANTQ LOGICAL -C Indicates whether or not the user wishes to accumulate -C the matrix Q as follows: -C = .TRUE. : The matrix Q is updated; -C = .FALSE.: the matrix Q is not required. -C -C WANTZ LOGICAL -C Indicates whether or not the user wishes to accumulate -C the matrix Z as follows: -C = .TRUE. : The matrix Z is updated; -C = .FALSE.: the matrix Z is not required. -C -C Input/Output Parameters -C -C N1 (input) INTEGER -C The order of the first block A11*B11. N1 = 0, 1 or 2. -C -C N2 (input) INTEGER -C The order of the second block A22*B22. N2 = 0, 1 or 2. -C -C A (input/output) DOUBLE PRECISION array, dimension -C (LDA,N1+N2) -C On entry, the leading (N1+N2)-by-(N1+N2) part of this -C array must contain the matrix A. -C On exit, the leading (N1+N2)-by-(N1+N2) part of this array -C contains the matrix A of the reordered pair. -C -C LDA INTEGER -C The leading dimension of the array A. LDA >= MAX(1,N1+N2). -C -C B (input/output) DOUBLE PRECISION array, dimension -C (LDB,N1+N2) -C On entry, the leading (N1+N2)-by-(N1+N2) part of this -C array must contain the matrix B. -C On exit, the leading (N1+N2)-by-(N1+N2) part of this array -C contains the matrix B of the reordered pair. -C -C LDB INTEGER -C The leading dimension of the array B. LDB >= MAX(1,N1+N2). -C -C Q (input/output) DOUBLE PRECISION array, dimension -C (LDQ,N1+N2) -C On entry, if WANTQ = .TRUE., the leading -C (N1+N2)-by-(N1+N2) part of this array must contain the -C orthogonal matrix Q. -C On exit, the leading (N1+N2)-by-(N1+N2) part of this array -C contains the updated matrix Q. Q will be a rotation -C matrix for N1=N2=1. -C This array is not referenced if WANTQ = .FALSE.. -C -C LDQ INTEGER -C The leading dimension of the array Q. LDQ >= 1. -C If WANTQ = .TRUE., LDQ >= N1+N2. -C -C Z (input/output) DOUBLE PRECISION array, dimension -C (LDZ,N1+N2) -C On entry, if WANTZ = .TRUE., the leading -C (N1+N2)-by-(N1+N2) part of this array must contain the -C orthogonal matrix Z. -C On exit, the leading (N1+N2)-by-(N1+N2) part of this array -C contains the updated matrix Z. Z will be a rotation -C matrix for N1=N2=1. -C This array is not referenced if WANTZ = .FALSE.. -C -C LDZ INTEGER -C The leading dimension of the array Z. LDZ >= 1. -C If WANTZ = .TRUE., LDZ >= N1+N2. -C -C Error Indicator -C -C INFO INTEGER -C = 0: successful exit; -C = 1: the transformed matrix (A, B) would be -C too far from periodic Schur form; the blocks are -C not swapped and (A,B) and (Q,Z) are unchanged. -C -C METHOD -C -C In the current code both weak and strong stability tests are -C performed. The user can omit the strong stability test by changing -C the internal logical parameter WANDS to .FALSE.. See ref. [2] for -C details. -C -C REFERENCES -C -C [1] Kagstrom, B. -C A direct method for reordering eigenvalues in the generalized -C real Schur form of a regular matrix pair (A,B), in M.S. Moonen -C et al (eds.), Linear Algebra for Large Scale and Real-Time -C Applications, Kluwer Academic Publ., 1993, pp. 195-218. -C -C [2] Kagstrom, B., and Poromaa, P. -C Computing eigenspaces with specified eigenvalues of a regular -C matrix pair (A, B) and condition estimation: Theory, -C algorithms and software, Numer. Algorithms, 1996, vol. 12, -C pp. 369-407. -C -C CONTRIBUTORS -C -C D. Kressner, Technical Univ. Berlin, Germany, and -C P. Benner, Technical Univ. Chemnitz, Germany, December 2003. -C -C REVISIONS -C -C V. Sima, May 2008 (SLICOT version of the HAPACK routine DTGPX2). -C -C KEYWORDS -C -C Eigenvalue, periodic Schur form, reordering -C -C ****************************************************************** -C -C .. Parameters .. - DOUBLE PRECISION ZERO, ONE - PARAMETER ( ZERO = 0.0D+0, ONE = 1.0D+0 ) - DOUBLE PRECISION TEN - PARAMETER ( TEN = 1.0D+01 ) - INTEGER LDST - PARAMETER ( LDST = 4 ) - LOGICAL WANDS - PARAMETER ( WANDS = .TRUE. ) -C .. Scalar Arguments .. - LOGICAL WANTQ, WANTZ - INTEGER INFO, LDA, LDB, LDQ, LDZ, N1, N2 -C .. Array Arguments .. - DOUBLE PRECISION A(LDA,*), B(LDB,*), Q(LDQ,*), Z(LDZ,*) -C .. Local Scalars .. - LOGICAL DTRONG, WEAK - INTEGER I, LINFO, M - DOUBLE PRECISION BQRA21, BRQA21, DDUM, DNORM, DSCALE, DSUM, EPS, - $ F, G, SA, SB, SCALE, SMLNUM, SS, THRESH, WS -C .. Local Arrays .. - INTEGER IWORK( LDST ) - DOUBLE PRECISION AI(2), AR(2), BE(2), DWORK(32), IR(LDST,LDST), - $ IRCOP(LDST,LDST), LI(LDST,LDST), - $ LICOP(LDST,LDST), S(LDST,LDST), - $ SCPY(LDST,LDST), T(LDST,LDST), TAUL(LDST), - $ TAUR(LDST), TCPY(LDST,LDST) -C .. External Functions .. - DOUBLE PRECISION DLAMCH - EXTERNAL DLAMCH -C .. External Subroutines .. - EXTERNAL DGEMM, DGEQR2, DGERQ2, DLACPY, DLARTG, DLASET, - $ DLASSQ, DORG2R, DORGR2, DORM2R, DORMR2, DROT, - $ DSCAL, MB03YT, SB04OW -C .. Intrinsic Functions .. - INTRINSIC ABS, MAX, SQRT -C -C .. Executable Statements .. -C - INFO = 0 -C -C Quick return if possible. -C For efficiency, the arguments are not checked. -C - IF ( N1.LE.0 .OR. N2.LE.0 ) - $ RETURN - M = N1 + N2 -C - WEAK = .FALSE. - DTRONG = .FALSE. -C -C Make a local copy of selected block. -C - CALL DLASET( 'All', LDST, LDST, ZERO, ZERO, LI, LDST ) - CALL DLASET( 'All', LDST, LDST, ZERO, ZERO, IR, LDST ) - CALL DLACPY( 'Full', M, M, A, LDA, S, LDST ) - CALL DLACPY( 'Full', M, M, B, LDB, T, LDST ) -C -C Compute threshold for testing acceptance of swapping. -C - EPS = DLAMCH( 'P' ) - SMLNUM = DLAMCH( 'S' ) / EPS - DSCALE = ZERO - DSUM = ONE - CALL DLACPY( 'Full', M, M, S, LDST, DWORK, M ) - CALL DLASSQ( M*M, DWORK, 1, DSCALE, DSUM ) - CALL DLACPY( 'Full', M, M, T, LDST, DWORK, M ) - CALL DLASSQ( M*M, DWORK, 1, DSCALE, DSUM ) - DNORM = DSCALE*SQRT( DSUM ) - THRESH = MAX( TEN*EPS*DNORM, SMLNUM ) -C - IF ( M.EQ.2 ) THEN -C -C CASE 1: Swap 1-by-1 and 1-by-1 blocks. -C -C Compute orthogonal QL and RQ that swap 1-by-1 and 1-by-1 blocks -C using Givens rotations and perform the swap tentatively. -C - F = S(2,2)*T(2,2) - T(1,1)*S(1,1) - G = -S(2,2)*T(1,2) - T(1,1)*S(1,2) - SB = ABS( T(1,1) ) - SA = ABS( S(2,2) ) - CALL DLARTG( F, G, IR(1,2), IR(1,1), DDUM ) - IR(2,1) = -IR(1,2) - IR(2,2) = IR(1,1) - CALL DROT( 2, S(1,1), 1, S(1,2), 1, IR(1,1), IR(2,1) ) - CALL DROT( 2, T(1,1), LDST, T(2,1), LDST, IR(1,1), IR(2,1) ) - IF( SA.GE.SB ) THEN - CALL DLARTG( S(1,1), S(2,1), LI(1,1), LI(2,1), DDUM ) - ELSE - CALL DLARTG( T(2,2), T(2,1), LI(1,1), LI(2,1), DDUM ) - LI(2,1) = -LI(2,1) - END IF - CALL DROT( 2, S(1,1), LDST, S(2,1), LDST, LI(1,1), LI(2,1) ) - CALL DROT( 2, T(1,1), 1, T(1,2), 1, LI(1,1), LI(2,1) ) - LI(2,2) = LI(1,1) - LI(1,2) = -LI(2,1) -C -C Weak stability test: -C |S21| + |T21| <= O(EPS * F-norm((S, T))). -C - WS = ABS( S(2,1) ) + ABS( T(2,1) ) - WEAK = WS.LE.THRESH - IF ( .NOT.WEAK ) - $ GO TO 50 -C - IF ( WANDS ) THEN -C -C Strong stability test: -C F-norm((A-QL'*S*QR, B-QR'*T*QL)) <= O(EPS*F-norm((A,B))). -C - CALL DLACPY( 'Full', M, M, A, LDA, DWORK(M*M+1), M ) - CALL DGEMM( 'No Transpose', 'No Transpose', M, M, M, ONE, - $ LI, LDST, S, LDST, ZERO, DWORK, M ) - CALL DGEMM( 'No Transpose', 'Transpose', M, M, M, -ONE, - $ DWORK, M, IR, LDST, ONE, DWORK(M*M+1), M ) - DSCALE = ZERO - DSUM = ONE - CALL DLASSQ( M*M, DWORK(M*M+1), 1, DSCALE, DSUM ) -C - CALL DLACPY( 'Full', M, M, B, LDB, DWORK(M*M+1), M ) - CALL DGEMM( 'No Transpose', 'No Transpose', M, M, M, ONE, - $ IR, LDST, T, LDST, ZERO, DWORK, M ) - CALL DGEMM( 'No Transpose', 'Transpose', M, M, M, -ONE, - $ DWORK, M, LI, LDST, ONE, DWORK(M*M+1), M ) - CALL DLASSQ( M*M, DWORK(M*M+1), 1, DSCALE, DSUM ) - SS = DSCALE*SQRT( DSUM ) - DTRONG = SS.LE.THRESH - IF( .NOT.DTRONG ) - $ GO TO 50 - END IF -C -C Update A and B. -C - CALL DLACPY( 'All', M, M, S, LDST, A, LDA ) - CALL DLACPY( 'All', M, M, T, LDST, B, LDB ) -C -C Set N1-by-N2 (2,1) - blocks to ZERO. -C - A(2,1) = ZERO - B(2,1) = ZERO -C -C Accumulate transformations into Q and Z if requested. -C - IF ( WANTQ ) - $ CALL DROT( 2, Q(1,1), 1, Q(1,2), 1, LI(1,1), LI(2,1) ) - IF ( WANTZ ) - $ CALL DROT( 2, Z(1,1), 1, Z(1,2), 1, IR(1,1), IR(2,1) ) -C -C Exit with INFO = 0 if swap was successfully performed. -C - RETURN -C - ELSE -C -C CASE 2: Swap 1-by-1 and 2-by-2 blocks, or 2-by-2 -C and 2-by-2 blocks. -C -C Solve the periodic Sylvester equation -C S11 * R - L * S22 = SCALE * S12 -C T11 * L - R * T22 = SCALE * T12 -C for R and L. Solutions in IR and LI. -C - CALL DLACPY( 'Full', N1, N2, T(1,N1+1), LDST, LI, LDST ) - CALL DLACPY( 'Full', N1, N2, S(1,N1+1), LDST, IR(N2+1,N1+1), - $ LDST ) - CALL SB04OW( N1, N2, S, LDST, S(N1+1,N1+1), LDST, - $ IR(N2+1,N1+1), LDST, T, LDST, T(N1+1,N1+1), LDST, - $ LI, LDST, SCALE, IWORK, LINFO ) - IF ( LINFO.NE.0 ) - $ GO TO 50 -C -C Compute orthogonal matrix QL: -C -C QL' * LI = [ TL ] -C [ 0 ] -C where -C LI = [ -L ]. -C [ SCALE * identity(N2) ] -C - DO 10 I = 1, N2 - CALL DSCAL( N1, -ONE, LI(1,I), 1 ) - LI(N1+I,I) = SCALE - 10 CONTINUE - CALL DGEQR2( M, N2, LI, LDST, TAUL, DWORK, LINFO ) - CALL DORG2R( M, M, N2, LI, LDST, TAUL, DWORK, LINFO ) -C -C Compute orthogonal matrix RQ: -C -C IR * RQ' = [ 0 TR], -C -C where IR = [ SCALE * identity(N1), R ]. -C - DO 20 I = 1, N1 - IR(N2+I,I) = SCALE - 20 CONTINUE - CALL DGERQ2( N1, M, IR(N2+1,1), LDST, TAUR, DWORK, LINFO ) - CALL DORGR2( M, M, N1, IR, LDST, TAUR, DWORK, LINFO ) -C -C Perform the swapping tentatively: -C - CALL DGEMM( 'Transpose', 'No Transpose', M, M, M, ONE, LI, - $ LDST, S, LDST, ZERO, DWORK, M ) - CALL DGEMM( 'No Transpose', 'Transpose', M, M, M, ONE, DWORK, - $ M, IR, LDST, ZERO, S, LDST ) - CALL DGEMM( 'No Transpose', 'No Transpose', M, M, M, ONE, IR, - $ LDST, T, LDST, ZERO, DWORK, M ) - CALL DGEMM( 'No Transpose', 'No Transpose', M, M, M, ONE, - $ DWORK, M, LI, LDST, ZERO, T, LDST ) - CALL DLACPY( 'All', M, M, S, LDST, SCPY, LDST ) - CALL DLACPY( 'All', M, M, T, LDST, TCPY, LDST ) - CALL DLACPY( 'All', M, M, IR, LDST, IRCOP, LDST ) - CALL DLACPY( 'All', M, M, LI, LDST, LICOP, LDST ) -C -C Triangularize the B-part by a QR factorization. -C Apply transformation (from left) to A-part, giving S. -C - CALL DGEQR2( M, M, T, LDST, TAUR, DWORK, LINFO ) - CALL DORM2R( 'Right', 'No Transpose', M, M, M, T, LDST, TAUR, - $ S, LDST, DWORK, LINFO ) - CALL DORM2R( 'Left', 'Transpose', M, M, M, T, LDST, TAUR, - $ IR, LDST, DWORK, LINFO ) -C -C Compute F-norm(S21) in BRQA21. (T21 is 0.) -C - DSCALE = ZERO - DSUM = ONE - DO 30 I = 1, N2 - CALL DLASSQ( N1, S(N2+1,I), 1, DSCALE, DSUM ) - 30 CONTINUE - BRQA21 = DSCALE*SQRT( DSUM ) -C -C Triangularize the B-part by an RQ factorization. -C Apply transformation (from right) to A-part, giving S. -C - CALL DGERQ2( M, M, TCPY, LDST, TAUL, DWORK, LINFO ) - CALL DORMR2( 'Left', 'No Transpose', M, M, M, TCPY, LDST, - $ TAUL, SCPY, LDST, DWORK, LINFO ) - CALL DORMR2( 'Right', 'Transpose', M, M, M, TCPY, LDST, - $ TAUL, LICOP, LDST, DWORK, LINFO ) -C -C Compute F-norm(S21) in BQRA21. (T21 is 0.) -C - DSCALE = ZERO - DSUM = ONE - DO 40 I = 1, N2 - CALL DLASSQ( N1, SCPY(N2+1,I), 1, DSCALE, DSUM ) - 40 CONTINUE - BQRA21 = DSCALE*SQRT( DSUM ) -C -C Decide which method to use. -C Weak stability test: -C F-norm(S21) <= O(EPS * F-norm((S, T))) -C - IF ( BQRA21.LE.BRQA21 .AND. BQRA21.LE.THRESH ) THEN - CALL DLACPY( 'All', M, M, SCPY, LDST, S, LDST ) - CALL DLACPY( 'All', M, M, TCPY, LDST, T, LDST ) - CALL DLACPY( 'All', M, M, IRCOP, LDST, IR, LDST ) - CALL DLACPY( 'All', M, M, LICOP, LDST, LI, LDST ) - ELSE IF ( BRQA21.GE.THRESH ) THEN - GO TO 50 - END IF -C -C Set lower triangle of B-part to zero -C - CALL DLASET( 'Lower', M-1, M-1, ZERO, ZERO, T(2,1), LDST ) -C - IF ( WANDS ) THEN -C -C Strong stability test: -C F-norm((A-QL*S*QR', B-QR*T*QL')) <= O(EPS*F-norm((A,B))) -C - CALL DLACPY( 'All', M, M, A, LDA, DWORK(M*M+1), M ) - CALL DGEMM( 'No Transpose', 'No Transpose', M, M, M, ONE, - $ LI, LDST, S, LDST, ZERO, DWORK, M ) - CALL DGEMM( 'No Transpose', 'No Transpose', M, M, M, -ONE, - $ DWORK, M, IR, LDST, ONE, DWORK(M*M+1), M ) - DSCALE = ZERO - DSUM = ONE - CALL DLASSQ( M*M, DWORK(M*M+1), 1, DSCALE, DSUM ) -C - CALL DLACPY( 'All', M, M, B, LDB, DWORK(M*M+1), M ) - CALL DGEMM( 'Transpose', 'No Transpose', M, M, M, ONE, - $ IR, LDST, T, LDST, ZERO, DWORK, M ) - CALL DGEMM( 'No Transpose', 'Transpose', M, M, M, -ONE, - $ DWORK, M, LI, LDST, ONE, DWORK(M*M+1), M ) - CALL DLASSQ( M*M, DWORK(M*M+1), 1, DSCALE, DSUM ) - SS = DSCALE*SQRT( DSUM ) - DTRONG = ( SS.LE.THRESH ) - IF( .NOT.DTRONG ) - $ GO TO 50 -C - END IF -C -C If the swap is accepted ("weakly" and "strongly"), apply the -C transformations and set N1-by-N2 (2,1)-block to zero. -C - CALL DLASET( 'All', N1, N2, ZERO, ZERO, S(N2+1,1), LDST ) -C -C Copy (S,T) to (A,B). -C - CALL DLACPY( 'All', M, M, S, LDST, A, LDA ) - CALL DLACPY( 'All', M, M, T, LDST, B, LDB ) - CALL DLASET( 'All', LDST, LDST, ZERO, ZERO, T, LDST ) -C -C Standardize existing 2-by-2 blocks. -C - CALL DLASET( 'All', M, M, ZERO, ZERO, DWORK, M ) - DWORK(1) = ONE - T(1,1) = ONE - IF ( N2.GT.1 ) THEN - CALL MB03YT( A, LDA, B, LDB, AR, AI, BE, DWORK(1), DWORK(2), - $ T(1,1), T(2,1) ) - DWORK(M+1) = -DWORK(2) - DWORK(M+2) = DWORK(1) - T(N2,N2) = T(1,1) - T(1,2) = -T(2,1) - END IF - DWORK(M*M) = ONE - T(M,M) = ONE -C - IF ( N1.GT.1 ) THEN - CALL MB03YT( A(N2+1,N2+1), LDA, B(N2+1,N2+1), LDB, TAUR, - $ TAUL, DWORK(M*M+1), DWORK(N2*M+N2+1), - $ DWORK(N2*M+N2+2), T(N2+1,N2+1), T(M,M-1) ) - DWORK(M*M) = DWORK(N2*M+N2+1) - DWORK(M*M-1 ) = -DWORK(N2*M+N2+2) - T(M,M) = T(N2+1,N2+1) - T(M-1,M) = -T(M,M-1) - END IF -C - CALL DGEMM( 'Transpose', 'No Transpose', N2, N1, N2, ONE, - $ DWORK, M, A(1,N2+1), LDA, ZERO, DWORK(M*M+1), N2 ) - CALL DLACPY( 'All', N2, N1, DWORK(M*M+1), N2, A(1,N2+1), LDA ) - CALL DGEMM( 'Transpose', 'No Transpose', N2, N1, N2, ONE, - $ T(1,1), LDST, B(1,N2+1), LDB, ZERO, - $ DWORK(M*M+1), N2 ) - CALL DLACPY( 'All', N2, N1, DWORK(M*M+1), N2, B(1,N2+1), LDB ) - CALL DGEMM( 'No Transpose', 'No Transpose', M, M, M, ONE, LI, - $ LDST, DWORK, M, ZERO, DWORK(M*M+1), M ) - CALL DLACPY( 'All', M, M, DWORK(M*M+1), M, LI, LDST ) - CALL DGEMM( 'No Transpose', 'No Transpose', N2, N1, N1, ONE, - $ A(1,N2+1), LDA, T(N2+1,N2+1), LDST, ZERO, - $ DWORK(M*M+1), M ) - CALL DLACPY( 'All', N2, N1, DWORK(M*M+1), M, A(1,N2+1), LDA ) - CALL DGEMM( 'No Transpose', 'No Transpose', N2, N1, N1, ONE, - $ B(1,N2+1), LDB, DWORK(N2*M+N2+1), M, ZERO, - $ DWORK(M*M+1), M ) - CALL DLACPY( 'All', N2, N1, DWORK(M*M+1), M, B(1,N2+1), LDB ) - CALL DGEMM( 'Transpose', 'No Transpose', M, M, M, ONE, T, - $ LDST, IR, LDST, ZERO, DWORK, M ) - CALL DLACPY( 'All', M, M, DWORK, M, IR, LDST ) -C -C Accumulate transformations into Q and Z if requested. -C - IF( WANTQ ) THEN - CALL DGEMM( 'No Transpose', 'No Transpose', M, M, M, ONE, Q, - $ LDQ, LI, LDST, ZERO, DWORK, M ) - CALL DLACPY( 'All', M, M, DWORK, M, Q, LDQ ) - END IF -C - IF( WANTZ ) THEN - CALL DGEMM( 'No Transpose', 'Transpose', M, M, M, ONE, Z, - $ LDZ, IR, LDST, ZERO, DWORK, M ) - CALL DLACPY( 'Full', M, M, DWORK, M, Z, LDZ ) -C - END IF -C -C Exit with INFO = 0 if swap was successfully performed. -C - RETURN -C - END IF -C -C Exit with INFO = 1 if swap was rejected. -C - 50 CONTINUE -C - INFO = 1 - RETURN -C *** Last line of MB03WA *** - END diff --git a/mex/sources/libslicot/MB03WD.f b/mex/sources/libslicot/MB03WD.f deleted file mode 100644 index 76bd6780d..000000000 --- a/mex/sources/libslicot/MB03WD.f +++ /dev/null @@ -1,966 +0,0 @@ - SUBROUTINE MB03WD( JOB, COMPZ, N, P, ILO, IHI, ILOZ, IHIZ, H, - $ LDH1, LDH2, Z, LDZ1, LDZ2, WR, WI, DWORK, - $ LDWORK, INFO ) -C -C SLICOT RELEASE 5.0. -C -C Copyright (c) 2002-2009 NICONET e.V. -C -C This program is free software: you can redistribute it and/or -C modify it under the terms of the GNU General Public License as -C published by the Free Software Foundation, either version 2 of -C the License, or (at your option) any later version. -C -C This program is distributed in the hope that it will be useful, -C but WITHOUT ANY WARRANTY; without even the implied warranty of -C MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the -C GNU General Public License for more details. -C -C You should have received a copy of the GNU General Public License -C along with this program. If not, see -C . -C -C PURPOSE -C -C To compute the Schur decomposition and the eigenvalues of a -C product of matrices, H = H_1*H_2*...*H_p, with H_1 an upper -C Hessenberg matrix and H_2, ..., H_p upper triangular matrices, -C without evaluating the product. Specifically, the matrices Z_i -C are computed, such that -C -C Z_1' * H_1 * Z_2 = T_1, -C Z_2' * H_2 * Z_3 = T_2, -C ... -C Z_p' * H_p * Z_1 = T_p, -C -C where T_1 is in real Schur form, and T_2, ..., T_p are upper -C triangular. -C -C The routine works primarily with the Hessenberg and triangular -C submatrices in rows and columns ILO to IHI, but optionally applies -C the transformations to all the rows and columns of the matrices -C H_i, i = 1,...,p. The transformations can be optionally -C accumulated. -C -C ARGUMENTS -C -C Mode Parameters -C -C JOB CHARACTER*1 -C Indicates whether the user wishes to compute the full -C Schur form or the eigenvalues only, as follows: -C = 'E': Compute the eigenvalues only; -C = 'S': Compute the factors T_1, ..., T_p of the full -C Schur form, T = T_1*T_2*...*T_p. -C -C COMPZ CHARACTER*1 -C Indicates whether or not the user wishes to accumulate -C the matrices Z_1, ..., Z_p, as follows: -C = 'N': The matrices Z_1, ..., Z_p are not required; -C = 'I': Z_i is initialized to the unit matrix and the -C orthogonal transformation matrix Z_i is returned, -C i = 1, ..., p; -C = 'V': Z_i must contain an orthogonal matrix Q_i on -C entry, and the product Q_i*Z_i is returned, -C i = 1, ..., p. -C -C Input/Output Parameters -C -C N (input) INTEGER -C The order of the matrix H. N >= 0. -C -C P (input) INTEGER -C The number of matrices in the product H_1*H_2*...*H_p. -C P >= 1. -C -C ILO (input) INTEGER -C IHI (input) INTEGER -C It is assumed that all matrices H_j, j = 2, ..., p, are -C already upper triangular in rows and columns 1:ILO-1 and -C IHI+1:N, and H_1 is upper quasi-triangular in rows and -C columns 1:ILO-1 and IHI+1:N, with H_1(ILO,ILO-1) = 0 -C (unless ILO = 1), and H_1(IHI+1,IHI) = 0 (unless IHI = N). -C The routine works primarily with the Hessenberg submatrix -C in rows and columns ILO to IHI, but applies the -C transformations to all the rows and columns of the -C matrices H_i, i = 1,...,p, if JOB = 'S'. -C 1 <= ILO <= max(1,N); min(ILO,N) <= IHI <= N. -C -C ILOZ (input) INTEGER -C IHIZ (input) INTEGER -C Specify the rows of Z to which the transformations must be -C applied if COMPZ = 'I' or COMPZ = 'V'. -C 1 <= ILOZ <= ILO; IHI <= IHIZ <= N. -C -C H (input/output) DOUBLE PRECISION array, dimension -C (LDH1,LDH2,P) -C On entry, the leading N-by-N part of H(*,*,1) must contain -C the upper Hessenberg matrix H_1 and the leading N-by-N -C part of H(*,*,j) for j > 1 must contain the upper -C triangular matrix H_j, j = 2, ..., p. -C On exit, if JOB = 'S', the leading N-by-N part of H(*,*,1) -C is upper quasi-triangular in rows and columns ILO:IHI, -C with any 2-by-2 diagonal blocks corresponding to a pair of -C complex conjugated eigenvalues, and the leading N-by-N -C part of H(*,*,j) for j > 1 contains the resulting upper -C triangular matrix T_j. -C If JOB = 'E', the contents of H are unspecified on exit. -C -C LDH1 INTEGER -C The first leading dimension of the array H. -C LDH1 >= max(1,N). -C -C LDH2 INTEGER -C The second leading dimension of the array H. -C LDH2 >= max(1,N). -C -C Z (input/output) DOUBLE PRECISION array, dimension -C (LDZ1,LDZ2,P) -C On entry, if COMPZ = 'V', the leading N-by-N-by-P part of -C this array must contain the current matrix Q of -C transformations accumulated by SLICOT Library routine -C MB03VY. -C If COMPZ = 'I', Z need not be set on entry. -C On exit, if COMPZ = 'V', or COMPZ = 'I', the leading -C N-by-N-by-P part of this array contains the transformation -C matrices which produced the Schur form; the -C transformations are applied only to the submatrices -C Z_j(ILOZ:IHIZ,ILO:IHI), j = 1, ..., P. -C If COMPZ = 'N', Z is not referenced. -C -C LDZ1 INTEGER -C The first leading dimension of the array Z. -C LDZ1 >= 1, if COMPZ = 'N'; -C LDZ1 >= max(1,N), if COMPZ = 'I' or COMPZ = 'V'. -C -C LDZ2 INTEGER -C The second leading dimension of the array Z. -C LDZ2 >= 1, if COMPZ = 'N'; -C LDZ2 >= max(1,N), if COMPZ = 'I' or COMPZ = 'V'. -C -C WR (output) DOUBLE PRECISION array, dimension (N) -C WI (output) DOUBLE PRECISION array, dimension (N) -C The real and imaginary parts, respectively, of the -C computed eigenvalues ILO to IHI are stored in the -C corresponding elements of WR and WI. If two eigenvalues -C are computed as a complex conjugate pair, they are stored -C in consecutive elements of WR and WI, say the i-th and -C (i+1)th, with WI(i) > 0 and WI(i+1) < 0. If JOB = 'S', the -C eigenvalues are stored in the same order as on the -C diagonal of the Schur form returned in H. -C -C Workspace -C -C DWORK DOUBLE PRECISION work array, dimension (LDWORK) -C -C LDWORK INTEGER -C The length of the array DWORK. LDWORK >= IHI-ILO+P-1. -C -C Error Indicator -C -C INFO INTEGER -C = 0: successful exit; -C < 0: if INFO = -i, the i-th argument had an illegal -C value; -C > 0: if INFO = i, ILO <= i <= IHI, the QR algorithm -C failed to compute all the eigenvalues ILO to IHI -C in a total of 30*(IHI-ILO+1) iterations; -C the elements i+1:IHI of WR and WI contain those -C eigenvalues which have been successfully computed. -C -C METHOD -C -C A refined version of the QR algorithm proposed in [1] and [2] is -C used. The elements of the subdiagonal, diagonal, and the first -C supradiagonal of current principal submatrix of H are computed -C in the process. -C -C REFERENCES -C -C [1] Bojanczyk, A.W., Golub, G. and Van Dooren, P. -C The periodic Schur decomposition: algorithms and applications. -C Proc. of the SPIE Conference (F.T. Luk, Ed.), 1770, pp. 31-42, -C 1992. -C -C [2] Sreedhar, J. and Van Dooren, P. -C Periodic Schur form and some matrix equations. -C Proc. of the Symposium on the Mathematical Theory of Networks -C and Systems (MTNS'93), Regensburg, Germany (U. Helmke, -C R. Mennicken and J. Saurer, Eds.), Vol. 1, pp. 339-362, 1994. -C -C NUMERICAL ASPECTS -C -C The algorithm is numerically stable. -C -C FURTHER COMMENTS -C -C Note that for P = 1, the LAPACK Library routine DHSEQR could be -C more efficient on some computer architectures than this routine, -C because DHSEQR uses a block multishift QR algorithm. -C When P is large and JOB = 'S', it could be more efficient to -C compute the product matrix H, and use the LAPACK Library routines. -C -C CONTRIBUTOR -C -C V. Sima, Katholieke Univ. Leuven, Belgium, and A. Varga, -C German Aerospace Center, DLR Oberpfaffenhofen, February 1999. -C Partly based on the routine PSHQR by A. Varga -C (DLR Oberpfaffenhofen), January 22, 1996. -C -C REVISIONS -C -C Oct. 2001, V. Sima, Research Institute for Informatics, Bucharest. -C -C KEYWORDS -C -C Eigenvalue, eigenvalue decomposition, Hessenberg form, -C orthogonal transformation, periodic systems, (periodic) Schur -C form, real Schur form, similarity transformation, triangular form. -C -C ****************************************************************** -C -C .. Parameters .. - DOUBLE PRECISION ZERO, ONE, HALF - PARAMETER ( ZERO = 0.0D+0, ONE = 1.0D+0, HALF = 0.5D+0 ) - DOUBLE PRECISION DAT1, DAT2 - PARAMETER ( DAT1 = 0.75D+0, DAT2 = -0.4375D+0 ) -C .. -C .. Scalar Arguments .. - CHARACTER COMPZ, JOB - INTEGER IHI, IHIZ, ILO, ILOZ, INFO, LDH1, LDH2, LDWORK, - $ LDZ1, LDZ2, N, P -C .. -C .. Array Arguments .. - DOUBLE PRECISION DWORK( * ), H( LDH1, LDH2, * ), WI( * ), - $ WR( * ), Z( LDZ1, LDZ2, * ) -C .. -C .. Local Scalars .. - LOGICAL INITZ, WANTT, WANTZ - INTEGER I, I1, I2, ITN, ITS, J, JMAX, JMIN, K, L, M, - $ NH, NR, NROW, NZ - DOUBLE PRECISION AVE, CS, DISC, H11, H12, H21, H22, H33, H33S, - $ H43H34, H44, H44S, HH10, HH11, HH12, HH21, HH22, - $ HP00, HP01, HP02, HP11, HP12, HP22, OVFL, S, - $ SMLNUM, SN, TAU, TST1, ULP, UNFL, V1, V2, V3 -C .. -C .. Local Arrays .. - DOUBLE PRECISION V( 3 ) -C .. -C .. External Functions .. - LOGICAL LSAME - DOUBLE PRECISION DLAMCH, DLANHS, DLANTR - EXTERNAL DLAMCH, DLANHS, DLANTR, LSAME -C .. -C .. External Subroutines .. - EXTERNAL DCOPY, DLABAD, DLANV2, DLARFG, DLARFX, DLARTG, - $ DLASET, DROT, MB04PY, XERBLA -C .. -C .. Intrinsic Functions .. - INTRINSIC ABS, DBLE, MAX, MIN, SIGN, SQRT -C .. -C .. Executable Statements .. -C -C Test the input scalar arguments. -C - WANTT = LSAME( JOB, 'S' ) - INITZ = LSAME( COMPZ, 'I' ) - WANTZ = LSAME( COMPZ, 'V' ) .OR. INITZ - INFO = 0 - IF( .NOT. ( WANTT .OR. LSAME( JOB, 'E' ) ) ) THEN - INFO = -1 - ELSE IF( .NOT. ( WANTZ .OR. LSAME( COMPZ, 'N' ) ) ) THEN - INFO = -2 - ELSE IF( N.LT.0 ) THEN - INFO = -3 - ELSE IF( P.LT.1 ) THEN - INFO = -4 - ELSE IF( ILO.LT.1 .OR. ILO.GT.MAX( 1, N ) ) THEN - INFO = -5 - ELSE IF( IHI.LT.MIN( ILO, N ) .OR. IHI.GT.N ) THEN - INFO = -6 - ELSE IF( ILOZ.LT.1 .OR. ILOZ.GT.ILO ) THEN - INFO = -7 - ELSE IF( IHIZ.LT.IHI .OR. IHIZ.GT.N ) THEN - INFO = -8 - ELSE IF( LDH1.LT.MAX( 1, N ) ) THEN - INFO = -10 - ELSE IF( LDH2.LT.MAX( 1, N ) ) THEN - INFO = -11 - ELSE IF( LDZ1.LT.1 .OR. ( WANTZ .AND. LDZ1.LT.N ) ) THEN - INFO = -13 - ELSE IF( LDZ2.LT.1 .OR. ( WANTZ .AND. LDZ2.LT.N ) ) THEN - INFO = -14 - ELSE IF( LDWORK.LT.IHI - ILO + P - 1 ) THEN - INFO = -18 - END IF - IF( INFO.EQ.0 ) THEN - IF( ILO.GT.1 ) THEN - IF( H( ILO, ILO-1, 1 ).NE.ZERO ) - $ INFO = -5 - ELSE IF( IHI.LT.N ) THEN - IF( H( IHI+1, IHI, 1 ).NE.ZERO ) - $ INFO = -6 - END IF - END IF -C - IF( INFO.NE.0 ) THEN - CALL XERBLA( 'MB03WD', -INFO ) - RETURN - END IF -C -C Quick return if possible. -C - IF( N.EQ.0 ) - $ RETURN -C -C Initialize Z, if necessary. -C - IF( INITZ ) THEN -C - DO 10 J = 1, P - CALL DLASET( 'Full', N, N, ZERO, ONE, Z( 1, 1, J ), LDZ1 ) - 10 CONTINUE -C - END IF -C - NH = IHI - ILO + 1 -C - IF( NH.EQ.1 ) THEN - HP00 = ONE -C - DO 20 J = 1, P - HP00 = HP00 * H( ILO, ILO, J ) - 20 CONTINUE -C - WR( ILO ) = HP00 - WI( ILO ) = ZERO - RETURN - END IF -C -C Set machine-dependent constants for the stopping criterion. -C If norm(H) <= sqrt(OVFL), overflow should not occur. -C - UNFL = DLAMCH( 'Safe minimum' ) - OVFL = ONE / UNFL - CALL DLABAD( UNFL, OVFL ) - ULP = DLAMCH( 'Precision' ) - SMLNUM = UNFL*( DBLE( NH ) / ULP ) -C -C Set the elements in rows and columns ILO to IHI to zero below the -C first subdiagonal in H(*,*,1) and below the first diagonal in -C H(*,*,j), j >= 2. In the same loop, compute and store in -C DWORK(NH:NH+P-2) the 1-norms of the matrices H_2, ..., H_p, to be -C used later. -C - I = NH - S = ULP * DBLE( N ) - IF( NH.GT.2 ) - $ CALL DLASET( 'Lower', NH-2, NH-2, ZERO, ZERO, - $ H( ILO+2, ILO, 1 ), LDH1 ) -C - DO 30 J = 2, P - CALL DLASET( 'Lower', NH-1, NH-1, ZERO, ZERO, - $ H( ILO+1, ILO, J ), LDH1 ) - DWORK( I ) = S * DLANTR( '1-norm', 'Upper', 'NonUnit', NH, NH, - $ H( ILO, ILO, J ), LDH1, DWORK ) - I = I + 1 - 30 CONTINUE -C -C I1 and I2 are the indices of the first row and last column of H -C to which transformations must be applied. If eigenvalues only are -C being computed, I1 and I2 are set inside the main loop. -C - IF( WANTT ) THEN - I1 = 1 - I2 = N - END IF -C - IF( WANTZ ) - $ NZ = IHIZ - ILOZ + 1 -C -C ITN is the total number of QR iterations allowed. -C - ITN = 30*NH -C -C The main loop begins here. I is the loop index and decreases from -C IHI to ILO in steps of 1 or 2. Each iteration of the loop works -C with the active submatrix in rows and columns L to I. -C Eigenvalues I+1 to IHI have already converged. Either L = ILO or -C H(L,L-1) is negligible so that the matrix splits. -C - I = IHI -C - 40 CONTINUE - L = ILO -C -C Perform QR iterations on rows and columns ILO to I until a -C submatrix of order 1 or 2 splits off at the bottom because a -C subdiagonal element has become negligible. -C -C Let T = H_2*...*H_p, and H = H_1*T. Part of the currently -C free locations of WR and WI are temporarily used as workspace. -C -C WR(L:I): the current diagonal elements of h = H(L:I,L:I); -C WI(L+1:I): the current elements of the first subdiagonal of h; -C DWORK(NH-I+L:NH-1): the current elements of the first -C supradiagonal of h. -C - DO 160 ITS = 0, ITN -C -C Initialization: compute H(I,I) (and H(I,I-1) if I > L). -C - HP22 = ONE - IF( I.GT.L ) THEN - HP12 = ZERO - HP11 = ONE -C - DO 50 J = 2, P - HP22 = HP22*H( I, I, J ) - HP12 = HP11*H( I-1, I, J ) + HP12*H( I, I, J ) - HP11 = HP11*H( I-1, I-1, J ) - 50 CONTINUE -C - HH21 = H( I, I-1, 1 )*HP11 - HH22 = H( I, I-1, 1 )*HP12 + H( I, I, 1 )*HP22 -C - WR( I ) = HH22 - WI( I ) = HH21 - ELSE -C - DO 60 J = 1, P - HP22 = HP22*H( I, I, J ) - 60 CONTINUE -C - WR( I ) = HP22 - END IF -C -C Look for a single small subdiagonal element. -C The loop also computes the needed current elements of the -C diagonal and the first two supradiagonals of T, as well as -C the current elements of the central tridiagonal of H. -C - DO 80 K = I, L + 1, -1 -C -C Evaluate H(K-1,K-1), H(K-1,K) (and H(K-1,K-2) if K > L+1). -C - HP00 = ONE - HP01 = ZERO - IF( K.GT.L+1 ) THEN - HP02 = ZERO -C - DO 70 J = 2, P - HP02 = HP00*H( K-2, K, J ) + HP01*H( K-1, K, J ) - $ + HP02*H( K, K, J ) - HP01 = HP00*H( K-2, K-1, J ) + HP01*H( K-1, K-1, J ) - HP00 = HP00*H( K-2, K-2, J ) - 70 CONTINUE -C - HH10 = H( K-1, K-2, 1 )*HP00 - HH11 = H( K-1, K-2, 1 )*HP01 + H( K-1, K-1, 1 )*HP11 - HH12 = H( K-1, K-2, 1 )*HP02 + H( K-1, K-1, 1 )*HP12 - $ + H( K-1, K, 1 )*HP22 - WI( K-1 ) = HH10 - ELSE - HH10 = ZERO - HH11 = H( K-1, K-1, 1 )*HP11 - HH12 = H( K-1, K-1, 1 )*HP12 + H( K-1, K, 1 )*HP22 - END IF - WR( K-1 ) = HH11 - DWORK( NH-I+K-1) = HH12 -C -C Test for a negligible subdiagonal element. -C - TST1 = ABS( HH11 ) + ABS( HH22 ) - IF( TST1.EQ.ZERO ) - $ TST1 = DLANHS( '1-norm', I-L+1, H( L, L, 1 ), LDH1, - $ DWORK ) - IF( ABS( HH21 ).LE.MAX( ULP*TST1, SMLNUM ) ) - $ GO TO 90 -C -C Update the values for the next cycle. -C - HP22 = HP11 - HP11 = HP00 - HP12 = HP01 - HH22 = HH11 - HH21 = HH10 - 80 CONTINUE -C - 90 CONTINUE - L = K -C - IF( L.GT.ILO ) THEN -C -C H(L,L-1) is negligible. -C - IF( WANTT ) THEN -C -C If H(L,L-1,1) is also negligible, set it to 0; otherwise, -C annihilate the subdiagonal elements bottom-up, and -C restore the triangular form of H(*,*,j). Since H(L,L-1) -C is negligible, the second case can only appear when the -C product of H(L-1,L-1,j), j >= 2, is negligible. -C - TST1 = ABS( H( L-1, L-1, 1 ) ) + ABS( H( L, L, 1 ) ) - IF( TST1.EQ.ZERO ) - $ TST1 = DLANHS( '1-norm', I-L+1, H( L, L, 1 ), LDH1, - $ DWORK ) - IF( ABS( H( L, L-1, 1 ) ).GT.MAX( ULP*TST1, SMLNUM ) ) - $ THEN -C - DO 110 K = I, L, -1 -C - DO 100 J = 1, P - 1 -C -C Compute G to annihilate from the right the -C (K,K-1) element of the matrix H_j. -C - V( 1 ) = H( K, K-1, J ) - CALL DLARFG( 2, H( K, K, J ), V, 1, TAU ) - H( K, K-1, J ) = ZERO - V( 2 ) = ONE -C -C Apply G from the right to transform the columns -C of the matrix H_j in rows I1 to K-1. -C - CALL DLARFX( 'Right', K-I1, 2, V, TAU, - $ H( I1, K-1, J ), LDH1, DWORK ) -C -C Apply G from the left to transform the rows of -C the matrix H_(j+1) in columns K-1 to I2. -C - CALL DLARFX( 'Left', 2, I2-K+2, V, TAU, - $ H( K-1, K-1, J+1 ), LDH1, DWORK ) -C - IF( WANTZ ) THEN -C -C Accumulate transformations in the matrix -C Z_(j+1). -C - CALL DLARFX( 'Right', NZ, 2, V, TAU, - $ Z( ILOZ, K-1, J+1 ), LDZ1, - $ DWORK ) - END IF - 100 CONTINUE -C - IF( K.LT.I ) THEN -C -C Compute G to annihilate from the right the -C (K+1,K) element of the matrix H_p. -C - V( 1 ) = H( K+1, K, P ) - CALL DLARFG( 2, H( K+1, K+1, P ), V, 1, TAU ) - H( K+1, K, P ) = ZERO - V( 2 ) = ONE -C -C Apply G from the right to transform the columns -C of the matrix H_p in rows I1 to K. -C - CALL DLARFX( 'Right', K-I1+1, 2, V, TAU, - $ H( I1, K, P ), LDH1, DWORK ) -C -C Apply G from the left to transform the rows of -C the matrix H_1 in columns K to I2. -C - CALL DLARFX( 'Left', 2, I2-K+1, V, TAU, - $ H( K, K, 1 ), LDH1, DWORK ) -C - IF( WANTZ ) THEN -C -C Accumulate transformations in the matrix Z_1. -C - CALL DLARFX( 'Right', NZ, 2, V, TAU, - $ Z( ILOZ, K, 1 ), LDZ1, DWORK ) - END IF - END IF - 110 CONTINUE -C - H( L, L-1, P ) = ZERO - END IF - H( L, L-1, 1 ) = ZERO - END IF - END IF -C -C Exit from loop if a submatrix of order 1 or 2 has split off. -C - IF( L.GE.I-1 ) - $ GO TO 170 -C -C Now the active submatrix is in rows and columns L to I. If -C eigenvalues only are being computed, only the active submatrix -C need be transformed. -C - IF( .NOT.WANTT ) THEN - I1 = L - I2 = I - END IF -C - IF( ITS.EQ.10 .OR. ITS.EQ.20 ) THEN -C -C Exceptional shift. -C - S = ABS( WI( I ) ) + ABS( WI( I-1 ) ) - H44 = DAT1*S + WR( I ) - H33 = H44 - H43H34 = DAT2*S*S - ELSE -C -C Prepare to use Francis' double shift (i.e., second degree -C generalized Rayleigh quotient). -C - H44 = WR( I ) - H33 = WR( I-1 ) - H43H34 = WI( I )*DWORK( NH-1 ) - DISC = ( H33 - H44 )*HALF - DISC = DISC*DISC + H43H34 - IF( DISC.GT.ZERO ) THEN -C -C Real roots: use Wilkinson's shift twice. -C - DISC = SQRT( DISC ) - AVE = HALF*( H33 + H44 ) - IF( ABS( H33 )-ABS( H44 ).GT.ZERO ) THEN - H33 = H33*H44 - H43H34 - H44 = H33 / ( SIGN( DISC, AVE ) + AVE ) - ELSE - H44 = SIGN( DISC, AVE ) + AVE - END IF - H33 = H44 - H43H34 = ZERO - END IF - END IF -C -C Look for two consecutive small subdiagonal elements. -C - DO 120 M = I - 2, L, -1 -C -C Determine the effect of starting the double-shift QR -C iteration at row M, and see if this would make H(M,M-1) -C negligible. -C - H11 = WR( M ) - H12 = DWORK( NH-I+M ) - H21 = WI( M+1 ) - H22 = WR( M+1 ) - H44S = H44 - H11 - H33S = H33 - H11 - V1 = ( H33S*H44S - H43H34 ) / H21 + H12 - V2 = H22 - H11 - H33S - H44S - V3 = WI( M+2 ) - S = ABS( V1 ) + ABS( V2 ) + ABS( V3 ) - V1 = V1 / S - V2 = V2 / S - V3 = V3 / S - V( 1 ) = V1 - V( 2 ) = V2 - V( 3 ) = V3 - IF( M.EQ.L ) - $ GO TO 130 - TST1 = ABS( V1 )*( ABS( WR( M-1 ) ) + - $ ABS( H11 ) + ABS( H22 ) ) - IF( ABS( WI( M ) )*( ABS( V2 ) + ABS( V3 ) ).LE.ULP*TST1 ) - $ GO TO 130 - 120 CONTINUE -C - 130 CONTINUE -C -C Double-shift QR step. -C - DO 150 K = M, I - 1 -C -C The first iteration of this loop determines a reflection G -C from the vector V and applies it from left and right to H, -C thus creating a nonzero bulge below the subdiagonal. -C -C Each subsequent iteration determines a reflection G to -C restore the Hessenberg form in the (K-1)th column, and thus -C chases the bulge one step toward the bottom of the active -C submatrix. NR is the order of G. -C - NR = MIN( 3, I-K+1 ) - NROW = MIN( K+NR, I ) - I1 + 1 - IF( K.GT.M ) - $ CALL DCOPY( NR, H( K, K-1, 1 ), 1, V, 1 ) - CALL DLARFG( NR, V( 1 ), V( 2 ), 1, TAU ) - IF( K.GT.M ) THEN - H( K, K-1, 1 ) = V( 1 ) - H( K+1, K-1, 1 ) = ZERO - IF( K.LT.I-1 ) - $ H( K+2, K-1, 1 ) = ZERO - ELSE IF( M.GT.L ) THEN - H( K, K-1, 1 ) = -H( K, K-1, 1 ) - END IF -C -C Apply G from the left to transform the rows of the matrix -C H_1 in columns K to I2. -C - CALL MB04PY( 'Left', NR, I2-K+1, V( 2 ), TAU, H( K, K, 1 ), - $ LDH1, DWORK ) -C -C Apply G from the right to transform the columns of the -C matrix H_p in rows I1 to min(K+NR,I). -C - CALL MB04PY( 'Right', NROW, NR, V( 2 ), TAU, H( I1, K, P ), - $ LDH1, DWORK ) -C - IF( WANTZ ) THEN -C -C Accumulate transformations in the matrix Z_1. -C - CALL MB04PY( 'Right', NZ, NR, V( 2 ), TAU, - $ Z( ILOZ, K, 1 ), LDZ1, DWORK ) - END IF -C - DO 140 J = P, 2, -1 -C -C Apply G1 (and G2, if NR = 3) from the left to transform -C the NR-by-NR submatrix of H_j in position (K,K) to upper -C triangular form. -C -C Compute G1. -C - CALL DCOPY( NR-1, H( K+1, K, J ), 1, V, 1 ) - CALL DLARFG( NR, H( K, K, J ), V, 1, TAU ) - H( K+1, K, J ) = ZERO - IF( NR.EQ.3 ) - $ H( K+2, K, J ) = ZERO -C -C Apply G1 from the left to transform the rows of the -C matrix H_j in columns K+1 to I2. -C - CALL MB04PY( 'Left', NR, I2-K, V, TAU, H( K, K+1, J ), - $ LDH1, DWORK ) -C -C Apply G1 from the right to transform the columns of the -C matrix H_(j-1) in rows I1 to min(K+NR,I). -C - CALL MB04PY( 'Right', NROW, NR, V, TAU, H( I1, K, J-1 ), - $ LDH1, DWORK ) -C - IF( WANTZ ) THEN -C -C Accumulate transformations in the matrix Z_j. -C - CALL MB04PY( 'Right', NZ, NR, V, TAU, Z( ILOZ, K, J ), - $ LDZ1, DWORK ) - END IF -C - IF( NR.EQ.3 ) THEN -C -C Compute G2. -C - V( 1 ) = H( K+2, K+1, J ) - CALL DLARFG( 2, H( K+1, K+1, J ), V, 1, TAU ) - H( K+2, K+1, J ) = ZERO -C -C Apply G2 from the left to transform the rows of the -C matrix H_j in columns K+2 to I2. -C - CALL MB04PY( 'Left', 2, I2-K-1, V, TAU, - $ H( K+1, K+2, J ), LDH1, DWORK ) -C -C Apply G2 from the right to transform the columns of -C the matrix H_(j-1) in rows I1 to min(K+3,I). -C - CALL MB04PY( 'Right', NROW, 2, V, TAU, - $ H( I1, K+1, J-1 ), LDH1, DWORK ) -C - IF( WANTZ ) THEN -C -C Accumulate transformations in the matrix Z_j. -C - CALL MB04PY( 'Right', NZ, 2, V, TAU, - $ Z( ILOZ, K+1, J ), LDZ1, DWORK ) - END IF - END IF - 140 CONTINUE -C - 150 CONTINUE -C - 160 CONTINUE -C -C Failure to converge in remaining number of iterations. -C - INFO = I - RETURN -C - 170 CONTINUE -C - IF( L.EQ.I ) THEN -C -C H(I,I-1,1) is negligible: one eigenvalue has converged. -C Note that WR(I) has already been set. -C - WI( I ) = ZERO - ELSE IF( L.EQ.I-1 ) THEN -C -C H(I-1,I-2,1) is negligible: a pair of eigenvalues have -C converged. -C -C Transform the 2-by-2 submatrix of H_1*H_2*...*H_p in position -C (I-1,I-1) to standard Schur form, and compute and store its -C eigenvalues. If the Schur form is not required, then the -C previously stored values of a similar submatrix are used. -C For real eigenvalues, a Givens transformation is used to -C triangularize the submatrix. -C - IF( WANTT ) THEN - HP22 = ONE - HP12 = ZERO - HP11 = ONE -C - DO 180 J = 2, P - HP22 = HP22*H( I, I, J ) - HP12 = HP11*H( I-1, I, J ) + HP12*H( I, I, J ) - HP11 = HP11*H( I-1, I-1, J ) - 180 CONTINUE -C - HH21 = H( I, I-1, 1 )*HP11 - HH22 = H( I, I-1, 1 )*HP12 + H( I, I, 1 )*HP22 - HH11 = H( I-1, I-1, 1 )*HP11 - HH12 = H( I-1, I-1, 1 )*HP12 + H( I-1, I, 1 )*HP22 - ELSE - HH11 = WR( I-1 ) - HH12 = DWORK( NH-1 ) - HH21 = WI( I ) - HH22 = WR( I ) - END IF -C - CALL DLANV2( HH11, HH12, HH21, HH22, WR( I-1 ), WI( I-1 ), - $ WR( I ), WI( I ), CS, SN ) -C - IF( WANTT ) THEN -C -C Detect negligible diagonal elements in positions (I-1,I-1) -C and (I,I) in H_j, J > 1. -C - JMIN = 0 - JMAX = 0 -C - DO 190 J = 2, P - IF( JMIN.EQ.0 ) THEN - IF( ABS( H( I-1, I-1, J ) ).LE.DWORK( NH+J-2 ) ) - $ JMIN = J - END IF - IF( ABS( H( I, I, J ) ).LE.DWORK( NH+J-2 ) ) JMAX = J - 190 CONTINUE -C - IF( JMIN.NE.0 .AND. JMAX.NE.0 ) THEN -C -C Choose the shorter path if zero elements in both -C (I-1,I-1) and (I,I) positions are present. -C - IF( JMIN-1.LE.P-JMAX+1 ) THEN - JMAX = 0 - ELSE - JMIN = 0 - END IF - END IF -C - IF( JMIN.NE.0 ) THEN -C - DO 200 J = 1, JMIN - 1 -C -C Compute G to annihilate from the right the (I,I-1) -C element of the matrix H_j. -C - V( 1 ) = H( I, I-1, J ) - CALL DLARFG( 2, H( I, I, J ), V, 1, TAU ) - H( I, I-1, J ) = ZERO - V( 2 ) = ONE -C -C Apply G from the right to transform the columns of the -C matrix H_j in rows I1 to I-1. -C - CALL DLARFX( 'Right', I-I1, 2, V, TAU, - $ H( I1, I-1, J ), LDH1, DWORK ) -C -C Apply G from the left to transform the rows of the -C matrix H_(j+1) in columns I-1 to I2. -C - CALL DLARFX( 'Left', 2, I2-I+2, V, TAU, - $ H( I-1, I-1, J+1 ), LDH1, DWORK ) -C - IF( WANTZ ) THEN -C -C Accumulate transformations in the matrix Z_(j+1). -C - CALL DLARFX( 'Right', NZ, 2, V, TAU, - $ Z( ILOZ, I-1, J+1 ), LDZ1, DWORK ) - END IF - 200 CONTINUE -C - H( I, I-1, JMIN ) = ZERO -C - ELSE - IF( JMAX.GT.0 .AND. WI( I-1 ).EQ.ZERO ) - $ CALL DLARTG( H( I-1, I-1, 1 ), H( I, I-1, 1 ), CS, SN, - $ TAU ) -C -C Apply the transformation to H. -C - CALL DROT( I2-I+2, H( I-1, I-1, 1 ), LDH1, - $ H( I, I-1, 1 ), LDH1, CS, SN ) - CALL DROT( I-I1+1, H( I1, I-1, P ), 1, H( I1, I, P ), 1, - $ CS, SN ) - IF( WANTZ ) THEN -C -C Apply transformation to Z_1. -C - CALL DROT( NZ, Z( ILOZ, I-1, 1 ), 1, Z( ILOZ, I, 1 ), - $ 1, CS, SN ) - END IF -C - DO 210 J = P, MAX( 2, JMAX+1 ), -1 -C -C Compute G1 to annihilate from the left the (I,I-1) -C element of the matrix H_j. -C - V( 1 ) = H( I, I-1, J ) - CALL DLARFG( 2, H( I-1, I-1, J ), V, 1, TAU ) - H( I, I-1, J ) = ZERO -C -C Apply G1 from the left to transform the rows of the -C matrix H_j in columns I to I2. -C - CALL MB04PY( 'Left', 2, I2-I+1, V, TAU, - $ H( I-1, I, J ), LDH1, DWORK ) -C -C Apply G1 from the right to transform the columns of -C the matrix H_(j-1) in rows I1 to I. -C - CALL MB04PY( 'Right', I-I1+1, 2, V, TAU, - $ H( I1, I-1, J-1 ), LDH1, DWORK ) -C - IF( WANTZ ) THEN -C -C Apply G1 to Z_j. -C - CALL MB04PY( 'Right', NZ, 2, V, TAU, - $ Z( ILOZ, I-1, J ), LDZ1, DWORK ) - END IF - 210 CONTINUE -C - IF( JMAX.GT.0 ) THEN - H( I, I-1, 1 ) = ZERO - H( I, I-1, JMAX ) = ZERO - ELSE - IF( HH21.EQ.ZERO ) - $ H( I, I-1, 1 ) = ZERO - END IF - END IF - END IF - END IF -C -C Decrement number of remaining iterations, and return to start of -C the main loop with new value of I. -C - ITN = ITN - ITS - I = L - 1 - IF( I.GE.ILO ) - $ GO TO 40 -C - RETURN -C -C *** Last line of MB03WD *** - END diff --git a/mex/sources/libslicot/MB03WX.f b/mex/sources/libslicot/MB03WX.f deleted file mode 100644 index b8c3a9e28..000000000 --- a/mex/sources/libslicot/MB03WX.f +++ /dev/null @@ -1,170 +0,0 @@ - SUBROUTINE MB03WX( N, P, T, LDT1, LDT2, WR, WI, INFO ) -C -C SLICOT RELEASE 5.0. -C -C Copyright (c) 2002-2009 NICONET e.V. -C -C This program is free software: you can redistribute it and/or -C modify it under the terms of the GNU General Public License as -C published by the Free Software Foundation, either version 2 of -C the License, or (at your option) any later version. -C -C This program is distributed in the hope that it will be useful, -C but WITHOUT ANY WARRANTY; without even the implied warranty of -C MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the -C GNU General Public License for more details. -C -C You should have received a copy of the GNU General Public License -C along with this program. If not, see -C . -C -C PURPOSE -C -C To compute the eigenvalues of a product of matrices, -C T = T_1*T_2*...*T_p, where T_1 is an upper quasi-triangular -C matrix and T_2, ..., T_p are upper triangular matrices. -C -C ARGUMENTS -C -C Input/Output Parameters -C -C N (input) INTEGER -C The order of the matrix T. N >= 0. -C -C P (input) INTEGER -C The number of matrices in the product T_1*T_2*...*T_p. -C P >= 1. -C -C T (input) DOUBLE PRECISION array, dimension (LDT1,LDT2,P) -C The leading N-by-N part of T(*,*,1) must contain the upper -C quasi-triangular matrix T_1 and the leading N-by-N part of -C T(*,*,j) for j > 1 must contain the upper-triangular -C matrix T_j, j = 2, ..., p. -C The elements below the subdiagonal of T(*,*,1) and below -C the diagonal of T(*,*,j), j = 2, ..., p, are not -C referenced. -C -C LDT1 INTEGER -C The first leading dimension of the array T. -C LDT1 >= max(1,N). -C -C LDT2 INTEGER -C The second leading dimension of the array T. -C LDT2 >= max(1,N). -C -C WR, WI (output) DOUBLE PRECISION arrays, dimension (N) -C The real and imaginary parts, respectively, of the -C eigenvalues of T. The eigenvalues are stored in the same -C order as on the diagonal of T_1. If T(i:i+1,i:i+1,1) is a -C 2-by-2 diagonal block with complex conjugated eigenvalues -C then WI(i) > 0 and WI(i+1) = -WI(i). -C -C Error Indicator -C -C INFO INTEGER -C = 0: successful exit; -C < 0: if INFO = -i, the i-th argument had an illegal -C value. -C -C CONTRIBUTOR -C -C V. Sima, Katholieke Univ. Leuven, Belgium, February 1999. -C -C REVISIONS -C -C - -C -C KEYWORDS -C -C Eigenvalue, eigenvalue decomposition, periodic systems, -C real Schur form, triangular form. -C -C ****************************************************************** -C -C .. Parameters .. - DOUBLE PRECISION ZERO, ONE - PARAMETER ( ZERO = 0.0D0, ONE = 1.0D+0 ) -C .. Scalar Arguments .. - INTEGER INFO, LDT1, LDT2, N, P -C .. Array Arguments .. - DOUBLE PRECISION T( LDT1, LDT2, * ), WI( * ), WR( * ) -C .. Local Scalars .. - INTEGER I, I1, INEXT, J - DOUBLE PRECISION A11, A12, A21, A22, CS, SN, T11, T12, T22 -C .. External Subroutines .. - EXTERNAL DLANV2, XERBLA -C .. Intrinsic Functions .. - INTRINSIC MAX -C .. Executable Statements .. -C - INFO = 0 -C -C Test the input scalar arguments. -C - IF( N.LT.0 ) THEN - INFO = -1 - ELSE IF( P.LT.1 ) THEN - INFO = -2 - ELSE IF( LDT1.LT.MAX( 1, N ) ) THEN - INFO = -4 - ELSE IF( LDT2.LT.MAX( 1, N ) ) THEN - INFO = -5 - END IF -C - IF( INFO.NE.0 ) THEN -C -C Error return. -C - CALL XERBLA( 'MB03WX', -INFO ) - RETURN - END IF -C - INEXT = 1 - DO 30 I = 1, N - IF( I.LT.INEXT ) - $ GO TO 30 - IF( I.NE.N ) THEN - IF( T( I+1, I, 1 ).NE.ZERO ) THEN -C -C A pair of eigenvalues. First compute the corresponding -C elements of T(I:I+1,I:I+1). -C - INEXT = I + 2 - I1 = I + 1 - T11 = ONE - T12 = ZERO - T22 = ONE -C - DO 10 J = 2, P - T22 = T22*T( I1, I1, J ) - T12 = T11*T( I, I1, J ) + T12*T( I1, I1, J ) - T11 = T11*T( I, I, J ) - 10 CONTINUE -C - A11 = T( I, I, 1 )*T11 - A12 = T( I, I, 1 )*T12 + T( I, I1, 1 )*T22 - A21 = T( I1, I, 1 )*T11 - A22 = T( I1, I, 1 )*T12 + T( I1, I1, 1 )*T22 -C - CALL DLANV2( A11, A12, A21, A22, WR( I ), WI( I ), - $ WR( I1 ), WI( I1 ), CS, SN ) - GO TO 30 - END IF - END IF -C -C Simple eigenvalue. Compute the corresponding element of T(I,I). -C - INEXT = I + 1 - T11 = ONE -C - DO 20 J = 1, P - T11 = T11*T( I, I, J ) - 20 CONTINUE -C - WR( I ) = T11 - WI( I ) = ZERO - 30 CONTINUE -C - RETURN -C *** Last line of MB03WX *** - END diff --git a/mex/sources/libslicot/MB03XD.f b/mex/sources/libslicot/MB03XD.f deleted file mode 100644 index 3b68a9726..000000000 --- a/mex/sources/libslicot/MB03XD.f +++ /dev/null @@ -1,826 +0,0 @@ - SUBROUTINE MB03XD( BALANC, JOB, JOBU, JOBV, N, A, LDA, QG, LDQG, - $ T, LDT, U1, LDU1, U2, LDU2, V1, LDV1, V2, LDV2, - $ WR, WI, ILO, SCALE, DWORK, LDWORK, INFO ) -C -C SLICOT RELEASE 5.0. -C -C Copyright (c) 2002-2009 NICONET e.V. -C -C This program is free software: you can redistribute it and/or -C modify it under the terms of the GNU General Public License as -C published by the Free Software Foundation, either version 2 of -C the License, or (at your option) any later version. -C -C This program is distributed in the hope that it will be useful, -C but WITHOUT ANY WARRANTY; without even the implied warranty of -C MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the -C GNU General Public License for more details. -C -C You should have received a copy of the GNU General Public License -C along with this program. If not, see -C . -C -C PURPOSE -C -C To compute the eigenvalues of a Hamiltonian matrix, -C -C [ A G ] T T -C H = [ T ], G = G, Q = Q, (1) -C [ Q -A ] -C -C where A, G and Q are real n-by-n matrices. -C -C Due to the structure of H all eigenvalues appear in pairs -C (lambda,-lambda). This routine computes the eigenvalues of H -C using an algorithm based on the symplectic URV and the periodic -C Schur decompositions as described in [1], -C -C T [ T G ] -C U H V = [ T ], (2) -C [ 0 -S ] -C -C where U and V are 2n-by-2n orthogonal symplectic matrices, -C S is in real Schur form and T is upper triangular. -C -C The algorithm is backward stable and preserves the eigenvalue -C pairings in finite precision arithmetic. -C -C Optionally, a symplectic balancing transformation to improve the -C conditioning of eigenvalues is computed (see MB04DD). In this -C case, the matrix H in decomposition (2) must be replaced by the -C balanced matrix. -C -C The SLICOT Library routine MB03ZD can be used to compute invariant -C subspaces of H from the output of this routine. -C -C ARGUMENTS -C -C Mode Parameters -C -C BALANC CHARACTER*1 -C Indicates how H should be diagonally scaled and/or -C permuted to reduce its norm. -C = 'N': Do not diagonally scale or permute; -C = 'P': Perform symplectic permutations to make the matrix -C closer to Hamiltonian Schur form. Do not diagonally -C scale; -C = 'S': Diagonally scale the matrix, i.e., replace A, G and -C Q by D*A*D**(-1), D*G*D and D**(-1)*Q*D**(-1) where -C D is a diagonal matrix chosen to make the rows and -C columns of H more equal in norm. Do not permute; -C = 'B': Both diagonally scale and permute A, G and Q. -C Permuting does not change the norm of H, but scaling does. -C -C JOB CHARACTER*1 -C Indicates whether the user wishes to compute the full -C decomposition (2) or the eigenvalues only, as follows: -C = 'E': compute the eigenvalues only; -C = 'S': compute matrices T and S of (2); -C = 'G': compute matrices T, S and G of (2). -C -C JOBU CHARACTER*1 -C Indicates whether or not the user wishes to compute the -C orthogonal symplectic matrix U of (2) as follows: -C = 'N': the matrix U is not computed; -C = 'U': the matrix U is computed. -C -C JOBV CHARACTER*1 -C Indicates whether or not the user wishes to compute the -C orthogonal symplectic matrix V of (2) as follows: -C = 'N': the matrix V is not computed; -C = 'V': the matrix V is computed. -C -C Input/Output Parameters -C -C N (input) INTEGER -C The order of the matrix A. N >= 0. -C -C A (input/output) DOUBLE PRECISION array, dimension (LDA,N) -C On entry, the leading N-by-N part of this array must -C contain the matrix A. -C On exit, this array is overwritten. If JOB = 'S' or -C JOB = 'G', the leading N-by-N part of this array contains -C the matrix S in real Schur form of decomposition (2). -C -C LDA INTEGER -C The leading dimension of the array A. LDA >= max(1,N). -C -C QG (input/output) DOUBLE PRECISION array, dimension -C (LDQG,N+1) -C On entry, the leading N-by-N+1 part of this array must -C contain in columns 1:N the lower triangular part of the -C matrix Q and in columns 2:N+1 the upper triangular part -C of the matrix G. -C On exit, this array is overwritten. If JOB = 'G', the -C leading N-by-N+1 part of this array contains in columns -C 2:N+1 the matrix G of decomposition (2). -C -C LDQG INTEGER -C The leading dimension of the array QG. LDQG >= max(1,N). -C -C T (output) DOUBLE PRECISION array, dimension (LDT,N) -C On exit, if JOB = 'S' or JOB = 'G', the leading N-by-N -C part of this array contains the upper triangular matrix T -C of the decomposition (2). Otherwise, this array is used as -C workspace. -C -C LDT INTEGER -C The leading dimension of the array T. LDT >= MAX(1,N). -C -C U1 (output) DOUBLE PRECISION array, dimension (LDU1,N) -C On exit, if JOBU = 'U', the leading N-by-N part of this -C array contains the (1,1) block of the orthogonal -C symplectic matrix U of decomposition (2). -C -C LDU1 INTEGER -C The leading dimension of the array U1. LDU1 >= 1. -C LDU1 >= N, if JOBU = 'U'. -C -C U2 (output) DOUBLE PRECISION array, dimension (LDU2,N) -C On exit, if JOBU = 'U', the leading N-by-N part of this -C array contains the (2,1) block of the orthogonal -C symplectic matrix U of decomposition (2). -C -C LDU2 INTEGER -C The leading dimension of the array U2. LDU2 >= 1. -C LDU2 >= N, if JOBU = 'U'. -C -C V1 (output) DOUBLE PRECISION array, dimension (LDV1,N) -C On exit, if JOBV = 'V', the leading N-by-N part of this -C array contains the (1,1) block of the orthogonal -C symplectic matrix V of decomposition (2). -C -C LDV1 INTEGER -C The leading dimension of the array V1. LDV1 >= 1. -C LDV1 >= N, if JOBV = 'V'. -C -C V2 (output) DOUBLE PRECISION array, dimension (LDV2,N) -C On exit, if JOBV = 'V', the leading N-by-N part of this -C array contains the (2,1) block of the orthogonal -C symplectic matrix V of decomposition (2). -C -C LDV2 INTEGER -C The leading dimension of the array V2. LDV2 >= 1. -C LDV2 >= N, if JOBV = 'V'. -C -C WR (output) DOUBLE PRECISION array, dimension (N) -C WI (output) DOUBLE PRECISION array, dimension (N) -C On exit, the leading N elements of WR and WI contain the -C real and imaginary parts, respectively, of N eigenvalues -C that have nonpositive real part. Complex conjugate pairs -C of eigenvalues with real part not equal to zero will -C appear consecutively with the eigenvalue having the -C positive imaginary part first. For complex conjugate pairs -C of eigenvalues on the imaginary axis only the eigenvalue -C having nonnegative imaginary part will be returned. -C -C ILO (output) INTEGER -C ILO is an integer value determined when H was balanced. -C The balanced A(i,j) = 0 if I > J and J = 1,...,ILO-1. -C The balanced Q(i,j) = 0 if J = 1,...,ILO-1 or -C I = 1,...,ILO-1. -C -C SCALE (output) DOUBLE PRECISION array, dimension (N) -C On exit, if SCALE = 'S', the leading N elements of this -C array contain details of the permutation and scaling -C factors applied when balancing H, see MB04DD. -C This array is not referenced if BALANC = 'N'. -C -C Workspace -C -C DWORK DOUBLE PRECISION array, dimension (LDWORK) -C On exit, if INFO = 0, DWORK(1) returns the optimal -C value of LDWORK. -C On exit, if INFO = -25, DWORK(1) returns the minimum -C value of LDWORK. -C -C LDWORK (input) INTEGER -C The dimension of the array DWORK. LDWORK >= max( 1, 8*N ). -C Moreover: -C If JOB = 'E' or 'S' and JOBU = 'N' and JOBV = 'N', -C LDWORK >= 7*N+N*N. -C If JOB = 'G' and JOBU = 'N' and JOBV = 'N', -C LDWORK >= max( 7*N+N*N, 2*N+3*N*N ). -C If JOB = 'G' and JOBU = 'U' and JOBV = 'N', -C LDWORK >= 7*N+2*N*N. -C If JOB = 'G' and JOBU = 'N' and JOBV = 'V', -C LDWORK >= 7*N+2*N*N. -C If JOB = 'G' and JOBU = 'U' and JOBV = 'V', -C LDWORK >= 7*N+N*N. -C For good performance, LDWORK must generally be larger. -C -C Error Indicator -C -C INFO (output) INTEGER -C = 0: successful exit; -C < 0: if INFO = -i, the i-th argument had an illegal -C value; -C > 0: if INFO = i, the periodic QR algorithm failed to -C compute all the eigenvalues, elements i+1:N of WR -C and WI contain eigenvalues which have converged. -C -C REFERENCES -C -C [1] Benner, P., Mehrmann, V., and Xu, H. -C A numerically stable, structure preserving method for -C computing the eigenvalues of real Hamiltonian or symplectic -C pencils. -C Numer. Math., Vol. 78(3), pp. 329-358, 1998. -C -C [2] Benner, P., Mehrmann, V., and Xu, H. -C A new method for computing the stable invariant subspace of a -C real Hamiltonian matrix, J. Comput. Appl. Math., vol. 86, -C pp. 17-43, 1997. -C -C CONTRIBUTORS -C -C D. Kressner, Technical Univ. Berlin, Germany, and -C P. Benner, Technical Univ. Chemnitz, Germany, December 2003. -C -C REVISIONS -C -C V. Sima, May 2008 (SLICOT version of the HAPACK routine DHAESU). -C -C KEYWORDS -C -C Eigenvalues, invariant subspace, Hamiltonian matrix. -C -C ****************************************************************** -C -C .. Parameters .. - DOUBLE PRECISION ZERO, ONE - PARAMETER ( ZERO = 0.0D0, ONE = 1.0D0 ) -C .. Scalar Arguments .. - CHARACTER BALANC, JOB, JOBU, JOBV - INTEGER ILO, INFO, LDA, LDQG, LDT, LDU1, LDU2, LDV1, - $ LDV2, LDWORK, N -C .. Array Arguments .. - DOUBLE PRECISION A(LDA,*), DWORK(*), QG(LDQG,*), SCALE(*), - $ T(LDT,*), U1(LDU1,*), U2(LDU2,*), V1(LDV1,*), - $ V2(LDV2,*), WI(*), WR(*) -C .. Local Scalars .. - CHARACTER UCHAR, VCHAR - LOGICAL LPERM, LSCAL, SCALEH, WANTG, WANTS, WANTU, - $ WANTV - INTEGER I, IERR, ILO1, J, K, L, PBETA, PCSL, PCSR, PDW, - $ PQ, PTAUL, PTAUR, PZ, WRKMIN, WRKOPT - DOUBLE PRECISION BIGNUM, CSCALE, EPS, HNRM, SMLNUM, TEMP, TEMPI, - $ TEMPR -C .. External Functions .. - LOGICAL LSAME - DOUBLE PRECISION DLAMCH, MA02ID - EXTERNAL DLAMCH, LSAME, MA02ID -C .. External Subroutines .. - EXTERNAL DCOPY, DGEMM, DLABAD, DLACPY, DLASCL, DLASET, - $ DSCAL, MA01AD, MB03XP, MB04DD, MB04QB, MB04TB, - $ XERBLA -C .. Intrinsic Functions .. - INTRINSIC ABS, DBLE, MAX, SQRT -C -C .. Executable Statements .. -C -C Decode the scalar input parameters. -C - INFO = 0 - LPERM = LSAME( BALANC, 'P' ) .OR. LSAME( BALANC, 'B' ) - LSCAL = LSAME( BALANC, 'S' ) .OR. LSAME( BALANC, 'B' ) - WANTS = LSAME( JOB, 'S' ) .OR. LSAME( JOB, 'G' ) - WANTG = LSAME( JOB, 'G' ) - WANTU = LSAME( JOBU, 'U' ) - WANTV = LSAME( JOBV, 'V' ) -C - IF ( WANTG ) THEN - IF ( WANTU ) THEN - IF ( WANTV ) THEN - WRKMIN = MAX( 1, 7*N+N*N ) - ELSE - WRKMIN = MAX( 1, 7*N+2*N*N ) - END IF - ELSE - IF ( WANTV ) THEN - WRKMIN = MAX( 1, 7*N+2*N*N ) - ELSE - WRKMIN = MAX( 1, 7*N+N*N, 2*N+3*N*N ) - END IF - END IF - ELSE - IF ( WANTU ) THEN - IF ( WANTV ) THEN - WRKMIN = MAX( 1, 8*N ) - ELSE - WRKMIN = MAX( 1, 8*N ) - END IF - ELSE - IF ( WANTV ) THEN - WRKMIN = MAX( 1, 8*N ) - ELSE - WRKMIN = MAX( 1, 7*N+N*N ) - END IF - END IF - END IF -C - WRKOPT = WRKMIN -C -C Test the scalar input parameters. -C - IF ( .NOT.LPERM .AND. .NOT.LSCAL - $ .AND. .NOT.LSAME( BALANC, 'N' ) ) THEN - INFO = -1 - ELSE IF ( .NOT.WANTS .AND. .NOT.LSAME( JOB, 'E' ) ) THEN - INFO = -2 - ELSE IF ( .NOT.WANTU .AND. .NOT.LSAME( JOBU, 'N' ) ) THEN - INFO = -3 - ELSE IF ( .NOT.WANTV .AND. .NOT.LSAME( JOBV, 'N' ) ) THEN - INFO = -4 - ELSE IF ( N.LT.0 ) THEN - INFO = -5 - ELSE IF ( LDA.LT.MAX( 1, N ) ) THEN - INFO = -7 - ELSE IF ( LDQG.LT.MAX( 1, N ) ) THEN - INFO = -9 - ELSE IF ( LDT.LT.MAX( 1, N ) ) THEN - INFO = -11 - ELSE IF ( LDU1.LT.1 .OR. ( WANTU .AND. LDU1.LT.N ) ) THEN - INFO = -13 - ELSE IF ( LDU2.LT.1 .OR. ( WANTU .AND. LDU2.LT.N ) ) THEN - INFO = -15 - ELSE IF ( LDV1.LT.1 .OR. ( WANTV .AND. LDV1.LT.N ) ) THEN - INFO = -17 - ELSE IF ( LDV2.LT.1 .OR. ( WANTV .AND. LDV2.LT.N ) ) THEN - INFO = -19 - ELSE IF ( LDWORK.LT.WRKMIN ) THEN - INFO = -25 - DWORK(1) = DBLE( WRKMIN ) - END IF -C -C Return if there were illegal values. -C - IF ( INFO.NE.0 ) THEN - CALL XERBLA( 'MB03XD', -INFO ) - RETURN - END IF -C -C Quick return if possible. -C - ILO = 0 - IF( N.EQ.0 ) - $ RETURN -C - EPS = DLAMCH( 'P' ) - SMLNUM = DLAMCH( 'S' ) - BIGNUM = ONE / SMLNUM - CALL DLABAD( SMLNUM, BIGNUM ) - SMLNUM = SQRT( SMLNUM ) / EPS - BIGNUM = ONE / SMLNUM -C -C Scale H if maximal element is outside range [SMLNUM,BIGNUM]. -C - HNRM = MA02ID( 'Hamiltonian', 'MaxElement', N, A, LDA, QG, LDQG, - $ DWORK ) - SCALEH = .FALSE. - IF ( HNRM.GT.ZERO .AND. HNRM.LT.SMLNUM ) THEN - SCALEH = .TRUE. - CSCALE = SMLNUM - ELSE IF( HNRM.GT.BIGNUM ) THEN - SCALEH = .TRUE. - CSCALE = BIGNUM - END IF - IF ( SCALEH ) THEN - CALL DLASCL( 'General', 0, 0, HNRM, CSCALE, N, N, A, LDA, IERR ) - CALL DLASCL( 'General', 0, 0, HNRM, CSCALE, N, N+1, QG, LDQG, - $ IERR ) - END IF -C -C Balance the matrix. -C - CALL MB04DD( BALANC, N, A, LDA, QG, LDQG, ILO, SCALE, IERR ) -C -C Copy A to T and multiply A by -1. -C - CALL DLACPY( 'All', N, N, A, LDA, T, LDT ) - CALL DLASCL( 'General', 0, 0, ONE, -ONE, N, N, A, LDA, IERR ) -C -C --------------------------------------------- -C Step 1: Compute symplectic URV decomposition. -C --------------------------------------------- -C - PCSL = 1 - PCSR = PCSL + 2*N - PTAUL = PCSR + 2*N - PTAUR = PTAUL + N - PDW = PTAUR + N - - IF ( .NOT.WANTU .AND. .NOT.WANTV ) THEN -C -C Copy Q and Q' to workspace. -C - PQ = PDW - PDW = PDW + N*N - DO 20 J = 1, N - K = PQ + (N+1)*(J-1) - L = K - DWORK(K) = QG(J,J) - DO 10 I = J+1, N - K = K + 1 - L = L + N - TEMP = QG(I,J) - DWORK(K) = TEMP - DWORK(L) = TEMP - 10 CONTINUE - 20 CONTINUE - ELSE IF ( WANTU ) THEN -C -C Copy Q and Q' to U2. -C - DO 40 J = 1, N - U2(J,J) = QG(J,J) - DO 30 I = J+1, N - TEMP = QG(I,J) - U2(I,J) = TEMP - U2(J,I) = TEMP - 30 CONTINUE - 40 CONTINUE - ELSE -C -C Copy Q and Q' to V2. -C - DO 60 J = 1, N - V2(J,J) = QG(J,J) - DO 50 I = J+1, N - TEMP = QG(I,J) - V2(I,J) = TEMP - V2(J,I) = TEMP - 50 CONTINUE - 60 CONTINUE - END IF -C -C Transpose G. -C - DO 80 J = 1, N - DO 70 I = J+1, N - QG(I,J+1) = QG(J,I+1) - 70 CONTINUE - 80 CONTINUE -C - IF ( .NOT.WANTU .AND. .NOT.WANTV ) THEN - CALL MB04TB( 'Not Transposed', 'Transposed', N, ILO, T, LDT, A, - $ LDA, QG(1,2), LDQG, DWORK(PQ), N, DWORK(PCSL), - $ DWORK(PCSR), DWORK(PTAUL), DWORK(PTAUR), - $ DWORK(PDW), LDWORK-PDW+1, IERR ) - ELSE IF ( WANTU ) THEN - CALL MB04TB( 'Not Transposed', 'Transposed', N, ILO, T, LDT, A, - $ LDA, QG(1,2), LDQG, U2, LDU2, DWORK(PCSL), - $ DWORK(PCSR), DWORK(PTAUL), DWORK(PTAUR), - $ DWORK(PDW), LDWORK-PDW+1, IERR ) - ELSE - CALL MB04TB( 'Not Transposed', 'Transposed', N, ILO, T, LDT, A, - $ LDA, QG(1,2), LDQG, V2, LDV2, DWORK(PCSL), - $ DWORK(PCSR), DWORK(PTAUL), DWORK(PTAUR), - $ DWORK(PDW), LDWORK-PDW+1, IERR ) - END IF - WRKOPT = MAX( WRKOPT, INT( DWORK(PDW) ) + PDW - 1 ) -C - IF ( WANTU .AND. .NOT.WANTV .AND. .NOT.WANTG ) THEN - IF ( N.GT.1 ) - $ CALL DLACPY( 'Lower', N-1, N-1, T(2,1), LDT, QG(2,1), LDQG ) - ELSE IF ( .NOT.WANTU .AND. WANTV .AND. .NOT.WANTG ) THEN - IF ( N.GT.1 ) THEN - CALL DLACPY( 'Lower', N-1, N-1, A(2,1), LDA, QG(2,1), LDQG ) - CALL DLACPY( 'Upper', N-1, N-1, V2(1,2), LDV2, QG(1,2), - $ LDQG ) - END IF - ELSE IF ( WANTU .AND. WANTV .AND. .NOT.WANTG ) THEN - IF ( N.GT.1 ) THEN - CALL DLACPY( 'Lower', N-1, N-1, T(2,1), LDT, V2(2,1), LDV2 ) - CALL DLACPY( 'Lower', N-1, N-1, A(2,1), LDA, QG(2,1), LDQG ) - END IF - ELSE IF ( WANTU .AND. .NOT.WANTV .AND. WANTG ) THEN - IF ( N.GT.1 ) - $ CALL DLACPY( 'Lower', N-1, N-1, T(2,1), LDT, - $ DWORK(PDW+N*N+N), N-1 ) - ELSE IF ( .NOT.WANTU .AND. WANTV .AND. WANTG ) THEN - IF ( N.GT.2 ) - $ CALL DLACPY( 'Lower', N-2, N-2, A(3,1), LDA, - $ DWORK(PDW+N*N+N), N-2 ) - ELSE IF ( WANTU .AND. WANTV .AND. WANTG ) THEN - IF ( N.GT.1 ) - $ CALL DLACPY( 'Lower', N-1, N-1, T(2,1), LDT, - $ DWORK(PDW+N), N-1 ) - IF ( N.GT.2 ) - $ CALL DLACPY( 'Lower', N-2, N-2, A(3,1), LDA, V2(3,1), LDV2 ) - END IF -C -C ---------------------------------------------- -C Step 2: Compute periodic Schur decomposition. -C ---------------------------------------------- -C - IF ( N.GT.2 ) - $ CALL DLASET( 'Lower', N-2, N-2, ZERO, ZERO, A(3,1), LDA ) - IF ( N.GT.1 ) - $ CALL DLASET( 'Lower', N-1, N-1, ZERO, ZERO, T(2,1), LDT ) - IF ( .NOT.WANTU .AND. .NOT.WANTV ) THEN - PBETA = 1 - ELSE - PBETA = PDW - END IF -C - IF ( .NOT.WANTG ) THEN -C -C Workspace requirements: 2*N (8*N with U or V). -C - PDW = PBETA + N - IF ( WANTU ) THEN - UCHAR = 'I' - ELSE - UCHAR = 'N' - END IF - IF ( WANTV ) THEN - VCHAR = 'I' - ELSE - VCHAR = 'N' - END IF - CALL MB03XP( JOB, VCHAR, UCHAR, N, ILO, N, A, LDA, T, LDT, V1, - $ LDV1, U1, LDU1, WR, WI, DWORK(PBETA), DWORK(PDW), - $ LDWORK-PDW+1, INFO ) - IF ( INFO.NE.0 ) - $ GO TO 90 - WRKOPT = MAX( WRKOPT, INT( DWORK(PDW) ) + PDW - 1 ) -C - ELSE IF ( .NOT.WANTU .AND. .NOT.WANTV .AND. WANTG ) THEN -C -C Workspace requirements: 3*N*N + 2*N. -C - PQ = PBETA + N - PZ = PQ + N*N - PDW = PZ + N*N - CALL MB03XP( 'Schur', 'Init', 'Init', N, ILO, N, A, LDA, T, - $ LDT, DWORK(PQ), N, DWORK(PZ), N, WR, WI, - $ DWORK(PBETA), DWORK(PDW), LDWORK-PDW+1, INFO ) - IF ( INFO.NE.0 ) - $ GO TO 90 - WRKOPT = MAX( WRKOPT, INT( DWORK(PDW) ) + PDW - 1 ) - CALL DGEMM( 'Transpose', 'No Transpose', N, N, N, ONE, - $ DWORK(PZ), N, QG(1,2), LDQG, ZERO, DWORK(PDW), N ) - CALL DGEMM( 'No Transpose', 'No Transpose', N, N, N, ONE, - $ DWORK(PDW), N, DWORK(PQ), N, ZERO, QG(1,2), LDQG ) - ELSE IF ( WANTU .AND. .NOT.WANTV .AND. WANTG ) THEN -C -C Workspace requirements: 2*N*N + 7*N. -C - PQ = PBETA + N - PDW = PQ + N*N - CALL MB03XP( 'Schur', 'Init', 'Init', N, ILO, N, A, LDA, T, - $ LDT, DWORK(PQ), N, U1, LDU1, WR, WI, DWORK(PBETA), - $ DWORK(PDW+(N-1)*(N-1)), LDWORK-PDW-(N-1)*(N-1)+1, - $ INFO ) - IF ( INFO.NE.0 ) - $ GO TO 90 - WRKOPT = MAX( WRKOPT, INT( DWORK(PDW+(N-1)*(N-1)) ) + PDW - $ + (N-1)*(N-1) - 1 ) - IF ( N.GT.1 ) - $ CALL DLACPY( 'Lower', N-1, N-1, DWORK(PDW), N-1, T(2,1), - $ LDT ) - CALL DGEMM( 'Transpose', 'No Transpose', N, N, N, ONE, - $ U1, LDU1, QG(1,2), LDQG, ZERO, DWORK(PDW), N ) - CALL DGEMM( 'No Transpose', 'No Transpose', N, N, N, ONE, - $ DWORK(PDW), N, DWORK(PQ), N, ZERO, QG(1,2), LDQG ) -C - ELSE IF ( .NOT.WANTU .AND. WANTV .AND. WANTG ) THEN -C -C Workspace requirements: 2*N*N + 7*N -C - PZ = PBETA + N - PDW = PZ + N*N - CALL MB03XP( 'Schur', 'Init', 'Init', N, ILO, N, A, LDA, T, - $ LDT, V1, LDV1, DWORK(PZ), N, WR, WI, DWORK(PBETA), - $ DWORK(PDW+(N-1)*(N-1)), LDWORK-PDW-(N-1)*(N-1)+1, - $ INFO ) - IF ( INFO.NE.0 ) - $ GO TO 90 - WRKOPT = MAX( WRKOPT, INT( DWORK(PDW+(N-1)*(N-1)) ) + PDW - $ + (N-1)*(N-1) - 1 ) - IF ( N.GT.2 ) - $ CALL DLACPY( 'Lower', N-2, N-2, DWORK(PDW), N-2, A(3,1), - $ LDA ) - CALL DGEMM( 'Transpose', 'No Transpose', N, N, N, ONE, - $ DWORK(PZ), N, QG(1,2), LDQG, ZERO, DWORK(PDW), N ) - CALL DGEMM( 'No Transpose', 'No Transpose', N, N, N, ONE, - $ DWORK(PDW), N, V1, LDV1, ZERO, QG(1,2), LDQG ) -C - ELSE IF ( WANTU .AND. WANTV .AND. WANTG ) THEN -C -C Workspace requirements: N*N + 7*N. -C - PDW = PBETA + N - CALL MB03XP( 'Schur', 'Init', 'Init', N, ILO, N, A, LDA, T, - $ LDT, V1, LDV1, U1, LDU1, WR, WI, DWORK(PBETA), - $ DWORK(PDW+(N-1)*(N-1)), LDWORK-PDW-(N-1)*(N-1)+1, - $ INFO ) - IF ( INFO.NE.0 ) - $ GO TO 90 - WRKOPT = MAX( WRKOPT, INT( DWORK(PDW+(N-1)*(N-1)) ) + PDW - $ + (N-1)*(N-1) - 1 ) - IF ( N.GT.1 ) - $ CALL DLACPY( 'Lower', N-1, N-1, DWORK(PDW), N-1, T(2,1), - $ LDT ) - IF ( N.GT.2 ) - $ CALL DLACPY( 'Lower', N-2, N-2, V2(3,1), LDV2, A(3,1), LDA ) - CALL DGEMM( 'Transpose', 'No Transpose', N, N, N, ONE, - $ U1, LDU1, QG(1,2), LDQG, ZERO, DWORK(PDW), N ) - CALL DGEMM( 'No Transpose', 'No Transpose', N, N, N, ONE, - $ DWORK(PDW), N, V1, LDV1, ZERO, QG(1,2), LDQG ) - END IF -C - 90 CONTINUE -C -C Compute square roots of eigenvalues and rescale. -C - DO 100 I = INFO + 1, N - TEMPR = WR(I) - TEMPI = WI(I) - TEMP = DWORK(PBETA + I - 1) - IF ( TEMP.GT.ZERO ) - $ TEMPR = -TEMPR - TEMP = ABS( TEMP ) - IF ( TEMPI.EQ.ZERO ) THEN - IF ( TEMPR.LT.ZERO ) THEN - WR(I) = ZERO - WI(I) = SQRT( TEMP ) * SQRT( -TEMPR ) - ELSE - WR(I) = -SQRT( TEMP ) * SQRT( TEMPR ) - WI(I) = ZERO - END IF - ELSE - CALL MA01AD( TEMPR, TEMPI, WR(I), WI(I) ) - WR(I) = -WR(I) * SQRT( TEMP ) - IF ( TEMP.GT.0 ) THEN - WI(I) = WI(I) * SQRT( TEMP ) - ELSE - WI(I) = ZERO - END IF - END IF - 100 CONTINUE -C - IF ( SCALEH ) THEN -C -C Undo scaling. -C - CALL DLASCL( 'Hessenberg', 0, 0, CSCALE, HNRM, N, N, A, LDA, - $ IERR ) - CALL DLASCL( 'Upper', 0, 0, CSCALE, HNRM, N, N, T, LDT, IERR ) - If ( WANTG ) - $ CALL DLASCL( 'General', 0, 0, CSCALE, HNRM, N, N, QG(1,2), - $ LDQG, IERR ) - CALL DLASCL( 'General', 0, 0, CSCALE, HNRM, N, 1, WR, N, IERR ) - CALL DLASCL( 'General', 0, 0, CSCALE, HNRM, N, 1, WI, N, IERR ) - END IF -C - IF ( INFO.NE.0 ) - $ RETURN -C -C ----------------------------------------------- -C Step 3: Compute orthogonal symplectic factors. -C ----------------------------------------------- -C -C Fix CSL and CSR for MB04QB. -C - IF ( WANTU ) - $ CALL DSCAL( N, -ONE, DWORK(PCSL+1), 2 ) - IF ( WANTV ) - $ CALL DSCAL( N-1, -ONE, DWORK(PCSR+1), 2 ) - ILO1 = MIN( N, ILO + 1 ) -C - IF ( WANTU .AND. .NOT.WANTV .AND. .NOT.WANTG ) THEN -C -C Workspace requirements: 7*N. -C - PDW = PTAUR - CALL DCOPY( N, T(1,1), LDT+1, DWORK(PDW), 1 ) - CALL DLACPY( 'Lower', N, N, U2, LDU2, T, LDT ) - CALL DLASET( 'All', N, N, ZERO, ZERO, U2, LDU2 ) - CALL MB04QB( 'No Transpose', 'No Transpose', 'No Transpose', - $ 'Columnwise', 'Columnwise', N-ILO+1, N, N-ILO+1, - $ QG(ILO,ILO), LDQG, T(ILO,ILO), LDT, U1(ILO,1), - $ LDU1, U2(ILO,1), LDU2, DWORK(PCSL+2*ILO-2), - $ DWORK(PTAUL+ILO-1), DWORK(PDW+N), LDWORK-PDW-N+1, - $ IERR ) - WRKOPT = MAX( WRKOPT, INT( DWORK(PDW+N) ) + PDW + N - 1 ) - CALL DCOPY( N, DWORK(PDW), 1, T(1,1), LDT+1 ) - IF ( N.GT.1 ) - $ CALL DLASET( 'Lower', N-1, N-1, ZERO, ZERO, T(2,1), LDT ) -C - ELSE IF ( .NOT.WANTU .AND. WANTV .AND. .NOT.WANTG ) THEN -C -C Workspace requirements: 7*N. -C - PDW = PTAUR + N - CALL DLASET( 'All', N, N, ZERO, ZERO, V2, LDV2 ) - CALL MB04QB( 'No Transpose', 'No Transpose', 'No Transpose', - $ 'Columnwise', 'Rowwise', MAX(0,N-ILO), N, - $ MAX(0,N-ILO), QG(ILO1,ILO), LDQG, QG(ILO,ILO1), - $ LDQG, V1(ILO1,1), LDV1, V2(ILO1,1), LDV2, - $ DWORK(PCSR+2*ILO-2), DWORK(PTAUR+ILO-1), - $ DWORK(PDW), LDWORK-PDW+1, IERR ) - WRKOPT = MAX( WRKOPT, INT( DWORK(PDW) ) + PDW - 1 ) -C - ELSE IF ( WANTU .AND. WANTV .AND. .NOT.WANTG ) THEN -C -C Workspace requirements: 8*N. -C - PDW = PTAUR + N - CALL DCOPY( N, T(1,1), LDT+1, DWORK(PDW), 1 ) - CALL DLACPY( 'Lower', N, N, V2, LDV2, T, LDT ) - CALL DLASET( 'All', N, N, ZERO, ZERO, V2, LDV2 ) - CALL MB04QB( 'No Transpose', 'No Transpose', 'No Transpose', - $ 'Columnwise', 'Rowwise', MAX(0,N-ILO), N, - $ MAX(0,N-ILO), QG(ILO1,ILO), LDQG, U2(ILO,ILO1), - $ LDU2, V1(ILO1,1), LDV1, V2(ILO1,1), LDV2, - $ DWORK(PCSR+2*ILO-2), DWORK(PTAUR+ILO-1), - $ DWORK(PDW+N), LDWORK-PDW-N+1, IERR ) - WRKOPT = MAX( WRKOPT, INT( DWORK(PDW+N) ) + PDW + N - 1 ) -C - CALL DLACPY( 'Lower', N, N, U2, LDU2, QG, LDQG ) - CALL DLASET( 'All', N, N, ZERO, ZERO, U2, LDU2 ) - CALL MB04QB( 'No Transpose', 'No Transpose', 'No Transpose', - $ 'Columnwise', 'Columnwise', N-ILO+1, N, N-ILO+1, - $ T(ILO,ILO), LDT, QG(ILO,ILO), LDQG, U1(ILO,1), - $ LDU1, U2(ILO,1), LDU2, DWORK(PCSL+2*ILO-2), - $ DWORK(PTAUL+ILO-1), DWORK(PDW+N), LDWORK-PDW-N+1, - $ IERR ) - WRKOPT = MAX( WRKOPT, INT( DWORK(PDW+N) ) + PDW + N - 1 ) - CALL DCOPY( N, DWORK(PDW), 1, T(1,1), LDT+1 ) - IF ( N.GT.1 ) - $ CALL DLASET( 'Lower', N-1, N-1, ZERO, ZERO, T(2,1), LDT ) -C - ELSE IF ( WANTU .AND. .NOT.WANTV .AND. WANTG ) THEN -C -C Workspace requirements: 6*N + N*N. -C - PQ = PTAUR - PDW = PQ + N*N - CALL DLACPY( 'Lower', N, N, U2, LDU2, DWORK(PQ), N ) - CALL DLASET( 'All', N, N, ZERO, ZERO, U2, LDU2 ) - CALL MB04QB( 'No Transpose', 'No Transpose', 'No Transpose', - $ 'Columnwise', 'Columnwise', N-ILO+1, N, N-ILO+1, - $ T(ILO,ILO), LDT, DWORK(PQ+(ILO-1)*(N+1)), N, - $ U1(ILO,1), LDU1, U2(ILO,1), LDU2, - $ DWORK(PCSL+2*ILO-2), DWORK(PTAUL+ILO-1), - $ DWORK(PDW), LDWORK-PDW+1, IERR ) - WRKOPT = MAX( WRKOPT, INT( DWORK(PDW) ) + PDW - 1 ) - IF ( N.GT.1 ) - $ CALL DLASET( 'Lower', N-1, N-1, ZERO, ZERO, T(2,1), LDT ) -C - ELSE IF ( .NOT.WANTU .AND. WANTV .AND. WANTG ) THEN -C -C Workspace requirements: 7*N + N*N. -C - PQ = PTAUR+N - PDW = PQ + N*N - CALL DLACPY( 'Upper', N, N, V2, LDV2, DWORK(PQ), N ) - CALL DLASET( 'All', N, N, ZERO, ZERO, V2, LDV2 ) - CALL MB04QB( 'No Transpose', 'No Transpose', 'No Transpose', - $ 'Columnwise', 'Rowwise', MAX(0,N-ILO), N, - $ MAX(0,N-ILO), A(ILO1,ILO), LDA, - $ DWORK(PQ+ILO*N+ILO-1), N, V1(ILO1,1), LDV1, - $ V2(ILO1,1), LDV2, DWORK(PCSR+2*ILO-2), - $ DWORK(PTAUR+ILO-1), DWORK(PDW+N), - $ LDWORK-PDW-N+1, IERR ) - WRKOPT = MAX( WRKOPT, INT( DWORK(PDW+N) ) + PDW + N - 1 ) - IF ( N.GT.2 ) - $ CALL DLASET( 'Lower', N-2, N-2, ZERO, ZERO, A(3,1), LDA ) -C - ELSE IF ( WANTU .AND. WANTV .AND. WANTG ) THEN -C -C Workspace requirements: 6*N + N*N. -C - PDW = PTAUR + N - CALL DLASET( 'All', N, N, ZERO, ZERO, V2, LDV2 ) - CALL MB04QB( 'No Transpose', 'No Transpose', 'No Transpose', - $ 'Columnwise', 'Rowwise', MAX(0,N-ILO), N, - $ MAX(0,N-ILO), A(ILO1,ILO), LDA, U2(ILO,ILO1), - $ LDU2, V1(ILO1,1), LDV1, V2(ILO1,1), LDV2, - $ DWORK(PCSR+2*ILO-2), DWORK(PTAUR+ILO-1), - $ DWORK(PDW), LDWORK-PDW+1, IERR ) - WRKOPT = MAX( WRKOPT, INT( DWORK(PDW) ) + PDW - 1 ) -C - PQ = PTAUR - PDW = PQ + N*N - CALL DLACPY( 'Lower', N, N, U2, LDU2, DWORK(PQ), N ) - CALL DLASET( 'All', N, N, ZERO, ZERO, U2, LDU2 ) - CALL MB04QB( 'No Transpose', 'No Transpose', 'No Transpose', - $ 'Columnwise', 'Columnwise', N-ILO+1, N, N-ILO+1, - $ T(ILO,ILO), LDT, DWORK(PQ+(ILO-1)*(N+1)), N, - $ U1(ILO,1), LDU1, U2(ILO,1), LDU2, - $ DWORK(PCSL+2*ILO-2), DWORK(PTAUL+ILO-1), - $ DWORK(PDW), LDWORK-PDW+1, IERR ) - WRKOPT = MAX( WRKOPT, INT( DWORK(PDW) ) + PDW - 1 ) - IF ( N.GT.2 ) - $ CALL DLASET( 'Lower', N-2, N-2, ZERO, ZERO, A(3,1), LDA ) - IF ( N.GT.1 ) - $ CALL DLASET( 'Lower', N-1, N-1, ZERO, ZERO, T(2,1), LDT ) - END IF -C - DWORK(1) = DBLE( WRKOPT ) - RETURN -C *** Last line of MB03XD *** - END diff --git a/mex/sources/libslicot/MB03XP.f b/mex/sources/libslicot/MB03XP.f deleted file mode 100644 index bf374c251..000000000 --- a/mex/sources/libslicot/MB03XP.f +++ /dev/null @@ -1,659 +0,0 @@ - SUBROUTINE MB03XP( JOB, COMPQ, COMPZ, N, ILO, IHI, A, LDA, B, LDB, - $ Q, LDQ, Z, LDZ, ALPHAR, ALPHAI, BETA, DWORK, - $ LDWORK, INFO ) -C -C SLICOT RELEASE 5.0. -C -C Copyright (c) 2002-2009 NICONET e.V. -C -C This program is free software: you can redistribute it and/or -C modify it under the terms of the GNU General Public License as -C published by the Free Software Foundation, either version 2 of -C the License, or (at your option) any later version. -C -C This program is distributed in the hope that it will be useful, -C but WITHOUT ANY WARRANTY; without even the implied warranty of -C MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the -C GNU General Public License for more details. -C -C You should have received a copy of the GNU General Public License -C along with this program. If not, see -C . -C -C PURPOSE -C -C To compute the periodic Schur decomposition and the eigenvalues of -C a product of matrices, H = A*B, with A upper Hessenberg and B -C upper triangular without evaluating any part of the product. -C Specifically, the matrices Q and Z are computed, so that -C -C Q' * A * Z = S, Z' * B * Q = T -C -C where S is in real Schur form, and T is upper triangular. -C -C ARGUMENTS -C -C Mode Parameters -C -C JOB CHARACTER*1 -C Indicates whether the user wishes to compute the full -C Schur form or the eigenvalues only, as follows: -C = 'E': Compute the eigenvalues only; -C = 'S': compute the factors S and T of the full -C Schur form. -C -C COMPQ CHARACTER*1 -C Indicates whether or not the user wishes to accumulate -C the matrix Q as follows: -C = 'N': The matrix Q is not required; -C = 'I': Q is initialized to the unit matrix and the -C orthogonal transformation matrix Q is returned; -C = 'V': Q must contain an orthogonal matrix U on entry, -C and the product U*Q is returned. -C -C COMPZ CHARACTER*1 -C Indicates whether or not the user wishes to accumulate -C the matrix Z as follows: -C = 'N': The matrix Z is not required; -C = 'I': Z is initialized to the unit matrix and the -C orthogonal transformation matrix Z is returned; -C = 'V': Z must contain an orthogonal matrix U on entry, -C and the product U*Z is returned. -C -C Input/Output Parameters -C -C N (input) INTEGER -C The order of the matrices A and B. N >= 0. -C -C ILO (input) INTEGER -C IHI (input) INTEGER -C It is assumed that the matrices A and B are already upper -C triangular in rows and columns 1:ILO-1 and IHI+1:N. -C The routine works primarily with the submatrices in rows -C and columns ILO to IHI, but applies the transformations to -C all the rows and columns of the matrices A and B, if -C JOB = 'S'. -C 1 <= ILO <= max(1,N); min(ILO,N) <= IHI <= N. -C -C A (input/output) DOUBLE PRECISION array, dimension (LDA,N) -C On entry, the leading N-by-N part of this array A must -C contain the upper Hessenberg matrix A. -C On exit, if JOB = 'S', the leading N-by-N part of this -C array is upper quasi-triangular with any 2-by-2 diagonal -C blocks corresponding to a pair of complex conjugated -C eigenvalues. -C If JOB = 'E', the diagonal elements and 2-by-2 diagonal -C blocks of A will be correct, but the remaining parts of A -C are unspecified on exit. -C -C LDA INTEGER -C The leading dimension of the array A. LDA >= MAX(1,N). -C -C B (input/output) DOUBLE PRECISION array, dimension (LDB,N) -C On entry, the leading N-by-N part of this array B must -C contain the upper triangular matrix B. -C On exit, if JOB = 'S', the leading N-by-N part of this -C array contains the transformed upper triangular matrix. -C 2-by-2 blocks in B corresponding to 2-by-2 blocks in A -C will be reduced to positive diagonal form. (I.e., if -C A(j+1,j) is non-zero, then B(j+1,j)=B(j,j+1)=0 and B(j,j) -C and B(j+1,j+1) will be positive.) -C If JOB = 'E', the elements corresponding to diagonal -C elements and 2-by-2 diagonal blocks in A will be correct, -C but the remaining parts of B are unspecified on exit. -C -C LDB INTEGER -C The leading dimension of the array B. LDB >= MAX(1,N). -C -C Q (input/output) DOUBLE PRECISION array, dimension (LDQ,N) -C On entry, if COMPQ = 'V', then the leading N-by-N part of -C this array must contain a matrix Q which is assumed to be -C equal to the unit matrix except for the submatrix -C Q(ILO:IHI,ILO:IHI). -C If COMPQ = 'I', Q need not be set on entry. -C On exit, if COMPQ = 'V' or COMPQ = 'I' the leading N-by-N -C part of this array contains the transformation matrix -C which produced the Schur form. -C If COMPQ = 'N', Q is not referenced. -C -C LDQ INTEGER -C The leading dimension of the array Q. LDQ >= 1. -C If COMPQ <> 'N', LDQ >= MAX(1,N). -C -C Z (input/output) DOUBLE PRECISION array, dimension (LDZ,N) -C On entry, if COMPZ = 'V', then the leading N-by-N part of -C this array must contain a matrix Z which is assumed to be -C equal to the unit matrix except for the submatrix -C Z(ILO:IHI,ILO:IHI). -C If COMPZ = 'I', Z need not be set on entry. -C On exit, if COMPZ = 'V' or COMPZ = 'I' the leading N-by-N -C part of this array contains the transformation matrix -C which produced the Schur form. -C If COMPZ = 'N', Z is not referenced. -C -C LDZ INTEGER -C The leading dimension of the array Z. LDZ >= 1. -C If COMPZ <> 'N', LDZ >= MAX(1,N). -C -C ALPHAR (output) DOUBLE PRECISION array, dimension (N) -C ALPHAI (output) DOUBLE PRECISION array, dimension (N) -C BETA (output) DOUBLE PRECISION array, dimension (N) -C The i-th (1 <= i <= N) computed eigenvalue is given by -C BETA(I) * ( ALPHAR(I) + sqrt(-1)*ALPHAI(I) ). If two -C eigenvalues are computed as a complex conjugate pair, -C they are stored in consecutive elements of ALPHAR, ALPHAI -C and BETA. If JOB = 'S', the eigenvalues are stored in the -C same order as on the diagonales of the Schur forms of A -C and B. -C -C Workspace -C -C DWORK DOUBLE PRECISION array, dimension (LDWORK) -C On exit, if INFO = 0, DWORK(1) returns the optimal -C value of LDWORK. -C On exit, if INFO = -19, DWORK(1) returns the minimum -C value of LDWORK. -C -C LDWORK INTEGER -C The length of the array DWORK. LDWORK >= MAX(1,N). -C -C Error Indicator -C -C INFO INTEGER -C = 0: successful exit; -C < 0: if INFO = -i, the i-th argument had an illegal -C value; -C > 0: if INFO = i, then MB03XP failed to compute the Schur -C form in a total of 30*(IHI-ILO+1) iterations; -C elements 1:ilo-1 and i+1:n of ALPHAR, ALPHAI and -C BETA contain successfully computed eigenvalues. -C -C METHOD -C -C The implemented algorithm is a multi-shift version of the periodic -C QR algorithm described in [1,3] with some minor modifications -C proposed in [2]. -C -C REFERENCES -C -C [1] Bojanczyk, A.W., Golub, G.H., and Van Dooren, P. -C The periodic Schur decomposition: Algorithms and applications. -C Proc. of the SPIE Conference (F.T. Luk, Ed.), 1770, pp. 31-42, -C 1992. -C -C [2] Kressner, D. -C An efficient and reliable implementation of the periodic QZ -C algorithm. Proc. of the IFAC Workshop on Periodic Control -C Systems, pp. 187-192, 2001. -C -C [3] Van Loan, C. -C Generalized Singular Values with Algorithms and Applications. -C Ph. D. Thesis, University of Michigan, 1973. -C -C NUMERICAL ASPECTS -C -C The algorithm requires O(N**3) floating point operations and is -C backward stable. -C -C CONTRIBUTORS -C -C D. Kressner, Technical Univ. Berlin, Germany, and -C P. Benner, Technical Univ. Chemnitz, Germany, December 2003. -C -C REVISIONS -C -C V. Sima, May 2008 (SLICOT version of the HAPACK routine DHGPQR). -C -C KEYWORDS -C -C Eigenvalue, eigenvalue decomposition, Hessenberg form, orthogonal -C transformation, (periodic) Schur form -C -C ****************************************************************** -C -C .. Parameters .. - DOUBLE PRECISION ZERO, ONE - PARAMETER ( ZERO = 0.0D+0, ONE = 1.0D+0 ) - INTEGER NSMAX, LDAS, LDBS - PARAMETER ( NSMAX = 15, LDAS = NSMAX, LDBS = NSMAX ) -C .. Scalar Arguments .. - CHARACTER COMPQ, COMPZ, JOB - INTEGER IHI, ILO, INFO, LDA, LDB, LDQ, LDWORK, LDZ, N -C .. Array Arguments .. - DOUBLE PRECISION A(LDA,*), ALPHAI(*), ALPHAR(*), B(LDB,*), - $ BETA(*), DWORK(*), Q(LDQ,*), Z(LDZ,*) -C .. Local Scalars .. - LOGICAL INITQ, INITZ, WANTQ, WANTT, WANTZ - INTEGER DUM, I, I1, I2, IERR, ITEMP, ITN, ITS, J, K, - $ KK, L, MAXB, NH, NR, NS, NV, PV2, PV3 - DOUBLE PRECISION OVFL, SMLNUM, TAUV, TAUW, TEMP, TST, ULP, UNFL -C .. Local Arrays .. - INTEGER ISEED(4) - DOUBLE PRECISION AS(LDAS,LDAS), BS(LDBS,LDBS), V(3*NSMAX+6) -C .. External Functions .. - LOGICAL LSAME - INTEGER IDAMAX, UE01MD - DOUBLE PRECISION DLAMCH, DLANHS - EXTERNAL DLAMCH, DLANHS, IDAMAX, LSAME, UE01MD -C .. External Subroutines .. - EXTERNAL DAXPY, DCOPY, DGEMV, DLABAD, DLACPY, DLARFG, - $ DLARFX, DLARNV, DLASET, DSCAL, DTRMV, MB03YA, - $ MB03YD, XERBLA -C .. Intrinsic Functions .. - INTRINSIC ABS, DBLE, MAX, MIN -C -C .. Executable Statements .. -C -C Decode the scalar input parameters. -C - WANTT = LSAME( JOB, 'S' ) - INITQ = LSAME( COMPQ, 'I' ) - WANTQ = INITQ.OR.LSAME( COMPQ, 'V' ) - INITZ = LSAME( COMPZ, 'I' ) - WANTZ = INITZ.OR.LSAME( COMPZ, 'V' ) -C -C Check the scalar input parameters. -C - INFO = 0 - IF ( .NOT.LSAME( JOB, 'E' ) .AND. .NOT.WANTT ) THEN - INFO = -1 - ELSE IF ( .NOT.LSAME( COMPQ, 'N' ) .AND. .NOT.WANTQ ) THEN - INFO = -2 - ELSE IF ( .NOT.LSAME( COMPZ, 'N' ) .AND. .NOT.WANTZ ) THEN - INFO = -3 - ELSE IF ( N.LT.0 ) THEN - INFO = -4 - ELSE IF ( ILO.LT.1 .OR. ILO.GT.MAX( 1, N ) ) THEN - INFO = -5 - ELSE IF ( IHI.LT.MIN( ILO,N ).OR.IHI.GT.N ) THEN - INFO = -6 - ELSE IF ( LDA.LT.MAX( 1, N ) ) THEN - INFO = -8 - ELSE IF ( LDB.LT.MAX( 1, N ) ) THEN - INFO = -10 - ELSE IF ( LDQ.LT.1 .OR. WANTQ .AND. LDQ.LT.N ) THEN - INFO = -12 - ELSE IF ( LDZ.LT.1 .OR. WANTZ .AND. LDZ.LT.N ) THEN - INFO = -14 - ELSE IF ( LDWORK.LT.MAX( 1, N ) ) THEN - DWORK(1) = DBLE( MAX( 1, N ) ) - INFO = -19 - END IF -C -C Return if there were illegal values. -C - IF ( INFO.NE.0 ) THEN - CALL XERBLA( 'MB03XP', -INFO ) - RETURN - END IF -C -C Initialize Q and Z, if necessary. -C - IF ( INITQ ) - $ CALL DLASET( 'All', N, N, ZERO, ONE, Q, LDQ ) - IF ( INITZ ) - $ CALL DLASET( 'All', N, N, ZERO, ONE, Z, LDZ ) -C -C Store isolated eigenvalues and standardize B. -C -C FOR I = [1:ILO-1, IHI+1:N] - I = 1 - 10 CONTINUE - IF ( I.EQ.ILO ) THEN - I = IHI+1 - END IF - IF ( I.LE.N ) THEN - IF ( B(I,I).LT.ZERO ) THEN - IF ( WANTT ) THEN - DO 20 K = ILO, I - B(K,I) = -B(K,I) - 20 CONTINUE - DO 30 K = I, IHI - A(I,K) = -A(I,K) - 30 CONTINUE - ELSE - B(I,I) = -B(I,I) - A(I,I) = -A(I,I) - END IF - IF ( WANTQ ) THEN - DO 40 K = ILO, IHI - Q(K,I) = -Q(K,I) - 40 CONTINUE - END IF - END IF - ALPHAR(I) = A(I,I) - ALPHAI(I) = ZERO - BETA(I) = B(I,I) - I = I + 1 -C END FOR - GO TO 10 - END IF -C -C Quick return if possible. -C - IF ( N.EQ.0 .OR. ILO.EQ.IHI+1 ) THEN - DWORK(1) = ONE - RETURN - END IF -C -C Set rows and coloms ILO to IHI of B (A) to zero below the first -C (sub)diagonal. -C - DO 60 J = ILO, IHI - 2 - DO 50 I = J + 2, N - A(I,J) = ZERO - 50 CONTINUE - 60 CONTINUE - DO 80 J = ILO, IHI - 1 - DO 70 I = J + 1, N - B(I,J) = ZERO - 70 CONTINUE - 80 CONTINUE - NH = IHI - ILO + 1 -C -C Suboptimal choice of the number of shifts. -C - IF ( WANTQ ) THEN - NS = UE01MD( 4, 'MB03XP', JOB // COMPQ, N, ILO, IHI ) - MAXB = UE01MD( 8, 'MB03XP', JOB // COMPQ, N, ILO, IHI ) - ELSE - NS = UE01MD( 4, 'MB03XP', JOB // COMPZ, N, ILO, IHI ) - MAXB = UE01MD( 8, 'MB03XP', JOB // COMPZ, N, ILO, IHI ) - END IF -C - IF ( NS.LE.2 .OR. NS.GT.NH .OR. MAXB.GE.NH ) THEN -C -C Standard double-shift product QR. -C - CALL MB03YD( WANTT, WANTQ, WANTZ, N, ILO, IHI, ILO, IHI, A, - $ LDA, B, LDB, Q, LDQ, Z, LDZ, ALPHAR, ALPHAI, BETA, - $ DWORK, LDWORK, INFO ) - RETURN - END IF - MAXB = MAX( 3, MAXB ) - NS = MIN( NS, MAXB, NSMAX ) -C -C Set machine-dependent constants for the stopping criterion. -C If max(norm(A),norm(B)) <= sqrt(OVFL), then overflow should not -C occur. -C - UNFL = DLAMCH( 'Safe minimum' ) - OVFL = ONE / UNFL - CALL DLABAD( UNFL, OVFL ) - ULP = DLAMCH( 'Precision' ) - SMLNUM = UNFL*( DBLE( NH ) / ULP ) -C -C I1 and I2 are the indices of the first rows and last columns of -C A and B to which transformations must be applied. -C - IF ( WANTT ) THEN - I1 = 1 - I2 = N - END IF - ISEED(1) = 1 - ISEED(2) = 0 - ISEED(3) = 0 - ISEED(4) = 1 -C -C ITN is the maximal number of QR iterations. -C - ITN = 30*NH - DUM = 0 -C -C Main loop. Eigenvalues I+1:IHI have converged. Either L = ILO -C or A(L,L-1) is negligible. -C - I = IHI - 90 CONTINUE - L = ILO - IF ( I.LT.ILO ) - $ GO TO 210 -C - DO 190 ITS = 0, ITN - DUM = DUM + (IHI-ILO)*(IHI-ILO) -C -C Look for deflations in A. -C - DO 100 K = I, L + 1, -1 - TST = ABS( A(K-1,K-1) ) + ABS( A(K,K) ) - IF ( TST.EQ.ZERO ) - $ TST = DLANHS( '1', I-L+1, A(L,L), LDA, DWORK ) - IF ( ABS( A(K,K-1) ).LE.MAX( ULP*TST, SMLNUM ) ) - $ GO TO 110 - 100 CONTINUE - 110 CONTINUE -C -C Look for deflation in B if problem size is greater than 1. -C - IF ( I-K.GE.1 ) THEN - DO 120 KK = I, K, -1 - IF ( KK.EQ.I ) THEN - TST = ABS( B(KK-1,KK) ) - ELSE IF ( KK.EQ.K ) THEN - TST = ABS( B(KK,KK+1) ) - ELSE - TST = ABS( B(KK-1,KK) ) + ABS( B(KK,KK+1) ) - END IF - IF ( TST.EQ.ZERO ) - $ TST = DLANHS( '1', I-K+1, B(K,K), LDB, DWORK ) - IF ( ABS( B(KK,KK) ).LE.MAX( ULP*TST, SMLNUM ) ) - $ GO TO 130 - 120 CONTINUE - ELSE - KK = K-1 - END IF - 130 CONTINUE - IF ( KK.GE.K ) THEN -C -C B has an element close to zero at position (KK,KK). -C - B(KK,KK) = ZERO - CALL MB03YA( WANTT, WANTQ, WANTZ, N, K, I, ILO, IHI, KK, - $ A, LDA, B, LDB, Q, LDQ, Z, LDZ, INFO ) - K = KK+1 - END IF - L = K - IF( L.GT.ILO ) THEN -C -C A(L,L-1) is negligible. -C - A(L,L-1) = ZERO - END IF -C -C Exit from loop if a submatrix of order <= MAXB has split off. -C - IF ( L.GE.I-MAXB+1 ) - $ GO TO 200 -C -C The active submatrices are now in rows and columns L:I. -C - IF ( .NOT.WANTT ) THEN - I1 = L - I2 = I - END IF - IF ( ITS.EQ.10.OR.ITS.EQ.20 ) THEN -C -C Exceptional shift. The first column of the shift polynomial -C is a pseudo-random vector. -C - CALL DLARNV( 3, ISEED, NS+1, V ) - ELSE -C -C Use eigenvalues of trailing submatrix as shifts. -C - CALL DLACPY( 'Full', NS, NS, A(I-NS+1,I-NS+1), LDA, AS, - $ LDAS ) - CALL DLACPY( 'Full', NS, NS, B(I-NS+1,I-NS+1), LDB, BS, - $ LDBS ) - CALL MB03YD( .FALSE., .FALSE., .FALSE., NS, 1, NS, 1, NS, - $ AS, LDAS, BS, LDBS, Q, LDQ, Z, LDZ, - $ ALPHAR(I-NS+1), ALPHAI(I-NS+1), BETA(I-NS+1), - $ DWORK, LDWORK, IERR ) - END IF -C -C Compute the nonzero elements of the first column of -C (A*B-w(1)) (A*B-w(2)) .. (A*B-w(ns)). -C - V(1) = ONE - NV = 1 -C WHILE NV <= NS - 140 CONTINUE - IF ( NV.LE.NS ) THEN - IF ( NV.EQ.NS .OR. AS(NV+1,NV).EQ.ZERO ) THEN -C -C Real shift. -C - V(NV+1) = ZERO - PV2 = NV+2 - CALL DCOPY( NV, V, 1, V(PV2), 1 ) - CALL DTRMV( 'Upper', 'No transpose', 'No unit diagonal', - $ NV, B(L,L), LDB, V(PV2), 1 ) - CALL DSCAL( NV, BS(NV,NV), V, 1 ) - ITEMP = IDAMAX( 2*NV+1, V, 1 ) - TEMP = ONE / MAX( ABS( V(ITEMP) ), SMLNUM ) - CALL DSCAL( 2*NV+1, TEMP, V, 1 ) - CALL DGEMV( 'No transpose', NV+1, NV, ONE, A(L,L), LDA, - $ V(PV2), 1, -AS(NV,NV), V, 1 ) - NV = NV + 1 - ELSE -C -C Double shift using a product formulation of the shift -C polynomial [2]. -C - V(NV+1) = ZERO - V(NV+2) = ZERO - PV2 = NV+3 - PV3 = 2*NV+5 - CALL DCOPY( NV+2, V, 1, V(PV2), 1 ) - CALL DCOPY( NV+1, V, 1, V(PV3), 1 ) - CALL DSCAL( NV, BS(NV+1,NV+1), V(PV2), 1 ) - CALL DTRMV( 'Upper', 'No transpose', 'No unit diagonal', - $ NV, B(L,L), LDB, V(PV3), 1 ) - ITEMP = IDAMAX( 2*NV+3, V(PV2), 1 ) - TEMP = ONE / MAX( ABS( V(PV2+ITEMP-1) ), SMLNUM ) - CALL DSCAL( 2*NV+3, TEMP, V(PV2), 1 ) -C - CALL DCOPY( NV, V(PV2), 1, V, 1 ) - CALL DGEMV( 'No transpose', NV+1, NV, -ONE, A(L,L), LDA, - $ V(PV3), 1, AS(NV+1,NV+1), V(PV2), 1 ) - CALL DSCAL( NV, AS(NV,NV+1), V, 1 ) - ITEMP = IDAMAX( 2*NV+3, V, 1 ) - TEMP = ONE / MAX( ABS( V(ITEMP) ), SMLNUM ) - CALL DSCAL( 2*NV+3, TEMP, V, 1 ) -C - CALL DSCAL( NV, -AS(NV+1,NV), V, 1 ) - CALL DAXPY( NV+1, AS(NV,NV), V(PV2), 1, V, 1) - ITEMP = IDAMAX( 2*NV+3, V, 1 ) - TEMP = ONE / MAX( ABS( V(ITEMP) ), SMLNUM ) - CALL DSCAL( 2*NV+3, TEMP, V, 1 ) -C - CALL DSCAL( NV+1, BS(NV,NV), V, 1 ) - CALL DTRMV( 'Upper', 'No transpose', 'No unit diagonal', - $ NV+1, B(L,L), LDB, V(PV2), 1 ) - ITEMP = IDAMAX( 2*NV+3, V, 1 ) - TEMP = ONE / MAX( ABS( V(ITEMP) ), SMLNUM ) - CALL DSCAL( 2*NV+3, TEMP, V, 1 ) -C - CALL DGEMV( 'No transpose', NV+2, NV+1, -ONE, A(L,L), - $ LDA, V(PV2), 1, ONE, V, 1 ) - NV = NV + 2 - END IF - ITEMP = IDAMAX( NV, V, 1 ) - TEMP = ABS( V(ITEMP) ) - IF ( TEMP.EQ.ZERO ) THEN - V(1) = ONE - DO 150 K = 2, NV - V(K) = ZERO - 150 CONTINUE - ELSE - TEMP = MAX( TEMP, SMLNUM ) - CALL DSCAL( NV, ONE/TEMP, V, 1 ) - END IF - GO TO 140 -C END WHILE - END IF -C -C Multi-shift product QR step. -C - PV2 = NS+2 - DO 180 K = L,I-1 - NR = MIN( NS+1,I-K+1 ) - IF ( K.GT.L ) - $ CALL DCOPY( NR, A(K,K-1), 1, V, 1 ) - CALL DLARFG( NR, V(1), V(2), 1, TAUV ) - IF ( K.GT.L ) THEN - A(K,K-1) = V(1) - DO 160 KK = K+1,I - A(KK,K-1) = ZERO - 160 CONTINUE - END IF -C -C Apply reflector V from the right to B in rows -C I1:min(K+NS,I). -C - V(1) = ONE - CALL DLARFX( 'Right', MIN(K+NS,I)-I1+1, NR, V, TAUV, - $ B(I1,K), LDB, DWORK ) -C -C Annihilate the introduced nonzeros in the K-th column. -C - CALL DCOPY( NR, B(K,K), 1, V(PV2), 1 ) - CALL DLARFG( NR, V(PV2), V(PV2+1), 1, TAUW ) - B(K,K) = V(PV2) - DO 170 KK = K+1,I - B(KK,K) = ZERO - 170 CONTINUE - V(PV2) = ONE -C -C Apply reflector W from the left to transform the rows of the -C matrix B in columns K+1:I2. -C - CALL DLARFX( 'Left', NR, I2-K, V(PV2), TAUW, B(K,K+1), LDB, - $ DWORK ) -C -C Apply reflector V from the left to transform the rows of the -C matrix A in columns K:I2. -C - CALL DLARFX( 'Left', NR, I2-K+1, V, TAUV, A(K,K), LDA, - $ DWORK ) -C -C Apply reflector W from the right to transform the columns of -C the matrix A in rows I1:min(K+NS,I). -C - CALL DLARFX( 'Right', MIN(K+NS+1,I)-I1+1, NR, V(PV2), TAUW, - $ A(I1,K), LDA, DWORK ) -C -C Accumulate transformations in the matrices Q and Z. -C - IF ( WANTQ ) - $ CALL DLARFX( 'Right', NH, NR, V, TAUV, Q(ILO,K), LDQ, - $ DWORK ) - IF ( WANTZ ) - $ CALL DLARFX( 'Right', NH, NR, V(PV2), TAUW, Z(ILO,K), - $ LDZ, DWORK ) - 180 CONTINUE - 190 CONTINUE -C -C Failure to converge. -C - INFO = I - RETURN - 200 CONTINUE -C -C Submatrix of order <= MAXB has split off. Use double-shift -C periodic QR algorithm. -C - CALL MB03YD( WANTT, WANTQ, WANTZ, N, L, I, ILO, IHI, A, LDA, B, - $ LDB, Q, LDQ, Z, LDZ, ALPHAR, ALPHAI, BETA, DWORK, - $ LDWORK, INFO ) - IF ( INFO.GT.0 ) - $ RETURN - ITN = ITN - ITS - I = L - 1 - GO TO 90 -C - 210 CONTINUE - DWORK(1) = DBLE( MAX( 1,N ) ) - RETURN -C *** Last line of MB03XP *** - END diff --git a/mex/sources/libslicot/MB03XU.f b/mex/sources/libslicot/MB03XU.f deleted file mode 100644 index b25d49da3..000000000 --- a/mex/sources/libslicot/MB03XU.f +++ /dev/null @@ -1,2338 +0,0 @@ - SUBROUTINE MB03XU( LTRA, LTRB, N, K, NB, A, LDA, B, LDB, G, LDG, - $ Q, LDQ, XA, LDXA, XB, LDXB, XG, LDXG, XQ, LDXQ, - $ YA, LDYA, YB, LDYB, YG, LDYG, YQ, LDYQ, CSL, - $ CSR, TAUL, TAUR, DWORK ) -C -C SLICOT RELEASE 5.0. -C -C Copyright (c) 2002-2009 NICONET e.V. -C -C This program is free software: you can redistribute it and/or -C modify it under the terms of the GNU General Public License as -C published by the Free Software Foundation, either version 2 of -C the License, or (at your option) any later version. -C -C This program is distributed in the hope that it will be useful, -C but WITHOUT ANY WARRANTY; without even the implied warranty of -C MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the -C GNU General Public License for more details. -C -C You should have received a copy of the GNU General Public License -C along with this program. If not, see -C . -C -C PURPOSE -C -C To reduce 2*nb columns and rows of a real (k+2n)-by-(k+2n) -C matrix H: -C -C [ op(A) G ] -C H = [ ], -C [ Q op(B) ] -C -C so that elements in the first nb columns below the k-th -C subdiagonal of the (k+n)-by-n matrix op(A), in the first nb -C columns and rows of the n-by-n matrix Q and in the first nb rows -C above the diagonal of the n-by-(k+n) matrix op(B) are zero. -C The reduction is performed by orthogonal symplectic -C transformations UU'*H*VV and matrices U, V, YA, YB, YG, YQ, XA, -C XB, XG, and XQ are returned so that -C -C [ op(Aout)+U*YA'+XA*V' G+U*YG'+XG*V' ] -C UU' H VV = [ ]. -C [ Qout+U*YQ'+XQ*V' op(Bout)+U*YB'+XB*V' ] -C -C This is an auxiliary routine called by MB04TB. -C -C ARGUMENTS -C -C Mode Parameters -C -C LTRA LOGICAL -C Specifies the form of op( A ) as follows: -C = .FALSE.: op( A ) = A; -C = .TRUE.: op( A ) = A'. -C -C LTRB LOGICAL -C Specifies the form of op( B ) as follows: -C = .FALSE.: op( B ) = B; -C = .TRUE.: op( B ) = B'. -C -C Input/Output Parameters -C -C N (input) INTEGER -C The order of the matrix Q. N >= 0. -C -C K (input) INTEGER -C The offset of the reduction. Elements below the K-th -C subdiagonal in the first NB columns of op(A) are -C reduced to zero. K >= 0. -C -C NB (input) INTEGER -C The number of columns/rows to be reduced. N > NB >= 0. -C -C A (input/output) DOUBLE PRECISION array, dimension -C (LDA,N) if LTRA = .FALSE. -C (LDA,K+N) if LTRA = .TRUE. -C On entry with LTRA = .FALSE., the leading (K+N)-by-N part -C of this array must contain the matrix A. -C On entry with LTRA = .TRUE., the leading N-by-(K+N) part -C of this array must contain the matrix A. -C On exit with LTRA = .FALSE., the leading (K+N)-by-N part -C of this array contains the matrix Aout and, in the zero -C parts, information about the elementary reflectors used to -C compute the reduction. -C On exit with LTRA = .TRUE., the leading N-by-(K+N) part of -C this array contains the matrix Aout and in the zero parts -C information about the elementary reflectors. -C -C LDA INTEGER -C The leading dimension of the array A. -C LDA >= MAX(1,K+N), if LTRA = .FALSE.; -C LDA >= MAX(1,N), if LTRA = .TRUE.. -C -C B (input/output) DOUBLE PRECISION array, dimension -C (LDB,K+N) if LTRB = .FALSE. -C (LDB,N) if LTRB = .TRUE. -C On entry with LTRB = .FALSE., the leading N-by-(K+N) part -C of this array must contain the matrix B. -C On entry with LTRB = .TRUE., the leading (K+N)-by-N part -C of this array must contain the matrix B. -C On exit with LTRB = .FALSE., the leading N-by-(K+N) part -C of this array contains the matrix Bout and, in the zero -C parts, information about the elementary reflectors used to -C compute the reduction. -C On exit with LTRB = .TRUE., the leading (K+N)-by-N part of -C this array contains the matrix Bout and in the zero parts -C information about the elementary reflectors. -C -C LDB INTEGER -C The leading dimension of the array B. -C LDB >= MAX(1,N), if LTRB = .FALSE.; -C LDB >= MAX(1,K+N), if LTRB = .TRUE.. -C -C G (input/output) DOUBLE PRECISION array, dimension (LDG,N) -C On entry, the leading N-by-N part of this array must -C contain the matrix G. -C On exit, the leading N-by-N part of this array contains -C the matrix Gout. -C -C LDG INTEGER -C The leading dimension of the array G. LDG >= MAX(1,N). -C -C Q (input/output) DOUBLE PRECISION array, dimension (LDQ,N) -C On entry, the leading N-by-N part of this array must -C contain the matrix Q. -C On exit, the leading N-by-N part of this array contains -C the matrix Qout and in the zero parts information about -C the elementary reflectors used to compute the reduction. -C -C LDQ INTEGER -C The leading dimension of the array Q. LDQ >= MAX(1,N). -C -C XA (output) DOUBLE PRECISION array, dimension (LDXA,2*NB) -C On exit, the leading N-by-(2*NB) part of this array -C contains the matrix XA. -C -C LDXA INTEGER -C The leading dimension of the array XA. LDXA >= MAX(1,N). -C -C XB (output) DOUBLE PRECISION array, dimension (LDXB,2*NB) -C On exit, the leading (K+N)-by-(2*NB) part of this array -C contains the matrix XB. -C -C LDXB INTEGER -C The leading dimension of the array XB. LDXB >= MAX(1,K+N). -C -C XG (output) DOUBLE PRECISION array, dimension (LDXG,2*NB) -C On exit, the leading (K+N)-by-(2*NB) part of this array -C contains the matrix XG. -C -C LDXG INTEGER -C The leading dimension of the array XG. LDXG >= MAX(1,K+N). -C -C XQ (output) DOUBLE PRECISION array, dimension (LDXQ,2*NB) -C On exit, the leading N-by-(2*NB) part of this array -C contains the matrix XQ. -C -C LDXQ INTEGER -C The leading dimension of the array XQ. LDXQ >= MAX(1,N). -C -C YA (output) DOUBLE PRECISION array, dimension (LDYA,2*NB) -C On exit, the leading (K+N)-by-(2*NB) part of this array -C contains the matrix YA. -C -C LDYA INTEGER -C The leading dimension of the array YA. LDYA >= MAX(1,K+N). -C -C YB (output) DOUBLE PRECISION array, dimension (LDYB,2*NB) -C On exit, the leading N-by-(2*NB) part of this array -C contains the matrix YB. -C -C LDYB INTEGER -C The leading dimension of the array YB. LDYB >= MAX(1,N). -C -C YG (output) DOUBLE PRECISION array, dimension (LDYG,2*NB) -C On exit, the leading (K+N)-by-(2*NB) part of this array -C contains the matrix YG. -C -C LDYG INTEGER -C The leading dimension of the array YG. LDYG >= MAX(1,K+N). -C -C YQ (output) DOUBLE PRECISION array, dimension (LDYQ,2*NB) -C On exit, the leading N-by-(2*NB) part of this array -C contains the matrix YQ. -C -C LDYQ INTEGER -C The leading dimension of the array YQ. LDYQ >= MAX(1,N). -C -C CSL (output) DOUBLE PRECISION array, dimension (2*NB) -C On exit, the first 2NB elements of this array contain the -C cosines and sines of the symplectic Givens rotations -C applied from the left-hand side used to compute the -C reduction. -C -C CSR (output) DOUBLE PRECISION array, dimension (2*NB) -C On exit, the first 2NB-2 elements of this array contain -C the cosines and sines of the symplectic Givens rotations -C applied from the right-hand side used to compute the -C reduction. -C -C TAUL (output) DOUBLE PRECISION array, dimension (NB) -C On exit, the first NB elements of this array contain the -C scalar factors of some of the elementary reflectors -C applied form the left-hand side. -C -C TAUR (output) DOUBLE PRECISION array, dimension (NB) -C On exit, the first NB-1 elements of this array contain the -C scalar factors of some of the elementary reflectors -C applied form the right-hand side. -C -C Workspace -C -C DWORK DOUBLE PRECISION array, dimension (5*NB) -C -C METHOD -C -C For details regarding the representation of the orthogonal -C symplectic matrices UU and VV within the arrays A, B, CSL, CSR, Q, -C TAUL and TAUR see the description of MB04TB. -C -C The contents of A, B, G and Q on exit are illustrated by the -C following example with op(A) = A, op(B) = B, n = 5, k = 2 and -C nb = 2: -C -C ( a r r a a ) ( g g g r r g g ) -C ( a r r a a ) ( g g g r r g g ) -C ( r r r r r ) ( r r r r r r r ) -C A = ( u2 r r r r ), G = ( r r r r r r r ), -C ( u2 u2 r a a ) ( g g g r r g g ) -C ( u2 u2 r a a ) ( g g g r r g g ) -C ( u2 u2 r a a ) ( g g g r r g g ) -C -C ( t t v1 v1 v1 ) ( r r r r r v2 v2 ) -C ( u1 t t v1 v1 ) ( r r r r r r v2 ) -C Q = ( u1 u1 r q q ), B = ( b b b r r b b ). -C ( u1 u1 r q q ) ( b b b r r b b ) -C ( u1 u1 r q q ) ( b b b r r b b ) -C -C where a, b, g and q denote elements of the original matrices, r -C denotes a modified element, t denotes a scalar factor of an -C applied elementary reflector, ui and vi denote elements of the -C matrices U and V, respectively. -C -C NUMERICAL ASPECTS -C -C The algorithm requires ( 16*K + 32*N + 42 )*N*NB + -C ( 16*K + 112*N - 208/3*NB - 69 )*NB*NB - 29/3*NB floating point -C operations and is numerically backward stable. -C -C REFERENCES -C -C [1] Benner, P., Mehrmann, V., and Xu, H. -C A numerically stable, structure preserving method for -C computing the eigenvalues of real Hamiltonian or symplectic -C pencils. -C Numer. Math., Vol. 78 (3), pp. 329-358, 1998. -C -C [2] Kressner, D. -C Block algorithms for orthogonal symplectic factorizations. -C BIT Numerical Mathematics, 43 (4), pp. 775-790, 2003. -C -C CONTRIBUTORS -C -C D. Kressner, Technical Univ. Berlin, Germany, and -C P. Benner, Technical Univ. Chemnitz, Germany, December 2003. -C -C REVISIONS -C -C V. Sima, June 2008 (SLICOT version of the HAPACK routine DLASUB). -C -C KEYWORDS -C -C Elementary matrix operations, Matrix decompositions, Hamiltonian -C matrix. -C -C ****************************************************************** -C -C .. Parameters .. - DOUBLE PRECISION ZERO, ONE - PARAMETER ( ZERO = 0.0D0, ONE = 1.0D0 ) -C .. Scalar Arguments .. - LOGICAL LTRA, LTRB - INTEGER K, LDA, LDB, LDG, LDQ, LDXA, LDXB, LDXG, LDXQ, - $ LDYA, LDYB, LDYG, LDYQ, N, NB -C .. Array Arguments .. - DOUBLE PRECISION A(LDA,*), B(LDB,*), CSL(*), CSR(*), DWORK(*), - $ G(LDG,*), Q(LDQ,*), TAUL(*), TAUR(*), - $ XA(LDXA,*), XB(LDXB,*), XG(LDXG,*), XQ(LDXQ,*), - $ YA(LDYA,*), YB(LDYB,*), YG(LDYG,*), YQ(LDYQ,*) -C .. Local Scalars .. - INTEGER I, J, NB1, NB2, NB3, PDW - DOUBLE PRECISION ALPHA, C, S, TAUQ, TEMP -C .. External Functions .. - DOUBLE PRECISION DDOT - EXTERNAL DDOT -C .. External Subroutines .. - EXTERNAL DAXPY, DGEMV, DLARFG, DLARTG, DROT, DSCAL -C -C .. Executable Statements .. -C -C Quick return if possible. -C - IF ( N+K.LE.0 ) THEN - RETURN - END IF -C - NB1 = NB + 1 - NB2 = NB + NB - NB3 = NB2 + NB - PDW = NB3 + NB + 1 -C - IF ( LTRA.AND.LTRB ) THEN - DO 90 I = 1, NB -C -C Transform first row/column of A and Q. See routine MB04TS. -C - ALPHA = Q(I,I) - CALL DLARFG( N-I+1, ALPHA, Q(I+1,I), 1, TAUQ ) - Q(I,I) = ONE - TEMP = -TAUQ*DDOT( N-I+1, Q(I,I), 1, A(I,K+I), LDA ) - CALL DAXPY( N-I+1, TEMP, Q(I,I), 1, A(I,K+I), LDA ) - TEMP = A(I,K+I) - CALL DLARTG( TEMP, ALPHA, C, S, A(I,K+I) ) - CALL DLARFG( N-I+1, A(I,K+I), A(I,K+I+1), LDA, TAUL(I) ) - TEMP = A(I,K+I) - A(I,K+I) = ONE -C -C Update XQ with first Householder reflection. -C - CALL DGEMV( 'Transpose', N-I+1, N-I, ONE, Q(I,I+1), LDQ, - $ Q(I,I), 1, ZERO, XQ(I+1,I), 1 ) - CALL DGEMV( 'Transpose', N-I+1, I-1, ONE, Q(I,1), LDQ, - $ Q(I,I), 1, ZERO, DWORK, 1 ) - CALL DGEMV( 'No transpose', N-I, I-1, ONE, XQ(I+1,1), LDXQ, - $ DWORK, 1, ONE, XQ(I+1,I), 1 ) - CALL DGEMV( 'No transpose', I-1, N-I+1, ONE, A(1,K+I), LDA, - $ Q(I,I), 1, ZERO, DWORK(NB+1), 1 ) - CALL DGEMV( 'No transpose', N-I, I-1, ONE, XQ(I+1,NB1), - $ LDXQ, DWORK(NB+1), 1, ONE, XQ(I+1,I), 1 ) - CALL DGEMV( 'Transpose', N-I+1, I-1, ONE, YQ(I,1), LDYQ, - $ Q(I,I), 1, ZERO, XQ(1,I), 1 ) - CALL DGEMV( 'Transpose', I-1, N-I, ONE, Q(1,I+1), LDQ, - $ XQ(1,I), 1, ONE, XQ(I+1,I), 1 ) - CALL DGEMV( 'Transpose', N-I+1, I-1, ONE, YQ(I,NB1), LDYQ, - $ Q(I,I), 1, ZERO, XQ(1,I+NB), 1 ) - CALL DGEMV( 'No transpose', N-I, I-1, ONE, B(K+I+1,1), LDB, - $ XQ(1,I+NB), 1, ONE, XQ(I+1,I), 1 ) - CALL DSCAL( N-I, -TAUQ, XQ(I+1,I), 1 ) -C -C Update Q(i,i+1:n). -C - CALL DGEMV( 'No transpose', N-I, I, ONE, XQ(I+1,1), LDXQ, - $ Q(I,1), LDQ, ONE, Q(I,I+1), LDQ ) - CALL DGEMV( 'No transpose', N-I, I-1, ONE, XQ(I+1,NB1), - $ LDXQ, A(1,K+I), 1, ONE, Q(I,I+1), LDQ ) - CALL DGEMV( 'Transpose', I-1, N-I, ONE, Q(1,I+1), LDQ, - $ YQ(I,1), LDYQ, ONE, Q(I,I+1), LDQ ) - CALL DGEMV( 'No transpose', N-I, I-1, ONE, B(K+I+1,1), LDB, - $ YQ(I,NB1), LDYQ, ONE, Q(I,I+1), LDQ ) -C -C Update XA with first Householder reflection. -C - CALL DGEMV( 'No transpose', N-I, N-I+1, ONE, A(I+1,K+I), - $ LDA, Q(I,I), 1, ZERO, XA(I+1,I), 1 ) - CALL DGEMV( 'No transpose', N-I, I-1, ONE, XA(I+1,1), LDXA, - $ DWORK, 1, ONE, XA(I+1,I), 1 ) - CALL DGEMV( 'No transpose', N-I, I-1, ONE, XA(I+1,NB1), - $ LDXA, DWORK(NB+1), 1, ONE, XA(I+1,I), 1 ) - CALL DGEMV( 'Transpose', N-I+1, I-1, ONE, YA(K+I,1), LDYA, - $ Q(I,I), 1, ZERO, XA(1,I), 1 ) - CALL DGEMV( 'Transpose', I-1, N-I, ONE, Q(1,I+1), LDQ, - $ XA(1,I), 1, ONE, XA(I+1,I), 1 ) - CALL DGEMV( 'Transpose', N-I+1, I-1, ONE, YA(K+I,NB1), LDYA, - $ Q(I,I), 1, ZERO, XA(1,I), 1 ) - CALL DGEMV( 'No transpose', N-I, I-1, ONE, B(K+I+1,1), LDB, - $ XA(1,I), 1, ONE, XA(I+1,I), 1 ) - CALL DSCAL( N-I, -TAUQ, XA(I+1,I), 1 ) -C -C Update A(i+1:n,k+i). -C - CALL DGEMV( 'No transpose', N-I, I, ONE, XA(I+1,1), LDXA, - $ Q(I,1), LDQ, ONE, A(I+1,K+I), 1 ) - CALL DGEMV( 'No transpose', N-I, I-1, ONE, XA(I+1,NB1), - $ LDXA, A(1,K+I), 1, ONE, A(I+1,K+I), 1 ) - CALL DGEMV( 'Transpose', I-1, N-I, ONE, Q(1,I+1), LDQ, - $ YA(K+I,1), LDYA, ONE, A(I+1,K+I), 1 ) - CALL DGEMV( 'No transpose', N-I, I-1, ONE, B(K+I+1,1), LDB, - $ YA(K+I,NB1), LDYA, ONE, A(I+1,K+I), 1 ) -C -C Apply rotation to [ A(i+1:n,k+i)'; Q(i,i+1:n) ]. -C - CALL DROT( N-I, A(I+1,K+I), 1, Q(I,I+1), LDQ, C, S ) -C -C Update XQ with second Householder reflection. -C - CALL DGEMV( 'Transpose', N-I+1, N-I, ONE, Q(I,I+1), LDQ, - $ A(I,K+I), LDA, ZERO, XQ(I+1,I+NB), 1 ) - CALL DGEMV( 'Transpose', N-I, I, ONE, Q(I+1,1), LDQ, - $ A(I,K+I+1), LDA, ZERO, DWORK(NB2+1), 1 ) - CALL DGEMV( 'No transpose', N-I, I, ONE, XQ(I+1,1), LDXQ, - $ DWORK(NB2+1), 1, ONE, XQ(I+1,I+NB), 1 ) - CALL DGEMV( 'No transpose', I-1, N-I, ONE, A(1,K+I+1), LDA, - $ A(I,K+I+1), LDA, ZERO, DWORK(NB3+1), 1 ) - CALL DGEMV( 'No transpose', N-I, I-1, ONE, XQ(I+1,NB1), - $ LDXQ, DWORK(NB3+1), 1, ONE, XQ(I+1,I+NB), 1 ) - CALL DGEMV( 'Transpose', N-I, I-1, ONE, YQ(I+1,1), LDYQ, - $ A(I,K+I+1), LDA, ZERO, XQ(1,I+NB), 1 ) - CALL DGEMV( 'Transpose', I-1, N-I, ONE, Q(1,I+1), LDQ, - $ XQ(1,I+NB), 1, ONE, XQ(I+1,I+NB), 1 ) - CALL DGEMV( 'Transpose', N-I, I-1, ONE, YQ(I+1,NB1), LDYQ, - $ A(I,K+I+1), LDA, ZERO, XQ(1,I+NB), 1 ) - CALL DGEMV( 'No transpose', N-I, I-1, ONE, B(K+I+1,1), LDB, - $ XQ(1,I+NB), 1, ONE, XQ(I+1,I+NB), 1 ) - CALL DSCAL( N-I, -TAUL(I), XQ(I+1,I+NB), 1 ) -C -C Update Q(i,i+1:n). -C - CALL DAXPY( N-I, ONE, XQ(I+1,I+NB), 1, Q(I,I+1), LDQ ) -C -C Update XA with second Householder reflection. -C - CALL DGEMV( 'No transpose', N-I, N-I+1, ONE, A(I+1,K+I), - $ LDA, A(I,K+I), LDA, ZERO, XA(I+1,I+NB), 1 ) - CALL DGEMV( 'No transpose', N-I, I, ONE, XA(I+1,1), LDXA, - $ DWORK(NB2+1), 1, ONE, XA(I+1,I+NB), 1 ) - CALL DGEMV( 'No transpose', N-I, I-1, ONE, XA(I+1,NB1), - $ LDXA, DWORK(NB3+1), 1, ONE, XA(I+1,I+NB), 1 ) - CALL DGEMV( 'Transpose', N-I, I-1, ONE, YA(K+I+1,1), LDYA, - $ A(I,K+I+1), LDA, ZERO, XA(1,I+NB), 1 ) - CALL DGEMV( 'Transpose', I-1, N-I, ONE, Q(1,I+1), LDQ, - $ XA(1,I+NB), 1, ONE, XA(I+1,I+NB), 1 ) - CALL DGEMV( 'Transpose', N-I, I-1, ONE, YA(K+I+1,NB1), LDYA, - $ A(I,K+I+1), LDA, ZERO, XA(1,I+NB), 1 ) - CALL DGEMV( 'No transpose', N-I, I-1, ONE, B(K+I+1,1), LDB, - $ XA(1,I+NB), 1, ONE, XA(I+1,I+NB), 1 ) - CALL DSCAL( N-I, -TAUL(I), XA(I+1,I+NB), 1 ) -C -C Update A(i+1:n,k+i). -C - CALL DAXPY( N-I, ONE, XA(I+1,I+NB), 1, A(I+1,K+I), 1 ) -C -C Update XG with first Householder reflection. -C - CALL DGEMV( 'Transpose', N-I+1, K+N, ONE, G(K+I,1), LDG, - $ Q(I,I), 1, ZERO, XG(1,I), 1 ) - CALL DGEMV( 'No transpose', K+N, I-1, ONE, XG, LDXG, - $ DWORK, 1, ONE, XG(1,I), 1 ) - CALL DGEMV( 'No transpose', K+N, I-1, ONE, XG(1,NB1), - $ LDXG, DWORK(NB+1), 1, ONE, XG(1,I), 1 ) - CALL DGEMV( 'Transpose', N-I+1, I-1, ONE, YG(K+I,1), LDYG, - $ Q(I,I), 1, ZERO, DWORK(PDW), 1 ) - CALL DGEMV( 'Transpose', I-1, N-I, ONE, Q(1,I+1), LDQ, - $ DWORK(PDW), 1, ONE, XG(K+I+1,I), 1 ) - CALL DGEMV( 'Transpose', N-I+1, I-1, ONE, YG(K+I,NB1), LDYG, - $ Q(I,I), 1, ZERO, DWORK(PDW), 1 ) - CALL DGEMV( 'No transpose', N-I, I-1, ONE, B(K+I+1,1), LDB, - $ DWORK(PDW), 1, ONE, XG(K+I+1,I), 1 ) - CALL DSCAL( K+N, -TAUQ, XG(1,I), 1 ) -C -C Update G(k+i,:). -C - CALL DGEMV( 'No transpose', K+N, I, ONE, XG, LDXG, - $ Q(I,1), LDQ, ONE, G(K+I,1), LDG ) - CALL DGEMV( 'No transpose', K+N, I-1, ONE, XG(1,NB1), - $ LDXG, A(1,K+I), 1, ONE, G(K+I,1), LDG ) - CALL DGEMV( 'Transpose', I-1, N-I, ONE, Q(1,I+1), LDQ, - $ YG(K+I,1), LDYG, ONE, G(K+I,K+I+1), LDG ) - CALL DGEMV( 'No transpose', N-I, I-1, ONE, B(K+I+1,1), LDB, - $ YG(K+I,NB1), LDYG, ONE, G(K+I,K+I+1), LDG ) -C -C Update XB with first Householder reflection. -C - CALL DGEMV( 'No transpose', K+N, N-I+1, ONE, B(1,I), LDB, - $ Q(I,I), 1, ZERO, XB(1,I), 1 ) - CALL DGEMV( 'No transpose', K+N, I-1, ONE, XB, LDXB, - $ DWORK, 1, ONE, XB(1,I), 1 ) - CALL DGEMV( 'No transpose', K+N, I-1, ONE, XB(1,NB1), - $ LDXB, DWORK(NB+1), 1, ONE, XB(1,I), 1 ) - CALL DGEMV( 'Transpose', N-I+1, I-1, ONE, YB(I,1), LDYB, - $ Q(I,I), 1, ZERO, DWORK(PDW), 1 ) - CALL DGEMV( 'Transpose', I-1, N-I, ONE, Q(1,I+1), LDQ, - $ DWORK(PDW), 1, ONE, XB(K+I+1,I), 1 ) - CALL DGEMV( 'Transpose', N-I+1, I-1, ONE, YB(I,NB1), LDYB, - $ Q(I,I), 1, ZERO, DWORK(PDW), 1 ) - CALL DGEMV( 'No transpose', N-I, I-1, ONE, B(K+I+1,1), LDB, - $ DWORK(PDW), 1, ONE, XB(K+I+1,I), 1 ) - CALL DSCAL( K+N, -TAUQ, XB(1,I), 1 ) -C -C Update B(:,i). -C - CALL DGEMV( 'No transpose', K+N, I, ONE, XB, LDXB, - $ Q(I,1), LDQ, ONE, B(1,I), 1 ) - CALL DGEMV( 'No transpose', K+N, I-1, ONE, XB(1,NB1), - $ LDXB, A(1,K+I), 1, ONE, B(1,I), 1 ) - CALL DGEMV( 'Transpose', I-1, N-I, ONE, Q(1,I+1), LDQ, - $ YB(I,1), LDYB, ONE, B(K+I+1,I), 1 ) - CALL DGEMV( 'No transpose', N-I, I-1, ONE, B(K+I+1,1), LDB, - $ YB(I,NB1), LDYB, ONE, B(K+I+1,I), 1 ) -C -C Apply rotation to [ G(k+i,:); B(:,i)' ]. -C - CALL DROT( K+N, G(K+I,1), LDG, B(1,I), 1, C, S ) -C - DO 10 J = 1, I-1 - YG(K+I,J) = ZERO - 10 CONTINUE - DO 20 J = 1, I-1 - YG(K+I,NB+J) = ZERO - 20 CONTINUE - DO 30 J = 1, I-1 - YA(K+I,J) = ZERO - 30 CONTINUE - DO 40 J = 1, I-1 - YA(K+I,NB+J) = ZERO - 40 CONTINUE -C -C Update XG with second Householder reflection. -C - CALL DGEMV( 'Transpose', N-I+1, K+N, ONE, G(K+I,1), LDG, - $ A(I,K+I), LDA, ZERO, XG(1,I+NB), 1 ) - CALL DGEMV( 'No transpose', K+N, I, ONE, XG, LDXG, - $ DWORK(NB2+1), 1, ONE, XG(1,I+NB), 1 ) - CALL DGEMV( 'No transpose', K+N, I-1, ONE, XG(1,NB1), - $ LDXG, DWORK(NB3+1), 1, ONE, XG(1,I+NB), 1 ) - CALL DGEMV( 'Transpose', N-I, I-1, ONE, YG(K+I+1,1), LDYG, - $ A(I,K+I+1), LDA, ZERO, DWORK(PDW), 1 ) - CALL DGEMV( 'Transpose', I-1, N-I, ONE, Q(1,I+1), LDQ, - $ DWORK(PDW), 1, ONE, XG(K+I+1,I+NB), 1 ) - CALL DGEMV( 'Transpose', N-I, I-1, ONE, YG(K+I+1,NB1), LDYG, - $ A(I,K+I+1), LDA, ZERO, DWORK(PDW), 1 ) - CALL DGEMV( 'No transpose', N-I, I-1, ONE, B(K+I+1,1), LDB, - $ DWORK(PDW), 1, ONE, XG(K+I+1,I+NB), 1 ) - CALL DSCAL( K+N, -TAUL(I), XG(1,I+NB), 1 ) -C -C Update G(k+i,:). -C - CALL DAXPY( K+N, ONE, XG(1,I+NB), 1, G(K+I,1), LDG ) -C -C Update XB with second Householder reflection. -C - CALL DGEMV( 'No transpose', K+N, N-I+1, ONE, B(1,I), LDB, - $ A(I,K+I), LDA, ZERO, XB(1,I+NB), 1 ) - CALL DGEMV( 'No transpose', K+N, I, ONE, XB, LDXB, - $ DWORK(NB2+1), 1, ONE, XB(1,I+NB), 1 ) - CALL DGEMV( 'No transpose', K+N, I-1, ONE, XB(1,NB1), - $ LDXB, DWORK(NB3+1), 1, ONE, XB(1,I+NB), 1 ) - CALL DGEMV( 'Transpose', N-I, I-1, ONE, YB(I+1,1), LDYB, - $ A(I,K+I+1), LDA, ZERO, DWORK(PDW), 1 ) - CALL DGEMV( 'Transpose', I-1, N-I, ONE, Q(1,I+1), LDQ, - $ DWORK(PDW), 1, ONE, XB(K+I+1,I+NB), 1 ) - CALL DGEMV( 'Transpose', N-I, I-1, ONE, YB(I+1,NB1), LDYB, - $ A(I,K+I+1), LDA, ZERO, DWORK(PDW), 1 ) - CALL DGEMV( 'No transpose', N-I, I-1, ONE, B(K+I+1,1), LDB, - $ DWORK(PDW), 1, ONE, XB(K+I+1,I+NB), 1 ) - CALL DSCAL( K+N, -TAUL(I), XB(1,I+NB), 1 ) -C -C Update B(:,i). -C - CALL DAXPY( K+N, ONE, XB(1,I+NB), 1, B(1,I), 1 ) -C - A(I,K+I) = TEMP - Q(I,I) = TAUQ - CSL(2*I-1) = C - CSL(2*I) = S -C -C Transform first row/column of Q and B. -C - ALPHA = Q(I,I+1) - CALL DLARFG( N-I, ALPHA, Q(I,I+2), LDQ, TAUQ ) - Q(I,I+1) = ONE - TEMP = -TAUQ*DDOT( N-I, Q(I,I+1), LDQ, B(K+I+1,I), 1 ) - CALL DAXPY( N-I, TEMP, Q(I,I+1), LDQ, B(K+I+1,I), 1 ) - TEMP = B(K+I+1,I) - CALL DLARTG( TEMP, ALPHA, C, S, B(K+I+1,I) ) - S = -S - CALL DLARFG( N-I, B(K+I+1,I), B(K+I+2,I), 1, TAUR(I) ) - TEMP = B(K+I+1,I) - B(K+I+1,I) = ONE -C -C Update YB with first Householder reflection. -C - CALL DGEMV( 'Transpose', N-I, N-I, ONE, B(K+I+1,I+1), - $ LDB, Q(I,I+1), LDQ, ZERO, YB(I+1,I), 1 ) - CALL DGEMV( 'Transpose', N-I, I, ONE, XB(K+I+1,1), LDXB, - $ Q(I,I+1), LDQ, ZERO, YB(1,I), 1 ) - CALL DGEMV( 'No transpose', N-I, I, ONE, Q(I+1,1), LDQ, - $ YB(1,I), 1, ONE, YB(I+1,I), 1 ) - CALL DGEMV( 'Transpose', N-I, I, ONE, XB(K+I+1,NB1), LDXB, - $ Q(I,I+1), LDQ, ZERO, YB(1,I), 1 ) - CALL DGEMV( 'Transpose', I, N-I, ONE, A(1,K+I+1), LDA, - $ YB(1,I), 1, ONE, YB(I+1,I), 1 ) - CALL DGEMV( 'No transpose', I-1, N-I, ONE, Q(1,I+1), LDQ, - $ Q(I,I+1), LDQ, ZERO, DWORK, 1 ) - CALL DGEMV( 'No transpose', N-I, I-1, ONE, YB(I+1,1), LDYB, - $ DWORK, 1, ONE, YB(I+1,I), 1 ) - CALL DGEMV( 'Transpose', N-I, I-1, ONE, B(K+I+1,1), LDB, - $ Q(I,I+1), LDQ, ZERO, DWORK(NB+1), 1 ) - CALL DGEMV( 'No transpose', N-I, I-1, ONE, YB(I+1,NB1), - $ LDYB, DWORK(NB+1), 1, ONE, YB(I+1,I), 1 ) - CALL DSCAL( N-I, -TAUQ, YB(I+1,I), 1 ) -C -C Update B(k+i+1,i+1:n). -C - CALL DGEMV( 'No transpose', N-I, I, ONE, Q(I+1,1), LDQ, - $ XB(K+I+1,1), LDXB, ONE, B(K+I+1,I+1), LDB ) - CALL DGEMV( 'Transpose', I, N-I, ONE, A(1,K+I+1), LDA, - $ XB(K+I+1,NB1), LDXB, ONE, B(K+I+1,I+1), LDB ) - CALL DGEMV( 'No transpose', N-I, I, ONE, YB(I+1,1), LDYB, - $ Q(1,I+1), 1, ONE, B(K+I+1,I+1), LDB ) - CALL DGEMV( 'No transpose', N-I, I-1, ONE, YB(I+1,NB1), - $ LDYB, B(K+I+1,1), LDB, ONE, B(K+I+1,I+1), LDB ) -C -C Update YQ with first Householder reflection. -C - CALL DGEMV( 'No transpose', N-I, N-I, ONE, Q(I+1,I+1), LDQ, - $ Q(I,I+1), LDQ, ZERO, YQ(I+1,I), 1 ) - CALL DGEMV( 'Transpose', N-I, I, ONE, XQ(I+1,1), LDXQ, - $ Q(I,I+1), LDQ, ZERO, YQ(1,I), 1 ) - CALL DGEMV( 'No transpose', N-I, I, ONE, Q(I+1,1), LDQ, - $ YQ(1,I), 1, ONE, YQ(I+1,I), 1 ) - CALL DGEMV( 'Transpose', N-I, I, ONE, XQ(I+1,NB1), LDXQ, - $ Q(I,I+1), LDQ, ZERO, YQ(1,I), 1 ) - CALL DGEMV( 'Transpose', I, N-I, ONE, A(1,K+I+1), LDA, - $ YQ(1,I), 1, ONE, YQ(I+1,I), 1 ) - CALL DGEMV( 'No transpose', N-I, I-1, ONE, YQ(I+1,1), LDYQ, - $ DWORK, 1, ONE, YQ(I+1,I), 1 ) - CALL DGEMV( 'No transpose', N-I, I-1, ONE, YQ(I+1,NB1), - $ LDYQ, DWORK(NB+1), 1, ONE, YQ(I+1,I), 1 ) - CALL DSCAL( N-I, -TAUQ, YQ(I+1,I), 1 ) -C -C Update Q(i+1:n,i+1). -C - CALL DGEMV( 'No transpose', N-I, I, ONE, Q(I+1,1), LDQ, - $ XQ(I+1,1), LDXQ, ONE, Q(I+1,I+1), 1 ) - CALL DGEMV( 'Transpose', I, N-I, ONE, A(1,K+I+1), LDA, - $ XQ(I+1,NB1), LDXQ, ONE, Q(I+1,I+1), 1 ) - CALL DGEMV( 'No transpose', N-I, I, ONE, YQ(I+1,1), LDYQ, - $ Q(1,I+1), 1, ONE, Q(I+1,I+1), 1 ) - CALL DGEMV( 'No transpose', N-I, I-1, ONE, YQ(I+1,NB1), - $ LDYQ, B(K+I+1,1), LDB, ONE, Q(I+1,I+1), 1 ) -C -C Apply rotation to [ Q(i+1:n,i+1), B(k+i+1,i+1:n)' ]. -C - CALL DROT( N-I, Q(I+1,I+1), 1, B(K+I+1,I+1), LDB, C, S ) - DO 50 J = 1, I - XB(K+I+1,J) = ZERO - 50 CONTINUE - DO 60 J = 1, I - XB(K+I+1,NB+J) = ZERO - 60 CONTINUE -C -C Update YB with second Householder reflection. -C - CALL DGEMV( 'Transpose', N-I, N-I, ONE, B(K+I+1,I+1), - $ LDB, B(K+I+1,I), 1, ZERO, YB(I+1,I+NB), 1 ) - CALL DGEMV( 'Transpose', N-I-1, I, ONE, XB(K+I+2,1), LDXB, - $ B(K+I+2,I), 1, ZERO, YB(1,I+NB), 1 ) - CALL DGEMV( 'No transpose', N-I, I, ONE, Q(I+1,1), LDQ, - $ YB(1,I+NB), 1, ONE, YB(I+1,I+NB), 1 ) - CALL DGEMV( 'Transpose', N-I-1, I, ONE, XB(K+I+2,NB1), LDXB, - $ B(K+I+2,I), 1, ZERO, YB(1,I+NB), 1 ) - CALL DGEMV( 'Transpose', I, N-I, ONE, A(1,K+I+1), LDA, - $ YB(1,I+NB), 1, ONE, YB(I+1,I+NB), 1 ) - CALL DGEMV( 'No transpose', I, N-I-1, ONE, Q(1,I+2), LDQ, - $ B(K+I+2,I), 1, ZERO, DWORK(NB2+1), 1 ) - CALL DGEMV( 'No transpose', N-I, I, ONE, YB(I+1,1), LDYB, - $ DWORK(NB2+1), 1, ONE, YB(I+1,I+NB), 1 ) - CALL DGEMV( 'Transpose', N-I-1, I-1, ONE, B(K+I+2,1), - $ LDQ, B(K+I+2,I), 1, ZERO, DWORK(NB3+1), 1 ) - CALL DGEMV( 'No transpose', N-I, I-1, ONE, YB(I+1,NB1), - $ LDYB, DWORK(NB3+1), 1, ONE, YB(I+1,I+NB), 1 ) - CALL DSCAL( N-I, -TAUR(I), YB(I+1,I+NB), 1 ) -C -C Update B(k+i+1,i+1:n). -C - CALL DAXPY( N-I, ONE, YB(I+1,I+NB), 1, B(K+I+1,I+1), LDB ) -C -C Update YQ with second Householder reflection. -C - CALL DGEMV( 'No transpose', N-I, N-I, ONE, Q(I+1,I+1), LDQ, - $ B(K+I+1,I), 1, ZERO, YQ(I+1,I+NB), 1 ) - CALL DGEMV( 'Transpose', N-I-1, I, ONE, XQ(I+2,1), LDXQ, - $ B(K+I+2,I), 1, ZERO, YQ(1,I+NB), 1 ) - CALL DGEMV( 'No transpose', N-I, I, ONE, Q(I+1,1), LDQ, - $ YQ(1,I+NB), 1, ONE, YQ(I+1,I+NB), 1 ) - CALL DGEMV( 'Transpose', N-I-1, I, ONE, XQ(I+2,NB1), LDXQ, - $ B(K+I+2,I), 1, ZERO, YQ(1,I+NB), 1 ) - CALL DGEMV( 'Transpose', I, N-I, ONE, A(1,K+I+1), LDA, - $ YQ(1,I+NB), 1, ONE, YQ(I+1,I+NB), 1 ) - CALL DGEMV( 'No transpose', N-I, I, ONE, YQ(I+1,1), LDYQ, - $ DWORK(NB2+1), 1, ONE, YQ(I+1,I+NB), 1 ) - CALL DGEMV( 'No transpose', N-I, I-1, ONE, YQ(I+1,NB1), - $ LDYQ, DWORK(NB3+1), 1, ONE, YQ(I+1,I+NB), 1 ) - CALL DSCAL( N-I, -TAUR(I), YQ(I+1,I+NB), 1 ) -C -C Update Q(i+1:n,i+1). -C - CALL DAXPY( N-I, ONE, YQ(I+1,I+NB), 1, Q(I+1,I+1), 1 ) -C -C Update YA with first Householder reflection. -C - CALL DGEMV( 'Transpose', N-I, K+N, ONE, A(I+1,1), LDA, - $ Q(I,I+1), LDQ, ZERO, YA(1,I), 1 ) - CALL DGEMV( 'Transpose', N-I, I, ONE, XA(I+1,1), LDXA, - $ Q(I,I+1), LDQ, ZERO, DWORK(PDW), 1 ) - CALL DGEMV( 'No transpose', N-I, I, ONE, Q(I+1,1), LDQ, - $ DWORK(PDW), 1, ONE, YA(K+I+1,I), 1 ) - CALL DGEMV( 'Transpose', N-I, I, ONE, XA(I+1,NB1), LDXA, - $ Q(I,I+1), LDQ, ZERO, DWORK(PDW), 1 ) - CALL DGEMV( 'Transpose', I, N-I, ONE, A(1,K+I+1), LDA, - $ DWORK(PDW), 1, ONE, YA(K+I+1,I), 1 ) - CALL DGEMV( 'No transpose', K+N, I-1, ONE, YA, LDYA, - $ DWORK, 1, ONE, YA(1,I), 1 ) - CALL DGEMV( 'No transpose', K+N, I-1, ONE, YA(1,NB1), LDYA, - $ DWORK(NB+1), 1, ONE, YA(1,I), 1 ) - CALL DSCAL( K+N, -TAUQ, YA(1,I), 1 ) -C -C Update A(i+1,1:k+n). -C - CALL DGEMV( 'No transpose', N-I, I, ONE, Q(I+1,1), LDQ, - $ XA(I+1,1), LDXA, ONE, A(I+1,K+I+1), LDA ) - CALL DGEMV( 'Transpose', I, N-I, ONE, A(1,K+I+1), LDA, - $ XA(I+1,NB1), LDXA, ONE, A(I+1,K+I+1), LDA ) - CALL DGEMV( 'No transpose', K+N, I, ONE, YA, LDYA, - $ Q(1,I+1), 1, ONE, A(I+1,1), LDA ) - CALL DGEMV( 'No transpose', K+N, I-1, ONE, YA(1,NB1), LDYA, - $ B(K+I+1,1), LDB, ONE, A(I+1,1), LDA ) -C -C Update YG with first Householder reflection. -C - CALL DGEMV( 'No transpose', K+N, N-I, ONE, G(1,K+I+1), LDG, - $ Q(I,I+1), LDQ, ZERO, YG(1,I), 1 ) - CALL DGEMV( 'Transpose', N-I, I, ONE, XG(K+I+1,1), LDXG, - $ Q(I,I+1), LDQ, ZERO, DWORK(PDW), 1 ) - CALL DGEMV( 'No transpose', N-I, I, ONE, Q(I+1,1), LDQ, - $ DWORK(PDW), 1, ONE, YG(K+I+1,I), 1 ) - CALL DGEMV( 'Transpose', N-I, I, ONE, XG(K+I+1,NB1), LDXG, - $ Q(I,I+1), LDQ, ZERO, DWORK(PDW), 1 ) - CALL DGEMV( 'Transpose', I, N-I, ONE, A(1,K+I+1), LDA, - $ DWORK(PDW), 1, ONE, YG(K+I+1,I), 1 ) - CALL DGEMV( 'No transpose', K+N, I-1, ONE, YG, LDYG, - $ DWORK, 1, ONE, YG(1,I), 1 ) - CALL DGEMV( 'No transpose', K+N, I-1, ONE, YG(1,NB1), LDYG, - $ DWORK(NB+1), 1, ONE, YG(1,I), 1 ) - CALL DSCAL( K+N, -TAUQ, YG(1,I), 1 ) -C -C Update G(1:k+n,k+i+1). -C - CALL DGEMV( 'No transpose', N-I, I, ONE, Q(I+1,1), LDQ, - $ XG(K+I+1,1), LDXG, ONE, G(K+I+1,K+I+1), 1 ) - CALL DGEMV( 'Transpose', I, N-I, ONE, A(1,K+I+1), LDA, - $ XG(K+I+1,NB1), LDXG, ONE, G(K+I+1,K+I+1), 1 ) - CALL DGEMV( 'No transpose', K+N, I, ONE, YG, LDYG, - $ Q(1,I+1), 1, ONE, G(1,K+I+1), 1 ) - CALL DGEMV( 'No transpose', K+N, I-1, ONE, YG(1,NB1), LDYG, - $ B(K+I+1,1), LDB, ONE, G(1,K+I+1), 1 ) - DO 70 J = 1, I - XG(K+I+1,J) = ZERO - 70 CONTINUE - DO 80 J = 1, I - XG(K+I+1,NB+J) = ZERO - 80 CONTINUE -C -C Apply rotation to [ A(i+1,1:k+n)', G(1:k+n,k+i+1) ]. -C - CALL DROT( K+N, A(I+1,1), LDA, G(1,K+I+1), 1, C, S ) -C -C Update YA with second Householder reflection. -C - CALL DGEMV( 'Transpose', N-I, K+N, ONE, A(I+1,1), LDA, - $ B(K+I+1,I), 1, ZERO, YA(1,I+NB), 1 ) - CALL DGEMV( 'Transpose', N-I-1, I, ONE, XA(I+2,1), LDXA, - $ B(K+I+2,I), 1, ZERO, DWORK(PDW), 1 ) - CALL DGEMV( 'No transpose', N-I, I, ONE, Q(I+1,1), LDQ, - $ DWORK(PDW), 1, ONE, YA(K+I+1,I+NB), 1 ) - CALL DGEMV( 'Transpose', N-I-1, I, ONE, XA(I+2,NB1), LDXA, - $ B(K+I+2,I), 1, ZERO, DWORK(PDW), 1 ) - CALL DGEMV( 'Transpose', I, N-I, ONE, A(1,K+I+1), LDA, - $ DWORK(PDW), 1, ONE, YA(K+I+1,I+NB), 1 ) - CALL DGEMV( 'No transpose', K+N, I, ONE, YA, LDYA, - $ DWORK(NB2+1), 1, ONE, YA(1,I+NB), 1 ) - CALL DGEMV( 'No transpose', K+N, I-1, ONE, YA(1,NB1), LDYA, - $ DWORK(NB3+1), 1, ONE, YA(1,I+NB), 1 ) - CALL DSCAL( K+N, -TAUR(I), YA(1,I+NB), 1 ) -C -C Update A(i+1,1:k+n). -C - CALL DAXPY( K+N, ONE, YA(1,I+NB), 1, A(I+1,1), LDA ) -C -C Update YG with second Householder reflection. -C - CALL DGEMV( 'No transpose', K+N, N-I, ONE, G(1,K+I+1), LDG, - $ B(K+I+1,I), 1, ZERO, YG(1,I+NB), 1 ) - CALL DGEMV( 'Transpose', N-I-1, I, ONE, XG(K+I+2,1), LDXG, - $ B(K+I+2,I), 1, ZERO, DWORK(PDW), 1 ) - CALL DGEMV( 'No transpose', N-I, I, ONE, Q(I+1,1), LDQ, - $ DWORK(PDW), 1, ONE, YG(K+I+1,I+NB), 1 ) - CALL DGEMV( 'Transpose', N-I-1, I, ONE, XG(K+I+2,NB1), LDXG, - $ B(K+I+2,I), 1, ZERO, DWORK(PDW), 1 ) - CALL DGEMV( 'Transpose', I, N-I, ONE, A(1,K+I+1), LDA, - $ DWORK(PDW), 1, ONE, YG(K+I+1,I+NB), 1 ) - CALL DGEMV( 'No transpose', K+N, I, ONE, YG, LDYG, - $ DWORK(NB2+1), 1, ONE, YG(1,I+NB), 1 ) - CALL DGEMV( 'No transpose', K+N, I-1, ONE, YG(1,NB1), LDYG, - $ DWORK(NB3+1), 1, ONE, YG(1,I+NB), 1 ) - CALL DSCAL( K+N, -TAUR(I), YG(1,I+NB), 1 ) -C -C Update G(1:k+n,k+i+1). -C - CALL DAXPY( K+N, ONE, YG(1,I+NB), 1, G(1,K+I+1), 1 ) -C - B(K+I+1,I) = TEMP - Q(I,I+1) = TAUQ - CSR(2*I-1) = C - CSR(2*I) = S - 90 CONTINUE - ELSE IF ( LTRA ) THEN - DO 180 I = 1, NB -C -C Transform first row/column of A and Q. See routine MB04TS. -C - ALPHA = Q(I,I) - CALL DLARFG( N-I+1, ALPHA, Q(I+1,I), 1, TAUQ ) - Q(I,I) = ONE - TEMP = -TAUQ*DDOT( N-I+1, Q(I,I), 1, A(I,K+I), LDA ) - CALL DAXPY( N-I+1, TEMP, Q(I,I), 1, A(I,K+I), LDA ) - TEMP = A(I,K+I) - CALL DLARTG( TEMP, ALPHA, C, S, A(I,K+I) ) - CALL DLARFG( N-I+1, A(I,K+I), A(I,K+I+1), LDA, TAUL(I) ) - TEMP = A(I,K+I) - A(I,K+I) = ONE -C -C Update XQ with first Householder reflection. -C - CALL DGEMV( 'Transpose', N-I+1, N-I, ONE, Q(I,I+1), LDQ, - $ Q(I,I), 1, ZERO, XQ(I+1,I), 1 ) - CALL DGEMV( 'Transpose', N-I+1, I-1, ONE, Q(I,1), LDQ, - $ Q(I,I), 1, ZERO, DWORK, 1 ) - CALL DGEMV( 'No transpose', N-I, I-1, ONE, XQ(I+1,1), LDXQ, - $ DWORK, 1, ONE, XQ(I+1,I), 1 ) - CALL DGEMV( 'No transpose', I-1, N-I+1, ONE, A(1,K+I), LDA, - $ Q(I,I), 1, ZERO, DWORK(NB+1), 1 ) - CALL DGEMV( 'No transpose', N-I, I-1, ONE, XQ(I+1,NB1), - $ LDXQ, DWORK(NB+1), 1, ONE, XQ(I+1,I), 1 ) - CALL DGEMV( 'Transpose', N-I+1, I-1, ONE, YQ(I,1), LDYQ, - $ Q(I,I), 1, ZERO, XQ(1,I), 1 ) - CALL DGEMV( 'Transpose', I-1, N-I, ONE, Q(1,I+1), LDQ, - $ XQ(1,I), 1, ONE, XQ(I+1,I), 1 ) - CALL DGEMV( 'Transpose', N-I+1, I-1, ONE, YQ(I,NB1), LDYQ, - $ Q(I,I), 1, ZERO, XQ(1,I+NB), 1 ) - CALL DGEMV( 'Transpose', I-1, N-I, ONE, B(1,K+I+1), LDB, - $ XQ(1,I+NB), 1, ONE, XQ(I+1,I), 1 ) - CALL DSCAL( N-I, -TAUQ, XQ(I+1,I), 1 ) -C -C Update Q(i,i+1:n). -C - CALL DGEMV( 'No transpose', N-I, I, ONE, XQ(I+1,1), LDXQ, - $ Q(I,1), LDQ, ONE, Q(I,I+1), LDQ ) - CALL DGEMV( 'No transpose', N-I, I-1, ONE, XQ(I+1,NB1), - $ LDXQ, A(1,K+I), 1, ONE, Q(I,I+1), LDQ ) - CALL DGEMV( 'Transpose', I-1, N-I, ONE, Q(1,I+1), LDQ, - $ YQ(I,1), LDYQ, ONE, Q(I,I+1), LDQ ) - CALL DGEMV( 'Transpose', I-1, N-I, ONE, B(1,K+I+1), LDB, - $ YQ(I,NB1), LDYQ, ONE, Q(I,I+1), LDQ ) -C -C Update XA with first Householder reflection. -C - CALL DGEMV( 'No transpose', N-I, N-I+1, ONE, A(I+1,K+I), - $ LDA, Q(I,I), 1, ZERO, XA(I+1,I), 1 ) - CALL DGEMV( 'No transpose', N-I, I-1, ONE, XA(I+1,1), LDXA, - $ DWORK, 1, ONE, XA(I+1,I), 1 ) - CALL DGEMV( 'No transpose', N-I, I-1, ONE, XA(I+1,NB1), - $ LDXA, DWORK(NB+1), 1, ONE, XA(I+1,I), 1 ) - CALL DGEMV( 'Transpose', N-I+1, I-1, ONE, YA(K+I,1), LDYA, - $ Q(I,I), 1, ZERO, XA(1,I), 1 ) - CALL DGEMV( 'Transpose', I-1, N-I, ONE, Q(1,I+1), LDQ, - $ XA(1,I), 1, ONE, XA(I+1,I), 1 ) - CALL DGEMV( 'Transpose', N-I+1, I-1, ONE, YA(K+I,NB1), LDYA, - $ Q(I,I), 1, ZERO, XA(1,I), 1 ) - CALL DGEMV( 'Transpose', I-1, N-I, ONE, B(1,K+I+1), LDB, - $ XA(1,I), 1, ONE, XA(I+1,I), 1 ) - CALL DSCAL( N-I, -TAUQ, XA(I+1,I), 1 ) -C -C Update A(i+1:n,k+i). -C - CALL DGEMV( 'No transpose', N-I, I, ONE, XA(I+1,1), LDXA, - $ Q(I,1), LDQ, ONE, A(I+1,K+I), 1 ) - CALL DGEMV( 'No transpose', N-I, I-1, ONE, XA(I+1,NB1), - $ LDXA, A(1,K+I), 1, ONE, A(I+1,K+I), 1 ) - CALL DGEMV( 'Transpose', I-1, N-I, ONE, Q(1,I+1), LDQ, - $ YA(K+I,1), LDYA, ONE, A(I+1,K+I), 1 ) - CALL DGEMV( 'Transpose', I-1, N-I, ONE, B(1,K+I+1), LDB, - $ YA(K+I,NB1), LDYA, ONE, A(I+1,K+I), 1 ) -C -C Apply rotation to [ A(i+1:n,k+i)'; Q(i,i+1:n) ]. -C - CALL DROT( N-I, A(I+1,K+I), 1, Q(I,I+1), LDQ, C, S ) -C -C Update XQ with second Householder reflection. -C - CALL DGEMV( 'Transpose', N-I+1, N-I, ONE, Q(I,I+1), LDQ, - $ A(I,K+I), LDA, ZERO, XQ(I+1,I+NB), 1 ) - CALL DGEMV( 'Transpose', N-I, I, ONE, Q(I+1,1), LDQ, - $ A(I,K+I+1), LDA, ZERO, DWORK(NB2+1), 1 ) - CALL DGEMV( 'No transpose', N-I, I, ONE, XQ(I+1,1), LDXQ, - $ DWORK(NB2+1), 1, ONE, XQ(I+1,I+NB), 1 ) - CALL DGEMV( 'No transpose', I-1, N-I, ONE, A(1,K+I+1), LDA, - $ A(I,K+I+1), LDA, ZERO, DWORK(NB3+1), 1 ) - CALL DGEMV( 'No transpose', N-I, I-1, ONE, XQ(I+1,NB1), - $ LDXQ, DWORK(NB3+1), 1, ONE, XQ(I+1,I+NB), 1 ) - CALL DGEMV( 'Transpose', N-I, I-1, ONE, YQ(I+1,1), LDYQ, - $ A(I,K+I+1), LDA, ZERO, XQ(1,I+NB), 1 ) - CALL DGEMV( 'Transpose', I-1, N-I, ONE, Q(1,I+1), LDQ, - $ XQ(1,I+NB), 1, ONE, XQ(I+1,I+NB), 1 ) - CALL DGEMV( 'Transpose', N-I, I-1, ONE, YQ(I+1,NB1), LDYQ, - $ A(I,K+I+1), LDA, ZERO, XQ(1,I+NB), 1 ) - CALL DGEMV( 'Transpose', I-1, N-I, ONE, B(1,K+I+1), LDB, - $ XQ(1,I+NB), 1, ONE, XQ(I+1,I+NB), 1 ) - CALL DSCAL( N-I, -TAUL(I), XQ(I+1,I+NB), 1 ) -C -C Update Q(i,i+1:n). -C - CALL DAXPY( N-I, ONE, XQ(I+1,I+NB), 1, Q(I,I+1), LDQ ) -C -C Update XA with second Householder reflection. -C - CALL DGEMV( 'No transpose', N-I, N-I+1, ONE, A(I+1,K+I), - $ LDA, A(I,K+I), LDA, ZERO, XA(I+1,I+NB), 1 ) - CALL DGEMV( 'No transpose', N-I, I, ONE, XA(I+1,1), LDXA, - $ DWORK(NB2+1), 1, ONE, XA(I+1,I+NB), 1 ) - CALL DGEMV( 'No transpose', N-I, I-1, ONE, XA(I+1,NB1), - $ LDXA, DWORK(NB3+1), 1, ONE, XA(I+1,I+NB), 1 ) - CALL DGEMV( 'Transpose', N-I, I-1, ONE, YA(K+I+1,1), LDYA, - $ A(I,K+I+1), LDA, ZERO, XA(1,I+NB), 1 ) - CALL DGEMV( 'Transpose', I-1, N-I, ONE, Q(1,I+1), LDQ, - $ XA(1,I+NB), 1, ONE, XA(I+1,I+NB), 1 ) - CALL DGEMV( 'Transpose', N-I, I-1, ONE, YA(K+I+1,NB1), LDYA, - $ A(I,K+I+1), LDA, ZERO, XA(1,I+NB), 1 ) - CALL DGEMV( 'Transpose', I-1, N-I, ONE, B(1,K+I+1), LDB, - $ XA(1,I+NB), 1, ONE, XA(I+1,I+NB), 1 ) - CALL DSCAL( N-I, -TAUL(I), XA(I+1,I+NB), 1 ) -C -C Update A(i+1:n,k+i). -C - CALL DAXPY( N-I, ONE, XA(I+1,I+NB), 1, A(I+1,K+I), 1 ) -C -C Update XG with first Householder reflection. -C - CALL DGEMV( 'Transpose', N-I+1, K+N, ONE, G(K+I,1), LDG, - $ Q(I,I), 1, ZERO, XG(1,I), 1 ) - CALL DGEMV( 'No transpose', K+N, I-1, ONE, XG, LDXG, - $ DWORK, 1, ONE, XG(1,I), 1 ) - CALL DGEMV( 'No transpose', K+N, I-1, ONE, XG(1,NB1), - $ LDXG, DWORK(NB+1), 1, ONE, XG(1,I), 1 ) - CALL DGEMV( 'Transpose', N-I+1, I-1, ONE, YG(K+I,1), LDYG, - $ Q(I,I), 1, ZERO, DWORK(PDW), 1 ) - CALL DGEMV( 'Transpose', I-1, N-I, ONE, Q(1,I+1), LDQ, - $ DWORK(PDW), 1, ONE, XG(K+I+1,I), 1 ) - CALL DGEMV( 'Transpose', N-I+1, I-1, ONE, YG(K+I,NB1), LDYG, - $ Q(I,I), 1, ZERO, DWORK(PDW), 1 ) - CALL DGEMV( 'Transpose', I-1, N-I, ONE, B(1,K+I+1), LDB, - $ DWORK(PDW), 1, ONE, XG(K+I+1,I), 1 ) - CALL DSCAL( K+N, -TAUQ, XG(1,I), 1 ) -C -C Update G(k+i,:). -C - CALL DGEMV( 'No transpose', K+N, I, ONE, XG, LDXG, - $ Q(I,1), LDQ, ONE, G(K+I,1), LDG ) - CALL DGEMV( 'No transpose', K+N, I-1, ONE, XG(1,NB1), - $ LDXG, A(1,K+I), 1, ONE, G(K+I,1), LDG ) - CALL DGEMV( 'Transpose', I-1, N-I, ONE, Q(1,I+1), LDQ, - $ YG(K+I,1), LDYG, ONE, G(K+I,K+I+1), LDG ) - CALL DGEMV( 'Transpose', I-1, N-I, ONE, B(1,K+I+1), LDB, - $ YG(K+I,NB1), LDYG, ONE, G(K+I,K+I+1), LDG ) -C -C Update XB with first Householder reflection. -C - CALL DGEMV( 'Transpose', N-I+1, K+N, ONE, B(I,1), LDB, - $ Q(I,I), 1, ZERO, XB(1,I), 1 ) - CALL DGEMV( 'No transpose', K+N, I-1, ONE, XB, LDXB, - $ DWORK, 1, ONE, XB(1,I), 1 ) - CALL DGEMV( 'No transpose', K+N, I-1, ONE, XB(1,NB1), - $ LDXB, DWORK(NB+1), 1, ONE, XB(1,I), 1 ) - CALL DGEMV( 'Transpose', N-I+1, I-1, ONE, YB(I,1), LDYB, - $ Q(I,I), 1, ZERO, DWORK(PDW), 1 ) - CALL DGEMV( 'Transpose', I-1, N-I, ONE, Q(1,I+1), LDQ, - $ DWORK(PDW), 1, ONE, XB(K+I+1,I), 1 ) - CALL DGEMV( 'Transpose', N-I+1, I-1, ONE, YB(I,NB1), LDYB, - $ Q(I,I), 1, ZERO, DWORK(PDW), 1 ) - CALL DGEMV( 'Transpose', I-1, N-I, ONE, B(1,K+I+1), LDB, - $ DWORK(PDW), 1, ONE, XB(K+I+1,I), 1 ) - CALL DSCAL( K+N, -TAUQ, XB(1,I), 1 ) -C -C Update B(i,:). -C - CALL DGEMV( 'No transpose', K+N, I, ONE, XB, LDXB, - $ Q(I,1), LDQ, ONE, B(I,1), LDB ) - CALL DGEMV( 'No transpose', K+N, I-1, ONE, XB(1,NB1), - $ LDXB, A(1,K+I), 1, ONE, B(I,1), LDB ) - CALL DGEMV( 'Transpose', I-1, N-I, ONE, Q(1,I+1), LDQ, - $ YB(I,1), LDYB, ONE, B(I,K+I+1), LDB ) - CALL DGEMV( 'Transpose', I-1, N-I, ONE, B(1,K+I+1), LDB, - $ YB(I,NB1), LDYB, ONE, B(I,K+I+1), LDB ) -C -C Apply rotation to [ G(k+i,:); B(i,:) ]. -C - CALL DROT( K+N, G(K+I,1), LDG, B(I,1), LDB, C, S ) -C - DO 100 J = 1, I-1 - YG(K+I,J) = ZERO - 100 CONTINUE - DO 110 J = 1, I-1 - YG(K+I,NB+J) = ZERO - 110 CONTINUE - DO 120 J = 1, I-1 - YA(K+I,J) = ZERO - 120 CONTINUE - DO 130 J = 1, I-1 - YA(K+I,NB+J) = ZERO - 130 CONTINUE -C -C Update XG with second Householder reflection. -C - CALL DGEMV( 'Transpose', N-I+1, K+N, ONE, G(K+I,1), LDG, - $ A(I,K+I), LDA, ZERO, XG(1,I+NB), 1 ) - CALL DGEMV( 'No transpose', K+N, I, ONE, XG, LDXG, - $ DWORK(NB2+1), 1, ONE, XG(1,I+NB), 1 ) - CALL DGEMV( 'No transpose', K+N, I-1, ONE, XG(1,NB1), - $ LDXG, DWORK(NB3+1), 1, ONE, XG(1,I+NB), 1 ) - CALL DGEMV( 'Transpose', N-I, I-1, ONE, YG(K+I+1,1), LDYG, - $ A(I,K+I+1), LDA, ZERO, DWORK(PDW), 1 ) - CALL DGEMV( 'Transpose', I-1, N-I, ONE, Q(1,I+1), LDQ, - $ DWORK(PDW), 1, ONE, XG(K+I+1,I+NB), 1 ) - CALL DGEMV( 'Transpose', N-I, I-1, ONE, YG(K+I+1,NB1), LDYG, - $ A(I,K+I+1), LDA, ZERO, DWORK(PDW), 1 ) - CALL DGEMV( 'Transpose', I-1, N-I, ONE, B(1,K+I+1), LDB, - $ DWORK(PDW), 1, ONE, XG(K+I+1,I+NB), 1 ) - CALL DSCAL( K+N, -TAUL(I), XG(1,I+NB), 1 ) -C -C Update G(k+i,:). -C - CALL DAXPY( K+N, ONE, XG(1,I+NB), 1, G(K+I,1), LDG ) -C -C Update XB with second Householder reflection. -C - CALL DGEMV( 'Transpose', N-I+1, K+N, ONE, B(I,1), LDB, - $ A(I,K+I), LDA, ZERO, XB(1,I+NB), 1 ) - CALL DGEMV( 'No transpose', K+N, I, ONE, XB, LDXB, - $ DWORK(NB2+1), 1, ONE, XB(1,I+NB), 1 ) - CALL DGEMV( 'No transpose', K+N, I-1, ONE, XB(1,NB1), - $ LDXB, DWORK(NB3+1), 1, ONE, XB(1,I+NB), 1 ) - CALL DGEMV( 'Transpose', N-I, I-1, ONE, YB(I+1,1), LDYB, - $ A(I,K+I+1), LDA, ZERO, DWORK(PDW), 1 ) - CALL DGEMV( 'Transpose', I-1, N-I, ONE, Q(1,I+1), LDQ, - $ DWORK(PDW), 1, ONE, XB(K+I+1,I+NB), 1 ) - CALL DGEMV( 'Transpose', N-I, I-1, ONE, YB(I+1,NB1), LDYB, - $ A(I,K+I+1), LDA, ZERO, DWORK(PDW), 1 ) - CALL DGEMV( 'Transpose', I-1, N-I, ONE, B(1,K+I+1), LDB, - $ DWORK(PDW), 1, ONE, XB(K+I+1,I+NB), 1 ) - CALL DSCAL( K+N, -TAUL(I), XB(1,I+NB), 1 ) -C -C Update B(i,:). -C - CALL DAXPY( K+N, ONE, XB(1,I+NB), 1, B(I,1), LDB ) -C - A(I,K+I) = TEMP - Q(I,I) = TAUQ - CSL(2*I-1) = C - CSL(2*I) = S -C -C Transform first rows of Q and B. -C - ALPHA = Q(I,I+1) - CALL DLARFG( N-I, ALPHA, Q(I,I+2), LDQ, TAUQ ) - Q(I,I+1) = ONE - TEMP = -TAUQ*DDOT( N-I, Q(I,I+1), LDQ, B(I,K+I+1), LDB ) - CALL DAXPY( N-I, TEMP, Q(I,I+1), LDQ, B(I,K+I+1), LDB ) - TEMP = B(I,K+I+1) - CALL DLARTG( TEMP, ALPHA, C, S, B(I,K+I+1) ) - S = -S - CALL DLARFG( N-I, B(I,K+I+1), B(I,K+I+2), LDB, TAUR(I) ) - TEMP = B(I,K+I+1) - B(I,K+I+1) = ONE -C -C Update YB with first Householder reflection. -C - CALL DGEMV( 'No transpose', N-I, N-I, ONE, B(I+1,K+I+1), - $ LDB, Q(I,I+1), LDQ, ZERO, YB(I+1,I), 1 ) - CALL DGEMV( 'Transpose', N-I, I, ONE, XB(K+I+1,1), LDXB, - $ Q(I,I+1), LDQ, ZERO, YB(1,I), 1 ) - CALL DGEMV( 'No transpose', N-I, I, ONE, Q(I+1,1), LDQ, - $ YB(1,I), 1, ONE, YB(I+1,I), 1 ) - CALL DGEMV( 'Transpose', N-I, I, ONE, XB(K+I+1,NB1), LDXB, - $ Q(I,I+1), LDQ, ZERO, YB(1,I), 1 ) - CALL DGEMV( 'Transpose', I, N-I, ONE, A(1,K+I+1), LDA, - $ YB(1,I), 1, ONE, YB(I+1,I), 1 ) - CALL DGEMV( 'No transpose', I-1, N-I, ONE, Q(1,I+1), LDQ, - $ Q(I,I+1), LDQ, ZERO, DWORK, 1 ) - CALL DGEMV( 'No transpose', N-I, I-1, ONE, YB(I+1,1), LDYB, - $ DWORK, 1, ONE, YB(I+1,I), 1 ) - CALL DGEMV( 'No transpose', I-1, N-I, ONE, B(1,K+I+1), LDB, - $ Q(I,I+1), LDQ, ZERO, DWORK(NB+1), 1 ) - CALL DGEMV( 'No transpose', N-I, I-1, ONE, YB(I+1,NB1), - $ LDYB, DWORK(NB+1), 1, ONE, YB(I+1,I), 1 ) - CALL DSCAL( N-I, -TAUQ, YB(I+1,I), 1 ) -C -C Update B(i+1:n,k+i+1). -C - CALL DGEMV( 'No transpose', N-I, I, ONE, Q(I+1,1), LDQ, - $ XB(K+I+1,1), LDXB, ONE, B(I+1,K+I+1), 1 ) - CALL DGEMV( 'Transpose', I, N-I, ONE, A(1,K+I+1), LDA, - $ XB(K+I+1,NB1), LDXB, ONE, B(I+1,K+I+1), 1 ) - CALL DGEMV( 'No transpose', N-I, I, ONE, YB(I+1,1), LDYB, - $ Q(1,I+1), 1, ONE, B(I+1,K+I+1), 1 ) - CALL DGEMV( 'No transpose', N-I, I-1, ONE, YB(I+1,NB1), - $ LDYB, B(1,K+I+1), 1, ONE, B(I+1,K+I+1), 1 ) -C -C Update YQ with first Householder reflection. -C - CALL DGEMV( 'No transpose', N-I, N-I, ONE, Q(I+1,I+1), LDQ, - $ Q(I,I+1), LDQ, ZERO, YQ(I+1,I), 1 ) - CALL DGEMV( 'Transpose', N-I, I, ONE, XQ(I+1,1), LDXQ, - $ Q(I,I+1), LDQ, ZERO, YQ(1,I), 1 ) - CALL DGEMV( 'No transpose', N-I, I, ONE, Q(I+1,1), LDQ, - $ YQ(1,I), 1, ONE, YQ(I+1,I), 1 ) - CALL DGEMV( 'Transpose', N-I, I, ONE, XQ(I+1,NB1), LDXQ, - $ Q(I,I+1), LDQ, ZERO, YQ(1,I), 1 ) - CALL DGEMV( 'Transpose', I, N-I, ONE, A(1,K+I+1), LDA, - $ YQ(1,I), 1, ONE, YQ(I+1,I), 1 ) - CALL DGEMV( 'No transpose', N-I, I-1, ONE, YQ(I+1,1), LDYQ, - $ DWORK, 1, ONE, YQ(I+1,I), 1 ) - CALL DGEMV( 'No transpose', N-I, I-1, ONE, YQ(I+1,NB1), - $ LDYQ, DWORK(NB+1), 1, ONE, YQ(I+1,I), 1 ) - CALL DSCAL( N-I, -TAUQ, YQ(I+1,I), 1 ) -C -C Update Q(i+1:n,i+1). -C - CALL DGEMV( 'No transpose', N-I, I, ONE, Q(I+1,1), LDQ, - $ XQ(I+1,1), LDXQ, ONE, Q(I+1,I+1), 1 ) - CALL DGEMV( 'Transpose', I, N-I, ONE, A(1,K+I+1), LDA, - $ XQ(I+1,NB1), LDXQ, ONE, Q(I+1,I+1), 1 ) - CALL DGEMV( 'No transpose', N-I, I, ONE, YQ(I+1,1), LDYQ, - $ Q(1,I+1), 1, ONE, Q(I+1,I+1), 1 ) - CALL DGEMV( 'No transpose', N-I, I-1, ONE, YQ(I+1,NB1), - $ LDYQ, B(1,K+I+1), 1, ONE, Q(I+1,I+1), 1 ) -C -C Apply rotation to [ Q(i+1:n,i+1), B(i+1:n,k+i+1) ]. -C - CALL DROT( N-I, Q(I+1,I+1), 1, B(I+1,K+I+1), 1, C, S ) - DO 140 J = 1, I - XB(K+I+1,J) = ZERO - 140 CONTINUE - DO 150 J = 1, I - XB(K+I+1,NB+J) = ZERO - 150 CONTINUE -C -C Update YB with second Householder reflection. -C - CALL DGEMV( 'No transpose', N-I, N-I, ONE, B(I+1,K+I+1), - $ LDB, B(I,K+I+1), LDB, ZERO, YB(I+1,I+NB), 1 ) - CALL DGEMV( 'Transpose', N-I-1, I, ONE, XB(K+I+2,1), LDXB, - $ B(I,K+I+2), LDB, ZERO, YB(1,I+NB), 1 ) - CALL DGEMV( 'No transpose', N-I, I, ONE, Q(I+1,1), LDQ, - $ YB(1,I+NB), 1, ONE, YB(I+1,I+NB), 1 ) - CALL DGEMV( 'Transpose', N-I-1, I, ONE, XB(K+I+2,NB1), LDXB, - $ B(I,K+I+2), LDB, ZERO, YB(1,I+NB), 1 ) - CALL DGEMV( 'Transpose', I, N-I, ONE, A(1,K+I+1), LDA, - $ YB(1,I+NB), 1, ONE, YB(I+1,I+NB), 1 ) - CALL DGEMV( 'No transpose', I, N-I-1, ONE, Q(1,I+2), LDQ, - $ B(I,K+I+2), LDB, ZERO, DWORK(NB2+1), 1 ) - CALL DGEMV( 'No transpose', N-I, I, ONE, YB(I+1,1), LDYB, - $ DWORK(NB2+1), 1, ONE, YB(I+1,I+NB), 1 ) - CALL DGEMV( 'No transpose', I-1, N-I-1, ONE, B(1,K+I+2), - $ LDQ, B(I,K+I+2), LDB, ZERO, DWORK(NB3+1), 1 ) - CALL DGEMV( 'No transpose', N-I, I-1, ONE, YB(I+1,NB1), - $ LDYB, DWORK(NB3+1), 1, ONE, YB(I+1,I+NB), 1 ) - CALL DSCAL( N-I, -TAUR(I), YB(I+1,I+NB), 1 ) -C -C Update B(i+1:n,k+i+1). -C - CALL DAXPY( N-I, ONE, YB(I+1,I+NB), 1, B(I+1,K+I+1), 1 ) -C -C Update YQ with second Householder reflection. -C - CALL DGEMV( 'No transpose', N-I, N-I, ONE, Q(I+1,I+1), LDQ, - $ B(I,K+I+1), LDB, ZERO, YQ(I+1,I+NB), 1 ) - CALL DGEMV( 'Transpose', N-I-1, I, ONE, XQ(I+2,1), LDXQ, - $ B(I,K+I+2), LDB, ZERO, YQ(1,I+NB), 1 ) - CALL DGEMV( 'No transpose', N-I, I, ONE, Q(I+1,1), LDQ, - $ YQ(1,I+NB), 1, ONE, YQ(I+1,I+NB), 1 ) - CALL DGEMV( 'Transpose', N-I-1, I, ONE, XQ(I+2,NB1), LDXQ, - $ B(I,K+I+2), LDB, ZERO, YQ(1,I+NB), 1 ) - CALL DGEMV( 'Transpose', I, N-I, ONE, A(1,K+I+1), LDA, - $ YQ(1,I+NB), 1, ONE, YQ(I+1,I+NB), 1 ) - CALL DGEMV( 'No transpose', N-I, I, ONE, YQ(I+1,1), LDYQ, - $ DWORK(NB2+1), 1, ONE, YQ(I+1,I+NB), 1 ) - CALL DGEMV( 'No transpose', N-I, I-1, ONE, YQ(I+1,NB1), - $ LDYQ, DWORK(NB3+1), 1, ONE, YQ(I+1,I+NB), 1 ) - CALL DSCAL( N-I, -TAUR(I), YQ(I+1,I+NB), 1 ) -C -C Update Q(i+1:n,i+1). -C - CALL DAXPY( N-I, ONE, YQ(I+1,I+NB), 1, Q(I+1,I+1), 1 ) -C -C Update YA with first Householder reflection. -C - CALL DGEMV( 'Transpose', N-I, K+N, ONE, A(I+1,1), LDA, - $ Q(I,I+1), LDQ, ZERO, YA(1,I), 1 ) - CALL DGEMV( 'Transpose', N-I, I, ONE, XA(I+1,1), LDXA, - $ Q(I,I+1), LDQ, ZERO, DWORK(PDW), 1 ) - CALL DGEMV( 'No transpose', N-I, I, ONE, Q(I+1,1), LDQ, - $ DWORK(PDW), 1, ONE, YA(K+I+1,I), 1 ) - CALL DGEMV( 'Transpose', N-I, I, ONE, XA(I+1,NB1), LDXA, - $ Q(I,I+1), LDQ, ZERO, DWORK(PDW), 1 ) - CALL DGEMV( 'Transpose', I, N-I, ONE, A(1,K+I+1), LDA, - $ DWORK(PDW), 1, ONE, YA(K+I+1,I), 1 ) - CALL DGEMV( 'No transpose', K+N, I-1, ONE, YA, LDYA, - $ DWORK, 1, ONE, YA(1,I), 1 ) - CALL DGEMV( 'No transpose', K+N, I-1, ONE, YA(1,NB1), LDYA, - $ DWORK(NB+1), 1, ONE, YA(1,I), 1 ) - CALL DSCAL( K+N, -TAUQ, YA(1,I), 1 ) -C -C Update A(i+1,1:k+n). -C - CALL DGEMV( 'No transpose', N-I, I, ONE, Q(I+1,1), LDQ, - $ XA(I+1,1), LDXA, ONE, A(I+1,K+I+1), LDA ) - CALL DGEMV( 'Transpose', I, N-I, ONE, A(1,K+I+1), LDA, - $ XA(I+1,NB1), LDXA, ONE, A(I+1,K+I+1), LDA ) - CALL DGEMV( 'No transpose', K+N, I, ONE, YA, LDYA, - $ Q(1,I+1), 1, ONE, A(I+1,1), LDA ) - CALL DGEMV( 'No transpose', K+N, I-1, ONE, YA(1,NB1), LDYA, - $ B(1,K+I+1), 1, ONE, A(I+1,1), LDA ) -C -C Update YG with first Householder reflection. -C - CALL DGEMV( 'No transpose', K+N, N-I, ONE, G(1,K+I+1), LDG, - $ Q(I,I+1), LDQ, ZERO, YG(1,I), 1 ) - CALL DGEMV( 'Transpose', N-I, I, ONE, XG(K+I+1,1), LDXG, - $ Q(I,I+1), LDQ, ZERO, DWORK(PDW), 1 ) - CALL DGEMV( 'No transpose', N-I, I, ONE, Q(I+1,1), LDQ, - $ DWORK(PDW), 1, ONE, YG(K+I+1,I), 1 ) - CALL DGEMV( 'Transpose', N-I, I, ONE, XG(K+I+1,NB1), LDXG, - $ Q(I,I+1), LDQ, ZERO, DWORK(PDW), 1 ) - CALL DGEMV( 'Transpose', I, N-I, ONE, A(1,K+I+1), LDA, - $ DWORK(PDW), 1, ONE, YG(K+I+1,I), 1 ) - CALL DGEMV( 'No transpose', K+N, I-1, ONE, YG, LDYG, - $ DWORK, 1, ONE, YG(1,I), 1 ) - CALL DGEMV( 'No transpose', K+N, I-1, ONE, YG(1,NB1), LDYG, - $ DWORK(NB+1), 1, ONE, YG(1,I), 1 ) - CALL DSCAL( K+N, -TAUQ, YG(1,I), 1 ) -C -C Update G(1:k+n,k+i+1). -C - CALL DGEMV( 'No transpose', N-I, I, ONE, Q(I+1,1), LDQ, - $ XG(K+I+1,1), LDXG, ONE, G(K+I+1,K+I+1), 1 ) - CALL DGEMV( 'Transpose', I, N-I, ONE, A(1,K+I+1), LDA, - $ XG(K+I+1,NB1), LDXG, ONE, G(K+I+1,K+I+1), 1 ) - CALL DGEMV( 'No transpose', K+N, I, ONE, YG, LDYG, - $ Q(1,I+1), 1, ONE, G(1,K+I+1), 1 ) - CALL DGEMV( 'No transpose', K+N, I-1, ONE, YG(1,NB1), LDYG, - $ B(1,K+I+1), 1, ONE, G(1,K+I+1), 1 ) - DO 160 J = 1, I - XG(K+I+1,J) = ZERO - 160 CONTINUE - DO 170 J = 1, I - XG(K+I+1,NB+J) = ZERO - 170 CONTINUE -C -C Apply rotation to [ A(i+1,1:k+n)', G(1:k+n,k+i+1) ]. -C - CALL DROT( K+N, A(I+1,1), LDA, G(1,K+I+1), 1, C, S ) -C -C Update YA with second Householder reflection. -C - CALL DGEMV( 'Transpose', N-I, K+N, ONE, A(I+1,1), LDA, - $ B(I,K+I+1), LDB, ZERO, YA(1,I+NB), 1 ) - CALL DGEMV( 'Transpose', N-I-1, I, ONE, XA(I+2,1), LDXA, - $ B(I,K+I+2), LDB, ZERO, DWORK(PDW), 1 ) - CALL DGEMV( 'No transpose', N-I, I, ONE, Q(I+1,1), LDQ, - $ DWORK(PDW), 1, ONE, YA(K+I+1,I+NB), 1 ) - CALL DGEMV( 'Transpose', N-I-1, I, ONE, XA(I+2,NB1), LDXA, - $ B(I,K+I+2), LDB, ZERO, DWORK(PDW), 1 ) - CALL DGEMV( 'Transpose', I, N-I, ONE, A(1,K+I+1), LDA, - $ DWORK(PDW), 1, ONE, YA(K+I+1,I+NB), 1 ) - CALL DGEMV( 'No transpose', K+N, I, ONE, YA, LDYA, - $ DWORK(NB2+1), 1, ONE, YA(1,I+NB), 1 ) - CALL DGEMV( 'No transpose', K+N, I-1, ONE, YA(1,NB1), LDYA, - $ DWORK(NB3+1), 1, ONE, YA(1,I+NB), 1 ) - CALL DSCAL( K+N, -TAUR(I), YA(1,I+NB), 1 ) -C -C Update A(i+1,1:k+n). -C - CALL DAXPY( K+N, ONE, YA(1,I+NB), 1, A(I+1,1), LDA ) -C -C Update YG with second Householder reflection. -C - CALL DGEMV( 'No transpose', K+N, N-I, ONE, G(1,K+I+1), LDG, - $ B(I,K+I+1), LDB, ZERO, YG(1,I+NB), 1 ) - CALL DGEMV( 'Transpose', N-I-1, I, ONE, XG(K+I+2,1), LDXG, - $ B(I,K+I+2), LDB, ZERO, DWORK(PDW), 1 ) - CALL DGEMV( 'No transpose', N-I, I, ONE, Q(I+1,1), LDQ, - $ DWORK(PDW), 1, ONE, YG(K+I+1,I+NB), 1 ) - CALL DGEMV( 'Transpose', N-I-1, I, ONE, XG(K+I+2,NB1), LDXG, - $ B(I,K+I+2), LDB, ZERO, DWORK(PDW), 1 ) - CALL DGEMV( 'Transpose', I, N-I, ONE, A(1,K+I+1), LDA, - $ DWORK(PDW), 1, ONE, YG(K+I+1,I+NB), 1 ) - CALL DGEMV( 'No transpose', K+N, I, ONE, YG, LDYG, - $ DWORK(NB2+1), 1, ONE, YG(1,I+NB), 1 ) - CALL DGEMV( 'No transpose', K+N, I-1, ONE, YG(1,NB1), LDYG, - $ DWORK(NB3+1), 1, ONE, YG(1,I+NB), 1 ) - CALL DSCAL( K+N, -TAUR(I), YG(1,I+NB), 1 ) -C -C Update G(1:k+n,k+i+1). -C - CALL DAXPY( K+N, ONE, YG(1,I+NB), 1, G(1,K+I+1), 1 ) -C - B(I,K+I+1) = TEMP - Q(I,I+1) = TAUQ - CSR(2*I-1) = C - CSR(2*I) = S - 180 CONTINUE -C - ELSE IF ( LTRB ) THEN - DO 270 I = 1, NB -C -C Transform first columns of A and Q. See routine MB04TS. -C - ALPHA = Q(I,I) - CALL DLARFG( N-I+1, ALPHA, Q(I+1,I), 1, TAUQ ) - Q(I,I) = ONE - TEMP = -TAUQ*DDOT( N-I+1, Q(I,I), 1, A(K+I,I), 1 ) - CALL DAXPY( N-I+1, TEMP, Q(I,I), 1, A(K+I,I), 1 ) - TEMP = A(K+I,I) - CALL DLARTG( TEMP, ALPHA, C, S, A(K+I,I) ) - CALL DLARFG( N-I+1, A(K+I,I), A(K+I+1,I), 1, TAUL(I) ) - TEMP = A(K+I,I) - A(K+I,I) = ONE -C -C Update XQ with first Householder reflection. -C - CALL DGEMV( 'Transpose', N-I+1, N-I, ONE, Q(I,I+1), LDQ, - $ Q(I,I), 1, ZERO, XQ(I+1,I), 1 ) - CALL DGEMV( 'Transpose', N-I+1, I-1, ONE, Q(I,1), LDQ, - $ Q(I,I), 1, ZERO, DWORK, 1 ) - CALL DGEMV( 'No transpose', N-I, I-1, ONE, XQ(I+1,1), LDXQ, - $ DWORK, 1, ONE, XQ(I+1,I), 1 ) - CALL DGEMV( 'Transpose', N-I+1, I-1, ONE, A(K+I,1), LDA, - $ Q(I,I), 1, ZERO, DWORK(NB+1), 1 ) - CALL DGEMV( 'No transpose', N-I, I-1, ONE, XQ(I+1,NB1), - $ LDXQ, DWORK(NB+1), 1, ONE, XQ(I+1,I), 1 ) - CALL DGEMV( 'Transpose', N-I+1, I-1, ONE, YQ(I,1), LDYQ, - $ Q(I,I), 1, ZERO, XQ(1,I), 1 ) - CALL DGEMV( 'Transpose', I-1, N-I, ONE, Q(1,I+1), LDQ, - $ XQ(1,I), 1, ONE, XQ(I+1,I), 1 ) - CALL DGEMV( 'Transpose', N-I+1, I-1, ONE, YQ(I,NB1), LDYQ, - $ Q(I,I), 1, ZERO, XQ(1,I+NB), 1 ) - CALL DGEMV( 'No Transpose', N-I, I-1, ONE, B(K+I+1,1), LDB, - $ XQ(1,I+NB), 1, ONE, XQ(I+1,I), 1 ) - CALL DSCAL( N-I, -TAUQ, XQ(I+1,I), 1 ) -C -C Update Q(i,i+1:n). -C - CALL DGEMV( 'No transpose', N-I, I, ONE, XQ(I+1,1), LDXQ, - $ Q(I,1), LDQ, ONE, Q(I,I+1), LDQ ) - CALL DGEMV( 'No transpose', N-I, I-1, ONE, XQ(I+1,NB1), - $ LDXQ, A(K+I,1), LDA, ONE, Q(I,I+1), LDQ ) - CALL DGEMV( 'Transpose', I-1, N-I, ONE, Q(1,I+1), LDQ, - $ YQ(I,1), LDYQ, ONE, Q(I,I+1), LDQ ) - CALL DGEMV( 'No Transpose', N-I, I-1, ONE, B(K+I+1,1), LDB, - $ YQ(I,NB1), LDYQ, ONE, Q(I,I+1), LDQ ) -C -C Update XA with first Householder reflection. -C - CALL DGEMV( 'Transpose', N-I+1, N-I, ONE, A(K+I,I+1), LDA, - $ Q(I,I), 1, ZERO, XA(I+1,I), 1 ) - CALL DGEMV( 'No transpose', N-I, I-1, ONE, XA(I+1,1), LDXA, - $ DWORK, 1, ONE, XA(I+1,I), 1 ) - CALL DGEMV( 'No transpose', N-I, I-1, ONE, XA(I+1,NB1), - $ LDXA, DWORK(NB+1), 1, ONE, XA(I+1,I), 1 ) - CALL DGEMV( 'Transpose', N-I+1, I-1, ONE, YA(K+I,1), LDYA, - $ Q(I,I), 1, ZERO, XA(1,I), 1 ) - CALL DGEMV( 'Transpose', I-1, N-I, ONE, Q(1,I+1), LDQ, - $ XA(1,I), 1, ONE, XA(I+1,I), 1 ) - CALL DGEMV( 'Transpose', N-I+1, I-1, ONE, YA(K+I,NB1), LDYA, - $ Q(I,I), 1, ZERO, XA(1,I), 1 ) - CALL DGEMV( 'No Transpose', N-I, I-1, ONE, B(K+I+1,1), LDB, - $ XA(1,I), 1, ONE, XA(I+1,I), 1 ) - CALL DSCAL( N-I, -TAUQ, XA(I+1,I), 1 ) -C -C Update A(k+i,i+1:n). -C - CALL DGEMV( 'No transpose', N-I, I, ONE, XA(I+1,1), LDXA, - $ Q(I,1), LDQ, ONE, A(K+I,I+1), LDA ) - CALL DGEMV( 'No transpose', N-I, I-1, ONE, XA(I+1,NB1), - $ LDXA, A(K+I,1), LDA, ONE, A(K+I,I+1), LDA ) - CALL DGEMV( 'Transpose', I-1, N-I, ONE, Q(1,I+1), LDQ, - $ YA(K+I,1), LDYA, ONE, A(K+I,I+1), LDA ) - CALL DGEMV( 'No Transpose', N-I, I-1, ONE, B(K+I+1,1), LDB, - $ YA(K+I,NB1), LDYA, ONE, A(K+I,I+1), LDA ) -C -C Apply rotation to [ A(k+i,i+1:n); Q(i,i+1:n) ]. -C - CALL DROT( N-I, A(K+I,I+1), LDA, Q(I,I+1), LDQ, C, S ) -C -C Update XQ with second Householder reflection. -C - CALL DGEMV( 'Transpose', N-I+1, N-I, ONE, Q(I,I+1), LDQ, - $ A(K+I,I), 1, ZERO, XQ(I+1,I+NB), 1 ) - CALL DGEMV( 'Transpose', N-I, I, ONE, Q(I+1,1), LDQ, - $ A(K+I+1,I), 1, ZERO, DWORK(NB2+1), 1 ) - CALL DGEMV( 'No transpose', N-I, I, ONE, XQ(I+1,1), LDXQ, - $ DWORK(NB2+1), 1, ONE, XQ(I+1,I+NB), 1 ) - CALL DGEMV( 'Transpose', N-I, I-1, ONE, A(K+I+1,1), LDA, - $ A(K+I+1,I), 1, ZERO, DWORK(NB3+1), 1 ) - CALL DGEMV( 'No transpose', N-I, I-1, ONE, XQ(I+1,NB1), - $ LDXQ, DWORK(NB3+1), 1, ONE, XQ(I+1,I+NB), 1 ) - CALL DGEMV( 'Transpose', N-I, I-1, ONE, YQ(I+1,1), LDYQ, - $ A(K+I+1,I), 1, ZERO, XQ(1,I+NB), 1 ) - CALL DGEMV( 'Transpose', I-1, N-I, ONE, Q(1,I+1), LDQ, - $ XQ(1,I+NB), 1, ONE, XQ(I+1,I+NB), 1 ) - CALL DGEMV( 'Transpose', N-I, I-1, ONE, YQ(I+1,NB1), LDYQ, - $ A(K+I+1,I), 1, ZERO, XQ(1,I+NB), 1 ) - CALL DGEMV( 'No Transpose', N-I, I-1, ONE, B(K+I+1,1), LDB, - $ XQ(1,I+NB), 1, ONE, XQ(I+1,I+NB), 1 ) - CALL DSCAL( N-I, -TAUL(I), XQ(I+1,I+NB), 1 ) -C -C Update Q(i,i+1:n). -C - CALL DAXPY( N-I, ONE, XQ(I+1,I+NB), 1, Q(I,I+1), LDQ ) -C -C Update XA with second Householder reflection. -C - CALL DGEMV( 'Transpose', N-I+1, N-I, ONE, A(K+I,I+1), LDA, - $ A(K+I,I), 1, ZERO, XA(I+1,I+NB), 1 ) - CALL DGEMV( 'No transpose', N-I, I, ONE, XA(I+1,1), LDXA, - $ DWORK(NB2+1), 1, ONE, XA(I+1,I+NB), 1 ) - CALL DGEMV( 'No transpose', N-I, I-1, ONE, XA(I+1,NB1), - $ LDXA, DWORK(NB3+1), 1, ONE, XA(I+1,I+NB), 1 ) - CALL DGEMV( 'Transpose', N-I, I-1, ONE, YA(K+I+1,1), LDYA, - $ A(K+I+1,I), 1, ZERO, XA(1,I+NB), 1 ) - CALL DGEMV( 'Transpose', I-1, N-I, ONE, Q(1,I+1), LDQ, - $ XA(1,I+NB), 1, ONE, XA(I+1,I+NB), 1 ) - CALL DGEMV( 'Transpose', N-I, I-1, ONE, YA(K+I+1,NB1), LDYA, - $ A(K+I+1,I), 1, ZERO, XA(1,I+NB), 1 ) - CALL DGEMV( 'No Transpose', N-I, I-1, ONE, B(K+I+1,1), LDB, - $ XA(1,I+NB), 1, ONE, XA(I+1,I+NB), 1 ) - CALL DSCAL( N-I, -TAUL(I), XA(I+1,I+NB), 1 ) -C -C Update A(k+i,i+1:n). -C - CALL DAXPY( N-I, ONE, XA(I+1,I+NB), 1, A(K+I,I+1), LDA ) -C -C Update XG with first Householder reflection. -C - CALL DGEMV( 'Transpose', N-I+1, K+N, ONE, G(K+I,1), LDG, - $ Q(I,I), 1, ZERO, XG(1,I), 1 ) - CALL DGEMV( 'No transpose', K+N, I-1, ONE, XG, LDXG, - $ DWORK, 1, ONE, XG(1,I), 1 ) - CALL DGEMV( 'No transpose', K+N, I-1, ONE, XG(1,NB1), - $ LDXG, DWORK(NB+1), 1, ONE, XG(1,I), 1 ) - CALL DGEMV( 'Transpose', N-I+1, I-1, ONE, YG(K+I,1), LDYG, - $ Q(I,I), 1, ZERO, DWORK(PDW), 1 ) - CALL DGEMV( 'Transpose', I-1, N-I, ONE, Q(1,I+1), LDQ, - $ DWORK(PDW), 1, ONE, XG(K+I+1,I), 1 ) - CALL DGEMV( 'Transpose', N-I+1, I-1, ONE, YG(K+I,NB1), LDYG, - $ Q(I,I), 1, ZERO, DWORK(PDW), 1 ) - CALL DGEMV( 'No Transpose', N-I, I-1, ONE, B(K+I+1,1), LDB, - $ DWORK(PDW), 1, ONE, XG(K+I+1,I), 1 ) - CALL DSCAL( K+N, -TAUQ, XG(1,I), 1 ) -C -C Update G(k+i,:). -C - CALL DGEMV( 'No transpose', K+N, I, ONE, XG, LDXG, - $ Q(I,1), LDQ, ONE, G(K+I,1), LDG ) - CALL DGEMV( 'No transpose', K+N, I-1, ONE, XG(1,NB1), - $ LDXG, A(K+I,1), LDA, ONE, G(K+I,1), LDG ) - CALL DGEMV( 'Transpose', I-1, N-I, ONE, Q(1,I+1), LDQ, - $ YG(K+I,1), LDYG, ONE, G(K+I,K+I+1), LDG ) - CALL DGEMV( 'No Transpose', N-I, I-1, ONE, B(K+I+1,1), LDB, - $ YG(K+I,NB1), LDYG, ONE, G(K+I,K+I+1), LDG ) -C -C Update XB with first Householder reflection. -C - CALL DGEMV( 'No Transpose', K+N, N-I+1, ONE, B(1,I), LDB, - $ Q(I,I), 1, ZERO, XB(1,I), 1 ) - CALL DGEMV( 'No transpose', K+N, I-1, ONE, XB, LDXB, - $ DWORK, 1, ONE, XB(1,I), 1 ) - CALL DGEMV( 'No transpose', K+N, I-1, ONE, XB(1,NB1), - $ LDXB, DWORK(NB+1), 1, ONE, XB(1,I), 1 ) - CALL DGEMV( 'Transpose', N-I+1, I-1, ONE, YB(I,1), LDYB, - $ Q(I,I), 1, ZERO, DWORK(PDW), 1 ) - CALL DGEMV( 'Transpose', I-1, N-I, ONE, Q(1,I+1), LDQ, - $ DWORK(PDW), 1, ONE, XB(K+I+1,I), 1 ) - CALL DGEMV( 'Transpose', N-I+1, I-1, ONE, YB(I,NB1), LDYB, - $ Q(I,I), 1, ZERO, DWORK(PDW), 1 ) - CALL DGEMV( 'No Transpose', N-I, I-1, ONE, B(K+I+1,1), LDB, - $ DWORK(PDW), 1, ONE, XB(K+I+1,I), 1 ) - CALL DSCAL( K+N, -TAUQ, XB(1,I), 1 ) -C -C Update B(:,i). -C - CALL DGEMV( 'No transpose', K+N, I, ONE, XB, LDXB, - $ Q(I,1), LDQ, ONE, B(1,I), 1 ) - CALL DGEMV( 'No transpose', K+N, I-1, ONE, XB(1,NB1), - $ LDXB, A(K+I,1), LDA, ONE, B(1,I), 1 ) - CALL DGEMV( 'Transpose', I-1, N-I, ONE, Q(1,I+1), LDQ, - $ YB(I,1), LDYB, ONE, B(K+I+1,I), 1 ) - CALL DGEMV( 'No Transpose', N-I, I-1, ONE, B(K+I+1,1), LDB, - $ YB(I,NB1), LDYB, ONE, B(K+I+1,I), 1 ) -C -C Apply rotation to [ G(k+i,:); B(:,i)' ]. -C - CALL DROT( K+N, G(K+I,1), LDG, B(1,I), 1, C, S ) -C - DO 190 J = 1, I-1 - YG(K+I,J) = ZERO - 190 CONTINUE - DO 200 J = 1, I-1 - YG(K+I,NB+J) = ZERO - 200 CONTINUE - DO 210 J = 1, I-1 - YA(K+I,J) = ZERO - 210 CONTINUE - DO 220 J = 1, I-1 - YA(K+I,NB+J) = ZERO - 220 CONTINUE -C -C Update XG with second Householder reflection. -C - CALL DGEMV( 'Transpose', N-I+1, K+N, ONE, G(K+I,1), LDG, - $ A(K+I,I), 1, ZERO, XG(1,I+NB), 1 ) - CALL DGEMV( 'No transpose', K+N, I, ONE, XG, LDXG, - $ DWORK(NB2+1), 1, ONE, XG(1,I+NB), 1 ) - CALL DGEMV( 'No transpose', K+N, I-1, ONE, XG(1,NB1), - $ LDXG, DWORK(NB3+1), 1, ONE, XG(1,I+NB), 1 ) - CALL DGEMV( 'Transpose', N-I, I-1, ONE, YG(K+I+1,1), LDYG, - $ A(K+I+1,I), 1, ZERO, DWORK(PDW), 1 ) - CALL DGEMV( 'Transpose', I-1, N-I, ONE, Q(1,I+1), LDQ, - $ DWORK(PDW), 1, ONE, XG(K+I+1,I+NB), 1 ) - CALL DGEMV( 'Transpose', N-I, I-1, ONE, YG(K+I+1,NB1), LDYG, - $ A(K+I+1,I), 1, ZERO, DWORK(PDW), 1 ) - CALL DGEMV( 'No Transpose', N-I, I-1, ONE, B(K+I+1,1), LDB, - $ DWORK(PDW), 1, ONE, XG(K+I+1,I+NB), 1 ) - CALL DSCAL( K+N, -TAUL(I), XG(1,I+NB), 1 ) -C -C Update G(k+i,:). -C - CALL DAXPY( K+N, ONE, XG(1,I+NB), 1, G(K+I,1), LDG ) -C -C Update XB with second Householder reflection. -C - CALL DGEMV( 'No Transpose', K+N, N-I+1, ONE, B(1,I), LDB, - $ A(K+I,I), 1, ZERO, XB(1,I+NB), 1 ) - CALL DGEMV( 'No transpose', K+N, I, ONE, XB, LDXB, - $ DWORK(NB2+1), 1, ONE, XB(1,I+NB), 1 ) - CALL DGEMV( 'No transpose', K+N, I-1, ONE, XB(1,NB1), - $ LDXB, DWORK(NB3+1), 1, ONE, XB(1,I+NB), 1 ) - CALL DGEMV( 'Transpose', N-I, I-1, ONE, YB(I+1,1), LDYB, - $ A(K+I+1,I), 1, ZERO, DWORK(PDW), 1 ) - CALL DGEMV( 'Transpose', I-1, N-I, ONE, Q(1,I+1), LDQ, - $ DWORK(PDW), 1, ONE, XB(K+I+1,I+NB), 1 ) - CALL DGEMV( 'Transpose', N-I, I-1, ONE, YB(I+1,NB1), LDYB, - $ A(K+I+1,I), 1, ZERO, DWORK(PDW), 1 ) - CALL DGEMV( 'No Transpose', N-I, I-1, ONE, B(K+I+1,1), LDB, - $ DWORK(PDW), 1, ONE, XB(K+I+1,I+NB), 1 ) - CALL DSCAL( K+N, -TAUL(I), XB(1,I+NB), 1 ) -C -C Update B(:,i). -C - CALL DAXPY( K+N, ONE, XB(1,I+NB), 1, B(1,I), 1 ) -C - A(K+I,I) = TEMP - Q(I,I) = TAUQ - CSL(2*I-1) = C - CSL(2*I) = S -C -C Transform first rows of Q and B. -C - ALPHA = Q(I,I+1) - CALL DLARFG( N-I, ALPHA, Q(I,I+2), LDQ, TAUQ ) - Q(I,I+1) = ONE - TEMP = -TAUQ*DDOT( N-I, Q(I,I+1), LDQ, B(K+I+1,I), 1 ) - CALL DAXPY( N-I, TEMP, Q(I,I+1), LDQ, B(K+I+1,I), 1 ) - TEMP = B(K+I+1,I) - CALL DLARTG( TEMP, ALPHA, C, S, B(K+I+1,I) ) - S = -S - CALL DLARFG( N-I, B(K+I+1,I), B(K+I+2,I), 1, TAUR(I) ) - TEMP = B(K+I+1,I) - B(K+I+1,I) = ONE -C -C Update YB with first Householder reflection. -C - CALL DGEMV( 'Transpose', N-I, N-I, ONE, B(K+I+1,I+1), - $ LDB, Q(I,I+1), LDQ, ZERO, YB(I+1,I), 1 ) - CALL DGEMV( 'Transpose', N-I, I, ONE, XB(K+I+1,1), LDXB, - $ Q(I,I+1), LDQ, ZERO, YB(1,I), 1 ) - CALL DGEMV( 'No transpose', N-I, I, ONE, Q(I+1,1), LDQ, - $ YB(1,I), 1, ONE, YB(I+1,I), 1 ) - CALL DGEMV( 'Transpose', N-I, I, ONE, XB(K+I+1,NB1), LDXB, - $ Q(I,I+1), LDQ, ZERO, YB(1,I), 1 ) - CALL DGEMV( 'No transpose', N-I, I, ONE, A(K+I+1,1), LDA, - $ YB(1,I), 1, ONE, YB(I+1,I), 1 ) - CALL DGEMV( 'No transpose', I-1, N-I, ONE, Q(1,I+1), LDQ, - $ Q(I,I+1), LDQ, ZERO, DWORK, 1 ) - CALL DGEMV( 'No transpose', N-I, I-1, ONE, YB(I+1,1), LDYB, - $ DWORK, 1, ONE, YB(I+1,I), 1 ) - CALL DGEMV( 'Transpose', N-I, I-1, ONE, B(K+I+1,1), LDB, - $ Q(I,I+1), LDQ, ZERO, DWORK(NB+1), 1 ) - CALL DGEMV( 'No transpose', N-I, I-1, ONE, YB(I+1,NB1), - $ LDYB, DWORK(NB+1), 1, ONE, YB(I+1,I), 1 ) - CALL DSCAL( N-I, -TAUQ, YB(I+1,I), 1 ) -C -C Update B(k+i+1,i+1:n). -C - CALL DGEMV( 'No transpose', N-I, I, ONE, Q(I+1,1), LDQ, - $ XB(K+I+1,1), LDXB, ONE, B(K+I+1,I+1), LDB ) - CALL DGEMV( 'No transpose', N-I, I, ONE, A(K+I+1,1), LDA, - $ XB(K+I+1,NB1), LDXB, ONE, B(K+I+1,I+1), LDB ) - CALL DGEMV( 'No transpose', N-I, I, ONE, YB(I+1,1), LDYB, - $ Q(1,I+1), 1, ONE, B(K+I+1,I+1), LDB ) - CALL DGEMV( 'No transpose', N-I, I-1, ONE, YB(I+1,NB1), - $ LDYB, B(K+I+1,1), LDB, ONE, B(K+I+1,I+1), LDB ) -C -C Update YQ with first Householder reflection. -C - CALL DGEMV( 'No transpose', N-I, N-I, ONE, Q(I+1,I+1), LDQ, - $ Q(I,I+1), LDQ, ZERO, YQ(I+1,I), 1 ) - CALL DGEMV( 'Transpose', N-I, I, ONE, XQ(I+1,1), LDXQ, - $ Q(I,I+1), LDQ, ZERO, YQ(1,I), 1 ) - CALL DGEMV( 'No transpose', N-I, I, ONE, Q(I+1,1), LDQ, - $ YQ(1,I), 1, ONE, YQ(I+1,I), 1 ) - CALL DGEMV( 'Transpose', N-I, I, ONE, XQ(I+1,NB1), LDXQ, - $ Q(I,I+1), LDQ, ZERO, YQ(1,I), 1 ) - CALL DGEMV( 'No transpose', N-I, I, ONE, A(K+I+1,1), LDA, - $ YQ(1,I), 1, ONE, YQ(I+1,I), 1 ) - CALL DGEMV( 'No transpose', N-I, I-1, ONE, YQ(I+1,1), LDYQ, - $ DWORK, 1, ONE, YQ(I+1,I), 1 ) - CALL DGEMV( 'No transpose', N-I, I-1, ONE, YQ(I+1,NB1), - $ LDYQ, DWORK(NB+1), 1, ONE, YQ(I+1,I), 1 ) - CALL DSCAL( N-I, -TAUQ, YQ(I+1,I), 1 ) -C -C Update Q(i+1:n,i+1). -C - CALL DGEMV( 'No transpose', N-I, I, ONE, Q(I+1,1), LDQ, - $ XQ(I+1,1), LDXQ, ONE, Q(I+1,I+1), 1 ) - CALL DGEMV( 'No transpose', N-I, I, ONE, A(K+I+1,1), LDA, - $ XQ(I+1,NB1), LDXQ, ONE, Q(I+1,I+1), 1 ) - CALL DGEMV( 'No transpose', N-I, I, ONE, YQ(I+1,1), LDYQ, - $ Q(1,I+1), 1, ONE, Q(I+1,I+1), 1 ) - CALL DGEMV( 'No transpose', N-I, I-1, ONE, YQ(I+1,NB1), - $ LDYQ, B(K+I+1,1), LDB, ONE, Q(I+1,I+1), 1 ) -C -C Apply rotation to [ Q(i+1:n,i+1), B(k+i+1,i+1:n)' ]. -C - CALL DROT( N-I, Q(I+1,I+1), 1, B(K+I+1,I+1), LDB, C, S ) - DO 230 J = 1, I - XB(K+I+1,J) = ZERO - 230 CONTINUE - DO 240 J = 1, I - XB(K+I+1,NB+J) = ZERO - 240 CONTINUE -C -C Update YB with second Householder reflection. -C - CALL DGEMV( 'Transpose', N-I, N-I, ONE, B(K+I+1,I+1), - $ LDB, B(K+I+1,I), 1, ZERO, YB(I+1,I+NB), 1 ) - CALL DGEMV( 'Transpose', N-I-1, I, ONE, XB(K+I+2,1), LDXB, - $ B(K+I+2,I), 1, ZERO, YB(1,I+NB), 1 ) - CALL DGEMV( 'No transpose', N-I, I, ONE, Q(I+1,1), LDQ, - $ YB(1,I+NB), 1, ONE, YB(I+1,I+NB), 1 ) - CALL DGEMV( 'Transpose', N-I-1, I, ONE, XB(K+I+2,NB1), LDXB, - $ B(K+I+2,I), 1, ZERO, YB(1,I+NB), 1 ) - CALL DGEMV( 'No transpose', N-I, I, ONE, A(K+I+1,1), LDA, - $ YB(1,I+NB), 1, ONE, YB(I+1,I+NB), 1 ) - CALL DGEMV( 'No transpose', I, N-I-1, ONE, Q(1,I+2), LDQ, - $ B(K+I+2,I), 1, ZERO, DWORK(NB2+1), 1 ) - CALL DGEMV( 'No transpose', N-I, I, ONE, YB(I+1,1), LDYB, - $ DWORK(NB2+1), 1, ONE, YB(I+1,I+NB), 1 ) - CALL DGEMV( 'Transpose', N-I-1, I-1, ONE, B(K+I+2,1), - $ LDQ, B(K+I+2,I), 1, ZERO, DWORK(NB3+1), 1 ) - CALL DGEMV( 'No transpose', N-I, I-1, ONE, YB(I+1,NB1), - $ LDYB, DWORK(NB3+1), 1, ONE, YB(I+1,I+NB), 1 ) - CALL DSCAL( N-I, -TAUR(I), YB(I+1,I+NB), 1 ) -C -C Update B(k+i+1,i+1:n). -C - CALL DAXPY( N-I, ONE, YB(I+1,I+NB), 1, B(K+I+1,I+1), LDB ) -C -C Update YQ with second Householder reflection. -C - CALL DGEMV( 'No transpose', N-I, N-I, ONE, Q(I+1,I+1), LDQ, - $ B(K+I+1,I), 1, ZERO, YQ(I+1,I+NB), 1 ) - CALL DGEMV( 'Transpose', N-I-1, I, ONE, XQ(I+2,1), LDXQ, - $ B(K+I+2,I), 1, ZERO, YQ(1,I+NB), 1 ) - CALL DGEMV( 'No transpose', N-I, I, ONE, Q(I+1,1), LDQ, - $ YQ(1,I+NB), 1, ONE, YQ(I+1,I+NB), 1 ) - CALL DGEMV( 'Transpose', N-I-1, I, ONE, XQ(I+2,NB1), LDXQ, - $ B(K+I+2,I), 1, ZERO, YQ(1,I+NB), 1 ) - CALL DGEMV( 'No transpose', N-I, I, ONE, A(K+I+1,1), LDA, - $ YQ(1,I+NB), 1, ONE, YQ(I+1,I+NB), 1 ) - CALL DGEMV( 'No transpose', N-I, I, ONE, YQ(I+1,1), LDYQ, - $ DWORK(NB2+1), 1, ONE, YQ(I+1,I+NB), 1 ) - CALL DGEMV( 'No transpose', N-I, I-1, ONE, YQ(I+1,NB1), - $ LDYQ, DWORK(NB3+1), 1, ONE, YQ(I+1,I+NB), 1 ) - CALL DSCAL( N-I, -TAUR(I), YQ(I+1,I+NB), 1 ) -C -C Update Q(i+1:n,i+1). -C - CALL DAXPY( N-I, ONE, YQ(I+1,I+NB), 1, Q(I+1,I+1), 1 ) -C -C Update YA with first Householder reflection. -C - CALL DGEMV( 'No transpose', K+N, N-I, ONE, A(1,I+1), LDA, - $ Q(I,I+1), LDQ, ZERO, YA(1,I), 1 ) - CALL DGEMV( 'Transpose', N-I, I, ONE, XA(I+1,1), LDXA, - $ Q(I,I+1), LDQ, ZERO, DWORK(PDW), 1 ) - CALL DGEMV( 'No transpose', N-I, I, ONE, Q(I+1,1), LDQ, - $ DWORK(PDW), 1, ONE, YA(K+I+1,I), 1 ) - CALL DGEMV( 'Transpose', N-I, I, ONE, XA(I+1,NB1), LDXA, - $ Q(I,I+1), LDQ, ZERO, DWORK(PDW), 1 ) - CALL DGEMV( 'No transpose', N-I, I, ONE, A(K+I+1,1), LDA, - $ DWORK(PDW), 1, ONE, YA(K+I+1,I), 1 ) - CALL DGEMV( 'No transpose', K+N, I-1, ONE, YA, LDYA, - $ DWORK, 1, ONE, YA(1,I), 1 ) - CALL DGEMV( 'No transpose', K+N, I-1, ONE, YA(1,NB1), LDYA, - $ DWORK(NB+1), 1, ONE, YA(1,I), 1 ) - CALL DSCAL( K+N, -TAUQ, YA(1,I), 1 ) -C -C Update A(1:k+n,i+1). -C - CALL DGEMV( 'No transpose', N-I, I, ONE, Q(I+1,1), LDQ, - $ XA(I+1,1), LDXA, ONE, A(K+I+1,I+1), 1 ) - CALL DGEMV( 'No transpose', N-I, I, ONE, A(K+I+1,1), LDA, - $ XA(I+1,NB1), LDXA, ONE, A(K+I+1,I+1), 1 ) - CALL DGEMV( 'No transpose', K+N, I, ONE, YA, LDYA, - $ Q(1,I+1), 1, ONE, A(1,I+1), 1 ) - CALL DGEMV( 'No transpose', K+N, I-1, ONE, YA(1,NB1), LDYA, - $ B(K+I+1,1), LDB, ONE, A(1,I+1), 1 ) -C -C Update YG with first Householder reflection. -C - CALL DGEMV( 'No transpose', K+N, N-I, ONE, G(1,K+I+1), LDG, - $ Q(I,I+1), LDQ, ZERO, YG(1,I), 1 ) - CALL DGEMV( 'Transpose', N-I, I, ONE, XG(K+I+1,1), LDXG, - $ Q(I,I+1), LDQ, ZERO, DWORK(PDW), 1 ) - CALL DGEMV( 'No transpose', N-I, I, ONE, Q(I+1,1), LDQ, - $ DWORK(PDW), 1, ONE, YG(K+I+1,I), 1 ) - CALL DGEMV( 'Transpose', N-I, I, ONE, XG(K+I+1,NB1), LDXG, - $ Q(I,I+1), LDQ, ZERO, DWORK(PDW), 1 ) - CALL DGEMV( 'No transpose', N-I, I, ONE, A(K+I+1,1), LDA, - $ DWORK(PDW), 1, ONE, YG(K+I+1,I), 1 ) - CALL DGEMV( 'No transpose', K+N, I-1, ONE, YG, LDYG, - $ DWORK, 1, ONE, YG(1,I), 1 ) - CALL DGEMV( 'No transpose', K+N, I-1, ONE, YG(1,NB1), LDYG, - $ DWORK(NB+1), 1, ONE, YG(1,I), 1 ) - CALL DSCAL( K+N, -TAUQ, YG(1,I), 1 ) -C -C Update G(1:k+n,k+i+1). -C - CALL DGEMV( 'No transpose', N-I, I, ONE, Q(I+1,1), LDQ, - $ XG(K+I+1,1), LDXG, ONE, G(K+I+1,K+I+1), 1 ) - CALL DGEMV( 'No transpose', N-I, I, ONE, A(K+I+1,1), LDA, - $ XG(K+I+1,NB1), LDXG, ONE, G(K+I+1,K+I+1), 1 ) - CALL DGEMV( 'No transpose', K+N, I, ONE, YG, LDYG, - $ Q(1,I+1), 1, ONE, G(1,K+I+1), 1 ) - CALL DGEMV( 'No transpose', K+N, I-1, ONE, YG(1,NB1), LDYG, - $ B(K+I+1,1), LDB, ONE, G(1,K+I+1), 1 ) - DO 250 J = 1, I - XG(K+I+1,J) = ZERO - 250 CONTINUE - DO 260 J = 1, I - XG(K+I+1,NB+J) = ZERO - 260 CONTINUE -C -C Apply rotation to [ A(1:k+n,i+1), G(1:k+n,k+i+1) ]. -C - CALL DROT( K+N, A(1,I+1), 1, G(1,K+I+1), 1, C, S ) -C -C Update YA with second Householder reflection. -C - CALL DGEMV( 'No transpose', K+N, N-I, ONE, A(1,I+1), LDA, - $ B(K+I+1,I), 1, ZERO, YA(1,I+NB), 1 ) - CALL DGEMV( 'Transpose', N-I-1, I, ONE, XA(I+2,1), LDXA, - $ B(K+I+2,I), 1, ZERO, DWORK(PDW), 1 ) - CALL DGEMV( 'No transpose', N-I, I, ONE, Q(I+1,1), LDQ, - $ DWORK(PDW), 1, ONE, YA(K+I+1,I+NB), 1 ) - CALL DGEMV( 'Transpose', N-I-1, I, ONE, XA(I+2,NB1), LDXA, - $ B(K+I+2,I), 1, ZERO, DWORK(PDW), 1 ) - CALL DGEMV( 'No transpose', N-I, I, ONE, A(K+I+1,1), LDA, - $ DWORK(PDW), 1, ONE, YA(K+I+1,I+NB), 1 ) - CALL DGEMV( 'No transpose', K+N, I, ONE, YA, LDYA, - $ DWORK(NB2+1), 1, ONE, YA(1,I+NB), 1 ) - CALL DGEMV( 'No transpose', K+N, I-1, ONE, YA(1,NB1), LDYA, - $ DWORK(NB3+1), 1, ONE, YA(1,I+NB), 1 ) - CALL DSCAL( K+N, -TAUR(I), YA(1,I+NB), 1 ) -C -C Update A(1:k+n,i+1). -C - CALL DAXPY( K+N, ONE, YA(1,I+NB), 1, A(1,I+1), 1 ) -C -C Update YG with second Householder reflection. -C - CALL DGEMV( 'No transpose', K+N, N-I, ONE, G(1,K+I+1), LDG, - $ B(K+I+1,I), 1, ZERO, YG(1,I+NB), 1 ) - CALL DGEMV( 'Transpose', N-I-1, I, ONE, XG(K+I+2,1), LDXG, - $ B(K+I+2,I), 1, ZERO, DWORK(PDW), 1 ) - CALL DGEMV( 'No transpose', N-I, I, ONE, Q(I+1,1), LDQ, - $ DWORK(PDW), 1, ONE, YG(K+I+1,I+NB), 1 ) - CALL DGEMV( 'Transpose', N-I-1, I, ONE, XG(K+I+2,NB1), LDXG, - $ B(K+I+2,I), 1, ZERO, DWORK(PDW), 1 ) - CALL DGEMV( 'No transpose', N-I, I, ONE, A(K+I+1,1), LDA, - $ DWORK(PDW), 1, ONE, YG(K+I+1,I+NB), 1 ) - CALL DGEMV( 'No transpose', K+N, I, ONE, YG, LDYG, - $ DWORK(NB2+1), 1, ONE, YG(1,I+NB), 1 ) - CALL DGEMV( 'No transpose', K+N, I-1, ONE, YG(1,NB1), LDYG, - $ DWORK(NB3+1), 1, ONE, YG(1,I+NB), 1 ) - CALL DSCAL( K+N, -TAUR(I), YG(1,I+NB), 1 ) -C -C Update G(1:k+n,k+i+1). -C - CALL DAXPY( K+N, ONE, YG(1,I+NB), 1, G(1,K+I+1), 1 ) -C - B(K+I+1,I) = TEMP - Q(I,I+1) = TAUQ - CSR(2*I-1) = C - CSR(2*I) = S - 270 CONTINUE -C - ELSE - DO 360 I = 1, NB -C -C Transform first columns of A and Q. See routine MB04TS. -C - ALPHA = Q(I,I) - CALL DLARFG( N-I+1, ALPHA, Q(I+1,I), 1, TAUQ ) - Q(I,I) = ONE - TEMP = -TAUQ*DDOT( N-I+1, Q(I,I), 1, A(K+I,I), 1 ) - CALL DAXPY( N-I+1, TEMP, Q(I,I), 1, A(K+I,I), 1 ) - TEMP = A(K+I,I) - CALL DLARTG( TEMP, ALPHA, C, S, A(K+I,I) ) - CALL DLARFG( N-I+1, A(K+I,I), A(K+I+1,I), 1, TAUL(I) ) - TEMP = A(K+I,I) - A(K+I,I) = ONE -C -C Update XQ with first Householder reflection. -C - CALL DGEMV( 'Transpose', N-I+1, N-I, ONE, Q(I,I+1), LDQ, - $ Q(I,I), 1, ZERO, XQ(I+1,I), 1 ) - CALL DGEMV( 'Transpose', N-I+1, I-1, ONE, Q(I,1), LDQ, - $ Q(I,I), 1, ZERO, DWORK, 1 ) - CALL DGEMV( 'No transpose', N-I, I-1, ONE, XQ(I+1,1), LDXQ, - $ DWORK, 1, ONE, XQ(I+1,I), 1 ) - CALL DGEMV( 'Transpose', N-I+1, I-1, ONE, A(K+I,1), LDA, - $ Q(I,I), 1, ZERO, DWORK(NB+1), 1 ) - CALL DGEMV( 'No transpose', N-I, I-1, ONE, XQ(I+1,NB1), - $ LDXQ, DWORK(NB+1), 1, ONE, XQ(I+1,I), 1 ) - CALL DGEMV( 'Transpose', N-I+1, I-1, ONE, YQ(I,1), LDYQ, - $ Q(I,I), 1, ZERO, XQ(1,I), 1 ) - CALL DGEMV( 'Transpose', I-1, N-I, ONE, Q(1,I+1), LDQ, - $ XQ(1,I), 1, ONE, XQ(I+1,I), 1 ) - CALL DGEMV( 'Transpose', N-I+1, I-1, ONE, YQ(I,NB1), LDYQ, - $ Q(I,I), 1, ZERO, XQ(1,I+NB), 1 ) - CALL DGEMV( 'Transpose', I-1, N-I, ONE, B(1,K+I+1), LDB, - $ XQ(1,I+NB), 1, ONE, XQ(I+1,I), 1 ) - CALL DSCAL( N-I, -TAUQ, XQ(I+1,I), 1 ) -C -C Update Q(i,i+1:n). -C - CALL DGEMV( 'No transpose', N-I, I, ONE, XQ(I+1,1), LDXQ, - $ Q(I,1), LDQ, ONE, Q(I,I+1), LDQ ) - CALL DGEMV( 'No transpose', N-I, I-1, ONE, XQ(I+1,NB1), - $ LDXQ, A(K+I,1), LDA, ONE, Q(I,I+1), LDQ ) - CALL DGEMV( 'Transpose', I-1, N-I, ONE, Q(1,I+1), LDQ, - $ YQ(I,1), LDYQ, ONE, Q(I,I+1), LDQ ) - CALL DGEMV( 'Transpose', I-1, N-I, ONE, B(1,K+I+1), LDB, - $ YQ(I,NB1), LDYQ, ONE, Q(I,I+1), LDQ ) -C -C Update XA with first Householder reflection. -C - CALL DGEMV( 'Transpose', N-I+1, N-I, ONE, A(K+I,I+1), LDA, - $ Q(I,I), 1, ZERO, XA(I+1,I), 1 ) - CALL DGEMV( 'No transpose', N-I, I-1, ONE, XA(I+1,1), LDXA, - $ DWORK, 1, ONE, XA(I+1,I), 1 ) - CALL DGEMV( 'No transpose', N-I, I-1, ONE, XA(I+1,NB1), - $ LDXA, DWORK(NB+1), 1, ONE, XA(I+1,I), 1 ) - CALL DGEMV( 'Transpose', N-I+1, I-1, ONE, YA(K+I,1), LDYA, - $ Q(I,I), 1, ZERO, XA(1,I), 1 ) - CALL DGEMV( 'Transpose', I-1, N-I, ONE, Q(1,I+1), LDQ, - $ XA(1,I), 1, ONE, XA(I+1,I), 1 ) - CALL DGEMV( 'Transpose', N-I+1, I-1, ONE, YA(K+I,NB1), LDYA, - $ Q(I,I), 1, ZERO, XA(1,I), 1 ) - CALL DGEMV( 'Transpose', I-1, N-I, ONE, B(1,K+I+1), LDB, - $ XA(1,I), 1, ONE, XA(I+1,I), 1 ) - CALL DSCAL( N-I, -TAUQ, XA(I+1,I), 1 ) -C -C Update A(k+i,i+1:n). -C - CALL DGEMV( 'No transpose', N-I, I, ONE, XA(I+1,1), LDXA, - $ Q(I,1), LDQ, ONE, A(K+I,I+1), LDA ) - CALL DGEMV( 'No transpose', N-I, I-1, ONE, XA(I+1,NB1), - $ LDXA, A(K+I,1), LDA, ONE, A(K+I,I+1), LDA ) - CALL DGEMV( 'Transpose', I-1, N-I, ONE, Q(1,I+1), LDQ, - $ YA(K+I,1), LDYA, ONE, A(K+I,I+1), LDA ) - CALL DGEMV( 'Transpose', I-1, N-I, ONE, B(1,K+I+1), LDB, - $ YA(K+I,NB1), LDYA, ONE, A(K+I,I+1), LDA ) -C -C Apply rotation to [ A(k+i,i+1:n); Q(i,i+1:n) ]. -C - CALL DROT( N-I, A(K+I,I+1), LDA, Q(I,I+1), LDQ, C, S ) -C -C Update XQ with second Householder reflection. -C - CALL DGEMV( 'Transpose', N-I+1, N-I, ONE, Q(I,I+1), LDQ, - $ A(K+I,I), 1, ZERO, XQ(I+1,I+NB), 1 ) - CALL DGEMV( 'Transpose', N-I, I, ONE, Q(I+1,1), LDQ, - $ A(K+I+1,I), 1, ZERO, DWORK(NB2+1), 1 ) - CALL DGEMV( 'No transpose', N-I, I, ONE, XQ(I+1,1), LDXQ, - $ DWORK(NB2+1), 1, ONE, XQ(I+1,I+NB), 1 ) - CALL DGEMV( 'Transpose', N-I, I-1, ONE, A(K+I+1,1), LDA, - $ A(K+I+1,I), 1, ZERO, DWORK(NB3+1), 1 ) - CALL DGEMV( 'No transpose', N-I, I-1, ONE, XQ(I+1,NB1), - $ LDXQ, DWORK(NB3+1), 1, ONE, XQ(I+1,I+NB), 1 ) - CALL DGEMV( 'Transpose', N-I, I-1, ONE, YQ(I+1,1), LDYQ, - $ A(K+I+1,I), 1, ZERO, XQ(1,I+NB), 1 ) - CALL DGEMV( 'Transpose', I-1, N-I, ONE, Q(1,I+1), LDQ, - $ XQ(1,I+NB), 1, ONE, XQ(I+1,I+NB), 1 ) - CALL DGEMV( 'Transpose', N-I, I-1, ONE, YQ(I+1,NB1), LDYQ, - $ A(K+I+1,I), 1, ZERO, XQ(1,I+NB), 1 ) - CALL DGEMV( 'Transpose', I-1, N-I, ONE, B(1,K+I+1), LDB, - $ XQ(1,I+NB), 1, ONE, XQ(I+1,I+NB), 1 ) - CALL DSCAL( N-I, -TAUL(I), XQ(I+1,I+NB), 1 ) -C -C Update Q(i,i+1:n). -C - CALL DAXPY( N-I, ONE, XQ(I+1,I+NB), 1, Q(I,I+1), LDQ ) -C -C Update XA with second Householder reflection. -C - CALL DGEMV( 'Transpose', N-I+1, N-I, ONE, A(K+I,I+1), LDA, - $ A(K+I,I), 1, ZERO, XA(I+1,I+NB), 1 ) - CALL DGEMV( 'No transpose', N-I, I, ONE, XA(I+1,1), LDXA, - $ DWORK(NB2+1), 1, ONE, XA(I+1,I+NB), 1 ) - CALL DGEMV( 'No transpose', N-I, I-1, ONE, XA(I+1,NB1), - $ LDXA, DWORK(NB3+1), 1, ONE, XA(I+1,I+NB), 1 ) - CALL DGEMV( 'Transpose', N-I, I-1, ONE, YA(K+I+1,1), LDYA, - $ A(K+I+1,I), 1, ZERO, XA(1,I+NB), 1 ) - CALL DGEMV( 'Transpose', I-1, N-I, ONE, Q(1,I+1), LDQ, - $ XA(1,I+NB), 1, ONE, XA(I+1,I+NB), 1 ) - CALL DGEMV( 'Transpose', N-I, I-1, ONE, YA(K+I+1,NB1), LDYA, - $ A(K+I+1,I), 1, ZERO, XA(1,I+NB), 1 ) - CALL DGEMV( 'Transpose', I-1, N-I, ONE, B(1,K+I+1), LDB, - $ XA(1,I+NB), 1, ONE, XA(I+1,I+NB), 1 ) - CALL DSCAL( N-I, -TAUL(I), XA(I+1,I+NB), 1 ) -C -C Update A(k+i,i+1:n). -C - CALL DAXPY( N-I, ONE, XA(I+1,I+NB), 1, A(K+I,I+1), LDA ) -C -C Update XG with first Householder reflection. -C - CALL DGEMV( 'Transpose', N-I+1, K+N, ONE, G(K+I,1), LDG, - $ Q(I,I), 1, ZERO, XG(1,I), 1 ) - CALL DGEMV( 'No transpose', K+N, I-1, ONE, XG, LDXG, - $ DWORK, 1, ONE, XG(1,I), 1 ) - CALL DGEMV( 'No transpose', K+N, I-1, ONE, XG(1,NB1), - $ LDXG, DWORK(NB+1), 1, ONE, XG(1,I), 1 ) - CALL DGEMV( 'Transpose', N-I+1, I-1, ONE, YG(K+I,1), LDYG, - $ Q(I,I), 1, ZERO, DWORK(PDW), 1 ) - CALL DGEMV( 'Transpose', I-1, N-I, ONE, Q(1,I+1), LDQ, - $ DWORK(PDW), 1, ONE, XG(K+I+1,I), 1 ) - CALL DGEMV( 'Transpose', N-I+1, I-1, ONE, YG(K+I,NB1), LDYG, - $ Q(I,I), 1, ZERO, DWORK(PDW), 1 ) - CALL DGEMV( 'Transpose', I-1, N-I, ONE, B(1,K+I+1), LDB, - $ DWORK(PDW), 1, ONE, XG(K+I+1,I), 1 ) - CALL DSCAL( K+N, -TAUQ, XG(1,I), 1 ) -C -C Update G(k+i,:). -C - CALL DGEMV( 'No transpose', K+N, I, ONE, XG, LDXG, - $ Q(I,1), LDQ, ONE, G(K+I,1), LDG ) - CALL DGEMV( 'No transpose', K+N, I-1, ONE, XG(1,NB1), - $ LDXG, A(K+I,1), LDA, ONE, G(K+I,1), LDG ) - CALL DGEMV( 'Transpose', I-1, N-I, ONE, Q(1,I+1), LDQ, - $ YG(K+I,1), LDYG, ONE, G(K+I,K+I+1), LDG ) - CALL DGEMV( 'Transpose', I-1, N-I, ONE, B(1,K+I+1), LDB, - $ YG(K+I,NB1), LDYG, ONE, G(K+I,K+I+1), LDG ) -C -C Update XB with first Householder reflection. -C - CALL DGEMV( 'Transpose', N-I+1, K+N, ONE, B(I,1), LDB, - $ Q(I,I), 1, ZERO, XB(1,I), 1 ) - CALL DGEMV( 'No transpose', K+N, I-1, ONE, XB, LDXB, - $ DWORK, 1, ONE, XB(1,I), 1 ) - CALL DGEMV( 'No transpose', K+N, I-1, ONE, XB(1,NB1), - $ LDXB, DWORK(NB+1), 1, ONE, XB(1,I), 1 ) - CALL DGEMV( 'Transpose', N-I+1, I-1, ONE, YB(I,1), LDYB, - $ Q(I,I), 1, ZERO, DWORK(PDW), 1 ) - CALL DGEMV( 'Transpose', I-1, N-I, ONE, Q(1,I+1), LDQ, - $ DWORK(PDW), 1, ONE, XB(K+I+1,I), 1 ) - CALL DGEMV( 'Transpose', N-I+1, I-1, ONE, YB(I,NB1), LDYB, - $ Q(I,I), 1, ZERO, DWORK(PDW), 1 ) - CALL DGEMV( 'Transpose', I-1, N-I, ONE, B(1,K+I+1), LDB, - $ DWORK(PDW), 1, ONE, XB(K+I+1,I), 1 ) - CALL DSCAL( K+N, -TAUQ, XB(1,I), 1 ) -C -C Update B(i,:). -C - CALL DGEMV( 'No transpose', K+N, I, ONE, XB, LDXB, - $ Q(I,1), LDQ, ONE, B(I,1), LDB ) - CALL DGEMV( 'No transpose', K+N, I-1, ONE, XB(1,NB1), - $ LDXB, A(K+I,1), LDA, ONE, B(I,1), LDB ) - CALL DGEMV( 'Transpose', I-1, N-I, ONE, Q(1,I+1), LDQ, - $ YB(I,1), LDYB, ONE, B(I,K+I+1), LDB ) - CALL DGEMV( 'Transpose', I-1, N-I, ONE, B(1,K+I+1), LDB, - $ YB(I,NB1), LDYB, ONE, B(I,K+I+1), LDB ) -C -C Apply rotation to [ G(k+i,:); B(i,:) ]. -C - CALL DROT( K+N, G(K+I,1), LDG, B(I,1), LDB, C, S ) -C - DO 280 J = 1, I-1 - YG(K+I,J) = ZERO - 280 CONTINUE - DO 290 J = 1, I-1 - YG(K+I,NB+J) = ZERO - 290 CONTINUE - DO 300 J = 1, I-1 - YA(K+I,J) = ZERO - 300 CONTINUE - DO 310 J = 1, I-1 - YA(K+I,NB+J) = ZERO - 310 CONTINUE -C -C Update XG with second Householder reflection. -C - CALL DGEMV( 'Transpose', N-I+1, K+N, ONE, G(K+I,1), LDG, - $ A(K+I,I), 1, ZERO, XG(1,I+NB), 1 ) - CALL DGEMV( 'No transpose', K+N, I, ONE, XG, LDXG, - $ DWORK(NB2+1), 1, ONE, XG(1,I+NB), 1 ) - CALL DGEMV( 'No transpose', K+N, I-1, ONE, XG(1,NB1), - $ LDXG, DWORK(NB3+1), 1, ONE, XG(1,I+NB), 1 ) - CALL DGEMV( 'Transpose', N-I, I-1, ONE, YG(K+I+1,1), LDYG, - $ A(K+I+1,I), 1, ZERO, DWORK(PDW), 1 ) - CALL DGEMV( 'Transpose', I-1, N-I, ONE, Q(1,I+1), LDQ, - $ DWORK(PDW), 1, ONE, XG(K+I+1,I+NB), 1 ) - CALL DGEMV( 'Transpose', N-I, I-1, ONE, YG(K+I+1,NB1), LDYG, - $ A(K+I+1,I), 1, ZERO, DWORK(PDW), 1 ) - CALL DGEMV( 'Transpose', I-1, N-I, ONE, B(1,K+I+1), LDB, - $ DWORK(PDW), 1, ONE, XG(K+I+1,I+NB), 1 ) - CALL DSCAL( K+N, -TAUL(I), XG(1,I+NB), 1 ) -C -C Update G(k+i,:). -C - CALL DAXPY( K+N, ONE, XG(1,I+NB), 1, G(K+I,1), LDG ) -C -C Update XB with second Householder reflection. -C - CALL DGEMV( 'Transpose', N-I+1, K+N, ONE, B(I,1), LDB, - $ A(K+I,I), 1, ZERO, XB(1,I+NB), 1 ) - CALL DGEMV( 'No transpose', K+N, I, ONE, XB, LDXB, - $ DWORK(NB2+1), 1, ONE, XB(1,I+NB), 1 ) - CALL DGEMV( 'No transpose', K+N, I-1, ONE, XB(1,NB1), - $ LDXB, DWORK(NB3+1), 1, ONE, XB(1,I+NB), 1 ) - CALL DGEMV( 'Transpose', N-I, I-1, ONE, YB(I+1,1), LDYB, - $ A(K+I+1,I), 1, ZERO, DWORK(PDW), 1 ) - CALL DGEMV( 'Transpose', I-1, N-I, ONE, Q(1,I+1), LDQ, - $ DWORK(PDW), 1, ONE, XB(K+I+1,I+NB), 1 ) - CALL DGEMV( 'Transpose', N-I, I-1, ONE, YB(I+1,NB1), LDYB, - $ A(K+I+1,I), 1, ZERO, DWORK(PDW), 1 ) - CALL DGEMV( 'Transpose', I-1, N-I, ONE, B(1,K+I+1), LDB, - $ DWORK(PDW), 1, ONE, XB(K+I+1,I+NB), 1 ) - CALL DSCAL( K+N, -TAUL(I), XB(1,I+NB), 1 ) -C -C Update B(i,:). -C - CALL DAXPY( K+N, ONE, XB(1,I+NB), 1, B(I,1), LDB ) -C - A(K+I,I) = TEMP - Q(I,I) = TAUQ - CSL(2*I-1) = C - CSL(2*I) = S -C -C Transform first rows of Q and B. -C - ALPHA = Q(I,I+1) - CALL DLARFG( N-I, ALPHA, Q(I,I+2), LDQ, TAUQ ) - Q(I,I+1) = ONE - TEMP = -TAUQ*DDOT( N-I, Q(I,I+1), LDQ, B(I,K+I+1), LDB ) - CALL DAXPY( N-I, TEMP, Q(I,I+1), LDQ, B(I,K+I+1), LDB ) - TEMP = B(I,K+I+1) - CALL DLARTG( TEMP, ALPHA, C, S, B(I,K+I+1) ) - S = -S - CALL DLARFG( N-I, B(I,K+I+1), B(I,K+I+2), LDB, TAUR(I) ) - TEMP = B(I,K+I+1) - B(I,K+I+1) = ONE -C -C Update YB with first Householder reflection. -C - CALL DGEMV( 'No transpose', N-I, N-I, ONE, B(I+1,K+I+1), - $ LDB, Q(I,I+1), LDQ, ZERO, YB(I+1,I), 1 ) - CALL DGEMV( 'Transpose', N-I, I, ONE, XB(K+I+1,1), LDXB, - $ Q(I,I+1), LDQ, ZERO, YB(1,I), 1 ) - CALL DGEMV( 'No transpose', N-I, I, ONE, Q(I+1,1), LDQ, - $ YB(1,I), 1, ONE, YB(I+1,I), 1 ) - CALL DGEMV( 'Transpose', N-I, I, ONE, XB(K+I+1,NB1), LDXB, - $ Q(I,I+1), LDQ, ZERO, YB(1,I), 1 ) - CALL DGEMV( 'No transpose', N-I, I, ONE, A(K+I+1,1), LDA, - $ YB(1,I), 1, ONE, YB(I+1,I), 1 ) - CALL DGEMV( 'No transpose', I-1, N-I, ONE, Q(1,I+1), LDQ, - $ Q(I,I+1), LDQ, ZERO, DWORK, 1 ) - CALL DGEMV( 'No transpose', N-I, I-1, ONE, YB(I+1,1), LDYB, - $ DWORK, 1, ONE, YB(I+1,I), 1 ) - CALL DGEMV( 'No transpose', I-1, N-I, ONE, B(1,K+I+1), LDB, - $ Q(I,I+1), LDQ, ZERO, DWORK(NB+1), 1 ) - CALL DGEMV( 'No transpose', N-I, I-1, ONE, YB(I+1,NB1), - $ LDYB, DWORK(NB+1), 1, ONE, YB(I+1,I), 1 ) - CALL DSCAL( N-I, -TAUQ, YB(I+1,I), 1 ) -C -C Update B(i+1:n,k+i+1). -C - CALL DGEMV( 'No transpose', N-I, I, ONE, Q(I+1,1), LDQ, - $ XB(K+I+1,1), LDXB, ONE, B(I+1,K+I+1), 1 ) - CALL DGEMV( 'No transpose', N-I, I, ONE, A(K+I+1,1), LDA, - $ XB(K+I+1,NB1), LDXB, ONE, B(I+1,K+I+1), 1 ) - CALL DGEMV( 'No transpose', N-I, I, ONE, YB(I+1,1), LDYB, - $ Q(1,I+1), 1, ONE, B(I+1,K+I+1), 1 ) - CALL DGEMV( 'No transpose', N-I, I-1, ONE, YB(I+1,NB1), - $ LDYB, B(1,K+I+1), 1, ONE, B(I+1,K+I+1), 1 ) -C -C Update YQ with first Householder reflection. -C - CALL DGEMV( 'No transpose', N-I, N-I, ONE, Q(I+1,I+1), LDQ, - $ Q(I,I+1), LDQ, ZERO, YQ(I+1,I), 1 ) - CALL DGEMV( 'Transpose', N-I, I, ONE, XQ(I+1,1), LDXQ, - $ Q(I,I+1), LDQ, ZERO, YQ(1,I), 1 ) - CALL DGEMV( 'No transpose', N-I, I, ONE, Q(I+1,1), LDQ, - $ YQ(1,I), 1, ONE, YQ(I+1,I), 1 ) - CALL DGEMV( 'Transpose', N-I, I, ONE, XQ(I+1,NB1), LDXQ, - $ Q(I,I+1), LDQ, ZERO, YQ(1,I), 1 ) - CALL DGEMV( 'No transpose', N-I, I, ONE, A(K+I+1,1), LDA, - $ YQ(1,I), 1, ONE, YQ(I+1,I), 1 ) - CALL DGEMV( 'No transpose', N-I, I-1, ONE, YQ(I+1,1), LDYQ, - $ DWORK, 1, ONE, YQ(I+1,I), 1 ) - CALL DGEMV( 'No transpose', N-I, I-1, ONE, YQ(I+1,NB1), - $ LDYQ, DWORK(NB+1), 1, ONE, YQ(I+1,I), 1 ) - CALL DSCAL( N-I, -TAUQ, YQ(I+1,I), 1 ) -C -C Update Q(i+1:n,i+1). -C - CALL DGEMV( 'No transpose', N-I, I, ONE, Q(I+1,1), LDQ, - $ XQ(I+1,1), LDXQ, ONE, Q(I+1,I+1), 1 ) - CALL DGEMV( 'No transpose', N-I, I, ONE, A(K+I+1,1), LDA, - $ XQ(I+1,NB1), LDXQ, ONE, Q(I+1,I+1), 1 ) - CALL DGEMV( 'No transpose', N-I, I, ONE, YQ(I+1,1), LDYQ, - $ Q(1,I+1), 1, ONE, Q(I+1,I+1), 1 ) - CALL DGEMV( 'No transpose', N-I, I-1, ONE, YQ(I+1,NB1), - $ LDYQ, B(1,K+I+1), 1, ONE, Q(I+1,I+1), 1 ) -C -C Apply rotation to [ Q(i+1:n,i+1), B(i+1:n,k+i+1) ]. -C - CALL DROT( N-I, Q(I+1,I+1), 1, B(I+1,K+I+1), 1, C, S ) - DO 320 J = 1, I - XB(K+I+1,J) = ZERO - 320 CONTINUE - DO 330 J = 1, I - XB(K+I+1,NB+J) = ZERO - 330 CONTINUE -C -C Update YB with second Householder reflection. -C - CALL DGEMV( 'No transpose', N-I, N-I, ONE, B(I+1,K+I+1), - $ LDB, B(I,K+I+1), LDB, ZERO, YB(I+1,I+NB), 1 ) - CALL DGEMV( 'Transpose', N-I-1, I, ONE, XB(K+I+2,1), LDXB, - $ B(I,K+I+2), LDB, ZERO, YB(1,I+NB), 1 ) - CALL DGEMV( 'No transpose', N-I, I, ONE, Q(I+1,1), LDQ, - $ YB(1,I+NB), 1, ONE, YB(I+1,I+NB), 1 ) - CALL DGEMV( 'Transpose', N-I-1, I, ONE, XB(K+I+2,NB1), LDXB, - $ B(I,K+I+2), LDB, ZERO, YB(1,I+NB), 1 ) - CALL DGEMV( 'No transpose', N-I, I, ONE, A(K+I+1,1), LDA, - $ YB(1,I+NB), 1, ONE, YB(I+1,I+NB), 1 ) - CALL DGEMV( 'No transpose', I, N-I-1, ONE, Q(1,I+2), LDQ, - $ B(I,K+I+2), LDB, ZERO, DWORK(NB2+1), 1 ) - CALL DGEMV( 'No transpose', N-I, I, ONE, YB(I+1,1), LDYB, - $ DWORK(NB2+1), 1, ONE, YB(I+1,I+NB), 1 ) - CALL DGEMV( 'No transpose', I-1, N-I-1, ONE, B(1,K+I+2), - $ LDQ, B(I,K+I+2), LDB, ZERO, DWORK(NB3+1), 1 ) - CALL DGEMV( 'No transpose', N-I, I-1, ONE, YB(I+1,NB1), - $ LDYB, DWORK(NB3+1), 1, ONE, YB(I+1,I+NB), 1 ) - CALL DSCAL( N-I, -TAUR(I), YB(I+1,I+NB), 1 ) -C -C Update B(i+1:n,k+i+1). -C - CALL DAXPY( N-I, ONE, YB(I+1,I+NB), 1, B(I+1,K+I+1), 1 ) -C -C Update YQ with second Householder reflection. -C - CALL DGEMV( 'No transpose', N-I, N-I, ONE, Q(I+1,I+1), LDQ, - $ B(I,K+I+1), LDB, ZERO, YQ(I+1,I+NB), 1 ) - CALL DGEMV( 'Transpose', N-I-1, I, ONE, XQ(I+2,1), LDXQ, - $ B(I,K+I+2), LDB, ZERO, YQ(1,I+NB), 1 ) - CALL DGEMV( 'No transpose', N-I, I, ONE, Q(I+1,1), LDQ, - $ YQ(1,I+NB), 1, ONE, YQ(I+1,I+NB), 1 ) - CALL DGEMV( 'Transpose', N-I-1, I, ONE, XQ(I+2,NB1), LDXQ, - $ B(I,K+I+2), LDB, ZERO, YQ(1,I+NB), 1 ) - CALL DGEMV( 'No transpose', N-I, I, ONE, A(K+I+1,1), LDA, - $ YQ(1,I+NB), 1, ONE, YQ(I+1,I+NB), 1 ) - CALL DGEMV( 'No transpose', N-I, I, ONE, YQ(I+1,1), LDYQ, - $ DWORK(NB2+1), 1, ONE, YQ(I+1,I+NB), 1 ) - CALL DGEMV( 'No transpose', N-I, I-1, ONE, YQ(I+1,NB1), - $ LDYQ, DWORK(NB3+1), 1, ONE, YQ(I+1,I+NB), 1 ) - CALL DSCAL( N-I, -TAUR(I), YQ(I+1,I+NB), 1 ) -C -C Update Q(i+1:n,i+1). -C - CALL DAXPY( N-I, ONE, YQ(I+1,I+NB), 1, Q(I+1,I+1), 1 ) -C -C Update YA with first Householder reflection. -C - CALL DGEMV( 'No transpose', K+N, N-I, ONE, A(1,I+1), LDA, - $ Q(I,I+1), LDQ, ZERO, YA(1,I), 1 ) - CALL DGEMV( 'Transpose', N-I, I, ONE, XA(I+1,1), LDXA, - $ Q(I,I+1), LDQ, ZERO, DWORK(PDW), 1 ) - CALL DGEMV( 'No transpose', N-I, I, ONE, Q(I+1,1), LDQ, - $ DWORK(PDW), 1, ONE, YA(K+I+1,I), 1 ) - CALL DGEMV( 'Transpose', N-I, I, ONE, XA(I+1,NB1), LDXA, - $ Q(I,I+1), LDQ, ZERO, DWORK(PDW), 1 ) - CALL DGEMV( 'No transpose', N-I, I, ONE, A(K+I+1,1), LDA, - $ DWORK(PDW), 1, ONE, YA(K+I+1,I), 1 ) - CALL DGEMV( 'No transpose', K+N, I-1, ONE, YA, LDYA, - $ DWORK, 1, ONE, YA(1,I), 1 ) - CALL DGEMV( 'No transpose', K+N, I-1, ONE, YA(1,NB1), LDYA, - $ DWORK(NB+1), 1, ONE, YA(1,I), 1 ) - CALL DSCAL( K+N, -TAUQ, YA(1,I), 1 ) -C -C Update A(1:k+n,i+1). -C - CALL DGEMV( 'No transpose', N-I, I, ONE, Q(I+1,1), LDQ, - $ XA(I+1,1), LDXA, ONE, A(K+I+1,I+1), 1 ) - CALL DGEMV( 'No transpose', N-I, I, ONE, A(K+I+1,1), LDA, - $ XA(I+1,NB1), LDXA, ONE, A(K+I+1,I+1), 1 ) - CALL DGEMV( 'No transpose', K+N, I, ONE, YA, LDYA, - $ Q(1,I+1), 1, ONE, A(1,I+1), 1 ) - CALL DGEMV( 'No transpose', K+N, I-1, ONE, YA(1,NB1), LDYA, - $ B(1,K+I+1), 1, ONE, A(1,I+1), 1 ) -C -C Update YG with first Householder reflection. -C - CALL DGEMV( 'No transpose', K+N, N-I, ONE, G(1,K+I+1), LDG, - $ Q(I,I+1), LDQ, ZERO, YG(1,I), 1 ) - CALL DGEMV( 'Transpose', N-I, I, ONE, XG(K+I+1,1), LDXG, - $ Q(I,I+1), LDQ, ZERO, DWORK(PDW), 1 ) - CALL DGEMV( 'No transpose', N-I, I, ONE, Q(I+1,1), LDQ, - $ DWORK(PDW), 1, ONE, YG(K+I+1,I), 1 ) - CALL DGEMV( 'Transpose', N-I, I, ONE, XG(K+I+1,NB1), LDXG, - $ Q(I,I+1), LDQ, ZERO, DWORK(PDW), 1 ) - CALL DGEMV( 'No transpose', N-I, I, ONE, A(K+I+1,1), LDA, - $ DWORK(PDW), 1, ONE, YG(K+I+1,I), 1 ) - CALL DGEMV( 'No transpose', K+N, I-1, ONE, YG, LDYG, - $ DWORK, 1, ONE, YG(1,I), 1 ) - CALL DGEMV( 'No transpose', K+N, I-1, ONE, YG(1,NB1), LDYG, - $ DWORK(NB+1), 1, ONE, YG(1,I), 1 ) - CALL DSCAL( K+N, -TAUQ, YG(1,I), 1 ) -C -C Update G(1:k+n,k+i+1). -C - CALL DGEMV( 'No transpose', N-I, I, ONE, Q(I+1,1), LDQ, - $ XG(K+I+1,1), LDXG, ONE, G(K+I+1,K+I+1), 1 ) - CALL DGEMV( 'No transpose', N-I, I, ONE, A(K+I+1,1), LDA, - $ XG(K+I+1,NB1), LDXG, ONE, G(K+I+1,K+I+1), 1 ) - CALL DGEMV( 'No transpose', K+N, I, ONE, YG, LDYG, - $ Q(1,I+1), 1, ONE, G(1,K+I+1), 1 ) - CALL DGEMV( 'No transpose', K+N, I-1, ONE, YG(1,NB1), LDYG, - $ B(1,K+I+1), 1, ONE, G(1,K+I+1), 1 ) - DO 340 J = 1, I - XG(K+I+1,J) = ZERO - 340 CONTINUE - DO 350 J = 1, I - XG(K+I+1,NB+J) = ZERO - 350 CONTINUE -C -C Apply rotation to [ A(1:k+n,i+1), G(1:k+n,k+i+1) ]. -C - CALL DROT( K+N, A(1,I+1), 1, G(1,K+I+1), 1, C, S ) -C -C Update YA with second Householder reflection. -C - CALL DGEMV( 'No transpose', K+N, N-I, ONE, A(1,I+1), LDA, - $ B(I,K+I+1), LDB, ZERO, YA(1,I+NB), 1 ) - CALL DGEMV( 'Transpose', N-I-1, I, ONE, XA(I+2,1), LDXA, - $ B(I,K+I+2), LDB, ZERO, DWORK(PDW), 1 ) - CALL DGEMV( 'No transpose', N-I, I, ONE, Q(I+1,1), LDQ, - $ DWORK(PDW), 1, ONE, YA(K+I+1,I+NB), 1 ) - CALL DGEMV( 'Transpose', N-I-1, I, ONE, XA(I+2,NB1), LDXA, - $ B(I,K+I+2), LDB, ZERO, DWORK(PDW), 1 ) - CALL DGEMV( 'No transpose', N-I, I, ONE, A(K+I+1,1), LDA, - $ DWORK(PDW), 1, ONE, YA(K+I+1,I+NB), 1 ) - CALL DGEMV( 'No transpose', K+N, I, ONE, YA, LDYA, - $ DWORK(NB2+1), 1, ONE, YA(1,I+NB), 1 ) - CALL DGEMV( 'No transpose', K+N, I-1, ONE, YA(1,NB1), LDYA, - $ DWORK(NB3+1), 1, ONE, YA(1,I+NB), 1 ) - CALL DSCAL( K+N, -TAUR(I), YA(1,I+NB), 1 ) -C -C Update A(1:k+n,i+1). -C - CALL DAXPY( K+N, ONE, YA(1,I+NB), 1, A(1,I+1), 1 ) -C -C Update YG with second Householder reflection. -C - CALL DGEMV( 'No transpose', K+N, N-I, ONE, G(1,K+I+1), LDG, - $ B(I,K+I+1), LDB, ZERO, YG(1,I+NB), 1 ) - CALL DGEMV( 'Transpose', N-I-1, I, ONE, XG(K+I+2,1), LDXG, - $ B(I,K+I+2), LDB, ZERO, DWORK(PDW), 1 ) - CALL DGEMV( 'No transpose', N-I, I, ONE, Q(I+1,1), LDQ, - $ DWORK(PDW), 1, ONE, YG(K+I+1,I+NB), 1 ) - CALL DGEMV( 'Transpose', N-I-1, I, ONE, XG(K+I+2,NB1), LDXG, - $ B(I,K+I+2), LDB, ZERO, DWORK(PDW), 1 ) - CALL DGEMV( 'No transpose', N-I, I, ONE, A(K+I+1,1), LDA, - $ DWORK(PDW), 1, ONE, YG(K+I+1,I+NB), 1 ) - CALL DGEMV( 'No transpose', K+N, I, ONE, YG, LDYG, - $ DWORK(NB2+1), 1, ONE, YG(1,I+NB), 1 ) - CALL DGEMV( 'No transpose', K+N, I-1, ONE, YG(1,NB1), LDYG, - $ DWORK(NB3+1), 1, ONE, YG(1,I+NB), 1 ) - CALL DSCAL( K+N, -TAUR(I), YG(1,I+NB), 1 ) -C -C Update G(1:k+n,k+i+1). -C - CALL DAXPY( K+N, ONE, YG(1,I+NB), 1, G(1,K+I+1), 1 ) -C - B(I,K+I+1) = TEMP - Q(I,I+1) = TAUQ - CSR(2*I-1) = C - CSR(2*I) = S - 360 CONTINUE - END IF -C - RETURN -C *** Last line of MB03XU *** - END diff --git a/mex/sources/libslicot/MB03YA.f b/mex/sources/libslicot/MB03YA.f deleted file mode 100644 index 0a87c7c30..000000000 --- a/mex/sources/libslicot/MB03YA.f +++ /dev/null @@ -1,297 +0,0 @@ - SUBROUTINE MB03YA( WANTT, WANTQ, WANTZ, N, ILO, IHI, ILOQ, IHIQ, - $ POS, A, LDA, B, LDB, Q, LDQ, Z, LDZ, INFO ) -C -C SLICOT RELEASE 5.0. -C -C Copyright (c) 2002-2009 NICONET e.V. -C -C This program is free software: you can redistribute it and/or -C modify it under the terms of the GNU General Public License as -C published by the Free Software Foundation, either version 2 of -C the License, or (at your option) any later version. -C -C This program is distributed in the hope that it will be useful, -C but WITHOUT ANY WARRANTY; without even the implied warranty of -C MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the -C GNU General Public License for more details. -C -C You should have received a copy of the GNU General Public License -C along with this program. If not, see -C . -C -C PURPOSE -C -C To annihilate one or two entries on the subdiagonal of the -C Hessenberg matrix A for dealing with zero elements on the diagonal -C of the triangular matrix B. -C -C MB03YA is an auxiliary routine called by SLICOT Library routines -C MB03XP and MB03YD. -C -C ARGUMENTS -C -C Mode Parameters -C -C WANTT LOGICAL -C Indicates whether the user wishes to compute the full -C Schur form or the eigenvalues only, as follows: -C = .TRUE. : Compute the full Schur form; -C = .FALSE.: compute the eigenvalues only. -C -C WANTQ LOGICAL -C Indicates whether or not the user wishes to accumulate -C the matrix Q as follows: -C = .TRUE. : The matrix Q is updated; -C = .FALSE.: the matrix Q is not required. -C -C WANTZ LOGICAL -C Indicates whether or not the user wishes to accumulate -C the matrix Z as follows: -C = .TRUE. : The matrix Z is updated; -C = .FALSE.: the matrix Z is not required. -C -C Input/Output Parameters -C -C N (input) INTEGER -C The order of the matrices A and B. N >= 0. -C -C ILO (input) INTEGER -C IHI (input) INTEGER -C It is assumed that the matrices A and B are already -C (quasi) upper triangular in rows and columns 1:ILO-1 and -C IHI+1:N. The routine works primarily with the submatrices -C in rows and columns ILO to IHI, but applies the -C transformations to all the rows and columns of the -C matrices A and B, if WANTT = .TRUE.. -C 1 <= ILO <= max(1,N); min(ILO,N) <= IHI <= N. -C -C ILOQ (input) INTEGER -C IHIQ (input) INTEGER -C Specify the rows of Q and Z to which transformations -C must be applied if WANTQ = .TRUE. and WANTZ = .TRUE., -C respectively. -C 1 <= ILOQ <= ILO; IHI <= IHIQ <= N. -C -C POS (input) INTEGER -C The position of the zero element on the diagonal of B. -C ILO <= POS <= IHI. -C -C A (input/output) DOUBLE PRECISION array, dimension (LDA,N) -C On entry, the leading N-by-N part of this array must -C contain the upper Hessenberg matrix A. -C On exit, the leading N-by-N part of this array contains -C the updated matrix A where A(POS,POS-1) = 0, if POS > ILO, -C and A(POS+1,POS) = 0, if POS < IHI. -C -C LDA INTEGER -C The leading dimension of the array A. LDA >= MAX(1,N). -C -C B (input/output) DOUBLE PRECISION array, dimension (LDB,N) -C On entry, the leading N-by-N part of this array must -C contain an upper triangular matrix B with B(POS,POS) = 0. -C On exit, the leading N-by-N part of this array contains -C the updated upper triangular matrix B. -C -C LDB INTEGER -C The leading dimension of the array B. LDB >= MAX(1,N). -C -C Q (input/output) DOUBLE PRECISION array, dimension (LDQ,N) -C On entry, if WANTQ = .TRUE., then the leading N-by-N part -C of this array must contain the current matrix Q of -C transformations accumulated by MB03XP. -C On exit, if WANTQ = .TRUE., then the leading N-by-N part -C of this array contains the matrix Q updated in the -C submatrix Q(ILOQ:IHIQ,ILO:IHI). -C If WANTQ = .FALSE., Q is not referenced. -C -C LDQ INTEGER -C The leading dimension of the array Q. LDQ >= 1. -C If WANTQ = .TRUE., LDQ >= MAX(1,N). -C -C Z (input/output) DOUBLE PRECISION array, dimension (LDZ,N) -C On entry, if WANTZ = .TRUE., then the leading N-by-N part -C of this array must contain the current matrix Z of -C transformations accumulated by MB03XP. -C On exit, if WANTZ = .TRUE., then the leading N-by-N part -C of this array contains the matrix Z updated in the -C submatrix Z(ILOQ:IHIQ,ILO:IHI). -C If WANTZ = .FALSE., Z is not referenced. -C -C LDZ INTEGER -C The leading dimension of the array Z. LDZ >= 1. -C If WANTZ = .TRUE., LDZ >= MAX(1,N). -C -C Error Indicator -C -C INFO INTEGER -C = 0: successful exit; -C < 0: if INFO = -i, the i-th argument had an illegal -C value. -C -C METHOD -C -C The method is illustrated by Wilkinson diagrams for N = 5, -C POS = 3: -C -C [ x x x x x ] [ x x x x x ] -C [ x x x x x ] [ o x x x x ] -C A = [ o x x x x ], B = [ o o o x x ]. -C [ o o x x x ] [ o o o x x ] -C [ o o o x x ] [ o o o o x ] -C -C First, a QR factorization is applied to A(1:3,1:3) and the -C resulting nonzero in the updated matrix B is immediately -C annihilated by a Givens rotation acting on columns 1 and 2: -C -C [ x x x x x ] [ x x x x x ] -C [ x x x x x ] [ o x x x x ] -C A = [ o o x x x ], B = [ o o o x x ]. -C [ o o x x x ] [ o o o x x ] -C [ o o o x x ] [ o o o o x ] -C -C Secondly, an RQ factorization is applied to A(4:5,4:5) and the -C resulting nonzero in the updated matrix B is immediately -C annihilated by a Givens rotation acting on rows 4 and 5: -C -C [ x x x x x ] [ x x x x x ] -C [ x x x x x ] [ o x x x x ] -C A = [ o o x x x ], B = [ o o o x x ]. -C [ o o o x x ] [ o o o x x ] -C [ o o o x x ] [ o o o o x ] -C -C REFERENCES -C -C [1] Bojanczyk, A.W., Golub, G.H., and Van Dooren, P. -C The periodic Schur decomposition: Algorithms and applications. -C Proc. of the SPIE Conference (F.T. Luk, Ed.), 1770, pp. 31-42, -C 1992. -C -C NUMERICAL ASPECTS -C -C The algorithm requires O(N**2) floating point operations and is -C backward stable. -C -C CONTRIBUTORS -C -C D. Kressner, Technical Univ. Berlin, Germany, and -C P. Benner, Technical Univ. Chemnitz, Germany, December 2003. -C -C REVISIONS -C -C V. Sima, June 2008 (SLICOT version of the HAPACK routine DLADFB). -C -C ****************************************************************** -C -C .. Parameters .. - DOUBLE PRECISION ZERO - PARAMETER ( ZERO = 0.0D+0 ) -C .. Scalar Arguments .. - LOGICAL WANTQ, WANTT, WANTZ - INTEGER IHI, IHIQ, ILO, ILOQ, INFO, LDA, LDB, LDQ, LDZ, - $ N, POS -C .. Array Arguments .. - DOUBLE PRECISION A(LDA,*), B(LDB,*), Q(LDQ,*), Z(LDZ,*) -C .. Local Scalars .. - INTEGER I1, I2, J, NQ - DOUBLE PRECISION CS, SN, TEMP -C .. External Subroutines .. - EXTERNAL DLARTG, DROT, XERBLA -C .. Intrinsic Functions .. - INTRINSIC MAX, MIN -C -C .. Executable Statements .. -C -C Check the scalar input parameters. -C - INFO = 0 - NQ = IHIQ - ILOQ + 1 - IF ( N.LT.0 ) THEN - INFO = -4 - ELSE IF ( ILO.LT.1 .OR. ILO.GT.MAX( 1, N ) ) THEN - INFO = -5 - ELSE IF ( IHI.LT.MIN( ILO, N ) .OR. IHI.GT.N ) THEN - INFO = -6 - ELSE IF ( ILOQ.LT.1 .OR. ILOQ.GT.ILO ) THEN - INFO = -7 - ELSE IF ( IHIQ.LT.IHI .OR. IHIQ.GT.N ) THEN - INFO = -8 - ELSE IF ( POS.LT.ILO .OR. POS.GT.IHI ) THEN - INFO = -9 - ELSE IF ( LDA.LT.MAX( 1, N ) ) THEN - INFO = -11 - ELSE IF ( LDB.LT.MAX( 1, N ) ) THEN - INFO = -13 - ELSE IF ( LDQ.LT.1 .OR. WANTQ .AND. LDQ.LT.N ) THEN - INFO = -15 - ELSE IF ( LDZ.LT.1 .OR. WANTZ .AND. LDZ.LT.N ) THEN - INFO = -17 - END IF -C -C Return if there were illegal values. -C - IF ( INFO.NE.0 ) THEN - CALL XERBLA( 'MB03YA', -INFO ) - RETURN - END IF -C -C Quick return if possible. -C - IF ( N.EQ.0 ) - $ RETURN -C - IF ( WANTT ) THEN - I1 = 1 - I2 = N - ELSE - I1 = ILO - I2 = IHI - END IF -C -C Apply a zero-shifted QR step. -C - DO 10 J = ILO, POS-1 - TEMP = A(J,J) - CALL DLARTG( TEMP, A(J+1,J), CS, SN, A(J,J) ) - A(J+1,J) = ZERO - CALL DROT( I2-J, A(J,J+1), LDA, A(J+1,J+1), LDA, CS, SN ) - CALL DROT( MIN(J,POS-2)-I1+2, B(I1,J), 1, B(I1,J+1), 1, CS, - $ SN ) - IF ( WANTQ ) - $ CALL DROT( NQ, Q(ILOQ,J), 1, Q(ILOQ,J+1), 1, CS, SN ) - 10 CONTINUE - DO 20 J = ILO, POS-2 - TEMP = B(J,J) - CALL DLARTG( TEMP, B(J+1,J), CS, SN, B(J,J) ) - B(J+1,J) = ZERO - CALL DROT( I2-J, B(J,J+1), LDB, B(J+1,J+1), LDB, CS, SN ) - CALL DROT( J-I1+2, A(I1,J), 1, A(I1,J+1), 1, CS, SN ) - IF ( WANTZ ) - $ CALL DROT( NQ, Z(ILOQ,J), 1, Z(ILOQ,J+1), 1, CS, SN ) - 20 CONTINUE -C -C Apply a zero-shifted RQ step. -C - DO 30 J = IHI, POS+1, -1 - TEMP = A(J,J) - CALL DLARTG( TEMP, A(J,J-1), CS, SN, A(J,J) ) - A(J,J-1) = ZERO - SN = -SN - CALL DROT( J-I1, A(I1,J-1), 1, A(I1,J), 1, CS, SN ) - CALL DROT( I2 - MAX( J-1,POS+1 ) + 1, B(J-1,MAX( J-1,POS+1 )), - $ LDB, B(J,MAX(J-1,POS+1)), LDB, CS, SN ) - IF ( WANTZ ) - $ CALL DROT( NQ, Z(ILOQ,J-1), 1, Z(ILOQ,J), 1, CS, SN ) - 30 CONTINUE - DO 40 J = IHI, POS+2, -1 - TEMP = B(J,J) - CALL DLARTG( TEMP, B(J,J-1), CS, SN, B(J,J) ) - B(J,J-1) = ZERO - SN = -SN - CALL DROT( J-I1, B(I1,J-1), 1, B(I1,J), 1, CS, SN ) - CALL DROT( I2-J+2, A(J-1,J-1), LDA, A(J,J-1), LDA, CS, SN ) - IF ( WANTQ ) - $ CALL DROT( NQ, Q(ILOQ,J-1), 1, Q(ILOQ,J), 1, CS, SN ) - 40 CONTINUE - RETURN -C *** Last line of MB03YA *** - END diff --git a/mex/sources/libslicot/MB03YD.f b/mex/sources/libslicot/MB03YD.f deleted file mode 100644 index e99078cdb..000000000 --- a/mex/sources/libslicot/MB03YD.f +++ /dev/null @@ -1,540 +0,0 @@ - SUBROUTINE MB03YD( WANTT, WANTQ, WANTZ, N, ILO, IHI, ILOQ, IHIQ, - $ A, LDA, B, LDB, Q, LDQ, Z, LDZ, ALPHAR, ALPHAI, - $ BETA, DWORK, LDWORK, INFO ) -C -C SLICOT RELEASE 5.0. -C -C Copyright (c) 2002-2009 NICONET e.V. -C -C This program is free software: you can redistribute it and/or -C modify it under the terms of the GNU General Public License as -C published by the Free Software Foundation, either version 2 of -C the License, or (at your option) any later version. -C -C This program is distributed in the hope that it will be useful, -C but WITHOUT ANY WARRANTY; without even the implied warranty of -C MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the -C GNU General Public License for more details. -C -C You should have received a copy of the GNU General Public License -C along with this program. If not, see -C . -C -C PURPOSE -C -C To deal with small subtasks of the product eigenvalue problem. -C -C MB03YD is an auxiliary routine called by SLICOT Library routine -C MB03XP. -C -C ARGUMENTS -C -C Mode Parameters -C -C WANTT LOGICAL -C Indicates whether the user wishes to compute the full -C Schur form or the eigenvalues only, as follows: -C = .TRUE. : Compute the full Schur form; -C = .FALSE.: compute the eigenvalues only. -C -C WANTQ LOGICAL -C Indicates whether or not the user wishes to accumulate -C the matrix Q as follows: -C = .TRUE. : The matrix Q is updated; -C = .FALSE.: the matrix Q is not required. -C -C WANTZ LOGICAL -C Indicates whether or not the user wishes to accumulate -C the matrix Z as follows: -C = .TRUE. : The matrix Z is updated; -C = .FALSE.: the matrix Z is not required. -C -C Input/Output Parameters -C -C N (input) INTEGER -C The order of the matrices A and B. N >= 0. -C -C ILO (input) INTEGER -C IHI (input) INTEGER -C It is assumed that the matrices A and B are already -C (quasi) upper triangular in rows and columns 1:ILO-1 and -C IHI+1:N. The routine works primarily with the submatrices -C in rows and columns ILO to IHI, but applies the -C transformations to all the rows and columns of the -C matrices A and B, if WANTT = .TRUE.. -C 1 <= ILO <= max(1,N); min(ILO,N) <= IHI <= N. -C -C ILOQ (input) INTEGER -C IHIQ (input) INTEGER -C Specify the rows of Q and Z to which transformations -C must be applied if WANTQ = .TRUE. and WANTZ = .TRUE., -C respectively. -C 1 <= ILOQ <= ILO; IHI <= IHIQ <= N. -C -C A (input/output) DOUBLE PRECISION array, dimension (LDA,N) -C On entry, the leading N-by-N part of this array must -C contain the upper Hessenberg matrix A. -C On exit, if WANTT = .TRUE., the leading N-by-N part of -C this array is upper quasi-triangular in rows and columns -C ILO:IHI. -C If WANTT = .FALSE., the diagonal elements and 2-by-2 -C diagonal blocks of A will be correct, but the remaining -C parts of A are unspecified on exit. -C -C LDA INTEGER -C The leading dimension of the array A. LDA >= MAX(1,N). -C -C B (input/output) DOUBLE PRECISION array, dimension (LDB,N) -C On entry, the leading N-by-N part of this array must -C contain the upper triangular matrix B. -C On exit, if WANTT = .TRUE., the leading N-by-N part of -C this array contains the transformed upper triangular -C matrix. 2-by-2 blocks in B corresponding to 2-by-2 blocks -C in A will be reduced to positive diagonal form. (I.e., if -C A(j+1,j) is non-zero, then B(j+1,j)=B(j,j+1)=0 and B(j,j) -C and B(j+1,j+1) will be positive.) -C If WANTT = .FALSE., the elements corresponding to diagonal -C elements and 2-by-2 diagonal blocks in A will be correct, -C but the remaining parts of B are unspecified on exit. -C -C LDB INTEGER -C The leading dimension of the array B. LDB >= MAX(1,N). -C -C Q (input/output) DOUBLE PRECISION array, dimension (LDQ,N) -C On entry, if WANTQ = .TRUE., then the leading N-by-N part -C of this array must contain the current matrix Q of -C transformations accumulated by MB03XP. -C On exit, if WANTQ = .TRUE., then the leading N-by-N part -C of this array contains the matrix Q updated in the -C submatrix Q(ILOQ:IHIQ,ILO:IHI). -C If WANTQ = .FALSE., Q is not referenced. -C -C LDQ INTEGER -C The leading dimension of the array Q. LDQ >= 1. -C If WANTQ = .TRUE., LDQ >= MAX(1,N). -C -C Z (input/output) DOUBLE PRECISION array, dimension (LDZ,N) -C On entry, if WANTZ = .TRUE., then the leading N-by-N part -C of this array must contain the current matrix Z of -C transformations accumulated by MB03XP. -C On exit, if WANTZ = .TRUE., then the leading N-by-N part -C of this array contains the matrix Z updated in the -C submatrix Z(ILOQ:IHIQ,ILO:IHI). -C If WANTZ = .FALSE., Z is not referenced. -C -C LDZ INTEGER -C The leading dimension of the array Z. LDZ >= 1. -C If WANTZ = .TRUE., LDZ >= MAX(1,N). -C -C ALPHAR (output) DOUBLE PRECISION array, dimension (N) -C ALPHAI (output) DOUBLE PRECISION array, dimension (N) -C BETA (output) DOUBLE PRECISION array, dimension (N) -C The i-th (ILO <= i <= IHI) computed eigenvalue is given -C by BETA(I) * ( ALPHAR(I) + sqrt(-1)*ALPHAI(I) ). If two -C eigenvalues are computed as a complex conjugate pair, -C they are stored in consecutive elements of ALPHAR, ALPHAI -C and BETA. If WANTT = .TRUE., the eigenvalues are stored in -C the same order as on the diagonals of the Schur forms of -C A and B. -C -C Workspace -C -C DWORK DOUBLE PRECISION array, dimension (LDWORK) -C On exit, if INFO = -19, DWORK(1) returns the minimum -C value of LDWORK. -C -C LDWORK INTEGER -C The length of the array DWORK. LDWORK >= MAX(1,N). -C -C Error Indicator -C -C INFO INTEGER -C = 0: successful exit; -C < 0: if INFO = -i, the i-th argument had an illegal -C value; -C > 0: if INFO = i, then MB03YD failed to compute the Schur -C form in a total of 30*(IHI-ILO+1) iterations; -C elements i+1:n of ALPHAR, ALPHAI and BETA contain -C successfully computed eigenvalues. -C -C METHOD -C -C The implemented algorithm is a double-shift version of the -C periodic QR algorithm described in [1,3] with some minor -C modifications [2]. The eigenvalues are computed via an implicit -C complex single shift algorithm. -C -C REFERENCES -C -C [1] Bojanczyk, A.W., Golub, G.H., and Van Dooren, P. -C The periodic Schur decomposition: Algorithms and applications. -C Proc. of the SPIE Conference (F.T. Luk, Ed.), 1770, pp. 31-42, -C 1992. -C -C [2] Kressner, D. -C An efficient and reliable implementation of the periodic QZ -C algorithm. Proc. of the IFAC Workshop on Periodic Control -C Systems, pp. 187-192, 2001. -C -C [3] Van Loan, C. -C Generalized Singular Values with Algorithms and Applications. -C Ph. D. Thesis, University of Michigan, 1973. -C -C NUMERICAL ASPECTS -C -C The algorithm requires O(N**3) floating point operations and is -C backward stable. -C -C CONTRIBUTORS -C -C D. Kressner, Technical Univ. Berlin, Germany, and -C P. Benner, Technical Univ. Chemnitz, Germany, December 2003. -C -C REVISIONS -C -C V. Sima, June 2008 (SLICOT version of the HAPACK routine DLAPQR). -C -C KEYWORDS -C -C Eigenvalue, eigenvalue decomposition, Hessenberg form, orthogonal -C transformation, (periodic) Schur form -C -C ****************************************************************** -C -C .. Parameters .. - DOUBLE PRECISION ZERO, ONE - PARAMETER ( ZERO = 0.0D+0, ONE = 1.0D+0 ) -C .. Scalar Arguments .. - LOGICAL WANTQ, WANTT, WANTZ - INTEGER IHI, IHIQ, ILO, ILOQ, INFO, LDA, LDB, LDQ, - $ LDWORK, LDZ, N -C .. Array Arguments .. - DOUBLE PRECISION A(LDA,*), ALPHAI(*), ALPHAR(*), B(LDB,*), - $ BETA(*), DWORK(*), Q(LDQ,*), Z(LDZ,*) -C .. Local Scalars .. - INTEGER I, I1, I2, ITN, ITS, K, KK, L, NH, NQ, NR - DOUBLE PRECISION ALPHA, BETAX, CS1, CS2, CS3, DELTA, GAMMA, - $ OVFL, SMLNUM, SN1, SN2, SN3, TAUV, TAUW, - $ TEMP, TST, ULP, UNFL -C .. Local Arrays .. - INTEGER ISEED(4) - DOUBLE PRECISION V(3), W(3) -C .. External Functions .. - DOUBLE PRECISION DLAMCH, DLANHS - EXTERNAL DLAMCH, DLANHS -C .. External Subroutines .. - EXTERNAL DCOPY, DLABAD, DLARFG, DLARFX, DLARNV, DLARTG, - $ DROT, MB03YA, MB03YT, XERBLA -C .. Intrinsic Functions .. - INTRINSIC ABS, DBLE, MAX, MIN -C -C .. Executable Statements .. -C -C Check the scalar input parameters. -C - INFO = 0 - NH = IHI - ILO + 1 - NQ = IHIQ - ILOQ + 1 - IF ( N.LT.0 ) THEN - INFO = -4 - ELSE IF ( ILO.LT.1 .OR. ILO.GT.MAX( 1, N ) ) THEN - INFO = -5 - ELSE IF ( IHI.LT.MIN( ILO, N ) .OR. IHI.GT.N ) THEN - INFO = -6 - ELSE IF ( ILOQ.LT.1 .OR. ILOQ.GT.ILO ) THEN - INFO = -7 - ELSE IF ( IHIQ.LT.IHI .OR. IHIQ.GT.N ) THEN - INFO = -8 - ELSE IF ( LDA.LT.MAX( 1, N ) ) THEN - INFO = -10 - ELSE IF ( LDB.LT.MAX( 1, N ) ) THEN - INFO = -12 - ELSE IF ( LDQ.LT.1 .OR. WANTQ .AND. LDQ.LT.N ) THEN - INFO = -14 - ELSE IF ( LDZ.LT.1 .OR. WANTZ .AND. LDZ.LT.N ) THEN - INFO = -16 - ELSE IF ( LDWORK.LT.MAX( 1, N ) ) THEN - DWORK(1) = DBLE( MAX( 1, N ) ) - INFO = -21 - END IF -C -C Return if there were illegal values. -C - IF ( INFO.NE.0 ) THEN - CALL XERBLA( 'MB03YD', -INFO ) - RETURN - END IF -C -C Quick return if possible. -C - IF ( N.EQ.0 ) - $ RETURN -C -C Set machine-dependent constants for the stopping criterion. -C - UNFL = DLAMCH( 'Safe minimum' ) - OVFL = ONE / UNFL - CALL DLABAD( UNFL, OVFL ) - ULP = DLAMCH( 'Precision' ) - SMLNUM = UNFL*( NH / ULP ) -C -C I1 and I2 are the indices of the first rows and last columns of -C A and B to which transformations must be applied. -C - I1 = 1 - I2 = N - ISEED(1) = 1 - ISEED(2) = 0 - ISEED(3) = 0 - ISEED(4) = 1 -C -C ITN is the maximal number of QR iterations. -C - ITN = 30*NH -C -C Main loop. Eigenvalues I+1:IHI have converged. Either L = ILO -C or A(L,L-1) is negligible. -C - I = IHI - 10 CONTINUE - L = ILO - IF ( I.LT.ILO ) - $ GO TO 120 -C -C Perform periodic QR iteration on rows and columns ILO to I of A -C and B until a submatrix of order 1 or 2 splits off at the bottom. -C - DO 70 ITS = 0, ITN -C -C Look for deflations in A. -C - DO 20 K = I, L + 1, -1 - TST = ABS( A(K-1,K-1) ) + ABS( A(K,K) ) - IF ( TST.EQ.ZERO ) - $ TST = DLANHS( '1', I-L+1, A(L,L), LDA, DWORK ) - IF ( ABS( A(K,K-1) ).LE.MAX( ULP*TST, SMLNUM ) ) - $ GO TO 30 - 20 CONTINUE - 30 CONTINUE -C -C Look for deflation in B if problem size is greater than 1. -C - IF ( I-K.GE.1 ) THEN - DO 40 KK = I, K, -1 - IF ( KK.EQ.I ) THEN - TST = ABS( B(KK-1,KK) ) - ELSE IF ( KK.EQ.K ) THEN - TST = ABS( B(KK,KK+1) ) - ELSE - TST = ABS( B(KK-1,KK) ) + ABS( B(KK,KK+1) ) - END IF - IF ( TST.EQ.ZERO ) - $ TST = DLANHS( '1', I-K+1, B(K,K), LDB, DWORK ) - IF ( ABS( B(KK,KK) ).LE.MAX( ULP*TST, SMLNUM ) ) - $ GO TO 50 - 40 CONTINUE - ELSE - KK = K-1 - END IF - 50 CONTINUE - IF ( KK.GE.K ) THEN -C -C B has an element close to zero at position (KK,KK). -C - B(KK,KK) = ZERO - CALL MB03YA( WANTT, WANTQ, WANTZ, N, K, I, ILOQ, IHIQ, KK, - $ A, LDA, B, LDB, Q, LDQ, Z, LDZ, INFO ) - K = KK+1 - END IF - L = K - IF( L.GT.ILO ) THEN -C -C A(L,L-1) is negligible. -C - A(L,L-1) = ZERO - END IF -C -C Exit from loop if a submatrix of order 1 or 2 has split off. -C - IF ( L.GE.I-1 ) - $ GO TO 80 -C -C The active submatrices are now in rows and columns L:I. -C - IF ( .NOT.WANTT ) THEN - I1 = L - I2 = I - END IF - IF ( ITS.EQ.10.OR.ITS.EQ.20 ) THEN -C -C Exceptional shift. The first column of the shift polynomial -C is a pseudo-random vector. -C - CALL DLARNV( 3, ISEED, 3, V ) - ELSE -C -C The implicit double shift is constructed via a partial -C product QR factorization [2]. -C - CALL DLARTG( B(L,L), B(I,I), CS2, SN2, TEMP ) - CALL DLARTG( TEMP, B(I-1,I), CS1, SN1, ALPHA ) -C - ALPHA = A(L,L)*CS2 - A(I,I)*SN2 - BETAX = CS1*( CS2*A(L+1,L) ) - GAMMA = CS1*( SN2*A(I-1,I) ) + SN1*A(I-1,I-1) - ALPHA = ALPHA*CS1 - A(I,I-1)*SN1 - CALL DLARTG( ALPHA, BETAX, CS1, SN1, TEMP ) -C - CALL DLARTG( TEMP, GAMMA, CS2, SN2, ALPHA ) - ALPHA = CS2 - GAMMA = ( A(I-1,I-1)*CS1 )*CS2 + A(I,I-1)*SN2 - DELTA = ( A(I-1,I-1)*SN1 )*CS2 - CALL DLARTG( GAMMA, DELTA, CS3, SN3, TEMP ) - CALL DLARTG( ALPHA, TEMP, CS2, SN2, ALPHA ) -C - ALPHA = ( B(L,L)*CS1 + B(L,L+1)*SN1 )*CS2 - BETAX = ( B(L+1,L+1)*SN1 )*CS2 - GAMMA = B(I-1,I-1)*SN2 - CALL DLARTG( ALPHA, BETAX, CS1, SN1, TEMP ) - CALL DLARTG( TEMP, GAMMA, CS2, SN2, ALPHA ) -C - ALPHA = CS1*A(L,L) + SN1*A(L,L+1) - BETAX = CS1*A(L+1,L) + SN1*A(L+1,L+1) - GAMMA = SN1*A(L+2,L+1) -C - V(1) = CS2*ALPHA - SN2*CS3 - V(2) = CS2*BETAX - SN2*SN3 - V(3) = GAMMA*CS2 - END IF -C -C Double-shift QR step -C - DO 60 K = L, I-1 -C - NR = MIN( 3,I-K+1 ) - IF ( K.GT.L ) - $ CALL DCOPY( NR, A(K,K-1), 1, V, 1 ) - CALL DLARFG( NR, V(1), V(2), 1, TAUV ) - IF ( K.GT.L ) THEN - A(K,K-1) = V(1) - A(K+1,K-1) = ZERO - IF ( K.LT.I-1 ) - $ A(K+2,K-1) = ZERO - END IF -C -C Apply reflector V from the right to B in rows I1:min(K+2,I). -C - V(1) = ONE - CALL DLARFX( 'Right', MIN(K+2,I)-I1+1, NR, V, TAUV, B(I1,K), - $ LDB, DWORK ) -C -C Annihilate the introduced nonzeros in the K-th column. -C - CALL DCOPY( NR, B(K,K), 1, W, 1 ) - CALL DLARFG( NR, W(1), W(2), 1, TAUW ) - B(K,K) = W(1) - B(K+1,K) = ZERO - IF ( K.LT.I-1 ) - $ B(K+2,K) = ZERO -C -C Apply reflector W from the left to transform the rows of the -C matrix B in columns K+1:I2. -C - W(1) = ONE - CALL DLARFX( 'Left', NR, I2-K, W, TAUW, B(K,K+1), LDB, - $ DWORK ) -C -C Apply reflector V from the left to transform the rows of the -C matrix A in columns K:I2. -C - CALL DLARFX( 'Left', NR, I2-K+1, V, TAUV, A(K,K), LDA, - $ DWORK ) -C -C Apply reflector W from the right to transform the columns of -C the matrix A in rows I1:min(K+3,I). -C - CALL DLARFX( 'Right', MIN(K+3,I)-I1+1, NR, W, TAUW, A(I1,K), - $ LDA, DWORK ) -C -C Accumulate transformations in the matrices Q and Z. -C - IF ( WANTQ ) - $ CALL DLARFX( 'Right', NQ, NR, V, TAUV, Q(ILOQ,K), LDQ, - $ DWORK ) - IF ( WANTZ ) - $ CALL DLARFX( 'Right', NQ, NR, W, TAUW, Z(ILOQ,K), LDZ, - $ DWORK ) - 60 CONTINUE - 70 CONTINUE -C -C Failure to converge. -C - INFO = I - RETURN -C - 80 CONTINUE -C -C Compute 1-by-1 or 2-by-2 subproblem. -C - IF ( L.EQ.I ) THEN -C -C Standardize B, set ALPHAR, ALPHAI and BETA. -C - IF ( B(I,I).LT.ZERO ) THEN - IF ( WANTT ) THEN - DO 90 K = I1, I - B(K,I) = -B(K,I) - 90 CONTINUE - DO 100 K = I, I2 - A(I,K) = -A(I,K) - 100 CONTINUE - ELSE - B(I,I) = -B(I,I) - A(I,I) = -A(I,I) - END IF - IF ( WANTQ ) THEN - DO 110 K = ILOQ, IHIQ - Q(K,I) = -Q(K,I) - 110 CONTINUE - END IF - END IF - ALPHAR(I) = A(I,I) - ALPHAI(I) = ZERO - BETA(I) = B(I,I) - ELSE IF( L.EQ.I-1 ) THEN -C -C A double block has converged. -C Compute eigenvalues and standardize double block. -C - CALL MB03YT( A(I-1,I-1), LDA, B(I-1,I-1), LDB, ALPHAR(I-1), - $ ALPHAI(I-1), BETA(I-1), CS1, SN1, CS2, SN2 ) -C -C Apply transformation to rest of A and B. -C - IF ( I2.GT.I ) - $ CALL DROT( I2-I, A(I-1,I+1), LDA, A(I,I+1), LDA, CS1, SN1 ) - CALL DROT( I-I1-1, A(I1,I-1), 1, A(I1,I), 1, CS2, SN2 ) - IF ( I2.GT.I ) - $ CALL DROT( I2-I, B(I-1,I+1), LDB, B(I,I+1), LDB, CS2, SN2 ) - CALL DROT( I-I1-1, B(I1,I-1), 1, B(I1,I), 1, CS1, SN1 ) -C -C Apply transformation to rest of Q and Z if desired. -C - IF ( WANTQ ) - $ CALL DROT( NQ, Q(ILOQ,I-1), 1, Q(ILOQ,I), 1, CS1, SN1 ) - IF ( WANTZ ) - $ CALL DROT( NQ, Z(ILOQ,I-1), 1, Z(ILOQ,I), 1, CS2, SN2 ) - END IF -C -C Decrement number of remaining iterations, and return to start of -C the main loop with new value of I. -C - ITN = ITN - ITS - I = L - 1 - GO TO 10 -C - 120 CONTINUE - DWORK(1) = DBLE( MAX( 1, N ) ) - RETURN -C *** Last line of MB03YD *** - END diff --git a/mex/sources/libslicot/MB03YT.f b/mex/sources/libslicot/MB03YT.f deleted file mode 100644 index 774b0bdda..000000000 --- a/mex/sources/libslicot/MB03YT.f +++ /dev/null @@ -1,331 +0,0 @@ - SUBROUTINE MB03YT( A, LDA, B, LDB, ALPHAR, ALPHAI, BETA, CSL, SNL, - $ CSR, SNR ) -C -C SLICOT RELEASE 5.0. -C -C Copyright (c) 2002-2009 NICONET e.V. -C -C This program is free software: you can redistribute it and/or -C modify it under the terms of the GNU General Public License as -C published by the Free Software Foundation, either version 2 of -C the License, or (at your option) any later version. -C -C This program is distributed in the hope that it will be useful, -C but WITHOUT ANY WARRANTY; without even the implied warranty of -C MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the -C GNU General Public License for more details. -C -C You should have received a copy of the GNU General Public License -C along with this program. If not, see -C . -C -C PURPOSE -C -C To compute the periodic Schur factorization of a real 2-by-2 -C matrix pair (A,B) where B is upper triangular. This routine -C computes orthogonal (rotation) matrices given by CSL, SNL and CSR, -C SNR such that -C -C 1) if the pair (A,B) has two real eigenvalues, then -C -C [ a11 a12 ] := [ CSL SNL ] [ a11 a12 ] [ CSR -SNR ] -C [ 0 a22 ] [ -SNL CSL ] [ a21 a22 ] [ SNR CSR ] -C -C [ b11 b12 ] := [ CSR SNR ] [ b11 b12 ] [ CSL -SNL ] -C [ 0 b22 ] [ -SNR CSR ] [ 0 b22 ] [ SNL CSL ], -C -C 2) if the pair (A,B) has a pair of complex conjugate eigenvalues, -C then -C -C [ a11 a12 ] := [ CSL SNL ] [ a11 a12 ] [ CSR -SNR ] -C [ a21 a22 ] [ -SNL CSL ] [ a21 a22 ] [ SNR CSR ] -C -C [ b11 0 ] := [ CSR SNR ] [ b11 b12 ] [ CSL -SNL ] -C [ 0 b22 ] [ -SNR CSR ] [ 0 b22 ] [ SNL CSL ]. -C -C This is a modified version of the LAPACK routine DLAGV2 for -C computing the real, generalized Schur decomposition of a -C two-by-two matrix pencil. -C -C ARGUMENTS -C -C Input/Output Parameters -C -C A (input/output) DOUBLE PRECISION array, dimension (LDA,2) -C On entry, the leading 2-by-2 part of this array must -C contain the matrix A. -C On exit, the leading 2-by-2 part of this array contains -C the matrix A of the pair in periodic Schur form. -C -C LDA INTEGER -C The leading dimension of the array A. LDA >= 2. -C -C B (input/output) DOUBLE PRECISION array, dimension (LDB,2) -C On entry, the leading 2-by-2 part of this array must -C contain the upper triangular matrix B. -C On exit, the leading 2-by-2 part of this array contains -C the matrix B of the pair in periodic Schur form. -C -C LDB INTEGER -C The leading dimension of the array B. LDB >= 2. -C -C ALPHAR (output) DOUBLE PRECISION array, dimension (2) -C ALPHAI (output) DOUBLE PRECISION array, dimension (2) -C BETA (output) DOUBLE PRECISION array, dimension (2) -C (ALPHAR(k)+i*ALPHAI(k))*BETA(k) are the eigenvalues of the -C pair (A,B), k=1,2, i = sqrt(-1). ALPHAI(1) >= 0. -C -C CSL (output) DOUBLE PRECISION -C The cosine of the first rotation matrix. -C -C SNL (output) DOUBLE PRECISION -C The sine of the first rotation matrix. -C -C CSR (output) DOUBLE PRECISION -C The cosine of the second rotation matrix. -C -C SNR (output) DOUBLE PRECISION -C The sine of the second rotation matrix. -C -C REFERENCES -C -C [1] Van Loan, C. -C Generalized Singular Values with Algorithms and Applications. -C Ph. D. Thesis, University of Michigan, 1973. -C -C CONTRIBUTORS -C -C D. Kressner, Technical Univ. Berlin, Germany, and -C P. Benner, Technical Univ. Chemnitz, Germany, December 2003. -C -C REVISIONS -C -C V. Sima, June 2008 (SLICOT version of the HAPACK routine DLAPV2). -C V. Sima, July 2008, May 2009. -C -C KEYWORDS -C -C Eigenvalue, periodic Schur form -C -C ****************************************************************** -C -C .. Parameters .. - DOUBLE PRECISION ZERO, ONE - PARAMETER ( ZERO = 0.0D0, ONE = 1.0D0 ) -C .. Scalar Arguments .. - INTEGER LDA, LDB - DOUBLE PRECISION CSL, CSR, SNL, SNR -C .. Array Arguments .. - DOUBLE PRECISION A(LDA,*), ALPHAI(2), ALPHAR(2), B(LDB,*), - $ BETA(2) -C .. Local Scalars .. - DOUBLE PRECISION ANORM, BNORM, H1, H2, H3, QQ, R, RR, SAFMIN, - $ SCALE1, SCALE2, T, ULP, WI, WR1, WR2 -C .. External Functions .. - DOUBLE PRECISION DLAMCH, DLAPY2 - EXTERNAL DLAMCH, DLAPY2 -C .. External Subroutines .. - EXTERNAL DLAG2, DLARTG, DLASV2, DROT -C .. Intrinsic Functions .. - INTRINSIC ABS, MAX -C -C .. Executable Statements .. -C - SAFMIN = DLAMCH( 'S' ) - ULP = DLAMCH( 'P' ) -C -C Scale A. -C - ANORM = MAX( ABS( A(1,1) ) + ABS( A(2,1) ), - $ ABS( A(1,2) ) + ABS( A(2,2) ), SAFMIN ) - A(1,1) = A(1,1) / ANORM - A(1,2) = A(1,2) / ANORM - A(2,1) = A(2,1) / ANORM - A(2,2) = A(2,2) / ANORM -C -C Scale B. -C - BNORM = MAX( ABS( B(1,1) ), ABS( B(1,2) ) + ABS( B(2,2) ), SAFMIN) - B(1,1) = B(1,1) / BNORM - B(1,2) = B(1,2) / BNORM - B(2,2) = B(2,2) / BNORM -C -C Check if A can be deflated. -C - IF ( ABS( A(2,1) ).LE.ULP ) THEN - CSL = ONE - SNL = ZERO - CSR = ONE - SNR = ZERO - WI = ZERO - A(2,1) = ZERO - B(2,1) = ZERO -C -C Check if B is singular. -C - ELSE IF ( ABS( B(1,1) ).LE.ULP ) THEN - CALL DLARTG( A(2,2), A(2,1), CSR, SNR, T ) - SNR = -SNR - CALL DROT( 2, A(1,1), 1, A(1,2), 1, CSR, SNR ) - CALL DROT( 2, B(1,1), LDB, B(2,1), LDB, CSR, SNR ) - CSL = ONE - SNL = ZERO - WI = ZERO - A(2,1) = ZERO - B(1,1) = ZERO - B(2,1) = ZERO - ELSE IF( ABS( B(2,2) ).LE.ULP ) THEN - CALL DLARTG( A(1,1), A(2,1), CSL, SNL, R ) - CSR = ONE - SNR = ZERO - WI = ZERO - CALL DROT( 2, A(1,1), LDA, A(2,1), LDA, CSL, SNL ) - CALL DROT( 2, B(1,1), 1, B(1,2), 1, CSL, SNL ) - A(2,1) = ZERO - B(2,1) = ZERO - B(2,2) = ZERO - ELSE -C -C B is nonsingular, first compute the eigenvalues of A / adj(B). -C - R = B(1,1) - B(1,1) = B(2,2) - B(2,2) = R - B(1,2) = -B(1,2) - CALL DLAG2( A, LDA, B, LDB, SAFMIN, SCALE1, SCALE2, WR1, WR2, - $ WI ) -C - IF( WI.EQ.ZERO ) THEN -C -C Two real eigenvalues, compute s*A-w*B. -C - H1 = SCALE1*A(1,1) - WR1*B(1,1) - H2 = SCALE1*A(1,2) - WR1*B(1,2) - H3 = SCALE1*A(2,2) - WR1*B(2,2) -C - RR = DLAPY2( H1, H2 ) - QQ = DLAPY2( SCALE1*A(2,1), H3 ) -C - IF ( RR.GT.QQ ) THEN -C -C Find right rotation matrix to zero 1,1 element of -C (sA - wB). -C - CALL DLARTG( H2, H1, CSR, SNR, T ) -C - ELSE -C -C Find right rotation matrix to zero 2,1 element of -C (sA - wB). -C - CALL DLARTG( H3, SCALE1*A(2,1), CSR, SNR, T ) -C - END IF -C - SNR = -SNR - CALL DROT( 2, A(1,1), 1, A(1,2), 1, CSR, SNR ) - CALL DROT( 2, B(1,1), 1, B(1,2), 1, CSR, SNR ) -C -C Compute inf norms of A and B. -C - H1 = MAX( ABS( A(1,1) ) + ABS( A(1,2) ), - $ ABS( A(2,1) ) + ABS( A(2,2) ) ) - H2 = MAX( ABS( B(1,1) ) + ABS( B(1,2) ), - $ ABS( B(2,1) ) + ABS( B(2,2) ) ) -C - IF( ( SCALE1*H1 ).GE.ABS( WR1 )*H2 ) THEN -C -C Find left rotation matrix Q to zero out B(2,1). -C - CALL DLARTG( B(1,1), B(2,1), CSL, SNL, R ) -C - ELSE -C -C Find left rotation matrix Q to zero out A(2,1). -C - CALL DLARTG( A(1,1), A(2,1), CSL, SNL, R ) -C - END IF -C - CALL DROT( 2, A(1,1), LDA, A(2,1), LDA, CSL, SNL ) - CALL DROT( 2, B(1,1), LDB, B(2,1), LDB, CSL, SNL ) -C - A(2,1) = ZERO - B(2,1) = ZERO -C -C Re-adjoint B. -C - R = B(1,1) - B(1,1) = B(2,2) - B(2,2) = R - B(1,2) = -B(1,2) -C - ELSE -C -C A pair of complex conjugate eigenvalues: -C first compute the SVD of the matrix adj(B). -C - R = B(1,1) - B(1,1) = B(2,2) - B(2,2) = R - B(1,2) = -B(1,2) - CALL DLASV2( B(1,1), B(1,2), B(2,2), R, T, SNL, CSL, - $ SNR, CSR ) -C -C Form (A,B) := Q(A,adj(B))Z' where Q is left rotation matrix -C and Z is right rotation matrix computed from DLASV2. -C - CALL DROT( 2, A(1,1), LDA, A(2,1), LDA, CSL, SNL ) - CALL DROT( 2, B(1,1), LDB, B(2,1), LDB, CSR, SNR ) - CALL DROT( 2, A(1,1), 1, A(1,2), 1, CSR, SNR ) - CALL DROT( 2, B(1,1), 1, B(1,2), 1, CSL, SNL ) -C - B(2,1) = ZERO - B(1,2) = ZERO - END IF -C - END IF -C -C Unscaling -C - R = B(1,1) - T = B(2,2) - A(1,1) = ANORM*A(1,1) - A(2,1) = ANORM*A(2,1) - A(1,2) = ANORM*A(1,2) - A(2,2) = ANORM*A(2,2) - B(1,1) = BNORM*B(1,1) - B(2,1) = BNORM*B(2,1) - B(1,2) = BNORM*B(1,2) - B(2,2) = BNORM*B(2,2) -C - IF( WI.EQ.ZERO ) THEN - ALPHAR(1) = A(1,1) - ALPHAR(2) = A(2,2) - ALPHAI(1) = ZERO - ALPHAI(2) = ZERO - BETA(1) = B(1,1) - BETA(2) = B(2,2) - ELSE - WR1 = ANORM*WR1 - WI = ANORM*WI - IF ( ABS( WR1 ).GT.ONE .OR. WI.GT.ONE ) THEN - WR1 = WR1*R - WI = WI*R - R = ONE - END IF - IF ( ABS( WR1 ).GT.ONE .OR. ABS( WI ).GT.ONE ) THEN - WR1 = WR1*T - WI = WI*T - T = ONE - END IF - ALPHAR(1) = ( WR1 / SCALE1 )*R*T - ALPHAI(1) = ABS( ( WI / SCALE1 )*R*T ) - ALPHAR(2) = ALPHAR(1) - ALPHAI(2) = -ALPHAI(1) - BETA(1) = BNORM - BETA(2) = BNORM - END IF - RETURN -C *** Last line of MB03YT *** - END diff --git a/mex/sources/libslicot/MB03ZA.f b/mex/sources/libslicot/MB03ZA.f deleted file mode 100644 index 814525200..000000000 --- a/mex/sources/libslicot/MB03ZA.f +++ /dev/null @@ -1,1371 +0,0 @@ - SUBROUTINE MB03ZA( COMPC, COMPU, COMPV, COMPW, WHICH, SELECT, N, - $ A, LDA, B, LDB, C, LDC, U1, LDU1, U2, LDU2, V1, - $ LDV1, V2, LDV2, W, LDW, WR, WI, M, DWORK, - $ LDWORK, INFO ) -C -C SLICOT RELEASE 5.0. -C -C Copyright (c) 2002-2009 NICONET e.V. -C -C This program is free software: you can redistribute it and/or -C modify it under the terms of the GNU General Public License as -C published by the Free Software Foundation, either version 2 of -C the License, or (at your option) any later version. -C -C This program is distributed in the hope that it will be useful, -C but WITHOUT ANY WARRANTY; without even the implied warranty of -C MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the -C GNU General Public License for more details. -C -C You should have received a copy of the GNU General Public License -C along with this program. If not, see -C . -C -C PURPOSE -C -C 1. To compute, for a given matrix pair (A,B) in periodic Schur -C form, orthogonal matrices Ur and Vr so that -C -C T [ A11 A12 ] T [ B11 B12 ] -C Vr * A * Ur = [ ], Ur * B * Vr = [ ], (1) -C [ 0 A22 ] [ 0 B22 ] -C -C is in periodic Schur form, and the eigenvalues of A11*B11 -C form a selected cluster of eigenvalues. -C -C 2. To compute an orthogonal matrix W so that -C -C T [ 0 -A11 ] [ R11 R12 ] -C W * [ ] * W = [ ], (2) -C [ B11 0 ] [ 0 R22 ] -C -C where the eigenvalues of R11 and -R22 coincide and have -C positive real part. -C -C Optionally, the matrix C is overwritten by Ur'*C*Vr. -C -C All eigenvalues of A11*B11 must either be complex or real and -C negative. -C -C ARGUMENTS -C -C Mode Parameters -C -C COMPC CHARACTER*1 -C = 'U': update the matrix C; -C = 'N': do not update C. -C -C COMPU CHARACTER*1 -C = 'U': update the matrices U1 and U2; -C = 'N': do not update U1 and U2. -C See the description of U1 and U2. -C -C COMPV CHARACTER*1 -C = 'U': update the matrices V1 and V2; -C = 'N': do not update V1 and V2. -C See the description of V1 and V2. -C -C COMPW CHARACTER*1 -C Indicates whether or not the user wishes to accumulate -C the matrix W as follows: -C = 'N': the matrix W is not required; -C = 'I': W is initialized to the unit matrix and the -C orthogonal transformation matrix W is returned; -C = 'V': W must contain an orthogonal matrix Q on entry, -C and the product Q*W is returned. -C -C WHICH CHARACTER*1 -C = 'A': select all eigenvalues, this effectively means -C that Ur and Vr are identity matrices and A11 = A, -C B11 = B; -C = 'S': select a cluster of eigenvalues specified by -C SELECT. -C -C SELECT LOGICAL array, dimension (N) -C If WHICH = 'S', then SELECT specifies the eigenvalues of -C A*B in the selected cluster. To select a real eigenvalue -C w(j), SELECT(j) must be set to .TRUE.. To select a complex -C conjugate pair of eigenvalues w(j) and w(j+1), -C corresponding to a 2-by-2 diagonal block in A, both -C SELECT(j) and SELECT(j+1) must be set to .TRUE.; a complex -C conjugate pair of eigenvalues must be either both included -C in the cluster or both excluded. -C -C Input/Output Parameters -C -C N (input) INTEGER -C The order of the matrix A. N >= 0. -C -C A (input/output) DOUBLE PRECISION array, dimension (LDA,N) -C On entry, the leading N-by-N part of this array must -C contain the upper quasi-triangular matrix A of the matrix -C pair (A,B) in periodic Schur form. -C On exit, the leading M-by-M part of this array contains -C the matrix R22 in (2). -C -C LDA INTEGER -C The leading dimension of the array A. LDA >= MAX(1,N). -C -C B (input/output) DOUBLE PRECISION array, dimension (LDB,N) -C On entry, the leading N-by-N part of this array must -C contain the upper triangular matrix B of the matrix pair -C (A,B) in periodic Schur form. -C On exit, the leading N-by-N part of this array is -C overwritten. -C -C LDB INTEGER -C The leading dimension of the array B. LDB >= MAX(1,N). -C -C C (input/output) DOUBLE PRECISION array, dimension (LDC,N) -C On entry, if COMPC = 'U', the leading N-by-N part of this -C array must contain a general matrix C. -C On exit, if COMPC = 'U', the leading N-by-N part of this -C array contains the updated matrix Ur'*C*Vr. -C If COMPC = 'N' or WHICH = 'A', this array is not -C referenced. -C -C LDC INTEGER -C The leading dimension of the array C. LDC >= 1. -C LDC >= N, if COMPC = 'U' and WHICH = 'S'. -C -C U1 (input/output) DOUBLE PRECISION array, dimension (LDU1,N) -C On entry, if COMPU = 'U' and WHICH = 'S', the leading -C N-by-N part of this array must contain U1, the (1,1) -C block of an orthogonal symplectic matrix -C U = [ U1, U2; -U2, U1 ]. -C On exit, if COMPU = 'U' and WHICH = 'S', the leading -C N-by-N part of this array contains U1*Ur. -C If COMPU = 'N' or WHICH = 'A', this array is not -C referenced. -C -C LDU1 INTEGER -C The leading dimension of the array U1. LDU1 >= 1. -C LDU1 >= N, if COMPU = 'U' and WHICH = 'S'. -C -C U2 (input/output) DOUBLE PRECISION array, dimension (LDU2,N) -C On entry, if COMPU = 'U' and WHICH = 'S', the leading -C N-by-N part of this array must contain U2, the (1,2) -C block of an orthogonal symplectic matrix -C U = [ U1, U2; -U2, U1 ]. -C On exit, if COMPU = 'U' and WHICH = 'S', the leading -C N-by-N part of this array contains U2*Ur. -C If COMPU = 'N' or WHICH = 'A', this array is not -C referenced. -C -C LDU2 INTEGER -C The leading dimension of the array U2. LDU2 >= 1. -C LDU2 >= N, if COMPU = 'U' and WHICH = 'S'. -C -C V1 (input/output) DOUBLE PRECISION array, dimension (LDV1,N) -C On entry, if COMPV = 'U' and WHICH = 'S', the leading -C N-by-N part of this array must contain V1, the (1,1) -C block of an orthogonal symplectic matrix -C V = [ V1, V2; -V2, V1 ]. -C On exit, if COMPV = 'U' and WHICH = 'S', the leading -C N-by-N part of this array contains V1*Vr. -C If COMPV = 'N' or WHICH = 'A', this array is not -C referenced. -C -C LDV1 INTEGER -C The leading dimension of the array V1. LDV1 >= 1. -C LDV1 >= N, if COMPV = 'U' and WHICH = 'S'. -C -C V2 (input/output) DOUBLE PRECISION array, dimension (LDV2,N) -C On entry, if COMPV = 'U' and WHICH = 'S', the leading -C N-by-N part of this array must contain V2, the (1,2) -C block of an orthogonal symplectic matrix -C V = [ V1, V2; -V2, V1 ]. -C On exit, if COMPV = 'U' and WHICH = 'S', the leading -C N-by-N part of this array contains V2*Vr. -C If COMPV = 'N' or WHICH = 'A', this array is not -C referenced. -C -C LDV2 INTEGER -C The leading dimension of the array V2. LDV2 >= 1. -C LDV2 >= N, if COMPV = 'U' and WHICH = 'S'. -C -C W (input/output) DOUBLE PRECISION array, dimension (LDW,2*M) -C On entry, if COMPW = 'V', then the leading 2*M-by-2*M part -C of this array must contain a matrix W. -C If COMPW = 'I', then W need not be set on entry, W is set -C to the identity matrix. -C On exit, if COMPW = 'I' or 'V' the leading 2*M-by-2*M part -C of this array is post-multiplied by the transformation -C matrix that produced (2). -C If COMPW = 'N', this array is not referenced. -C -C LDW INTEGER -C The leading dimension of the array W. LDW >= 1. -C LDW >= 2*M, if COMPW = 'I' or COMPW = 'V'. -C -C WR (output) DOUBLE PRECISION array, dimension (M) -C WI (output) DOUBLE PRECISION array, dimension (M) -C The real and imaginary parts, respectively, of the -C eigenvalues of R22. The eigenvalues are stored in the same -C order as on the diagonal of R22, with -C WR(i) = R22(i,i) and, if R22(i:i+1,i:i+1) is a 2-by-2 -C diagonal block, WI(i) > 0 and WI(i+1) = -WI(i). -C In exact arithmetic, these eigenvalue are the positive -C square roots of the selected eigenvalues of the product -C A*B. However, if an eigenvalue is sufficiently -C ill-conditioned, then its value may differ significantly. -C -C M (output) INTEGER -C The number of selected eigenvalues. -C -C Workspace -C -C DWORK DOUBLE PRECISION array, dimension (LDWORK) -C On exit, if INFO = -28, DWORK(1) returns the minimum -C value of LDWORK. -C -C LDWORK INTEGER -C The length of the array DWORK. -C LDWORK >= MAX( 1, 4*N, 8*M ). -C -C Error Indicator -C -C INFO INTEGER -C = 0: successful exit; -C < 0: if INFO = -i, the i-th argument had an illegal -C value; -C = 1: reordering of the product A*B in Step 1 failed -C because some eigenvalues are too close to separate; -C = 2: reordering of some submatrix in Step 2 failed -C because some eigenvalues are too close to separate; -C = 3: the QR algorithm failed to compute the Schur form -C of some submatrix in Step 2; -C = 4: the condition that all eigenvalues of A11*B11 must -C either be complex or real and negative is -C numerically violated. -C -C METHOD -C -C Step 1 is performed using a reordering technique analogous to the -C LAPACK routine DTGSEN for reordering matrix pencils [1,2]. Step 2 -C is an implementation of Algorithm 2 in [3]. It requires O(M*N*N) -C floating point operations. -C -C REFERENCES -C -C [1] Kagstrom, B. -C A direct method for reordering eigenvalues in the generalized -C real Schur form of a regular matrix pair (A,B), in M.S. Moonen -C et al (eds), Linear Algebra for Large Scale and Real-Time -C Applications, Kluwer Academic Publ., 1993, pp. 195-218. -C -C [2] Kagstrom, B. and Poromaa P.: -C Computing eigenspaces with specified eigenvalues of a regular -C matrix pair (A, B) and condition estimation: Theory, -C algorithms and software, Numer. Algorithms, 1996, vol. 12, -C pp. 369-407. -C -C [3] Benner, P., Mehrmann, V., and Xu, H. -C A new method for computing the stable invariant subspace of a -C real Hamiltonian matrix, J. Comput. Appl. Math., 86, -C pp. 17-43, 1997. -C -C CONTRIBUTORS -C -C D. Kressner, Technical Univ. Berlin, Germany, and -C P. Benner, Technical Univ. Chemnitz, Germany, December 2003. -C -C REVISIONS -C -C V. Sima, June 2008 (SLICOT version of the HAPACK routine DLABMX). -C -C KEYWORDS -C -C Hamiltonian matrix, invariant subspace. -C -C ****************************************************************** -C -C .. Parameters .. - INTEGER LDQZ - PARAMETER ( LDQZ = 4 ) - DOUBLE PRECISION ZERO, ONE - PARAMETER ( ZERO = 0.0D0, ONE = 1.0D0 ) -C .. Scalar Arguments .. - CHARACTER COMPC, COMPU, COMPV, COMPW, WHICH - INTEGER INFO, LDA, LDB, LDC, LDU1, LDU2, LDV1, LDV2, - $ LDW, LDWORK, M, N -C .. Array Arguments .. - LOGICAL SELECT(*) - DOUBLE PRECISION A(LDA,*), B(LDB,*), C(LDC,*), DWORK(*), - $ U1(LDU1,*), U2(LDU2,*), V1(LDV1,*), V2(LDV2,*), - $ W(LDW,*), WI(*), WR(*) -C .. Local Scalars .. - LOGICAL CMPALL, INITW, PAIR, SWAP, WANTC, WANTU, WANTV, - $ WANTW - INTEGER HERE, I, IERR, IFST, ILST, K, KS, L, LEN, MM, - $ NB, NBF, NBL, NBNEXT, POS, PW, PWC, PWCK, PWD, - $ PWDL, WRKMIN - DOUBLE PRECISION TEMP -C .. Local Arrays .. - LOGICAL LDUM(1), SELNEW(4) - DOUBLE PRECISION DW12(12), Q(LDQZ,LDQZ), T(LDQZ,LDQZ), WINEW(4), - $ WRNEW(4), Z(LDQZ,LDQZ) - INTEGER IDUM(1) -C .. External Functions .. - LOGICAL LFDUM, LSAME - EXTERNAL LFDUM, LSAME -C .. External Subroutines .. - EXTERNAL DCOPY, DGEES, DGEMM, DLACPY, DLASET, DSCAL, - $ DTRSEN, MB03WA, XERBLA -C .. Intrinsic Functions .. - INTRINSIC DBLE, MAX -C -C .. Executable Statements .. -C -C Decode and check input parameters -C - WANTC = LSAME( COMPC, 'U' ) - WANTU = LSAME( COMPU, 'U' ) - WANTV = LSAME( COMPV, 'U' ) - INITW = LSAME( COMPW, 'I' ) - WANTW = INITW .OR. LSAME( COMPW, 'V' ) - CMPALL = LSAME( WHICH, 'A' ) - WRKMIN = MAX( 1, 4*N ) -C - INFO = 0 - IF ( .NOT.WANTC .AND. .NOT.LSAME( COMPC, 'N' ) ) THEN - INFO = -1 - ELSE IF ( .NOT.WANTU .AND. .NOT.LSAME( COMPU, 'N' ) ) THEN - INFO = -2 - ELSE IF ( .NOT.WANTV .AND. .NOT.LSAME( COMPV, 'N' ) ) THEN - INFO = -3 - ELSE IF ( .NOT.WANTW .AND. .NOT.LSAME( COMPW, 'N' ) ) THEN - INFO = -4 - ELSE IF ( .NOT.CMPALL .AND. .NOT.LSAME( WHICH, 'S' ) ) THEN - INFO = -5 - ELSE - IF ( CMPALL ) THEN - M = N - ELSE -C -C Set M to the dimension of the specified invariant subspace. -C - M = 0 - PAIR = .FALSE. - DO 10 K = 1, N - IF ( PAIR ) THEN - PAIR = .FALSE. - ELSE - IF ( K.LT.N ) THEN - IF ( A(K+1,K).EQ.ZERO ) THEN - IF ( SELECT(K) ) - $ M = M + 1 - ELSE - PAIR = .TRUE. - IF ( SELECT(K) .OR. SELECT(K+1) ) - $ M = M + 2 - END IF - ELSE - IF ( SELECT(N) ) - $ M = M + 1 - END IF - END IF - 10 CONTINUE - END IF -C -C Compute workspace requirements. -C - WRKMIN = MAX( WRKMIN, 8*M ) -C - IF ( N.LT.0 ) THEN - INFO = -7 - ELSE IF ( LDA.LT.MAX( 1, N ) ) THEN - INFO = -9 - ELSE IF ( LDB.LT.MAX( 1, N ) ) THEN - INFO = -11 - ELSE IF ( LDC.LT.1 .OR. ( WANTC .AND. .NOT.CMPALL .AND. - $ LDC.LT.N ) ) THEN - INFO = -13 - ELSE IF ( LDU1.LT.1 .OR. ( WANTU .AND. .NOT.CMPALL .AND. - $ LDU1.LT.N ) ) THEN - INFO = -15 - ELSE IF ( LDU2.LT.1 .OR. ( WANTU .AND. .NOT.CMPALL .AND. - $ LDU2.LT.N ) ) THEN - INFO = -17 - ELSE IF ( LDV1.LT.1 .OR. ( WANTV .AND. .NOT.CMPALL .AND. - $ LDV1.LT.N ) ) THEN - INFO = -19 - ELSE IF ( LDV2.LT.1 .OR. ( WANTV .AND. .NOT.CMPALL .AND. - $ LDV2.LT.N ) ) THEN - INFO = -21 - ELSE IF ( LDW.LT.1 .OR. ( WANTW .AND. LDW.LT.2*M ) ) THEN - INFO = -23 - ELSE IF ( LDWORK.LT.WRKMIN ) THEN - INFO = -28 - DWORK(1) = DBLE( WRKMIN ) - END IF - END IF -C -C Return if there were illegal values. -C - IF ( INFO.NE.0 ) THEN - CALL XERBLA( 'MB03ZA', -INFO ) - RETURN - END IF -C -C Quick return if possible. -C - IF ( N.EQ.0 ) THEN - DWORK(1) = ONE - RETURN - END IF -C -C Jump immediately to Step 2, if all eigenvalues are requested. -C - IF ( CMPALL ) - $ GO TO 50 -C -C Step 1: Collect the selected blocks at the top-left corner of A*B. -C - KS = 0 - PAIR = .FALSE. - DO 40 K = 1, N - IF ( PAIR ) THEN - PAIR = .FALSE. - ELSE - SWAP = SELECT(K) - IF ( K.LT.N ) THEN - IF ( A(K+1,K).NE.ZERO ) THEN - PAIR = .TRUE. - SWAP = SWAP .OR. SELECT(K+1) - END IF - END IF -C - IF ( PAIR ) THEN - NBF = 2 - ELSE - NBF = 1 - END IF -C - IF ( SWAP ) THEN - KS = KS + 1 - IFST = K -C -C Swap the K-th block to position KS. -C - ILST = KS - NBL = 1 - IF ( ILST.GT.1 ) THEN - IF ( A(ILST,ILST-1).NE.ZERO ) THEN - ILST = ILST - 1 - NBL = 2 - END IF - END IF -C - IF ( ILST.EQ.IFST ) - $ GO TO 30 -C - HERE = IFST - 20 CONTINUE -C -C Swap block with next one above. -C - IF ( NBF.EQ.1 .OR. NBF.EQ.2 ) THEN -C -C Current block either 1-by-1 or 2-by-2. -C - NBNEXT = 1 - IF ( HERE.GE.3 ) THEN - IF ( A(HERE-1,HERE-2).NE.ZERO ) - $ NBNEXT = 2 - END IF - POS = HERE - NBNEXT - NB = NBNEXT + NBF - CALL DLASET( 'All', NB, NB, ZERO, ONE, Q, LDQZ ) - CALL DLASET( 'All', NB, NB, ZERO, ONE, Z, LDQZ ) -C - CALL MB03WA( .TRUE., .TRUE., NBNEXT, NBF, A(POS,POS), - $ LDA, B(POS,POS), LDB, Q, LDQZ, Z, LDQZ, - $ IERR ) -C - IF ( IERR.NE.0 ) THEN - DWORK(1) = DBLE( WRKMIN ) - INFO = 1 - RETURN - END IF -C -C Update rest of A. -C - IF ( POS.GT.1 ) THEN - CALL DGEMM( 'No Transpose', 'No Transpose', POS-1, - $ NB, NB, ONE, A(1,POS), LDA, Z, LDQZ, - $ ZERO, DWORK, N ) - CALL DLACPY( 'All', POS-1, NB, DWORK, N, A(1,POS), - $ LDA ) - END IF - IF ( POS+NB.LE.N ) THEN - CALL DGEMM( 'Transpose', 'No Transpose', NB, - $ N-POS-NB+1, NB, ONE, Q, LDQZ, - $ A(POS,POS+NB), LDA, ZERO, DWORK, NB ) - CALL DLACPY( 'All', NB, N-POS-NB+1, DWORK, NB, - $ A(POS,POS+NB), LDA ) - END IF -C -C Update rest of B. -C - IF ( POS.GT.1 ) THEN - CALL DGEMM( 'No Transpose', 'No Transpose', POS-1, - $ NB, NB, ONE, B(1,POS), LDB, Q, LDQZ, - $ ZERO, DWORK, N ) - CALL DLACPY( 'All', POS-1, NB, DWORK, N, B(1,POS), - $ LDB ) - END IF - IF ( POS+NB.LE.N ) THEN - CALL DGEMM( 'Transpose', 'No Transpose', NB, - $ N-POS-NB+1, NB, ONE, Z, LDQZ, - $ B(POS,POS+NB), LDB, ZERO, DWORK, NB ) - CALL DLACPY( 'All', NB, N-POS-NB+1, DWORK, NB, - $ B(POS,POS+NB), LDB ) - END IF -C -C Update C. -C - IF ( WANTC ) THEN - CALL DGEMM( 'No Transpose', 'No Transpose', N, - $ NB, NB, ONE, C(1,POS), LDC, Q, LDQZ, - $ ZERO, DWORK, N ) - CALL DLACPY( 'All', N, NB, DWORK, N, C(1,POS), - $ LDC ) - CALL DGEMM( 'Transpose', 'No Transpose', NB, - $ N, NB, ONE, Z, LDQZ, C(POS,1), LDC, - $ ZERO, DWORK, NB ) - CALL DLACPY( 'All', NB, N, DWORK, NB, C(POS,1), - $ LDC ) - END IF -C -C Update U. -C - IF ( WANTU ) THEN - CALL DGEMM( 'No Transpose', 'No Transpose', N, - $ NB, NB, ONE, U1(1,POS), LDU1, Z, LDQZ, - $ ZERO, DWORK, N ) - CALL DLACPY( 'All', N, NB, DWORK, N, U1(1,POS), - $ LDU1 ) - CALL DGEMM( 'No Transpose', 'No Transpose', N, - $ NB, NB, ONE, U2(1,POS), LDU2, Z, LDQZ, - $ ZERO, DWORK, N ) - CALL DLACPY( 'All', N, NB, DWORK, N, U2(1,POS), - $ LDU2 ) - END IF -C -C Update V. -C - IF ( WANTV ) THEN - CALL DGEMM( 'No Transpose', 'No Transpose', N, - $ NB, NB, ONE, V1(1,POS), LDV1, Q, LDQZ, - $ ZERO, DWORK, N ) - CALL DLACPY( 'All', N, NB, DWORK, N, V1(1,POS), - $ LDV1 ) - CALL DGEMM( 'No Transpose', 'No Transpose', N, - $ NB, NB, ONE, V2(1,POS), LDV2, Q, LDQZ, - $ ZERO, DWORK, N ) - CALL DLACPY( 'All', N, NB, DWORK, N, V2(1,POS), - $ LDV2 ) - END IF -C - HERE = HERE - NBNEXT -C -C Test if 2-by-2 block breaks into two 1-by-1 blocks. -C - IF ( NBF.EQ.2 ) THEN - IF ( A(HERE+1,HERE).EQ.ZERO ) - $ NBF = 3 - END IF -C - ELSE -C -C Current block consists of two 1 by 1 blocks each of -C which must be swapped individually. -C - NBNEXT = 1 - IF ( HERE.GE.3 ) THEN - IF ( A(HERE-1,HERE-2).NE.ZERO ) - $ NBNEXT = 2 - END IF - POS = HERE - NBNEXT - NB = NBNEXT + 1 - CALL DLASET( 'All', NB, NB, ZERO, ONE, Q, LDQZ ) - CALL DLASET( 'All', NB, NB, ZERO, ONE, Z, LDQZ ) -C - CALL MB03WA( .TRUE., .TRUE., NBNEXT, 1, A(POS,POS), - $ LDA, B(POS,POS), LDB, Q, LDQZ, Z, LDQZ, - $ IERR ) -C - IF ( IERR.NE.0 ) THEN - DWORK(1) = DBLE( WRKMIN ) - INFO = 1 - RETURN - END IF -C -C Update rest of A. -C - IF ( POS.GT.1 ) THEN - CALL DGEMM( 'No Transpose', 'No Transpose', POS-1, - $ NB, NB, ONE, A(1,POS), LDA, Z, LDQZ, - $ ZERO, DWORK, N ) - CALL DLACPY( 'All', POS-1, NB, DWORK, N, A(1,POS), - $ LDA ) - END IF - IF ( POS+NB.LE.N ) THEN - CALL DGEMM( 'Transpose', 'No Transpose', NB, - $ N-POS-NB+1, NB, ONE, Q, LDQZ, - $ A(POS,POS+NB), LDA, ZERO, DWORK, NB ) - CALL DLACPY( 'All', NB, N-POS-NB+1, DWORK, NB, - $ A(POS,POS+NB), LDA ) - END IF -C -C Update rest of B. -C - IF ( POS.GT.1 ) THEN - CALL DGEMM( 'No Transpose', 'No Transpose', POS-1, - $ NB, NB, ONE, B(1,POS), LDB, Q, LDQZ, - $ ZERO, DWORK, N ) - CALL DLACPY( 'All', POS-1, NB, DWORK, N, B(1,POS), - $ LDB ) - END IF - IF ( POS+NB.LE.N ) THEN - CALL DGEMM( 'Transpose', 'No Transpose', NB, - $ N-POS-NB+1, NB, ONE, Z, LDQZ, - $ B(POS,POS+NB), LDB, ZERO, DWORK, NB ) - CALL DLACPY( 'All', NB, N-POS-NB+1, DWORK, NB, - $ B(POS,POS+NB), LDB ) - END IF -C -C Update C. -C - IF ( WANTC ) THEN - CALL DGEMM( 'No Transpose', 'No Transpose', N, - $ NB, NB, ONE, C(1,POS), LDC, Q, LDQZ, - $ ZERO, DWORK, N ) - CALL DLACPY( 'All', N, NB, DWORK, N, C(1,POS), - $ LDC ) - CALL DGEMM( 'Transpose', 'No Transpose', NB, - $ N, NB, ONE, Z, LDQZ, C(POS,1), LDC, - $ ZERO, DWORK, NB ) - CALL DLACPY( 'All', NB, N, DWORK, NB, C(POS,1), - $ LDC ) - END IF -C -C Update U. -C - IF ( WANTU ) THEN - CALL DGEMM( 'No Transpose', 'No Transpose', N, - $ NB, NB, ONE, U1(1,POS), LDU1, Z, LDQZ, - $ ZERO, DWORK, N ) - CALL DLACPY( 'All', N, NB, DWORK, N, U1(1,POS), - $ LDU1 ) - CALL DGEMM( 'No Transpose', 'No Transpose', N, - $ NB, NB, ONE, U2(1,POS), LDU2, Z, LDQZ, - $ ZERO, DWORK, N ) - CALL DLACPY( 'All', N, NB, DWORK, N, U2(1,POS), - $ LDU2 ) - END IF -C -C Update V. -C - IF ( WANTV ) THEN - CALL DGEMM( 'No Transpose', 'No Transpose', N, - $ NB, NB, ONE, V1(1,POS), LDV1, Q, LDQZ, - $ ZERO, DWORK, N ) - CALL DLACPY( 'All', N, NB, DWORK, N, V1(1,POS), - $ LDV1 ) - CALL DGEMM( 'No Transpose', 'No Transpose', N, - $ NB, NB, ONE, V2(1,POS), LDV2, Q, LDQZ, - $ ZERO, DWORK, N ) - CALL DLACPY( 'All', N, NB, DWORK, N, V2(1,POS), - $ LDV2 ) - END IF -C - IF ( NBNEXT.EQ.1 ) THEN -C -C Swap two 1-by-1 blocks. -C - POS = HERE - NB = NBNEXT + 1 - CALL DLASET( 'All', NB, NB, ZERO, ONE, Q, LDQZ ) - CALL DLASET( 'All', NB, NB, ZERO, ONE, Z, LDQZ ) -C - CALL MB03WA( .TRUE., .TRUE., NBNEXT, 1, A(POS,POS), - $ LDA, B(POS,POS), LDB, Q, LDQZ, Z, - $ LDQZ, IERR ) -C - IF ( IERR.NE.0 ) THEN - DWORK(1) = DBLE( WRKMIN ) - INFO = 1 - RETURN - END IF -C -C Update rest of A. -C - IF ( POS.GT.1 ) THEN - CALL DGEMM( 'No Transpose', 'No Transpose', - $ POS-1, NB, NB, ONE, A(1,POS), LDA, - $ Z, LDQZ, ZERO, DWORK, N ) - CALL DLACPY( 'All', POS-1, NB, DWORK, N, - $ A(1,POS), LDA ) - END IF - IF ( POS+NB.LE.N ) THEN - CALL DGEMM( 'Transpose', 'No Transpose', NB, - $ N-POS-NB+1, NB, ONE, Q, LDQZ, - $ A(POS,POS+NB), LDA, ZERO, DWORK, - $ NB ) - CALL DLACPY( 'All', NB, N-POS-NB+1, DWORK, NB, - $ A(POS,POS+NB), LDA ) - END IF -C -C Update rest of B. -C - IF ( POS.GT.1 ) THEN - CALL DGEMM( 'No Transpose', 'No Transpose', - $ POS-1, NB, NB, ONE, B(1,POS), LDB, - $ Q, LDQZ, ZERO, DWORK, N ) - CALL DLACPY( 'All', POS-1, NB, DWORK, N, - $ B(1,POS), LDB ) - END IF - IF ( POS+NB.LE.N ) THEN - CALL DGEMM( 'Transpose', 'No Transpose', NB, - $ N-POS-NB+1, NB, ONE, Z, LDQZ, - $ B(POS,POS+NB), LDB, ZERO, DWORK, - $ NB ) - CALL DLACPY( 'All', NB, N-POS-NB+1, DWORK, NB, - $ B(POS,POS+NB), LDB ) - END IF -C -C Update C. -C - IF ( WANTC ) THEN - CALL DGEMM( 'No Transpose', 'No Transpose', N, - $ NB, NB, ONE, C(1,POS), LDC, Q, LDQZ, - $ ZERO, DWORK, N ) - CALL DLACPY( 'All', N, NB, DWORK, N, C(1,POS), - $ LDC ) - CALL DGEMM( 'Transpose', 'No Transpose', NB, - $ N, NB, ONE, Z, LDQZ, C(POS,1), LDC, - $ ZERO, DWORK, NB ) - CALL DLACPY( 'All', NB, N, DWORK, NB, C(POS,1), - $ LDC ) - END IF -C -C Update U. -C - IF ( WANTU ) THEN - CALL DGEMM( 'No Transpose', 'No Transpose', N, - $ NB, NB, ONE, U1(1,POS), LDU1, Z, - $ LDQZ, ZERO, DWORK, N ) - CALL DLACPY( 'All', N, NB, DWORK, N, U1(1,POS), - $ LDU1 ) - CALL DGEMM( 'No Transpose', 'No Transpose', N, - $ NB, NB, ONE, U2(1,POS), LDU2, Z, - $ LDQZ, ZERO, DWORK, N ) - CALL DLACPY( 'All', N, NB, DWORK, N, U2(1,POS), - $ LDU2 ) - END IF -C -C Update V. -C - IF ( WANTV ) THEN - CALL DGEMM( 'No Transpose', 'No Transpose', N, - $ NB, NB, ONE, V1(1,POS), LDV1, Q, - $ LDQZ, ZERO, DWORK, N ) - CALL DLACPY( 'All', N, NB, DWORK, N, V1(1,POS), - $ LDV1 ) - CALL DGEMM( 'No Transpose', 'No Transpose', N, - $ NB, NB, ONE, V2(1,POS), LDV2, Q, - $ LDQZ, ZERO, DWORK, N ) - CALL DLACPY( 'All', N, NB, DWORK, N, V2(1,POS), - $ LDV2 ) - END IF -C - HERE = HERE - 1 - ELSE -C -C Recompute NBNEXT in case 2-by-2 split. -C - IF ( A(HERE,HERE-1).EQ.ZERO ) - $ NBNEXT = 1 -C - IF ( NBNEXT.EQ.2 ) THEN -C -C 2-by-2 block did not split. -C - POS = HERE - 1 - NB = 3 - CALL DLASET( 'All', NB, NB, ZERO, ONE, Q, LDQZ ) - CALL DLASET( 'All', NB, NB, ZERO, ONE, Z, LDQZ ) -C - CALL MB03WA( .TRUE., .TRUE., 2, 1, A(POS,POS), - $ LDA, B(POS,POS), LDB, Q, LDQZ, Z, - $ LDQZ, IERR ) -C - IF ( IERR.NE.0 ) THEN - DWORK(1) = DBLE( WRKMIN ) - INFO = 1 - RETURN - END IF -C -C Update rest of A. -C - IF ( POS.GT.1 ) THEN - CALL DGEMM( 'No Transpose', 'No Transpose', - $ POS-1, NB, NB, ONE, A(1,POS), - $ LDA, Z, LDQZ, ZERO, DWORK, N ) - CALL DLACPY( 'All', POS-1, NB, DWORK, N, - $ A(1,POS), LDA ) - END IF - IF ( POS+NB.LE.N ) THEN - CALL DGEMM( 'Transpose', 'No Transpose', NB, - $ N-POS-NB+1, NB, ONE, Q, LDQZ, - $ A(POS,POS+NB), LDA, ZERO, DWORK, - $ NB ) - CALL DLACPY( 'All', NB, N-POS-NB+1, DWORK, - $ NB, A(POS,POS+NB), LDA ) - END IF -C -C Update rest of B. -C - IF ( POS.GT.1 ) THEN - CALL DGEMM( 'No Transpose', 'No Transpose', - $ POS-1, NB, NB, ONE, B(1,POS), - $ LDB, Q, LDQZ, ZERO, DWORK, N ) - CALL DLACPY( 'All', POS-1, NB, DWORK, N, - $ B(1,POS), LDB ) - END IF - IF ( POS+NB.LE.N ) THEN - CALL DGEMM( 'Transpose', 'No Transpose', NB, - $ N-POS-NB+1, NB, ONE, Z, LDQZ, - $ B(POS,POS+NB), LDB, ZERO, DWORK, - $ NB ) - CALL DLACPY( 'All', NB, N-POS-NB+1, DWORK, - $ NB, B(POS,POS+NB), LDB ) - END IF -C -C Update C. -C - IF ( WANTC ) THEN - CALL DGEMM( 'No Transpose', 'No Transpose', - $ N, NB, NB, ONE, C(1,POS), LDC, Q, - $ LDQZ, ZERO, DWORK, N ) - CALL DLACPY( 'All', N, NB, DWORK, N, - $ C(1,POS), LDC ) - CALL DGEMM( 'Transpose', 'No Transpose', NB, - $ N, NB, ONE, Z, LDQZ, C(POS,1), - $ LDC, ZERO, DWORK, NB ) - CALL DLACPY( 'All', NB, N, DWORK, NB, - $ C(POS,1), LDC ) - END IF -C -C Update U. -C - IF ( WANTU ) THEN - CALL DGEMM( 'No Transpose', 'No Transpose', - $ N, NB, NB, ONE, U1(1,POS), LDU1, - $ Z, LDQZ, ZERO, DWORK, N ) - CALL DLACPY( 'All', N, NB, DWORK, N, - $ U1(1,POS), LDU1 ) - CALL DGEMM( 'No Transpose', 'No Transpose', - $ N, NB, NB, ONE, U2(1,POS), LDU2, - $ Z, LDQZ, ZERO, DWORK, N ) - CALL DLACPY( 'All', N, NB, DWORK, N, - $ U2(1,POS), LDU2 ) - END IF -C -C Update V. -C - IF ( WANTV ) THEN - CALL DGEMM( 'No Transpose', 'No Transpose', - $ N, NB, NB, ONE, V1(1,POS), LDV1, - $ Q, LDQZ, ZERO, DWORK, N ) - CALL DLACPY( 'All', N, NB, DWORK, N, - $ V1(1,POS), LDV1 ) - CALL DGEMM( 'No Transpose', 'No Transpose', - $ N, NB, NB, ONE, V2(1,POS), LDV2, - $ Q, LDQZ, ZERO, DWORK, N ) - CALL DLACPY( 'All', N, NB, DWORK, N, - $ V2(1,POS), LDV2 ) - END IF -C - HERE = HERE - 2 - ELSE -C -C 2-by-2 block did split. -C - POS = HERE - NB = 2 - CALL DLASET( 'All', NB, NB, ZERO, ONE, Q, LDQZ ) - CALL DLASET( 'All', NB, NB, ZERO, ONE, Z, LDQZ ) -C - CALL MB03WA( .TRUE., .TRUE., 2, 1, A(POS,POS), - $ LDA, B(POS,POS), LDB, Q, LDQZ, Z, - $ LDQZ, IERR ) -C - IF ( IERR.NE.0 ) THEN - DWORK(1) = DBLE( WRKMIN ) - INFO = 1 - RETURN - END IF -C -C Update rest of A. -C - IF ( POS.GT.1 ) THEN - CALL DGEMM( 'No Transpose', 'No Transpose', - $ POS-1, NB, NB, ONE, A(1,POS), - $ LDA, Z, LDQZ, ZERO, DWORK, N ) - CALL DLACPY( 'All', POS-1, NB, DWORK, N, - $ A(1,POS), LDA ) - END IF - IF ( POS+NB.LE.N ) THEN - CALL DGEMM( 'Transpose', 'No Transpose', NB, - $ N-POS-NB+1, NB, ONE, Q, LDQZ, - $ A(POS,POS+NB), LDA, ZERO, DWORK, - $ NB ) - CALL DLACPY( 'All', NB, N-POS-NB+1, DWORK, - $ NB, A(POS,POS+NB), LDA ) - END IF -C -C Update rest of B. -C - IF ( POS.GT.1 ) THEN - CALL DGEMM( 'No Transpose', 'No Transpose', - $ POS-1, NB, NB, ONE, B(1,POS), - $ LDB, Q, LDQZ, ZERO, DWORK, N ) - CALL DLACPY( 'All', POS-1, NB, DWORK, N, - $ B(1,POS), LDB ) - END IF - IF ( POS+NB.LE.N ) THEN - CALL DGEMM( 'Transpose', 'No Transpose', NB, - $ N-POS-NB+1, NB, ONE, Z, LDQZ, - $ B(POS,POS+NB), LDB, ZERO, DWORK, - $ NB ) - CALL DLACPY( 'All', NB, N-POS-NB+1, DWORK, - $ NB, B(POS,POS+NB), LDB ) - END IF -C -C Update C. -C - IF ( WANTC ) THEN - CALL DGEMM( 'No Transpose', 'No Transpose', - $ N, NB, NB, ONE, C(1,POS), LDC, Q, - $ LDQZ, ZERO, DWORK, N ) - CALL DLACPY( 'All', N, NB, DWORK, N, - $ C(1,POS), LDC ) - CALL DGEMM( 'Transpose', 'No Transpose', NB, - $ N, NB, ONE, Z, LDQZ, C(POS,1), - $ LDC, ZERO, DWORK, NB ) - CALL DLACPY( 'All', NB, N, DWORK, NB, - $ C(POS,1), LDC ) - END IF -C -C Update U. -C - IF ( WANTU ) THEN - CALL DGEMM( 'No Transpose', 'No Transpose', - $ N, NB, NB, ONE, U1(1,POS), LDU1, - $ Z, LDQZ, ZERO, DWORK, N ) - CALL DLACPY( 'All', N, NB, DWORK, N, - $ U1(1,POS), LDU1 ) - CALL DGEMM( 'No Transpose', 'No Transpose', - $ N, NB, NB, ONE, U2(1,POS), LDU2, - $ Z, LDQZ, ZERO, DWORK, N ) - CALL DLACPY( 'All', N, NB, DWORK, N, - $ U2(1,POS), LDU2 ) - END IF -C -C Update V. -C - IF ( WANTV ) THEN - CALL DGEMM( 'No Transpose', 'No Transpose', - $ N, NB, NB, ONE, V1(1,POS), LDV1, - $ Q, LDQZ, ZERO, DWORK, N ) - CALL DLACPY( 'All', N, NB, DWORK, N, - $ V1(1,POS), LDV1 ) - CALL DGEMM( 'No Transpose', 'No Transpose', - $ N, NB, NB, ONE, V2(1,POS), LDV2, - $ Q, LDQZ, ZERO, DWORK, N ) - CALL DLACPY( 'All', N, NB, DWORK, N, - $ V2(1,POS), LDV2 ) - END IF -C - POS = HERE - 1 - NB = 2 - CALL DLASET( 'All', NB, NB, ZERO, ONE, Q, LDQZ ) - CALL DLASET( 'All', NB, NB, ZERO, ONE, Z, LDQZ ) -C - CALL MB03WA( .TRUE., .TRUE., 2, 1, A(POS,POS), - $ LDA, B(POS,POS), LDB, Q, LDQZ, Z, - $ LDQZ, IERR ) -C - IF ( IERR.NE.0 ) THEN - DWORK(1) = DBLE( WRKMIN ) - INFO = 1 - RETURN - END IF -C -C Update rest of A. -C - IF ( POS.GT.1 ) THEN - CALL DGEMM( 'No Transpose', 'No Transpose', - $ POS-1, NB, NB, ONE, A(1,POS), - $ LDA, Z, LDQZ, ZERO, DWORK, N ) - CALL DLACPY( 'All', POS-1, NB, DWORK, N, - $ A(1,POS), LDA ) - END IF - IF ( POS+NB.LE.N ) THEN - CALL DGEMM( 'Transpose', 'No Transpose', NB, - $ N-POS-NB+1, NB, ONE, Q, LDQZ, - $ A(POS,POS+NB), LDA, ZERO, DWORK, - $ NB ) - CALL DLACPY( 'All', NB, N-POS-NB+1, DWORK, - $ NB, A(POS,POS+NB), LDA ) - END IF -C -C Update rest of B. -C - IF ( POS.GT.1 ) THEN - CALL DGEMM( 'No Transpose', 'No Transpose', - $ POS-1, NB, NB, ONE, B(1,POS), - $ LDB, Q, LDQZ, ZERO, DWORK, N ) - CALL DLACPY( 'All', POS-1, NB, DWORK, N, - $ B(1,POS), LDB ) - END IF - IF ( POS+NB.LE.N ) THEN - CALL DGEMM( 'Transpose', 'No Transpose', NB, - $ N-POS-NB+1, NB, ONE, Z, LDQZ, - $ B(POS,POS+NB), LDB, ZERO, DWORK, - $ NB ) - CALL DLACPY( 'All', NB, N-POS-NB+1, DWORK, - $ NB, B(POS,POS+NB), LDB ) - END IF -C -C Update C. -C - IF ( WANTC ) THEN - CALL DGEMM( 'No Transpose', 'No Transpose', - $ N, NB, NB, ONE, C(1,POS), LDC, Q, - $ LDQZ, ZERO, DWORK, N ) - CALL DLACPY( 'All', N, NB, DWORK, N, - $ C(1,POS), LDC ) - CALL DGEMM( 'Transpose', 'No Transpose', NB, - $ N, NB, ONE, Z, LDQZ, C(POS,1), - $ LDC, ZERO, DWORK, NB ) - CALL DLACPY( 'All', NB, N, DWORK, NB, - $ C(POS,1), LDC ) - END IF -C -C Update U. -C - IF ( WANTU ) THEN - CALL DGEMM( 'No Transpose', 'No Transpose', - $ N, NB, NB, ONE, U1(1,POS), LDU1, - $ Z, LDQZ, ZERO, DWORK, N ) - CALL DLACPY( 'All', N, NB, DWORK, N, - $ U1(1,POS), LDU1 ) - CALL DGEMM( 'No Transpose', 'No Transpose', - $ N, NB, NB, ONE, U2(1,POS), LDU2, - $ Z, LDQZ, ZERO, DWORK, N ) - CALL DLACPY( 'All', N, NB, DWORK, N, - $ U2(1,POS), LDU2 ) - END IF -C -C Update V. -C - IF ( WANTV ) THEN - CALL DGEMM( 'No Transpose', 'No Transpose', - $ N, NB, NB, ONE, V1(1,POS), LDV1, - $ Q, LDQZ, ZERO, DWORK, N ) - CALL DLACPY( 'All', N, NB, DWORK, N, - $ V1(1,POS), LDV1 ) - CALL DGEMM( 'No Transpose', 'No Transpose', - $ N, NB, NB, ONE, V2(1,POS), LDV2, - $ Q, LDQZ, ZERO, DWORK, N ) - CALL DLACPY( 'All', N, NB, DWORK, N, - $ V2(1,POS), LDV2 ) - END IF -C - HERE = HERE - 2 - END IF - END IF - END IF -C - IF ( HERE.GT.ILST ) - $ GO TO 20 -C - 30 CONTINUE - IF ( PAIR ) - $ KS = KS + 1 - END IF - END IF - 40 CONTINUE -C - 50 CONTINUE -C -C Step 2: Compute an ordered Schur decomposition of -C [ 0, -A11; B11, 0 ]. -C - IF ( INITW ) - $ CALL DLASET( 'All', 2*M, 2*M, ZERO, ONE, W, LDW ) - PWC = 1 - PWD = PWC + 2*M - PW = PWD + 2*M - PAIR = .FALSE. - NB = 1 -C - DO 80 K = 1, M - IF ( PAIR ) THEN - PAIR = .FALSE. - NB = 1 - ELSE - IF ( K.LT.N ) THEN - IF ( A(K+1,K).NE.ZERO ) THEN - PAIR = .TRUE. - NB = 2 - END IF - END IF - PWCK = PWC + 2*( K - 1 ) - PWDL = PWD + 2*( K - 1 ) - CALL DLASET( 'All', NB, M-K+1, ZERO, ZERO, DWORK(PWCK), 2 ) - CALL DLACPY( 'All', NB, M-K+1, A(K,K), LDA, DWORK(PWDL), 2 ) - CALL DLASET( 'All', NB, M-K+1, ZERO, ZERO, A(K,K), LDA ) -C - L = K -C -C WHILE L >= 1 DO -C - 60 CONTINUE -C - IF ( K.EQ.L ) THEN -C -C Annihilate B(k,k). -C - NBL = NB - CALL DLASET( 'All', NB+NBL, NB+NBL, ZERO, ZERO, T, - $ LDQZ ) - CALL DLACPY( 'Upper', NBL, NBL, B(L,L), LDB, - $ T(NB+1,1), LDQZ ) - IF ( NB.EQ.1 ) THEN - DWORK(PWDL) = -DWORK(PWDL) - ELSE - CALL DSCAL( 2*NB, -ONE, DWORK(PWDL), 1 ) - END IF - CALL DLACPY( 'All', NB, NB, DWORK(PWDL), 2, T(1,NB+1), - $ LDQZ ) - ELSE -C -C Annihilate B(l,k). -C - CALL DLASET( 'All', NBL+NB, NBL+NB, ZERO, ZERO, T, - $ LDQZ ) - CALL DLACPY( 'All', NBL, NBL, A(L,L), LDA, T, LDQZ ) - CALL DLACPY( 'All', NBL, NB, B(L,K), LDB, T(1,NBL+1), - $ LDQZ ) - CALL DLACPY( 'All', NB, NB, DWORK(PWCK), 2, - $ T(NBL+1,NBL+1), LDQZ ) - PWDL = PWD + 2*( L - 1 ) - END IF -C - CALL DGEES( 'V', 'Not Sorted', LFDUM, NB+NBL, T, LDQZ, - $ MM, WRNEW, WINEW, Q, LDQZ, DW12, 12, LDUM, - $ IERR ) - IF ( IERR.NE.0 ) THEN - DWORK(1) = DBLE( WRKMIN ) - INFO = 3 - RETURN - END IF -C -C Reorder Schur form. -C - MM = 0 - DO 70 I = 1, NB+NBL - IF ( WRNEW(I).GT.0 ) THEN - MM = MM + 1 - SELNEW(I) = .TRUE. - ELSE - SELNEW(I) = .FALSE. - END IF - 70 CONTINUE - IF ( MM.LT.NB ) THEN - DWORK(1) = DBLE( WRKMIN ) - INFO = 4 - RETURN - END IF - CALL DTRSEN( 'None', 'V', SELNEW, NB+NBL, T, LDQZ, Q, - $ LDQZ, WRNEW, WINEW, MM, TEMP, TEMP, DW12, - $ 4, IDUM, 1, IERR ) - IF ( IERR.NE.0 ) THEN - DWORK(1) = DBLE( WRKMIN ) - INFO = 2 - RETURN - END IF -C -C Permute Q if necessary. -C - IF ( K.NE.L ) THEN - CALL DLACPY( 'All', NBL, NB+NBL, Q, LDQZ, Z(NB+1,1), - $ LDQZ ) - CALL DLACPY( 'All', NB, NB+NBL, Q(NBL+1,1), LDQZ, - $ Z, LDQZ ) - CALL DLACPY( 'All', NB+NBL, NB+NBL, Z, LDQZ, Q, LDQZ ) - END IF -C -C Update "diagonal" blocks. -C - CALL DLACPY( 'All', NB, NB, T, LDQZ, DWORK(PWCK), 2 ) - CALL DLACPY( 'All', NB, NBL, T(1,NB+1), LDQZ, - $ DWORK(PWDL), 2 ) - IF ( NB.EQ.1 ) THEN - CALL DSCAL( NBL, -ONE, DWORK(PWDL), 2 ) - ELSE - CALL DSCAL( 2*NBL, -ONE, DWORK(PWDL), 1 ) - END IF - CALL DLACPY( 'All', NBL, NBL, T(NB+1,NB+1), LDQZ, - $ A(L,L), LDA ) -C -C Update block columns of A and B. -C - LEN = L - 1 - IF ( LEN.GT.0 ) THEN - CALL DGEMM( 'No Transpose', 'No Transpose', LEN, NB, - $ NB, ONE, B(1,K), LDB, Q, LDQZ, ZERO, - $ DWORK(PW), M ) - CALL DGEMM( 'No Transpose', 'No Transpose', LEN, NBL, - $ NB, ONE, B(1,K), LDB, Q(1,NB+1), LDQZ, - $ ZERO, DWORK(PW+2*M), M ) - CALL DGEMM( 'No Transpose', 'No Transpose', LEN, NB, - $ NBL, ONE, A(1,L), LDA, Q(NB+1,1), LDQZ, - $ ONE, DWORK(PW), M ) - CALL DLACPY( 'All', LEN, NB, DWORK(PW), M, B(1,K), - $ LDB ) - CALL DGEMM( 'No Transpose', 'No Transpose', LEN, NBL, - $ NBL, ONE, A(1,L), LDA, Q(NB+1,NB+1), - $ LDQZ, ONE, DWORK(PW+2*M), M ) - CALL DLACPY( 'All', LEN, NBL, DWORK(PW+2*M), M, - $ A(1,L), LDA ) - END IF -C -C Update block column of A. -C - LEN = M - L - NBL + 1 - IF ( LEN.GT.0 ) THEN - CALL DGEMM( 'Transpose', 'No Transpose', NB, LEN, NB, - $ ONE, Q, LDQZ, DWORK(PWDL+2*NBL), 2, ZERO, - $ DWORK(PW), 2 ) - CALL DGEMM( 'Transpose', 'No Transpose', NBL, LEN, NB, - $ -ONE, Q(1,NB+1), LDQZ, DWORK(PWDL+2*NBL), - $ 2, ZERO, DWORK(PW+2*M), 2 ) - CALL DGEMM( 'Transpose', 'No Transpose', NB, LEN, NBL, - $ -ONE, Q(NB+1,1), LDQZ, A(L,L+NBL), LDA, - $ ONE, DWORK(PW), 2 ) - CALL DLACPY( 'All', NB, LEN, DWORK(PW), 2, - $ DWORK(PWDL+2*NBL), 2 ) - CALL DGEMM( 'Transpose', 'No Transpose', NBL, LEN, - $ NBL, ONE, Q(NB+1,NB+1), LDQZ, A(L,L+NBL), - $ LDA, ONE, DWORK(PW+2*M), 2 ) - CALL DLACPY( 'All', NBL, LEN, DWORK(PW+2*M), 2, - $ A(L,L+NBL), LDA ) - END IF -C -C Update block row of B. -C - LEN = M - K - NB + 1 - IF ( LEN.GT.0 ) THEN - CALL DGEMM( 'Transpose', 'No Transpose', NB, LEN, NB, - $ ONE, Q, LDQZ, DWORK(PWCK+2*NB), 2, ZERO, - $ DWORK(PW), 2 ) - CALL DGEMM( 'Transpose', 'No Transpose', NBL, LEN, NB, - $ ONE, Q(1,NB+1), LDQZ, DWORK(PWCK+2*NB), 2, - $ ZERO, DWORK(PW+2*M), 2 ) - CALL DGEMM( 'Transpose', 'No Transpose', NB, LEN, NBL, - $ ONE, Q(NB+1,1), LDQZ, B(L,K+NB), LDB, ONE, - $ DWORK(PW), 2 ) - CALL DLACPY( 'All', NB, LEN, DWORK(PW), 2, - $ DWORK(PWCK+2*NB), 2 ) - CALL DGEMM( 'Transpose', 'No Transpose', NBL, LEN, - $ NBL, ONE, Q(NB+1,NB+1), LDQZ, B(L,K+NB), - $ LDB, ONE, DWORK(PW+2*M), 2 ) - CALL DLACPY( 'All', NBL, LEN, DWORK(PW+2*M), 2, - $ B(L,K+NB), LDB ) - END IF -C -C Update W. -C - IF ( WANTW ) THEN - IF ( INITW ) THEN - POS = L - LEN = K + NB - L - ELSE - POS = 1 - LEN = M - END IF - CALL DGEMM( 'No Transpose', 'No Transpose', LEN, NB, - $ NB, ONE, W(POS,K), LDW, Q, LDQZ, ZERO, - $ DWORK(PW), M ) - CALL DGEMM( 'No Transpose', 'No Transpose', LEN, NBL, - $ NB, ONE, W(POS,K), LDW, Q(1,NB+1), LDQZ, - $ ZERO, DWORK(PW+2*M), M ) - CALL DGEMM( 'No Transpose', 'No Transpose', LEN, NB, - $ NBL, ONE, W(POS,M+L), LDW, Q(NB+1,1), - $ LDQZ, ONE, DWORK(PW), M ) - CALL DLACPY( 'All', LEN, NB, DWORK(PW), M, W(POS,K), - $ LDW ) - CALL DGEMM( 'No Transpose', 'No Transpose', LEN, NBL, - $ NBL, ONE, W(POS,M+L), LDW, Q(NB+1,NB+1), - $ LDQZ, ONE, DWORK(PW+2*M), M ) - CALL DLACPY( 'All', LEN, NBL, DWORK(PW+2*M), M, - $ W(POS,M+L), LDW ) -C - CALL DGEMM( 'No Transpose', 'No Transpose', LEN, NB, - $ NB, ONE, W(M+POS,K), LDW, Q, LDQZ, ZERO, - $ DWORK(PW), M ) - CALL DGEMM( 'No Transpose', 'No Transpose', LEN, NBL, - $ NB, ONE, W(M+POS,K), LDW, Q(1,NB+1), LDQZ, - $ ZERO, DWORK(PW+2*M), M ) - CALL DGEMM( 'No Transpose', 'No Transpose', LEN, NB, - $ NBL, ONE, W(M+POS,M+L), LDW, Q(NB+1,1), - $ LDQZ, ONE, DWORK(PW), M ) - CALL DLACPY( 'All', LEN, NB, DWORK(PW), M, W(M+POS,K), - $ LDW ) - CALL DGEMM( 'No Transpose', 'No Transpose', LEN, NBL, - $ NBL, ONE, W(M+POS,M+L), LDW, Q(NB+1,NB+1), - $ LDQZ, ONE, DWORK(PW+2*M), M ) - CALL DLACPY( 'All', LEN, NBL, DWORK(PW+2*M), M, - $ W(M+POS,M+L), LDW ) - END IF -C - L = L - 1 - NBL = 1 - IF ( L.GT.1 ) THEN - IF ( A(L,L-1).NE.ZERO ) THEN - NBL = 2 - L = L - 1 - END IF - END IF -C -C END WHILE L >= 1 DO -C - IF ( L.GE.1 ) - $ GO TO 60 -C -C Copy recomputed eigenvalues. -C - CALL DCOPY( NB, WRNEW, 1, WR(K), 1 ) - CALL DCOPY( NB, WINEW, 1, WI(K), 1 ) - END IF - 80 CONTINUE - DWORK(1) = DBLE( WRKMIN ) - RETURN -C *** Last line of MB03ZA *** - END -C - LOGICAL FUNCTION LFDUM( X, Y ) -C -C Void logical function for DGEES. -C - DOUBLE PRECISION X, Y - LFDUM = .FALSE. - RETURN -C *** Last line of LFDUM *** - END diff --git a/mex/sources/libslicot/MB03ZD.f b/mex/sources/libslicot/MB03ZD.f deleted file mode 100644 index 74e945525..000000000 --- a/mex/sources/libslicot/MB03ZD.f +++ /dev/null @@ -1,908 +0,0 @@ - SUBROUTINE MB03ZD( WHICH, METH, STAB, BALANC, ORTBAL, SELECT, N, - $ MM, ILO, SCALE, S, LDS, T, LDT, G, LDG, U1, - $ LDU1, U2, LDU2, V1, LDV1, V2, LDV2, M, WR, WI, - $ US, LDUS, UU, LDUU, LWORK, IWORK, DWORK, - $ LDWORK, INFO ) -C -C SLICOT RELEASE 5.0. -C -C Copyright (c) 2002-2009 NICONET e.V. -C -C This program is free software: you can redistribute it and/or -C modify it under the terms of the GNU General Public License as -C published by the Free Software Foundation, either version 2 of -C the License, or (at your option) any later version. -C -C This program is distributed in the hope that it will be useful, -C but WITHOUT ANY WARRANTY; without even the implied warranty of -C MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the -C GNU General Public License for more details. -C -C You should have received a copy of the GNU General Public License -C along with this program. If not, see -C . -C -C PURPOSE -C -C To compute the stable and unstable invariant subspaces for a -C Hamiltonian matrix with no eigenvalues on the imaginary axis, -C using the output of the SLICOT Library routine MB03XD. -C -C ARGUMENTS -C -C Mode Parameters -C -C WHICH CHARACTER*1 -C Specifies the cluster of eigenvalues for which the -C invariant subspaces are computed: -C = 'A': select all n eigenvalues; -C = 'S': select a cluster of eigenvalues specified by -C SELECT. -C -C METH CHARACTER*1 -C If WHICH = 'A' this parameter specifies the method to be -C used for computing bases of the invariant subspaces: -C = 'S': compute the n-dimensional basis from a set of -C n vectors; -C = 'L': compute the n-dimensional basis from a set of -C 2*n vectors. -C When in doubt, use METH = 'S'. In some cases, METH = 'L' -C may result in more accurately computed invariant -C subspaces, see [1]. -C -C STAB CHARACTER*1 -C Specifies the type of invariant subspaces to be computed: -C = 'S': compute the stable invariant subspace, i.e., the -C invariant subspace belonging to those selected -C eigenvalues that have negative real part; -C = 'U': compute the unstable invariant subspace, i.e., -C the invariant subspace belonging to those -C selected eigenvalues that have positive real -C part; -C = 'B': compute both the stable and unstable invariant -C subspaces. -C -C BALANC CHARACTER*1 -C Specifies the type of inverse balancing transformation -C required: -C = 'N': do nothing; -C = 'P': do inverse transformation for permutation only; -C = 'S': do inverse transformation for scaling only; -C = 'B': do inverse transformations for both permutation -C and scaling. -C BALANC must be the same as the argument BALANC supplied to -C MB03XD. Note that if the data is further post-processed, -C e.g., for solving an algebraic Riccati equation, it is -C recommended to delay inverse balancing (in particular the -C scaling part) and apply it to the final result only, -C see [2]. -C -C ORTBAL CHARACTER*1 -C If BALANC <> 'N', this option specifies how inverse -C balancing is applied to the computed invariant subspaces: -C = 'B': apply inverse balancing before orthogonal bases -C for the invariant subspaces are computed; -C = 'A': apply inverse balancing after orthogonal bases -C for the invariant subspaces have been computed; -C this may yield non-orthogonal bases if -C BALANC = 'S' or BALANC = 'B'. -C -C SELECT (input) LOGICAL array, dimension (N) -C If WHICH = 'S', SELECT specifies the eigenvalues -C corresponding to the positive and negative square -C roots of the eigenvalues of S*T in the selected cluster. -C To select a real eigenvalue w(j), SELECT(j) must be set -C to .TRUE.. To select a complex conjugate pair of -C eigenvalues w(j) and w(j+1), corresponding to a 2-by-2 -C diagonal block, both SELECT(j) and SELECT(j+1) must be set -C to .TRUE.; a complex conjugate pair of eigenvalues must be -C either both included in the cluster or both excluded. -C This array is not referenced if WHICH = 'A'. -C -C Input/Output Parameters -C -C N (input) INTEGER -C The order of the matrices S, T and G. N >= 0. -C -C MM (input) INTEGER -C The number of columns in the arrays US and/or UU. -C If WHICH = 'A' and METH = 'S', MM >= N; -C if WHICH = 'A' and METH = 'L', MM >= 2*N; -C if WHICH = 'S', MM >= M. -C The minimal values above for MM give the numbers of -C vectors to be used for computing a basis for the -C invariant subspace(s). -C -C ILO (input) INTEGER -C If BALANC <> 'N', then ILO is the integer returned by -C MB03XD. 1 <= ILO <= N+1. -C -C SCALE (input) DOUBLE PRECISION array, dimension (N) -C If BALANC <> 'N', the leading N elements of this array -C must contain details of the permutation and scaling -C factors, as returned by MB03XD. -C This array is not referenced if BALANC = 'N'. -C -C S (input/output) DOUBLE PRECISION array, dimension (LDS,N) -C On entry, the leading N-by-N part of this array must -C contain the matrix S in real Schur form. -C On exit, the leading N-by-N part of this array is -C overwritten. -C -C LDS INTEGER -C The leading dimension of the array S. LDS >= max(1,N). -C -C T (input/output) DOUBLE PRECISION array, dimension (LDT,N) -C On entry, the leading N-by-N part of this array must -C contain the upper triangular matrix T. -C On exit, the leading N-by-N part of this array is -C overwritten. -C -C LDT INTEGER -C The leading dimension of the array T. LDT >= max(1,N). -C -C G (input/output) DOUBLE PRECISION array, dimension (LDG,N) -C On entry, if METH = 'L', the leading N-by-N part of this -C array must contain a general matrix G. -C On exit, if METH = 'L', the leading N-by-N part of this -C array is overwritten. -C This array is not referenced if METH = 'S'. -C -C LDG INTEGER -C The leading dimension of the array G. LDG >= 1. -C LDG >= max(1,N) if METH = 'L'. -C -C U1 (input/output) DOUBLE PRECISION array, dimension (LDU1,N) -C On entry, the leading N-by-N part of this array must -C contain the (1,1) block of an orthogonal symplectic -C matrix U. -C On exit, this array is overwritten. -C -C LDU1 INTEGER -C The leading dimension of the array U1. LDU1 >= MAX(1,N). -C -C U2 (input/output) DOUBLE PRECISION array, dimension (LDU2,N) -C On entry, the leading N-by-N part of this array must -C contain the (2,1) block of an orthogonal symplectic -C matrix U. -C On exit, this array is overwritten. -C -C LDU2 INTEGER -C The leading dimension of the array U2. LDU2 >= MAX(1,N). -C -C V1 (input/output) DOUBLE PRECISION array, dimension (LDV1,N) -C On entry, the leading N-by-N part of this array must -C contain the (1,1) block of an orthogonal symplectic -C matrix V. -C On exit, this array is overwritten. -C -C LDV1 INTEGER -C The leading dimension of the array V1. LDV1 >= MAX(1,N). -C -C V2 (input/output) DOUBLE PRECISION array, dimension (LDV1,N) -C On entry, the leading N-by-N part of this array must -C contain the (2,1) block of an orthogonal symplectic -C matrix V. -C On exit, this array is overwritten. -C -C LDV2 INTEGER -C The leading dimension of the array V2. LDV2 >= MAX(1,N). -C -C M (output) INTEGER -C The number of selected eigenvalues. -C -C WR (output) DOUBLE PRECISION array, dimension (M) -C WI (output) DOUBLE PRECISION array, dimension (M) -C On exit, the leading M elements of WR and WI contain the -C real and imaginary parts, respectively, of the selected -C eigenvalues that have nonpositive real part. Complex -C conjugate pairs of eigenvalues with real part not equal -C to zero will appear consecutively with the eigenvalue -C having the positive imaginary part first. Note that, due -C to roundoff errors, these numbers may differ from the -C eigenvalues computed by MB03XD. -C -C US (output) DOUBLE PRECISION array, dimension (LDUS,MM) -C On exit, if STAB = 'S' or STAB = 'B', the leading 2*N-by-M -C part of this array contains a basis for the stable -C invariant subspace belonging to the selected eigenvalues. -C This basis is orthogonal unless ORTBAL = 'A'. -C -C LDUS INTEGER -C The leading dimension of the array US. LDUS >= 1. -C If STAB = 'S' or STAB = 'B', LDUS >= 2*N. -C -C UU (output) DOUBLE PRECISION array, dimension (LDUU,MM) -C On exit, if STAB = 'U' or STAB = 'B', the leading 2*N-by-M -C part of this array contains a basis for the unstable -C invariant subspace belonging to the selected eigenvalues. -C This basis is orthogonal unless ORTBAL = 'A'. -C -C LDUU INTEGER -C The leading dimension of the array UU. LDUU >= 1. -C If STAB = 'U' or STAB = 'B', LDUU >= 2*N. -C -C Workspace -C -C LWORK LOGICAL array, dimension (2*N) -C This array is only referenced if WHICH = 'A' and -C METH = 'L'. -C -C IWORK INTEGER array, dimension (2*N), -C This array is only referenced if WHICH = 'A' and -C METH = 'L'. -C -C DWORK DOUBLE PRECISION array, dimension (LDWORK) -C On exit, if INFO = 0, DWORK(1) returns the optimal -C value of LDWORK. -C On exit, if INFO = -35, DWORK(1) returns the minimum -C value of LDWORK. -C -C LDWORK INTEGER -C The length of the array DWORK. -C If WHICH = 'S' or METH = 'S': -C LDWORK >= MAX( 1, 4*M*M + MAX( 8*M, 4*N ) ). -C If WHICH = 'A' and METH = 'L' and -C ( STAB = 'U' or STAB = 'S' ): -C LDWORK >= MAX( 1, 2*N*N + 2*N, 8*N ). -C If WHICH = 'A' and METH = 'L' and STAB = 'B': -C LDWORK >= 8*N + 1. -C -C Error Indicator -C -C INFO INTEGER -C = 0: successful exit; -C < 0: if INFO = -i, the i-th argument had an illegal -C value; -C = 1: some of the selected eigenvalues are on or too close -C to the imaginary axis; -C = 2: reordering of the product S*T in routine MB03ZA -C failed because some eigenvalues are too close to -C separate; -C = 3: the QR algorithm failed to compute some Schur form -C in MB03ZA; -C = 4: reordering of the Hamiltonian Schur form in routine -C MB03TD failed because some eigenvalues are too close -C to separate. -C -C METHOD -C -C This is an implementation of Algorithm 1 in [1]. -C -C NUMERICAL ASPECTS -C -C The method is strongly backward stable for an embedded -C (skew-)Hamiltonian matrix, see [1]. Although good results have -C been reported if the eigenvalues are not too close to the -C imaginary axis, the method is not backward stable for the original -C Hamiltonian matrix itself. -C -C REFERENCES -C -C [1] Benner, P., Mehrmann, V., and Xu, H. -C A new method for computing the stable invariant subspace of a -C real Hamiltonian matrix, J. Comput. Appl. Math., 86, -C pp. 17-43, 1997. -C -C [2] Benner, P. -C Symplectic balancing of Hamiltonian matrices. -C SIAM J. Sci. Comput., 22 (5), pp. 1885-1904, 2000. -C -C CONTRIBUTORS -C -C D. Kressner, Technical Univ. Berlin, Germany, and -C P. Benner, Technical Univ. Chemnitz, Germany, December 2003. -C -C REVISIONS -C -C V. Sima, June 2008 (SLICOT version of the HAPACK routine DHASUB). -C -C KEYWORDS -C -C Hamiltonian matrix, invariant subspace. -C -C ****************************************************************** -C -C .. Parameters .. - DOUBLE PRECISION ZERO, ONE - PARAMETER ( ZERO = 0.0D0, ONE = 1.0D0 ) -C .. Scalar Arguments .. - CHARACTER BALANC, METH, ORTBAL, STAB, WHICH - INTEGER ILO, INFO, LDG, LDS, LDT, LDU1, LDU2, LDUS, - $ LDUU, LDV1, LDV2, LDWORK, M, MM, N -C .. Array Arguments .. - LOGICAL LWORK(*), SELECT(*) - INTEGER IWORK(*) - DOUBLE PRECISION DWORK(*), G(LDG,*), S(LDS,*), SCALE(*), - $ T(LDT,*), U1(LDU1,*), U2(LDU2,*), US(LDUS,*), - $ UU(LDUU,*), V1(LDV1,*), V2(LDV2,*), WI(*), - $ WR(*) -C .. Local Scalars .. - LOGICAL LALL, LBAL, LBEF, LEXT, LUS, LUU, PAIR - INTEGER I, IERR, J, K, PDW, PW, WRKMIN, WRKOPT - DOUBLE PRECISION TEMP -C .. External Functions .. - LOGICAL LSAME - EXTERNAL LSAME -C .. External Subroutines .. - EXTERNAL DAXPY, DGEMM, DGEQP3, DGEQRF, DLACPY, DLASCL, - $ DLASET, DORGQR, DSCAL, MB01UX, MB03TD, MB03ZA, - $ MB04DI, XERBLA -C .. Intrinsic Functions .. - INTRINSIC DBLE, INT, MAX, MIN -C -C .. Executable Statements .. -C -C Decode and check input parameters. -C - LALL = LSAME( WHICH, 'A' ) - IF ( LALL ) THEN - LEXT = LSAME( METH, 'L' ) - ELSE - LEXT = .FALSE. - END IF - LUS = LSAME( STAB, 'S' ) .OR. LSAME( STAB, 'B' ) - LUU = LSAME( STAB, 'U' ) .OR. LSAME( STAB, 'B' ) - LBAL = LSAME( BALANC, 'P' ) .OR. LSAME( BALANC, 'S' ) .OR. - $ LSAME( BALANC, 'B' ) - LBEF = .FALSE. - IF ( LBAL ) - $ LBEF = LSAME( ORTBAL, 'B' ) -C - WRKMIN = 1 - WRKOPT = WRKMIN -C - INFO = 0 -C - IF ( .NOT.LALL .AND. .NOT.LSAME( WHICH, 'S' ) ) THEN - INFO = -1 - ELSE IF ( LALL .AND. ( .NOT.LEXT .AND. - $ .NOT.LSAME( METH, 'S' ) ) ) THEN - INFO = -2 - ELSE IF ( .NOT.LUS .AND. .NOT.LUU ) THEN - INFO = -3 - ELSE IF ( .NOT.LBAL .AND. .NOT.LSAME( BALANC, 'N' ) ) THEN - INFO = -4 - ELSE IF ( LBAL .AND. ( .NOT.LBEF .AND. - $ .NOT.LSAME( ORTBAL, 'A' ) ) ) THEN - INFO = -5 - ELSE - IF ( LALL ) THEN - M = N - ELSE -C -C Set M to the dimension of the specified invariant subspace. -C - M = 0 - PAIR = .FALSE. - DO 10 K = 1, N - IF ( PAIR ) THEN - PAIR = .FALSE. - ELSE - IF ( K.LT.N ) THEN - IF ( S(K+1,K).EQ.ZERO ) THEN - IF ( SELECT(K) ) - $ M = M + 1 - ELSE - PAIR = .TRUE. - IF ( SELECT(K) .OR. SELECT(K+1) ) - $ M = M + 2 - END IF - ELSE - IF ( SELECT(N) ) - $ M = M + 1 - END IF - END IF - 10 CONTINUE - END IF -C -C Compute workspace requirements. -C - IF ( .NOT.LEXT ) THEN - WRKOPT = MAX( WRKOPT, 4*M*M + MAX( 8*M, 4*N ) ) - ELSE - IF ( LUS.AND.LUU ) THEN - WRKOPT = MAX( WRKOPT, 8*N + 1 ) - ELSE - WRKOPT = MAX( WRKOPT, 2*N*N + 2*N, 8*N ) - END IF - END IF -C - IF ( N.LT.0 ) THEN - INFO = -7 - ELSE IF ( MM.LT.M .OR. ( LEXT .AND. MM.LT.2*N ) ) THEN - INFO = -8 - ELSE IF ( LBAL .AND. ( ILO.LT.1 .OR. ILO.GT.N+1 ) ) THEN - INFO = -9 - ELSE IF ( LDS.LT.MAX( 1, N ) ) THEN - INFO = -12 - ELSE IF ( LDT.LT.MAX( 1, N ) ) THEN - INFO = -14 - ELSE IF ( LDG.LT.1 .OR. ( LEXT .AND. LDG.LT.N ) ) THEN - INFO = -16 - ELSE IF ( LDU1.LT.MAX( 1, N ) ) THEN - INFO = -18 - ELSE IF ( LDU2.LT.MAX( 1, N ) ) THEN - INFO = -20 - ELSE IF ( LDV1.LT.MAX( 1, N ) ) THEN - INFO = -22 - ELSE IF ( LDV2.LT.MAX( 1, N ) ) THEN - INFO = -24 - ELSE IF ( LDUS.LT.1 .OR. ( LUS .AND. LDUS.LT.2*N ) ) THEN - INFO = -29 - ELSE IF ( LDUU.LT.1 .OR. ( LUU .AND. LDUU.LT.2*N ) ) THEN - INFO = -31 - ELSE IF ( LDWORK.LT.WRKMIN ) THEN - INFO = -35 - DWORK(1) = DBLE( WRKMIN ) - END IF - END IF -C -C Return if there were illegal values. -C - IF ( INFO.NE.0 ) THEN - CALL XERBLA( 'MB03ZD', -INFO ) - RETURN - END IF -C -C Quick return if possible. -C - IF ( MIN( M, N ).EQ.0 ) THEN - DWORK(1) = ONE - RETURN - END IF - WRKOPT = WRKMIN -C - IF ( .NOT.LEXT ) THEN -C -C Workspace requirements: 4*M*M + MAX( 8*M, 4*N ). -C - PW = 1 - PDW = PW + 4*M*M - CALL MB03ZA( 'No Update', 'Update', 'Update', 'Init', WHICH, - $ SELECT, N, S, LDS, T, LDT, G, LDG, U1, LDU1, U2, - $ LDU2, V1, LDV1, V2, LDV2, DWORK(PW), 2*M, WR, WI, - $ M, DWORK(PDW), LDWORK-PDW+1, IERR ) - IF ( IERR.NE.0 ) - $ GO TO 250 -C - PDW = PW + 2*M*M - CALL MB01UX( 'Right', 'Upper', 'No Transpose', N, M, ONE, - $ DWORK(PW), 2*M, V1, LDV1, DWORK(PDW), - $ LDWORK-PDW+1, IERR ) - WRKOPT = MAX( WRKOPT, INT( DWORK(PDW) ) + PDW - 1 ) -C - IF ( LUS ) - $ CALL DLACPY( 'All', N, M, V1, LDV1, US, LDUS ) - IF ( LUU ) - $ CALL DLACPY( 'All', N, M, V1, LDV1, UU, LDUU ) -C - CALL MB01UX( 'Right', 'Upper', 'No Transpose', N, M, ONE, - $ DWORK(PW+M), 2*M, U1, LDU1, DWORK(PDW), - $ LDWORK-PDW+1, IERR ) -C - IF ( LUS ) THEN - DO 20 J = 1, M - CALL DAXPY( N, -ONE, U1(1,J), 1, US(1,J), 1 ) - 20 CONTINUE - END IF - IF ( LUU ) THEN - DO 30 J = 1, M - CALL DAXPY( N, ONE, U1(1,J), 1, UU(1,J), 1 ) - 30 CONTINUE - END IF -C - CALL MB01UX( 'Right', 'Upper', 'No Transpose', N, M, -ONE, - $ DWORK(PW), 2*M, V2, LDV2, DWORK(PDW), - $ LDWORK-PDW+1, IERR ) -C - IF ( LUS ) - $ CALL DLACPY( 'All', N, M, V2, LDV2, US(N+1,1), LDUS ) - IF ( LUU ) - $ CALL DLACPY( 'All', N, M, V2, LDV2, UU(N+1,1), LDUU ) -C - CALL MB01UX( 'Right', 'Upper', 'No Transpose', N, M, ONE, - $ DWORK(PW+M), 2*M, U2, LDU2, DWORK(PDW), - $ LDWORK-PDW+1, IERR ) -C - IF ( LUS ) THEN - DO 40 J = 1, M - CALL DAXPY( N, ONE, U2(1,J), 1, US(N+1,J), 1 ) - 40 CONTINUE - END IF - IF ( LUU ) THEN - DO 50 J = 1, M - CALL DAXPY( N, -ONE, U2(1,J), 1, UU(N+1,J), 1 ) - 50 CONTINUE - END IF -C -C Orthonormalize obtained bases and apply inverse balancing -C transformation. -C - IF ( LBAL .AND. LBEF ) THEN - IF ( LUS ) - $ CALL MB04DI( BALANC, 'Positive', N, ILO, SCALE, M, US, - $ LDUS, US(N+1,1), LDUS, IERR ) - IF ( LUU ) - $ CALL MB04DI( BALANC, 'Positive', N, ILO, SCALE, M, UU, - $ LDUU, UU(N+1,1), LDUU, IERR ) - END IF -C - IF ( LUS ) THEN - CALL DGEQRF( 2*N, M, US, LDUS, DWORK(1), DWORK(M+1), - $ LDWORK-M, IERR ) - WRKOPT = MAX( WRKOPT, INT( DWORK(M+1) ) + M ) - CALL DORGQR( 2*N, M, M, US, LDUS, DWORK(1), DWORK(M+1), - $ LDWORK-M, IERR ) - WRKOPT = MAX( WRKOPT, INT( DWORK(M+1) ) + M ) - END IF - IF ( LUU ) THEN - CALL DGEQRF( 2*N, M, UU, LDUU, DWORK(1), DWORK(M+1), - $ LDWORK-M, IERR ) - WRKOPT = MAX( WRKOPT, INT( DWORK(M+1) ) + M ) - CALL DORGQR( 2*N, M, M, UU, LDUU, DWORK(1), DWORK(M+1), - $ LDWORK-M, IERR ) - WRKOPT = MAX( WRKOPT, INT( DWORK(M+1) ) + M ) - END IF -C - IF ( LBAL .AND. .NOT.LBEF ) THEN - IF ( LUS ) - $ CALL MB04DI( BALANC, 'Positive', N, ILO, SCALE, M, US, - $ LDUS, US(N+1,1), LDUS, IERR ) - IF ( LUU ) - $ CALL MB04DI( BALANC, 'Positive', N, ILO, SCALE, M, UU, - $ LDUU, UU(N+1,1), LDUU, IERR ) - END IF -C - ELSE -C - DO 60 I = 1, 2*N - LWORK(I) = .TRUE. - 60 CONTINUE -C - IF ( LUS .AND.( .NOT.LUU ) ) THEN -C -C Workspace requirements: MAX( 2*N*N + 2*N, 8*N ) -C - CALL MB03ZA( 'Update', 'Update', 'Update', 'Init', WHICH, - $ SELECT, N, S, LDS, T, LDT, G, LDG, U1, LDU1, - $ U2, LDU2, V1, LDV1, V2, LDV2, US, LDUS, WR, - $ WI, M, DWORK, LDWORK, IERR ) - IF ( IERR.NE.0 ) - $ GO TO 250 -C - CALL MB01UX( 'Left', 'Lower', 'Transpose', N, N, ONE, - $ US(N+1,N+1), LDUS, G, LDG, DWORK, LDWORK, - $ IERR ) - WRKOPT = MAX( WRKOPT, INT( DWORK(1) ) ) -C - CALL MB01UX( 'Right', 'Lower', 'No Transpose', N, N, ONE, - $ US(1,N+1), LDUS, G, LDG, DWORK, LDWORK, - $ IERR ) - WRKOPT = MAX( WRKOPT, INT( DWORK(1) ) ) -C - DO 70 J = 1, N - CALL DAXPY( J, ONE, G(J,1), LDG, G(1,J), 1 ) - 70 CONTINUE - PDW = 2*N*N+1 -C -C DW <- -[V1;V2]*W11 -C - CALL DLACPY( 'All', N, N, V1, LDV1, DWORK, 2*N ) - CALL DLACPY( 'All', N, N, V2, LDV2, DWORK(N+1), 2*N ) - CALL MB01UX( 'Right', 'Upper', 'No Transpose', 2*N, N, -ONE, - $ US, LDUS, DWORK, 2*N, DWORK(PDW), LDWORK-PDW+1, - $ IERR ) - WRKOPT = MAX( WRKOPT, INT( DWORK(PDW) ) + PDW - 1 ) -C -C DW2 <- DW2 - U2*W21 -C - CALL DLACPY( 'All', N, N, U2, LDU2, US, LDUS ) - CALL MB01UX( 'Right', 'Upper', 'No Transpose', N, N, ONE, - $ US(N+1,1), LDUS, US, LDUS, DWORK(PDW), - $ LDWORK-PDW+1, IERR ) - DO 80 J = 1, N - CALL DAXPY( N, ONE, US(1,J), 1, DWORK(N+2*(J-1)*N+1), 1 ) - 80 CONTINUE -C -C US11 <- -U1*W21 - DW1 -C - CALL DLACPY( 'All', N, N, U1, LDU1, US, LDUS ) - CALL MB01UX( 'Right', 'Upper', 'No Transpose', N, N, -ONE, - $ US(N+1,1), LDUS, US, LDUS, DWORK(PDW), - $ LDWORK-PDW+1, IERR ) - DO 90 J = 1, N - CALL DAXPY( N, -ONE, DWORK(2*(J-1)*N+1), 1, US(1,J), 1 ) - 90 CONTINUE -C -C US21 <- DW2 -C - CALL DLACPY( 'All', N, N, DWORK(N+1), 2*N, US(N+1,1), LDUS ) -C - CALL MB01UX( 'Right', 'Lower', 'No Transpose', N, N, ONE, - $ US(1,N+1), LDUS, V1, LDV1, DWORK, LDWORK, - $ IERR ) - WRKOPT = MAX( WRKOPT, INT( DWORK(1) ) ) - CALL MB01UX( 'Right', 'Lower', 'No Transpose', N, N, ONE, - $ US(1,N+1), LDUS, V2, LDV2, DWORK, LDWORK, - $ IERR ) - CALL MB01UX( 'Right', 'Lower', 'No Transpose', N, N, ONE, - $ US(N+1,N+1), LDUS, U1, LDU1, DWORK, LDWORK, - $ IERR ) - CALL MB01UX( 'Right', 'Lower', 'No Transpose', N, N, ONE, - $ US(N+1,N+1), LDUS, U2, LDU2, DWORK, LDWORK, - $ IERR ) - CALL DLACPY( 'All', N, N, V1, LDV1, US(1,N+1), LDUS ) - CALL DLACPY( 'All', N, N, V2, LDV2, US(N+1,N+1), LDUS ) - DO 100 J = 1, N - CALL DAXPY( N, -ONE, U1(1,J), 1, US(1,N+J), 1 ) - 100 CONTINUE - DO 110 J = 1, N - CALL DAXPY( N, -ONE, U2(1,J), 1, US(N+1,N+J), 1 ) - 110 CONTINUE -C - CALL MB03TD( 'Hamiltonian', 'Update', LWORK, LWORK(N+1), N, - $ S, LDS, G, LDG, US(1,N+1), LDUS, US(N+1,N+1), - $ LDUS, WR, WI, M, DWORK, LDWORK, IERR ) - IF ( IERR.NE.0 ) THEN - INFO = 4 - RETURN - END IF - CALL DLASCL( 'General', 0, 0, ONE, -ONE, N, N, US(N+1,N+1), - $ LDUS, IERR ) -C - ELSE IF ( ( .NOT.LUS ).AND.LUU ) THEN -C -C Workspace requirements: MAX( 2*N*N + 2*N, 8*N ) -C - CALL MB03ZA( 'Update', 'Update', 'Update', 'Init', WHICH, - $ SELECT, N, S, LDS, T, LDT, G, LDG, U1, LDU1, - $ U2, LDU2, V1, LDV1, V2, LDV2, UU, LDUU, WR, - $ WI, M, DWORK, LDWORK, IERR ) - IF ( IERR.NE.0 ) - $ GO TO 250 - CALL MB01UX( 'Left', 'Lower', 'Transpose', N, N, ONE, - $ UU(N+1,N+1), LDUU, G, LDG, DWORK, LDWORK, - $ IERR ) - WRKOPT = MAX( WRKOPT, INT( DWORK(1) ) ) - CALL MB01UX( 'Right', 'Lower', 'No Transpose', N, N, ONE, - $ UU(1,N+1), LDUU, G, LDG, DWORK, LDWORK, - $ IERR ) - WRKOPT = MAX( WRKOPT, INT( DWORK(1) ) ) - DO 120 J = 1, N - CALL DAXPY( J, ONE, G(J,1), LDG, G(1,J), 1 ) - 120 CONTINUE - PDW = 2*N*N+1 -C -C DW <- -[V1;V2]*W11 -C - CALL DLACPY( 'All', N, N, V1, LDV1, DWORK, 2*N ) - CALL DLACPY( 'All', N, N, V2, LDV2, DWORK(N+1), 2*N ) - CALL MB01UX( 'Right', 'Upper', 'No Transpose', 2*N, N, -ONE, - $ UU, LDUU, DWORK, 2*N, DWORK(PDW), LDWORK-PDW+1, - $ IERR ) - WRKOPT = MAX( WRKOPT, INT( DWORK(PDW) ) + PDW - 1 ) -C -C DW2 <- DW2 - U2*W21 -C - CALL DLACPY( 'All', N, N, U2, LDU2, UU, LDUU ) - CALL MB01UX( 'Right', 'Upper', 'No Transpose', N, N, -ONE, - $ UU(N+1,1), LDUU, UU, LDUU, DWORK(PDW), - $ LDWORK-PDW+1, IERR ) - DO 130 J = 1, N - CALL DAXPY( N, ONE, UU(1,J), 1, DWORK(N+2*(J-1)*N+1), 1 ) - 130 CONTINUE -C -C UU11 <- U1*W21 - DW1 -C - CALL DLACPY( 'All', N, N, U1, LDU1, UU, LDUU ) - CALL MB01UX( 'Right', 'Upper', 'No Transpose', N, N, ONE, - $ UU(N+1,1), LDUU, UU, LDUU, DWORK(PDW), - $ LDWORK-PDW+1, IERR ) - DO 140 J = 1, N - CALL DAXPY( N, -ONE, DWORK(2*(J-1)*N+1), 1, UU(1,J), 1 ) - 140 CONTINUE -C -C UU21 <- DW2 -C - CALL DLACPY( 'All', N, N, DWORK(N+1), 2*N, UU(N+1,1), LDUU ) -C - CALL MB01UX( 'Right', 'Lower', 'No Transpose', N, N, ONE, - $ UU(1,N+1), LDUU, V1, LDV1, DWORK, LDWORK, - $ IERR ) - WRKOPT = MAX( WRKOPT, INT( DWORK(1) ) ) - CALL MB01UX( 'Right', 'Lower', 'No Transpose', N, N, ONE, - $ UU(1,N+1), LDUU, V2, LDV2, DWORK, LDWORK, - $ IERR ) - CALL MB01UX( 'Right', 'Lower', 'No Transpose', N, N, ONE, - $ UU(N+1,N+1), LDUU, U1, LDU1, DWORK, LDWORK, - $ IERR ) - CALL MB01UX( 'Right', 'Lower', 'No Transpose', N, N, ONE, - $ UU(N+1,N+1), LDUU, U2, LDU2, DWORK, LDWORK, - $ IERR ) - CALL DLACPY( 'All', N, N, V1, LDV1, UU(1,N+1), LDUU ) - CALL DLACPY( 'All', N, N, V2, LDV2, UU(N+1,N+1), LDUU ) - DO 150 J = 1, N - CALL DAXPY( N, ONE, U1(1,J), 1, UU(1,N+J), 1 ) - 150 CONTINUE - DO 160 J = 1, N - CALL DAXPY( N, ONE, U2(1,J), 1, UU(N+1,N+J), 1 ) - 160 CONTINUE -C - CALL MB03TD( 'Hamiltonian', 'Update', LWORK, LWORK(N+1), N, - $ S, LDS, G, LDG, UU(1,N+1), LDUU, UU(N+1,N+1), - $ LDUU, WR, WI, M, DWORK, LDWORK, IERR ) - IF ( IERR.NE.0 ) THEN - INFO = 4 - RETURN - END IF - CALL DLASCL( 'General', 0, 0, ONE, -ONE, N, N, UU(N+1,N+1), - $ LDUU, IERR ) - ELSE -C -C Workspace requirements: 8*N -C - CALL MB03ZA( 'Update', 'Update', 'Update', 'Init', WHICH, - $ SELECT, N, S, LDS, T, LDT, G, LDG, U1, LDU1, - $ U2, LDU2, V1, LDV1, V2, LDV2, US, LDUS, WR, - $ WI, M, DWORK, LDWORK, IERR ) - IF ( IERR.NE.0 ) - $ GO TO 250 - CALL MB01UX( 'Left', 'Lower', 'Transpose', N, N, ONE, - $ US(N+1,N+1), LDUS, G, LDG, DWORK, LDWORK, - $ IERR ) - WRKOPT = MAX( WRKOPT, INT( DWORK(1) ) ) - CALL MB01UX( 'Right', 'Lower', 'No Transpose', N, N, ONE, - $ US(1,N+1), LDUS, G, LDG, DWORK, LDWORK, - $ IERR ) - WRKOPT = MAX( WRKOPT, INT( DWORK(1) ) ) - DO 170 J = 1, N - CALL DAXPY( J, ONE, G(J,1), LDG, G(1,J), 1 ) - 170 CONTINUE -C -C UU = [ V1 -V2; U1 -U2 ]*diag(W11,W21) -C - CALL DLACPY( 'All', N, N, V1, LDV1, UU, LDUU ) - CALL DLACPY( 'All', N, N, V2, LDV2, UU(N+1,1), LDUU ) - CALL MB01UX( 'Right', 'Upper', 'No Transpose', 2*N, N, ONE, - $ US, LDUS, UU, LDUU, DWORK, LDWORK, IERR ) - WRKOPT = MAX( WRKOPT, INT( DWORK(1) ) ) - CALL DLACPY( 'All', N, N, U1, LDU1, UU(1,N+1), LDUU ) - CALL DLACPY( 'All', N, N, U2, LDU2, UU(N+1,N+1), LDUU ) - CALL MB01UX( 'Right', 'Upper', 'No Transpose', 2*N, N, ONE, - $ US(N+1,1), LDUS, UU(1,N+1), LDUU, DWORK, - $ LDWORK, IERR ) - CALL DLASCL( 'General', 0, 0, ONE, -ONE, N, 2*N, UU(N+1,1), - $ LDUU, IERR ) -C - CALL DLACPY( 'All', 2*N, N, UU, LDUU, US, LDUS ) - DO 180 J = 1, N - CALL DAXPY( 2*N, -ONE, UU(1,N+J), 1, US(1,J), 1 ) - 180 CONTINUE - DO 190 J = 1, N - CALL DAXPY( 2*N, ONE, UU(1,N+J), 1, UU(1,J), 1 ) - 190 CONTINUE -C -C V1 <- V1*W12-U1*W22 -C U1 <- V1*W12+U1*W22 -C V2 <- V2*W12-U2*W22 -C U2 <- V2*W12+U2*W22 -C - CALL MB01UX( 'Right', 'Lower', 'No Transpose', N, N, ONE, - $ US(1,N+1), LDUS, V1, LDV1, DWORK, LDWORK, - $ IERR ) - CALL MB01UX( 'Right', 'Lower', 'No Transpose', N, N, ONE, - $ US(1,N+1), LDUS, V2, LDV2, DWORK, LDWORK, - $ IERR ) - CALL MB01UX( 'Right', 'Lower', 'No Transpose', N, N, ONE, - $ US(N+1,N+1), LDUS, U1, LDU1, DWORK, LDWORK, - $ IERR ) - CALL MB01UX( 'Right', 'Lower', 'No Transpose', N, N, ONE, - $ US(N+1,N+1), LDUS, U2, LDU2, DWORK, LDWORK, - $ IERR ) - DO 210 J = 1, N - DO 200 I = 1, N - TEMP = V1(I,J) - V1(I,J) = TEMP - U1(I,J) - U1(I,J) = TEMP + U1(I,J) - 200 CONTINUE - 210 CONTINUE - DO 230 J = 1, N - DO 220 I = 1, N - TEMP = V2(I,J) - V2(I,J) = TEMP - U2(I,J) - U2(I,J) = TEMP + U2(I,J) - 220 CONTINUE - 230 CONTINUE -C - CALL DLASET( 'All', 2*N, N, ZERO, ONE, US(1,N+1), LDUS ) - CALL MB03TD( 'Hamiltonian', 'Update', LWORK, LWORK(N+1), N, - $ S, LDS, G, LDG, US(1,N+1), LDUS, US(N+1,N+1), - $ LDUS, WR, WI, M, DWORK, LDWORK, IERR ) - IF ( IERR.NE.0 ) THEN - INFO = 4 - RETURN - END IF - CALL DGEMM( 'No Transpose', 'No Transpose', N, N, N, ONE, - $ U1, LDU1, US(1,N+1), LDUS, ZERO, UU(1,N+1), - $ LDUU ) - CALL DGEMM( 'No Transpose', 'No Transpose', N, N, N, -ONE, - $ U2, LDU2, US(N+1,N+1), LDUS, ONE, UU(1,N+1), - $ LDUU ) - CALL DGEMM( 'No Transpose', 'No Transpose', N, N, N, -ONE, - $ U1, LDU1, US(N+1,N+1), LDUS, ZERO, UU(N+1,N+1), - $ LDUU ) - CALL DGEMM( 'No Transpose', 'No Transpose', N, N, N, -ONE, - $ U2, LDU2, US(1,N+1), LDUS, ONE, UU(N+1,N+1), - $ LDUU ) - CALL DLACPY( 'All', N, N, US(1,N+1), LDUS, U1, LDU1 ) - CALL DLACPY( 'All', N, N, US(N+1,N+1), LDUS, U2, LDU2 ) - CALL DGEMM( 'No Transpose', 'No Transpose', N, N, N, ONE, - $ V1, LDV1, U1, LDU1, ZERO, US(1,N+1), LDUS ) - CALL DGEMM( 'No Transpose', 'No Transpose', N, N, N, -ONE, - $ V2, LDV2, U2, LDU2, ONE, US(1,N+1), LDUS ) - CALL DGEMM( 'No Transpose', 'No Transpose', N, N, N, -ONE, - $ V1, LDV1, U2, LDU2, ZERO, US(N+1,N+1), LDUS ) - CALL DGEMM( 'No Transpose', 'No Transpose', N, N, N, -ONE, - $ V2, LDV2, U1, LDU1, ONE, US(N+1,N+1), LDUS ) - END IF -C -C Orthonormalize obtained bases and apply inverse balancing -C transformation. -C - IF ( LBAL .AND. LBEF ) THEN - IF ( LUS ) - $ CALL MB04DI( BALANC, 'Positive', N, ILO, SCALE, N, US, - $ LDUS, US(N+1,1), LDUS, IERR ) - IF ( LUU ) - $ CALL MB04DI( BALANC, 'Positive', N, ILO, SCALE, N, UU, - $ LDUU, UU(N+1,1), LDUU, IERR ) - END IF -C -C Workspace requirements: 8*N+1 -C - DO 240 J = 1, 2*N - IWORK(J) = 0 - 240 CONTINUE - IF ( LUS ) THEN - CALL DGEQP3( 2*N, 2*N, US, LDUS, IWORK, DWORK, DWORK(2*N+1), - $ LDWORK-2*N, IERR ) - WRKOPT = MAX( WRKOPT, INT( DWORK(2*N+1) ) + 2*N ) - CALL DORGQR( 2*N, 2*N, N, US, LDUS, DWORK, DWORK(2*N+1), - $ LDWORK-2*N, IERR ) - WRKOPT = MAX( WRKOPT, INT( DWORK(2*N+1) ) + 2*N ) - END IF - IF ( LUU ) THEN - CALL DGEQP3( 2*N, 2*N, UU, LDUU, IWORK, DWORK, DWORK(2*N+1), - $ LDWORK-2*N, IERR ) - WRKOPT = MAX( WRKOPT, INT( DWORK(2*N+1) ) + 2*N ) - CALL DORGQR( 2*N, 2*N, N, UU, LDUU, DWORK, DWORK(2*N+1), - $ LDWORK-2*N, IERR ) - WRKOPT = MAX( WRKOPT, INT( DWORK(2*N+1) ) + 2*N ) - END IF -C - IF ( LBAL .AND. .NOT.LBEF ) THEN - IF ( LUS ) - $ CALL MB04DI( BALANC, 'Positive', N, ILO, SCALE, N, US, - $ LDUS, US(N+1,1), LDUS, IERR ) - IF ( LUU ) - $ CALL MB04DI( BALANC, 'Positive', N, ILO, SCALE, N, UU, - $ LDUU, UU(N+1,1), LDUU, IERR ) - END IF - END IF -C - CALL DSCAL( M, -ONE, WR, 1 ) - DWORK(1) = DBLE( WRKOPT ) -C - RETURN - 250 CONTINUE - IF ( IERR.EQ.1 ) THEN - INFO = 2 - ELSE IF ( IERR.EQ.2 .OR. IERR.EQ.4 ) THEN - INFO = 1 - ELSE IF ( IERR.EQ.3 ) THEN - INFO = 3 - END IF - RETURN -C *** Last line of MB03ZD *** - END diff --git a/mex/sources/libslicot/MB04DD.f b/mex/sources/libslicot/MB04DD.f deleted file mode 100644 index 857bceef0..000000000 --- a/mex/sources/libslicot/MB04DD.f +++ /dev/null @@ -1,440 +0,0 @@ - SUBROUTINE MB04DD( JOB, N, A, LDA, QG, LDQG, ILO, SCALE, INFO ) -C -C SLICOT RELEASE 5.0. -C -C Copyright (c) 2002-2009 NICONET e.V. -C -C This program is free software: you can redistribute it and/or -C modify it under the terms of the GNU General Public License as -C published by the Free Software Foundation, either version 2 of -C the License, or (at your option) any later version. -C -C This program is distributed in the hope that it will be useful, -C but WITHOUT ANY WARRANTY; without even the implied warranty of -C MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the -C GNU General Public License for more details. -C -C You should have received a copy of the GNU General Public License -C along with this program. If not, see -C . -C -C PURPOSE -C -C To balance a real Hamiltonian matrix, -C -C [ A G ] -C H = [ T ] , -C [ Q -A ] -C -C where A is an N-by-N matrix and G, Q are N-by-N symmetric -C matrices. This involves, first, permuting H by a symplectic -C similarity transformation to isolate eigenvalues in the first -C 1:ILO-1 elements on the diagonal of A; and second, applying a -C diagonal similarity transformation to rows and columns -C ILO:2*N-ILO+1 to make the rows and columns as close in 1-norm -C as possible. Both steps are optional. -C -C ARGUMENTS -C -C Mode Parameters -C -C JOB CHARACTER*1 -C Specifies the operations to be performed on H: -C = 'N': none, set ILO = 1, SCALE(I) = 1.0, I = 1 .. N; -C = 'P': permute only; -C = 'S': scale only; -C = 'B': both permute and scale. -C -C Input/Output Parameters -C -C N (input) INTEGER -C The order of the matrix A. N >= 0. -C -C A (input/output) DOUBLE PRECISION array, dimension (LDA,N) -C On entry, the leading N-by-N part of this array must -C contain the matrix A. -C On exit, the leading N-by-N part of this array contains -C the matrix A of the balanced Hamiltonian. In particular, -C the lower triangular part of the first ILO-1 columns of A -C is zero. -C -C LDA INTEGER -C The leading dimension of the array A. LDA >= MAX(1,N). -C -C QG (input/output) DOUBLE PRECISION array, dimension -C (LDQG,N+1) -C On entry, the leading N-by-N+1 part of this array must -C contain the lower triangular part of the matrix Q and -C the upper triangular part of the matrix G. -C On exit, the leading N-by-N+1 part of this array contains -C the lower and upper triangular parts of the matrices Q and -C G, respectively, of the balanced Hamiltonian. In -C particular, the lower triangular and diagonal part of the -C first ILO-1 columns of QG is zero. -C -C LDQG INTEGER -C The leading dimension of the array QG. LDQG >= MAX(1,N). -C -C ILO (output) INTEGER -C ILO-1 is the number of deflated eigenvalues in the -C balanced Hamiltonian matrix. -C -C SCALE (output) DOUBLE PRECISION array of dimension (N) -C Details of the permutations and scaling factors applied to -C H. For j = 1,...,ILO-1 let P(j) = SCALE(j). If P(j) <= N, -C then rows and columns P(j) and P(j)+N are interchanged -C with rows and columns j and j+N, respectively. If -C P(j) > N, then row and column P(j)-N are interchanged with -C row and column j+N by a generalized symplectic -C permutation. For j = ILO,...,N the j-th element of SCALE -C contains the factor of the scaling applied to row and -C column j. -C -C Error Indicator -C -C INFO INTEGER -C = 0: successful exit; -C < 0: if INFO = -i, the i-th argument had an illegal -C value. -C -C REFERENCES -C -C [1] Benner, P. -C Symplectic balancing of Hamiltonian matrices. -C SIAM J. Sci. Comput., 22 (5), pp. 1885-1904, 2000. -C -C CONTRIBUTORS -C -C D. Kressner, Technical Univ. Berlin, Germany, and -C P. Benner, Technical Univ. Chemnitz, Germany, December 2003. -C -C REVISIONS -C -C V. Sima, June 2008 (SLICOT version of the HAPACK routine DHABAL). -C -C KEYWORDS -C -C Balancing, Hamiltonian matrix. -C -C ****************************************************************** -C -C .. Parameters .. - DOUBLE PRECISION ZERO, ONE - PARAMETER ( ZERO = 0.0D0, ONE = 1.0D0 ) -C .. Scalar Arguments .. - CHARACTER JOB - INTEGER ILO, INFO, LDA, LDQG, N -C .. Array Arguments .. - DOUBLE PRECISION A(LDA,*), QG(LDQG,*), SCALE(*) -C .. Local Scalars .. - LOGICAL CONV, LPERM, LSCAL - INTEGER I, IC, ILOOLD, J - DOUBLE PRECISION C, F, GII, MAXC, MAXR, QII, R, SCLFAC, - $ SFMAX1, SFMAX2, SFMIN1, SFMIN2, TEMP -C .. External Functions .. - LOGICAL LSAME - INTEGER IDAMAX - DOUBLE PRECISION DASUM, DLAMCH - EXTERNAL DASUM, DLAMCH, IDAMAX, LSAME -C .. External Subroutines .. - EXTERNAL DRSCL, DSCAL, DSWAP, XERBLA -C .. Intrinsic Functions .. - INTRINSIC ABS, DBLE, MAX, MIN -C -C .. Executable Statements .. -C -C Check the scalar input parameters. -C - INFO = 0 - LPERM = LSAME( JOB, 'P' ) .OR. LSAME( JOB, 'B' ) - LSCAL = LSAME( JOB, 'S' ) .OR. LSAME( JOB, 'B' ) -C - IF ( .NOT.LPERM .AND. .NOT.LSCAL - $ .AND. .NOT.LSAME( JOB, 'N' ) ) THEN - INFO = -1 - ELSE IF ( N.LT.0 ) THEN - INFO = -2 - ELSE IF ( LDA.LT.MAX( 1, N ) ) THEN - INFO = -4 - ELSE IF ( LDQG.LT.MAX( 1, N ) ) THEN - INFO = -6 - END IF -C -C Return if there were illegal values. -C - IF( INFO.NE.0 ) THEN - CALL XERBLA( 'MB04DD', -INFO ) - RETURN - END IF -C - ILO = 1 -C -C Quick return if possible. -C - IF ( N.EQ.0 ) - $ RETURN - IF ( .NOT.LPERM .AND. .NOT.LSCAL ) THEN - DO 10 I = 1, N - SCALE(I) = ONE - 10 CONTINUE - RETURN - END IF -C -C Permutations to isolate eigenvalues if possible. -C - IF ( LPERM ) THEN - ILOOLD = 0 -C WHILE ( ILO.NE.ILOOLD ) - 20 IF ( ILO.NE.ILOOLD ) THEN - ILOOLD = ILO -C -C Scan columns ILO .. N. -C - I = ILO -C WHILE ( I.LE.N .AND. ILO.EQ.ILOOLD ) - 30 IF ( I.LE.N .AND. ILO.EQ.ILOOLD ) THEN - DO 40 J = ILO, I-1 - IF ( A(J,I).NE.ZERO ) THEN - I = I + 1 - GOTO 30 - END IF - 40 CONTINUE - DO 50 J = I+1, N - IF ( A(J,I).NE.ZERO ) THEN - I = I + 1 - GOTO 30 - END IF - 50 CONTINUE - DO 60 J = ILO, I - IF ( QG(I,J).NE.ZERO ) THEN - I = I + 1 - GOTO 30 - END IF - 60 CONTINUE - DO 70 J = I+1, N - IF ( QG(J,I).NE.ZERO ) THEN - I = I + 1 - GOTO 30 - END IF - 70 CONTINUE -C -C Exchange columns/rows ILO <-> I. -C - SCALE( ILO ) = DBLE( I ) - IF ( ILO.NE.I ) THEN -C - CALL DSWAP( N, A(1,ILO), 1, A(1,I), 1 ) - CALL DSWAP( N-ILO+1, A(ILO,ILO), LDA, A(I,ILO), LDA ) -C - CALL DSWAP( 1, QG(I,ILO), LDQG, QG(ILO,ILO), LDQG ) - CALL DSWAP( N-I+1, QG(I,I), 1, QG(I,ILO), 1 ) - CALL DSWAP( I-ILO, QG(ILO,ILO), 1, QG(I,ILO), LDQG ) -C - CALL DSWAP( ILO, QG(1,I+1), 1, QG(1,ILO+1), 1 ) - CALL DSWAP( N-I+1, QG(I,I+1), LDQG, QG(ILO,I+1), - $ LDQG ) - CALL DSWAP( I-ILO, QG(ILO,ILO+1), LDQG, QG(ILO,I+1), - $ 1 ) - END IF - ILO = ILO + 1 - END IF -C END WHILE 30 -C -C Scan columns N+ILO .. 2*N. -C - I = ILO -C WHILE ( I.LE.N .AND. ILO.EQ.ILOOLD ) - 80 IF ( I.LE.N .AND. ILO.EQ.ILOOLD ) THEN - DO 90 J = ILO, I-1 - IF ( A(I,J).NE.ZERO ) THEN - I = I + 1 - GOTO 80 - END IF - 90 CONTINUE - DO 100 J = I+1, N - IF ( A(I,J).NE.ZERO ) THEN - I = I + 1 - GOTO 80 - END IF - 100 CONTINUE - DO 110 J = ILO, I - IF ( QG(J,I+1).NE.ZERO ) THEN - I = I + 1 - GOTO 80 - END IF - 110 CONTINUE - DO 120 J = I+1, N - IF ( QG(I,J+1).NE.ZERO ) THEN - I = I + 1 - GOTO 80 - END IF - 120 CONTINUE - SCALE( ILO ) = DBLE( N+I ) -C -C Exchange columns/rows I <-> I+N with a symplectic -C generalized permutation. -C - CALL DSWAP( I-ILO, A(I,ILO), LDA, QG(I,ILO), LDQG ) - CALL DSCAL( I-ILO, -ONE, A(I,ILO), LDA ) - CALL DSWAP( N-I, A(I,I+1), LDA, QG(I+1,I), 1 ) - CALL DSCAL( N-I, -ONE, A(I,I+1), LDA ) - CALL DSWAP( I-1, A(1,I), 1, QG(1,I+1), 1 ) - CALL DSCAL( I-1, -ONE, A(1,I), 1 ) - CALL DSWAP( N-I, A(I+1,I), 1, QG(I,I+2), LDQG ) - CALL DSCAL( N-I, -ONE, A(I+1,I), 1 ) - A(I,I) = -A(I,I) - TEMP = QG(I,I) - QG(I,I) = -QG(I,I+1) - QG(I,I+1) = -TEMP -C -C Exchange columns/rows ILO <-> I. -C - IF ( ILO.NE.I ) THEN -C - CALL DSWAP( N, A(1,ILO), 1, A(1,I), 1 ) - CALL DSWAP( N-ILO+1, A(ILO,ILO), LDA, A(I,ILO), LDA ) -C - CALL DSWAP( 1, QG(I,ILO), LDQG, QG(ILO,ILO), LDQG ) - CALL DSWAP( N-I+1, QG(I,I), 1, QG(I,ILO), 1 ) - CALL DSWAP( I-ILO, QG(ILO,ILO), 1, QG(I,ILO), LDQG ) -C - CALL DSWAP( ILO, QG(1,I+1), 1, QG(1,ILO+1), 1 ) - CALL DSWAP( N-I+1, QG(I,I+1), LDQG, QG(ILO,I+1), - $ LDQG ) - CALL DSWAP( I-ILO, QG(ILO,ILO+1), LDQG, QG(ILO,I+1), - $ 1 ) - END IF - ILO = ILO + 1 - END IF -C END WHILE 80 - GOTO 20 - END IF -C END WHILE 20 - END IF -C - DO 130 I = ILO, N - SCALE(I) = ONE - 130 CONTINUE -C -C Scale to reduce the 1-norm of the remaining blocks. -C - IF ( LSCAL ) THEN - SCLFAC = DLAMCH( 'B' ) - SFMIN1 = DLAMCH( 'S' ) / DLAMCH( 'P' ) - SFMAX1 = ONE / SFMIN1 - SFMIN2 = SFMIN1*SCLFAC - SFMAX2 = ONE / SFMIN2 -C -C Scale the rows and columns one at a time to minimize the -C 1-norm of the remaining Hamiltonian submatrix. -C Stop when the 1-norm is very roughly minimal. -C - 140 CONTINUE - CONV = .TRUE. - DO 170 I = ILO, N -C -C Compute 1-norm of row and column I without diagonal -C elements. -C - R = DASUM( I-ILO, A(I,ILO), LDA ) + - $ DASUM( N-I, A(I,I+1), LDA ) + - $ DASUM( I-ILO, QG(ILO,I+1), 1 ) + - $ DASUM( N-I, QG(I,I+2), LDQG ) - C = DASUM( I-ILO, A(ILO,I), 1 ) + - $ DASUM( N-I, A(I+1,I), 1 ) + - $ DASUM( I-ILO, QG(I,ILO), LDQG ) + - $ DASUM( N-I, QG(I+1,I), 1 ) - QII = ABS( QG(I,I) ) - GII = ABS( QG(I,I+1) ) -C -C Compute inf-norms of row and column I. -C - IC = IDAMAX( N-ILO+1, A(I,ILO), LDA ) - MAXR = ABS( A(I,IC+ILO-1) ) - IF ( I.GT.1 ) THEN - IC = IDAMAX( I-1, QG(1,I+1), 1 ) - MAXR = MAX( MAXR, ABS( QG(IC,I+1) ) ) - END IF - IF ( N.GT.I ) THEN - IC = IDAMAX( N-I, QG(I,I+2), LDQG ) - MAXR = MAX( MAXR, ABS( QG(I,IC+I+1) ) ) - END IF - IC = IDAMAX( N, A(1,I), 1 ) - MAXC = ABS( A(IC,I) ) - IF ( I.GT.ILO ) THEN - IC = IDAMAX( I-ILO, QG(I,ILO), LDQG ) - MAXC = MAX( MAXC, ABS( QG(I,IC+ILO-1) ) ) - END IF - IF ( N.GT.I ) THEN - IC = IDAMAX( N-I, QG(I+1,I), 1 ) - MAXC = MAX( MAXC, ABS( QG(IC+I,I) ) ) - END IF - IF ( ( C + QII ).EQ.ZERO .OR. ( R + GII ).EQ.ZERO ) - $ GO TO 170 -C - F = ONE - 150 CONTINUE - IF ( ( ( R + GII/SCLFAC )/SCLFAC ).GE. - $ ( ( C + QII*SCLFAC )*SCLFAC ) .AND. - $ MAX( F*SCLFAC, C*SCLFAC, MAXC*SCLFAC, - $ QII*SCLFAC*SCLFAC ).LT.SFMAX2 .AND. - $ MIN( ( R + GII/SCLFAC )/SCLFAC, MAX( MAXR/SCLFAC, - $ GII/SCLFAC/SCLFAC ) ).GT.SFMIN2 ) THEN - F = F*SCLFAC - C = C*SCLFAC - QII = QII*SCLFAC*SCLFAC - R = R / SCLFAC - GII = GII/SCLFAC/SCLFAC - MAXC = MAXC*SCLFAC - MAXR = MAXR / SCLFAC - GO TO 150 - END IF -C - 160 CONTINUE - IF ( ( ( R + GII*SCLFAC )*SCLFAC ).LE. - $ ( ( C + QII/SCLFAC )/SCLFAC ) .AND. - $ MAX( R*SCLFAC, MAXR*SCLFAC, - $ GII*SCLFAC*SCLFAC ).LT.SFMAX2 .AND. - $ MIN( F/SCLFAC, ( C + QII/SCLFAC )/SCLFAC, - $ MAX( MAXC/SCLFAC, QII/SCLFAC/SCLFAC ) ) - $ .GT.SFMIN2 ) THEN - F = F / SCLFAC - C = C / SCLFAC - QII = QII/SCLFAC/SCLFAC - R = R*SCLFAC - GII = GII*SCLFAC*SCLFAC - MAXC = MAXC/SCLFAC - MAXR = MAXR*SCLFAC - GO TO 160 - END IF -C -C Now balance if necessary. -C - IF ( F.NE.ONE ) THEN - IF ( F.LT.ONE .AND. SCALE(I).LT.ONE ) THEN - IF ( F*SCALE(I).LE.SFMIN1 ) - $ GO TO 170 - END IF - IF ( F.GT.ONE .AND. SCALE(I).GT.ONE ) THEN - IF ( SCALE(I).GE.SFMAX1 / F ) - $ GO TO 170 - END IF - CONV = .FALSE. - SCALE(I) = SCALE(I)*F - CALL DRSCL( I-ILO, F, A(I,ILO), LDA ) - CALL DRSCL( N-I, F, A(I,I+1), LDA ) - CALL DSCAL( I-1, F, A(1,I), 1 ) - CALL DSCAL( N-I, F, A(I+1,I), 1 ) - CALL DRSCL( I-1, F, QG(1,I+1), 1 ) - QG(I,I+1) = QG(I,I+1) / F / F - CALL DRSCL( N-I, F, QG(I,I+1+1), LDQG ) - CALL DSCAL( I-ILO, F, QG(I,ILO), LDQG ) - QG(I,I) = QG(I,I) * F * F - CALL DSCAL( N-I, F, QG(I+1,I), 1 ) - END IF - 170 CONTINUE - IF ( .NOT.CONV ) GO TO 140 - END IF - RETURN -C *** Last line of MB04DD *** - END diff --git a/mex/sources/libslicot/MB04DI.f b/mex/sources/libslicot/MB04DI.f deleted file mode 100644 index 793d6ab5a..000000000 --- a/mex/sources/libslicot/MB04DI.f +++ /dev/null @@ -1,216 +0,0 @@ - SUBROUTINE MB04DI( JOB, SGN, N, ILO, SCALE, M, V1, LDV1, V2, LDV2, - $ INFO ) -C -C SLICOT RELEASE 5.0. -C -C Copyright (c) 2002-2009 NICONET e.V. -C -C This program is free software: you can redistribute it and/or -C modify it under the terms of the GNU General Public License as -C published by the Free Software Foundation, either version 2 of -C the License, or (at your option) any later version. -C -C This program is distributed in the hope that it will be useful, -C but WITHOUT ANY WARRANTY; without even the implied warranty of -C MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the -C GNU General Public License for more details. -C -C You should have received a copy of the GNU General Public License -C along with this program. If not, see -C . -C -C PURPOSE -C -C To apply the inverse of a balancing transformation, computed by -C the SLICOT Library routines MB04DD or MB04DS, to a 2*N-by-M matrix -C -C [ V1 ] -C [ ], -C [ sgn*V2 ] -C -C where sgn is either +1 or -1. -C -C ARGUMENTS -C -C Mode Parameters -C -C JOB CHARACTER*1 -C Specifies the type of inverse transformation required: -C = 'N': do nothing, return immediately; -C = 'P': do inverse transformation for permutation only; -C = 'S': do inverse transformation for scaling only; -C = 'B': do inverse transformations for both permutation -C and scaling. -C JOB must be the same as the argument JOB supplied to -C MB04DD or MB04DS. -C -C SGN CHARACTER*1 -C Specifies the sign to use for V2: -C = 'P': sgn = +1; -C = 'N': sgn = -1. -C -C Input/Output Parameters -C -C N (input) INTEGER -C The number of rows of the matrices V1 and V2. N >= 0. -C -C ILO (input) INTEGER -C The integer ILO determined by MB04DD or MB04DS. -C 1 <= ILO <= N+1. -C -C SCALE (input) DOUBLE PRECISION array, dimension (N) -C Details of the permutation and scaling factors, as -C returned by MB04DD or MB04DS. -C -C M (input) INTEGER -C The number of columns of the matrices V1 and V2. M >= 0. -C -C V1 (input/output) DOUBLE PRECISION array, dimension (LDV1,M) -C On entry, the leading N-by-M part of this array must -C contain the matrix V1. -C On exit, the leading N-by-M part of this array is -C overwritten by the updated matrix V1 of the transformed -C matrix. -C -C LDV1 INTEGER -C The leading dimension of the array V1. LDV1 >= max(1,N). -C -C V2 (input/output) DOUBLE PRECISION array, dimension (LDV2,M) -C On entry, the leading N-by-M part of this array must -C contain the matrix V2. -C On exit, the leading N-by-M part of this array is -C overwritten by the updated matrix V2 of the transformed -C matrix. -C -C LDV2 INTEGER -C The leading dimension of the array V2. LDV2 >= max(1,N). -C -C Error Indicator -C -C INFO INTEGER -C = 0: successful exit; -C < 0: if INFO = -i, the i-th argument had an illegal -C value. -C -C REFERENCES -C -C [1] Benner, P. -C Symplectic balancing of Hamiltonian matrices. -C SIAM J. Sci. Comput., 22 (5), pp. 1885-1904, 2000. -C -C CONTRIBUTORS -C -C D. Kressner, Technical Univ. Berlin, Germany, and -C P. Benner, Technical Univ. Chemnitz, Germany, December 2003. -C -C REVISIONS -C -C V. Sima, June 2008 (SLICOT version of the HAPACK routine DHABAK). -C -C KEYWORDS -C -C Balancing, Hamiltonian matrix, skew-Hamiltonian matrix. -C -C ****************************************************************** -C -C .. Parameters .. - DOUBLE PRECISION ONE - PARAMETER ( ONE = 1.0D0 ) -C .. Scalar Arguments .. - CHARACTER JOB, SGN - INTEGER ILO, INFO, LDV1, LDV2, M, N -C .. Array Arguments .. - DOUBLE PRECISION SCALE(*), V1(LDV1,*), V2(LDV2,*) -C .. Local Scalars .. - LOGICAL LPERM, LSCAL, LSGN, SYSW - INTEGER I, K -C .. External Functions .. - LOGICAL LSAME - EXTERNAL LSAME -C .. External Subroutines .. - EXTERNAL DRSCL, DSCAL, DSWAP, XERBLA -C .. Intrinsic Functions .. - INTRINSIC MAX -C -C .. Executable Statements .. -C -C Check the scalar input parameters. -C - INFO = 0 - LPERM = LSAME( JOB, 'P' ) .OR. LSAME( JOB, 'B' ) - LSCAL = LSAME( JOB, 'S' ) .OR. LSAME( JOB, 'B' ) - LSGN = LSAME( SGN, 'N' ) - IF ( .NOT.LPERM .AND. .NOT.LSCAL - $ .AND. .NOT.LSAME( JOB, 'N' ) ) THEN - INFO = -1 - ELSE IF ( .NOT.LSGN .AND. .NOT.LSAME( SGN, 'P' ) ) THEN - INFO = -2 - ELSE IF ( N.LT.0 ) THEN - INFO = -3 - ELSE IF ( ILO.LT.1 .OR. ILO.GT.N+1 ) THEN - INFO = -4 - ELSE IF ( M.LT.0 ) THEN - INFO = -6 - ELSE IF ( LDV1.LT.MAX( 1, N ) ) THEN - INFO = -8 - ELSE IF ( LDV2.LT.MAX( 1, N ) ) THEN - INFO = -10 - END IF -C -C Return if there were illegal values. -C - IF( INFO.NE.0 ) THEN - CALL XERBLA( 'MB04DI', -INFO ) - RETURN - END IF -C -C Quick return if possible. -C - IF ( N.EQ.0 .OR. M.EQ.0 .OR. LSAME( JOB, 'N' ) ) - $ RETURN -C -C Inverse scaling. -C - IF ( LSCAL ) THEN - DO 20 I = ILO, N - CALL DRSCL( M, SCALE(I), V1(I,1), LDV1 ) - 20 CONTINUE - DO 30 I = ILO, N - CALL DRSCL( M, SCALE(I), V2(I,1), LDV2 ) - 30 CONTINUE - END IF -C -C Inverse permutation. -C - IF ( LPERM ) THEN - DO 40 I = ILO-1, 1, -1 - K = SCALE( I ) - SYSW = ( K.GT.N ) - IF ( SYSW ) - $ K = K - N -C - IF ( K.NE.I ) THEN -C -C Exchange rows k <-> i. -C - CALL DSWAP( M, V1(I,1), LDV1, V1(K,1), LDV1 ) - CALL DSWAP( M, V2(I,1), LDV2, V2(K,1), LDV2 ) - END IF -C - IF ( SYSW ) THEN -C -C Exchange V1(k,:) <-> V2(k,:). -C - CALL DSWAP( M, V1(K,1), LDV1, V2(K,1), LDV2 ) - IF ( LSGN ) THEN - CALL DSCAL( M, -ONE, V2(K,1), LDV2 ) - ELSE - CALL DSCAL( M, -ONE, V1(K,1), LDV1 ) - END IF - END IF - 40 CONTINUE - END IF -C - RETURN -C *** Last line of MB04DI *** - END diff --git a/mex/sources/libslicot/MB04DS.f b/mex/sources/libslicot/MB04DS.f deleted file mode 100644 index f543a97d1..000000000 --- a/mex/sources/libslicot/MB04DS.f +++ /dev/null @@ -1,450 +0,0 @@ - SUBROUTINE MB04DS( JOB, N, A, LDA, QG, LDQG, ILO, SCALE, INFO ) -C -C SLICOT RELEASE 5.0. -C -C Copyright (c) 2002-2009 NICONET e.V. -C -C This program is free software: you can redistribute it and/or -C modify it under the terms of the GNU General Public License as -C published by the Free Software Foundation, either version 2 of -C the License, or (at your option) any later version. -C -C This program is distributed in the hope that it will be useful, -C but WITHOUT ANY WARRANTY; without even the implied warranty of -C MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the -C GNU General Public License for more details. -C -C You should have received a copy of the GNU General Public License -C along with this program. If not, see -C . -C -C PURPOSE -C -C To balance a real skew-Hamiltonian matrix -C -C [ A G ] -C S = [ T ] , -C [ Q A ] -C -C where A is an N-by-N matrix and G, Q are N-by-N skew-symmetric -C matrices. This involves, first, permuting S by a symplectic -C similarity transformation to isolate eigenvalues in the first -C 1:ILO-1 elements on the diagonal of A; and second, applying a -C diagonal similarity transformation to rows and columns -C ILO:2*N-ILO+1 to make the rows and columns as close in 1-norm -C as possible. Both steps are optional. -C -C ARGUMENTS -C -C Mode Parameters -C -C JOB CHARACTER*1 -C Specifies the operations to be performed on S: -C = 'N': none, set ILO = 1, SCALE(I) = 1.0, I = 1 .. N; -C = 'P': permute only; -C = 'S': scale only; -C = 'B': both permute and scale. -C -C Input/Output Parameters -C -C N (input) INTEGER -C The order of the matrix A. N >= 0. -C -C A (input/output) DOUBLE PRECISION array, dimension (LDA,N) -C On entry, the leading N-by-N part of this array must -C contain the matrix A. -C On exit, the leading N-by-N part of this array contains -C the matrix A of the balanced skew-Hamiltonian. In -C particular, the lower triangular part of the first ILO-1 -C columns of A is zero. -C -C LDA INTEGER -C The leading dimension of the array A. LDA >= MAX(1,N). -C -C QG (input/output) DOUBLE PRECISION array, dimension -C (LDQG,N) -C On entry, the leading N-by-N+1 part of this array must -C contain in columns 1:N the strictly lower triangular part -C of the matrix Q and in columns 2:N+1 the strictly upper -C triangular part of the matrix G. The parts containing the -C diagonal and the first supdiagonal of this array are not -C referenced. -C On exit, the leading N-by-N+1 part of this array contains -C the strictly lower and strictly upper triangular parts of -C the matrices Q and G, respectively, of the balanced -C skew-Hamiltonian. In particular, the strictly lower -C triangular part of the first ILO-1 columns of QG is zero. -C -C LDQG INTEGER -C The leading dimension of the array QG. LDQG >= MAX(1,N). -C -C ILO (output) INTEGER -C ILO-1 is the number of deflated eigenvalues in the -C balanced skew-Hamiltonian matrix. -C -C SCALE (output) DOUBLE PRECISION array of dimension (N) -C Details of the permutations and scaling factors applied to -C S. For j = 1,...,ILO-1 let P(j) = SCALE(j). If P(j) <= N, -C then rows and columns P(j) and P(j)+N are interchanged -C with rows and columns j and j+N, respectively. If -C P(j) > N, then row and column P(j)-N are interchanged with -C row and column j+N by a generalized symplectic -C permutation. For j = ILO,...,N the j-th element of SCALE -C contains the factor of the scaling applied to row and -C column j. -C -C Error Indicator -C -C INFO INTEGER -C = 0: successful exit; -C < 0: if INFO = -i, the i-th argument had an illegal -C value. -C -C REFERENCES -C -C [1] Benner, P. -C Symplectic balancing of Hamiltonian matrices. -C SIAM J. Sci. Comput., 22 (5), pp. 1885-1904, 2000. -C -C CONTRIBUTORS -C -C D. Kressner, Technical Univ. Berlin, Germany, and -C P. Benner, Technical Univ. Chemnitz, Germany, December 2003. -C -C REVISIONS -C -C V. Sima, June 2008 (SLICOT version of the HAPACK routine DSHBAL). -C -C KEYWORDS -C -C Balancing, skew-Hamiltonian matrix. -C -C ****************************************************************** -C -C .. Parameters .. - DOUBLE PRECISION ZERO, ONE - PARAMETER ( ZERO = 0.0D0, ONE = 1.0D0 ) - DOUBLE PRECISION FACTOR - PARAMETER ( FACTOR = 0.95D0 ) -C .. Scalar Arguments .. - CHARACTER JOB - INTEGER ILO, INFO, LDA, LDQG, N -C .. Array Arguments .. - DOUBLE PRECISION A(LDA,*), QG(LDQG,*), SCALE(*) -C .. Local Scalars .. - LOGICAL CONV, LPERM, LSCAL - INTEGER I, IC, ILOOLD, J - DOUBLE PRECISION C, F, G, MAXC, MAXR, R, S, SCLFAC, SFMAX1, - $ SFMAX2, SFMIN1, SFMIN2 -C .. External Functions .. - LOGICAL LSAME - INTEGER IDAMAX - DOUBLE PRECISION DASUM, DLAMCH - EXTERNAL DASUM, DLAMCH, IDAMAX, LSAME -C .. External Subroutines .. - EXTERNAL DRSCL, DSCAL, DSWAP, XERBLA -C .. Intrinsic Functions .. - INTRINSIC ABS, DBLE, MAX, MIN -C -C .. Executable Statements .. -C -C Check the scalar input parameters. -C - INFO = 0 - LPERM = LSAME( JOB, 'P' ) .OR. LSAME( JOB, 'B' ) - LSCAL = LSAME( JOB, 'S' ) .OR. LSAME( JOB, 'B' ) -C - IF ( .NOT.LPERM .AND. .NOT.LSCAL .AND. - $ .NOT.LSAME( JOB, 'N' ) ) THEN - INFO = -1 - ELSE IF ( N.LT.0 ) THEN - INFO = -2 - ELSE IF ( LDA.LT.MAX( 1, N ) ) THEN - INFO = -4 - ELSE IF ( LDQG.LT.MAX( 1, N ) ) THEN - INFO = -6 - END IF -C -C Return if there were illegal values. -C - IF( INFO.NE.0 ) THEN - CALL XERBLA( 'MB04DS', -INFO ) - RETURN - END IF -C - ILO = 1 -C -C Quick return if possible. -C - IF ( N.EQ.0 ) - $ RETURN - IF ( .NOT.LPERM .AND. .NOT.LSCAL ) THEN - DO 10 I = 1, N - SCALE(I) = ONE - 10 CONTINUE - RETURN - END IF -C -C Permutations to isolate eigenvalues if possible. -C - IF ( LPERM ) THEN - ILOOLD = 0 -C WHILE ( ILO.NE.ILOOLD ) - 20 IF ( ILO.NE.ILOOLD ) THEN - ILOOLD = ILO -C -C Scan columns ILO .. N. -C - I = ILO -C WHILE ( I.LE.N .AND. ILO.EQ.ILOOLD ) - 30 IF ( I.LE.N .AND. ILO.EQ.ILOOLD ) THEN - DO 40 J = ILO, I-1 - IF ( A(J,I).NE.ZERO ) THEN - I = I + 1 - GOTO 30 - END IF - 40 CONTINUE - DO 50 J = I+1, N - IF ( A(J,I).NE.ZERO ) THEN - I = I + 1 - GOTO 30 - END IF - 50 CONTINUE - DO 60 J = ILO, I-1 - IF ( QG(I,J).NE.ZERO ) THEN - I = I + 1 - GOTO 30 - END IF - 60 CONTINUE - DO 70 J = I+1, N - IF ( QG(J,I).NE.ZERO ) THEN - I = I + 1 - GOTO 30 - END IF - 70 CONTINUE -C -C Exchange columns/rows ILO <-> I. -C - SCALE(ILO) = DBLE( I ) - IF ( ILO.NE.I ) THEN -C - CALL DSWAP( N, A(1,ILO), 1, A(1,I), 1 ) - CALL DSWAP( N-ILO+1, A(ILO,ILO), LDA, A(I,ILO), LDA ) -C - IF ( I.LT.N ) - $ CALL DSWAP( N-I, QG(I+1,I), 1, QG(I+1,ILO), 1 ) - IF ( I.GT.ILO+1 ) THEN - CALL DSCAL( I-ILO-1, -ONE, QG(ILO+1,ILO), 1 ) - CALL DSWAP( I-ILO-1, QG(ILO+1,ILO), 1, QG(I,ILO+1), - $ LDQG ) - END IF -C - CALL DSWAP( ILO-1, QG(1,I+1), 1, QG(1,ILO+1), 1 ) - IF ( N.GT.I ) - $ CALL DSWAP( N-I, QG(I,I+2), LDQG, QG(ILO,I+2), - $ LDQG ) - IF ( I.GT.ILO+1 ) THEN - CALL DSCAL( I-ILO-1, -ONE, QG(ILO+1,I+1), 1 ) - CALL DSWAP( I-ILO-1, QG(ILO,ILO+2), LDQG, - $ QG(ILO+1,I+1), 1 ) - END IF - CALL DSCAL( I-ILO, -ONE, QG(ILO,I+1), 1 ) - END IF - ILO = ILO + 1 - END IF -C END WHILE 30 -C -C Scan columns N+ILO .. 2*N. -C - I = ILO -C WHILE ( I.LE.N .AND. ILO.EQ.ILOOLD ) - 80 IF ( I.LE.N .AND. ILO.EQ.ILOOLD ) THEN - DO 90 J = ILO, I-1 - IF ( A(I,J).NE.ZERO ) THEN - I = I + 1 - GOTO 80 - END IF - 90 CONTINUE - DO 100 J = I+1, N - IF ( A(I,J).NE.ZERO ) THEN - I = I + 1 - GOTO 80 - END IF - 100 CONTINUE - DO 110 J = ILO, I-1 - IF ( QG(J,I+1).NE.ZERO ) THEN - I = I + 1 - GOTO 80 - END IF - 110 CONTINUE - DO 120 J = I+1, N - IF ( QG(I,J+1).NE.ZERO ) THEN - I = I + 1 - GOTO 80 - END IF - 120 CONTINUE - SCALE(ILO) = DBLE( N+I ) -C -C Exchange columns/rows I <-> I+N with a symplectic -C generalized permutation. -C - CALL DSWAP( I-ILO, A(I,ILO), LDA, QG(I,ILO), LDQG ) - CALL DSCAL( I-ILO, -ONE, A(I,ILO), LDA ) - CALL DSWAP( N-I, A(I,I+1), LDA, QG(I+1,I), 1 ) - CALL DSCAL( N-I, -ONE, QG(I+1,I), 1 ) - CALL DSWAP( I-1, A(1,I), 1, QG(1,I+1), 1 ) - CALL DSCAL( I-1, -ONE, A(1,I), 1 ) - CALL DSCAL( N-I, -ONE, A(I+1,I), 1 ) - CALL DSWAP( N-I, A(I+1,I), 1, QG(I,I+2), LDQG ) -C -C Exchange columns/rows ILO <-> I. -C - IF ( ILO.NE.I ) THEN -C - CALL DSWAP( N, A(1,ILO), 1, A(1,I), 1 ) - CALL DSWAP( N-ILO+1, A(ILO,ILO), LDA, A(I,ILO), LDA ) -C - IF ( I.LT.N ) - $ CALL DSWAP( N-I, QG(I+1,I), 1, QG(I+1,ILO), 1 ) - IF ( I.GT.ILO+1 ) THEN - CALL DSCAL( I-ILO-1, -ONE, QG(ILO+1,ILO), 1 ) - CALL DSWAP( I-ILO-1, QG(ILO+1,ILO), 1, QG(I,ILO+1), - $ LDQG ) - END IF -C - CALL DSWAP( ILO-1, QG(1,I+1), 1, QG(1,ILO+1), 1 ) - IF ( N.GT.I ) - $ CALL DSWAP( N-I, QG(I,I+2), LDQG, QG(ILO,I+2), - $ LDQG ) - IF ( I.GT.ILO+1 ) THEN - CALL DSCAL( I-ILO-1, -ONE, QG(ILO+1,I+1), 1 ) - CALL DSWAP( I-ILO-1, QG(ILO,ILO+2), LDQG, - $ QG(ILO+1,I+1), 1 ) - END IF - CALL DSCAL( I-ILO, -ONE, QG(ILO,I+1), 1 ) - END IF - ILO = ILO + 1 - END IF -C END WHILE 80 - GOTO 20 - END IF -C END WHILE 20 - END IF -C - DO 130 I = ILO, N - SCALE(I) = ONE - 130 CONTINUE -C -C Scale to reduce the 1-norm of the remaining blocks. -C - IF ( LSCAL ) THEN - SCLFAC = DLAMCH( 'B' ) - SFMIN1 = DLAMCH( 'S' ) / DLAMCH( 'P' ) - SFMAX1 = ONE / SFMIN1 - SFMIN2 = SFMIN1*SCLFAC - SFMAX2 = ONE / SFMIN2 -C -C Scale the rows and columns one at a time to minimize the -C 1-norm of the skew-Hamiltonian submatrix. -C Stop when the 1-norm is very roughly minimal. -C - 140 CONTINUE - CONV = .TRUE. - DO 190 I = ILO, N -C -C Compute 1-norm of row and column I without diagonal -C elements. -C - R = DASUM( I-ILO, A(I,ILO), LDA ) + - $ DASUM( N-I, A(I,I+1), LDA ) + - $ DASUM( I-ILO, QG(ILO,I+1), 1 ) + - $ DASUM( N-I, QG(I,I+2), LDQG ) - C = DASUM( I-ILO, A(ILO,I), 1 ) + - $ DASUM( N-I, A(I+1,I), 1 ) + - $ DASUM( I-ILO, QG(I,ILO), LDQG ) + - $ DASUM( N-I, QG(I+1,I), 1 ) -C -C Compute inf-norms of row and column I. -C - IC = IDAMAX( N-ILO+1, A(I,ILO), LDA ) - MAXR = ABS( A(I,IC+ILO-1) ) - IF ( I.GT.1 ) THEN - IC = IDAMAX( I-1, QG(1,I+1), 1 ) - MAXR = MAX( MAXR, ABS( QG(IC,I+1) ) ) - END IF - IF ( N.GT.I ) THEN - IC = IDAMAX( N-I, QG(I,I+2), LDQG ) - MAXR = MAX( MAXR, ABS( QG(I,IC+I+1) ) ) - END IF - IC = IDAMAX( N, A(1,I), 1 ) - MAXC = ABS( A(IC,I) ) - IF ( I.GT.ILO ) THEN - IC = IDAMAX( I-ILO, QG(I,ILO), LDQG ) - MAXC = MAX( MAXC, ABS( QG(I,IC+ILO-1) ) ) - END IF - IF ( N.GT.I ) THEN - IC = IDAMAX( N-I, QG(I+1,I), 1 ) - MAXC = MAX( MAXC, ABS( QG(IC+I,I) ) ) - END IF -C - IF ( C.EQ.ZERO .OR. R.EQ.ZERO ) - $ GOTO 190 - G = R / SCLFAC - F = ONE - S = C + R - 150 CONTINUE - IF ( C.GE.G .OR. MAX( F, C, MAXC ).GE.SFMAX2 .OR. - $ MIN( R, G, MAXR ).LE.SFMIN2 ) - $ GOTO 160 - F = F*SCLFAC - G = G / SCLFAC - C = C*SCLFAC - R = R / SCLFAC - MAXC = MAXC*SCLFAC - MAXR = MAXR / SCLFAC - GOTO 150 -C - 160 CONTINUE - G = C / SCLFAC - 170 CONTINUE - IF ( G.LT.R .OR. MAX( R, MAXR ).GE.SFMAX2 .OR. - $ MIN( F, C, G, MAXC ).LE.SFMIN2 ) - $ GOTO 180 - F = F / SCLFAC - G = G / SCLFAC - C = C / SCLFAC - R = R*SCLFAC - MAXC = MAXC / SCLFAC - MAXR = MAXR*SCLFAC - GOTO 170 -C - 180 CONTINUE -C -C Now balance if necessary. -C - IF ( ( C+R ).GE.FACTOR*S ) - $ GOTO 190 - IF ( F.LT.ONE .AND. SCALE(I).LT.ONE ) THEN - IF ( F*SCALE(I).LE.SFMIN1 ) - $ GOTO 190 - END IF - IF ( F.GT.ONE .AND. SCALE(I).GT.ONE ) THEN - IF ( SCALE(I).GE.SFMAX1 / F ) - $ GOTO 190 - END IF - CONV = .FALSE. - SCALE(I) = SCALE(I)*F - CALL DRSCL( I-ILO, F, A(I,ILO), LDA ) - CALL DRSCL( N-I, F, A(I,I+1), LDA ) - CALL DSCAL( I-1, F, A(1,I), 1 ) - CALL DSCAL( N-I, F, A(I+1,I), 1 ) - CALL DRSCL( I-1, F, QG(1,I+1), 1 ) - CALL DRSCL( N-I, F, QG(I,I+2), LDQG ) - CALL DSCAL( I-ILO, F, QG(I,ILO), LDQG ) - CALL DSCAL( N-I, F, QG(I+1,I), 1 ) - 190 CONTINUE - IF ( .NOT.CONV ) GOTO 140 - END IF - RETURN -C *** Last line of MB04DS *** - END diff --git a/mex/sources/libslicot/MB04DY.f b/mex/sources/libslicot/MB04DY.f deleted file mode 100644 index 6b8b3203d..000000000 --- a/mex/sources/libslicot/MB04DY.f +++ /dev/null @@ -1,329 +0,0 @@ - SUBROUTINE MB04DY( JOBSCL, N, A, LDA, QG, LDQG, D, DWORK, INFO ) -C -C SLICOT RELEASE 5.0. -C -C Copyright (c) 2002-2009 NICONET e.V. -C -C This program is free software: you can redistribute it and/or -C modify it under the terms of the GNU General Public License as -C published by the Free Software Foundation, either version 2 of -C the License, or (at your option) any later version. -C -C This program is distributed in the hope that it will be useful, -C but WITHOUT ANY WARRANTY; without even the implied warranty of -C MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the -C GNU General Public License for more details. -C -C You should have received a copy of the GNU General Public License -C along with this program. If not, see -C . -C -C PURPOSE -C -C To perform a symplectic scaling on the Hamiltonian matrix -C -C ( A G ) -C H = ( T ), (1) -C ( Q -A ) -C -C i.e., perform either the symplectic scaling transformation -C -C -1 -C ( A' G' ) ( D 0 ) ( A G ) ( D 0 ) -C H' <-- ( T ) = ( ) ( T ) ( -1 ), (2) -C ( Q' -A' ) ( 0 D ) ( Q -A ) ( 0 D ) -C -C where D is a diagonal scaling matrix, or the symplectic norm -C scaling transformation -C -C ( A'' G'' ) 1 ( A G/tau ) -C H'' <-- ( T ) = --- ( T ), (3) -C ( Q'' -A'' ) tau ( tau Q -A ) -C -C where tau is a real scalar. Note that if tau is not equal to 1, -C then (3) is NOT a similarity transformation. The eigenvalues -C of H are then tau times the eigenvalues of H''. -C -C For symplectic scaling (2), D is chosen to give the rows and -C columns of A' approximately equal 1-norms and to give Q' and G' -C approximately equal norms. (See METHOD below for details.) For -C norm scaling, tau = MAX(1, ||A||, ||G||, ||Q||) where ||.|| -C denotes the 1-norm (column sum norm). -C -C ARGUMENTS -C -C Mode Parameters -C -C JOBSCL CHARACTER*1 -C Indicates which scaling strategy is used, as follows: -C = 'S' : do the symplectic scaling (2); -C = '1' or 'O': do the 1-norm scaling (3); -C = 'N' : do nothing; set INFO and return. -C -C Input/Output Parameters -C -C N (input) INTEGER -C The order of the matrices A, G, and Q. N >= 0. -C -C A (input/output) DOUBLE PRECISION array, dimension (LDA,N) -C On input, if JOBSCL <> 'N', the leading N-by-N part of -C this array must contain the upper left block A of the -C Hamiltonian matrix H in (1). -C On output, if JOBSCL <> 'N', the leading N-by-N part of -C this array contains the leading N-by-N part of the scaled -C Hamiltonian matrix H' in (2) or H'' in (3), depending on -C the setting of JOBSCL. -C If JOBSCL = 'N', this array is not referenced. -C -C LDA INTEGER -C The leading dimension of the array A. -C LDA >= MAX(1,N), if JOBSCL <> 'N'; -C LDA >= 1, if JOBSCL = 'N'. -C -C QG (input/output) DOUBLE PRECISION array, dimension -C (LDQG,N+1) -C On input, if JOBSCL <> 'N', the leading N-by-N lower -C triangular part of this array must contain the lower -C triangle of the lower left symmetric block Q of the -C Hamiltonian matrix H in (1), and the N-by-N upper -C triangular part of the submatrix in the columns 2 to N+1 -C of this array must contain the upper triangle of the upper -C right symmetric block G of H in (1). -C So, if i >= j, then Q(i,j) = Q(j,i) is stored in QG(i,j) -C and G(i,j) = G(j,i) is stored in QG(j,i+1). -C On output, if JOBSCL <> 'N', the leading N-by-N lower -C triangular part of this array contains the lower triangle -C of the lower left symmetric block Q' or Q'', and the -C N-by-N upper triangular part of the submatrix in the -C columns 2 to N+1 of this array contains the upper triangle -C of the upper right symmetric block G' or G'' of the scaled -C Hamiltonian matrix H' in (2) or H'' in (3), depending on -C the setting of JOBSCL. -C If JOBSCL = 'N', this array is not referenced. -C -C LDQG INTEGER -C The leading dimension of the array QG. -C LDQG >= MAX(1,N), if JOBSCL <> 'N'; -C LDQG >= 1, if JOBSCL = 'N'. -C -C D (output) DOUBLE PRECISION array, dimension (nd) -C If JOBSCL = 'S', then nd = N and D contains the diagonal -C elements of the diagonal scaling matrix in (2). -C If JOBSCL = '1' or 'O', then nd = 1 and D(1) is set to tau -C from (3). In this case, no other elements of D are -C referenced. -C If JOBSCL = 'N', this array is not referenced. -C -C Workspace -C -C DWORK DOUBLE PRECISION array, dimension (N) -C If JOBSCL = 'N', this array is not referenced. -C -C Error Indicator -C -C INFO INTEGER -C = 0: successful exit; -C < 0: if INFO = -i, then the i-th argument had an illegal -C value. -C -C METHOD -C -C 1. Symplectic scaling (JOBSCL = 'S'): -C -C First, LAPACK subroutine DGEBAL is used to equilibrate the 1-norms -C of the rows and columns of A using a diagonal scaling matrix D_A. -C Then, H is similarily transformed by the symplectic diagonal -C matrix D1 = diag(D_A,D_A**(-1)). Next, the off-diagonal blocks of -C the resulting Hamiltonian matrix are equilibrated in the 1-norm -C using the symplectic diagonal matrix D2 of the form -C -C ( I/rho 0 ) -C D2 = ( ) -C ( 0 rho*I ) -C -C where rho is a real scalar. Thus, in (2), D = D1*D2. -C -C 2. Norm scaling (JOBSCL = '1' or 'O'): -C -C The norm of the matrices A and G of (1) is reduced by setting -C A := A/tau and G := G/(tau**2) where tau is the power of the -C base of the arithmetic closest to MAX(1, ||A||, ||G||, ||Q||) and -C ||.|| denotes the 1-norm. -C -C REFERENCES -C -C [1] Benner, P., Byers, R., and Barth, E. -C Fortran 77 Subroutines for Computing the Eigenvalues of -C Hamiltonian Matrices. I: The Square-Reduced Method. -C ACM Trans. Math. Software, 26, 1, pp. 49-77, 2000. -C -C NUMERICAL ASPECTS -C -C For symplectic scaling, the complexity of the used algorithms is -C hard to estimate and depends upon how well the rows and columns of -C A in (1) are equilibrated. In one sweep, each row/column of A is -C scaled once, i.e., the cost of one sweep is N**2 multiplications. -C Usually, 3-6 sweeps are enough to equilibrate the norms of the -C rows and columns of a matrix. Roundoff errors are possible as -C LAPACK routine DGEBAL does NOT use powers of the machine base for -C scaling. The second stage (equilibrating ||G|| and ||Q||) requires -C N**2 multiplications. -C For norm scaling, 3*N**2 + O(N) multiplications are required and -C NO rounding errors occur as all multiplications are performed with -C powers of the machine base. -C -C CONTRIBUTOR -C -C P. Benner, Universitaet Bremen, Germany, and -C R. Byers, University of Kansas, Lawrence, USA. -C Aug. 1998, routine DHABL. -C V. Sima, Research Institute for Informatics, Bucharest, Romania, -C Oct. 1998, SLICOT Library version. -C -C REVISIONS -C -C V. Sima, Research Institute for Informatics, Bucharest, May 2009. -C -C KEYWORDS -C -C Balancing, Hamiltonian matrix, norms, symplectic similarity -C transformation. -C -C ****************************************************************** -C -C .. Parameters .. - DOUBLE PRECISION ZERO, ONE - PARAMETER ( ZERO = 0.0D0, ONE = 1.0D0 ) -C -C .. Scalar Arguments .. - INTEGER INFO, LDA, LDQG, N - CHARACTER JOBSCL -C .. -C .. Array Arguments .. - DOUBLE PRECISION A(LDA,*), D(*), DWORK(*), QG(LDQG,*) -C .. -C .. Local Scalars .. - DOUBLE PRECISION ANRM, BASE, EPS, GNRM, OFL, QNRM, - $ RHO, SFMAX, SFMIN, TAU, UFL, Y - INTEGER I, IERR, IHI, ILO, J - LOGICAL NONE, NORM, SYMP -C .. -C .. External Functions .. - DOUBLE PRECISION DLAMCH, DLANGE, DLANSY - LOGICAL LSAME - EXTERNAL DLAMCH, DLANGE, DLANSY, LSAME -C .. -C .. External Subroutines .. - EXTERNAL DGEBAL, DLABAD, DLASCL, DRSCL, XERBLA -C .. -C .. Intrinsic Functions .. - INTRINSIC ABS, MAX, SQRT -C .. -C .. Executable Statements .. -C - INFO = 0 - SYMP = LSAME( JOBSCL, 'S' ) - NORM = LSAME( JOBSCL, '1' ) .OR. LSAME( JOBSCL, 'O' ) - NONE = LSAME( JOBSCL, 'N' ) -C - IF( .NOT.SYMP .AND. .NOT.NORM .AND. .NOT.NONE ) THEN - INFO = -1 - ELSE IF( N.LT.0 ) THEN - INFO = -2 - ELSE IF( LDA.LT.1 .OR. ( .NOT.NONE .AND. LDA.LT.N ) ) THEN - INFO = -4 - ELSE IF( LDQG.LT.1 .OR. ( .NOT.NONE .AND. LDQG.LT.N ) ) THEN - INFO = -6 - END IF -C - IF ( INFO.NE.0 ) THEN - CALL XERBLA( 'MB04DY', -INFO ) - RETURN - END IF -C -C Quick return if possible. -C - IF( N.EQ.0 .OR. NONE ) - $ RETURN -C -C Set some machine dependant constants. -C - BASE = DLAMCH( 'Base' ) - EPS = DLAMCH( 'Precision' ) - UFL = DLAMCH( 'Safe minimum' ) - OFL = ONE/UFL - CALL DLABAD( UFL, OFL ) - SFMAX = ( EPS/BASE )/UFL - SFMIN = ONE/SFMAX -C - IF ( NORM ) THEN -C -C Compute norms. -C - ANRM = DLANGE( '1-norm', N, N, A, LDA, DWORK ) - GNRM = DLANSY( '1-norm', 'Upper', N, QG(1,2), LDQG, DWORK ) - QNRM = DLANSY( '1-norm', 'Lower', N, QG, LDQG, DWORK ) - Y = MAX( ONE, ANRM, GNRM, QNRM ) - TAU = ONE -C -C WHILE ( TAU < Y ) DO - 10 CONTINUE - IF ( ( TAU.LT.Y ) .AND. ( TAU.LT.SQRT( SFMAX ) ) ) THEN - TAU = TAU*BASE - GO TO 10 - END IF -C END WHILE 10 - IF ( TAU.GT.ONE ) THEN - IF ( ABS( TAU/BASE - Y ).LT.ABS( TAU - Y ) ) - $ TAU = TAU/BASE - CALL DLASCL( 'General', 0, 0, TAU, ONE, N, N, A, LDA, IERR ) - CALL DLASCL( 'Upper', 0, 0, TAU, ONE, N, N, QG(1,2), LDQG, - $ IERR ) - CALL DLASCL( 'Upper', 0, 0, TAU, ONE, N, N, QG(1,2), LDQG, - $ IERR ) - END IF -C - D(1) = TAU -C - ELSE - CALL DGEBAL( 'Scale', N, A, LDA, ILO, IHI, D, IERR ) -C - DO 30 J = 1, N -C - DO 20 I = J, N - QG(I,J) = QG(I,J)*D(J)*D(I) - 20 CONTINUE -C - 30 CONTINUE -C - DO 50 J = 2, N + 1 -C - DO 40 I = 1, J - 1 - QG(I,J) = QG(I,J)/D(J-1)/D(I) - 40 CONTINUE -C - 50 CONTINUE -C - GNRM = DLANSY( '1-norm', 'Upper', N, QG(1,2), LDQG, DWORK ) - QNRM = DLANSY( '1-norm', 'Lower', N, QG, LDQG, DWORK ) - IF ( GNRM.EQ.ZERO ) THEN - IF ( QNRM.EQ.ZERO ) THEN - RHO = ONE - ELSE - RHO = SFMAX - END IF - ELSE IF ( QNRM.EQ.ZERO ) THEN - RHO = SFMIN - ELSE - RHO = SQRT( QNRM )/SQRT( GNRM ) - END IF -C - CALL DLASCL( 'Lower', 0, 0, RHO, ONE, N, N, QG, LDQG, IERR ) - CALL DLASCL( 'Upper', 0, 0, ONE, RHO, N, N, QG(1,2), LDQG, - $ IERR ) - CALL DRSCL( N, SQRT( RHO ), D, 1 ) - END IF -C - RETURN -C *** Last line of MB04DY *** - END diff --git a/mex/sources/libslicot/MB04GD.f b/mex/sources/libslicot/MB04GD.f deleted file mode 100644 index fa7502ec6..000000000 --- a/mex/sources/libslicot/MB04GD.f +++ /dev/null @@ -1,258 +0,0 @@ - SUBROUTINE MB04GD( M, N, A, LDA, JPVT, TAU, DWORK, INFO ) -C -C SLICOT RELEASE 5.0. -C -C Copyright (c) 2002-2009 NICONET e.V. -C -C This program is free software: you can redistribute it and/or -C modify it under the terms of the GNU General Public License as -C published by the Free Software Foundation, either version 2 of -C the License, or (at your option) any later version. -C -C This program is distributed in the hope that it will be useful, -C but WITHOUT ANY WARRANTY; without even the implied warranty of -C MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the -C GNU General Public License for more details. -C -C You should have received a copy of the GNU General Public License -C along with this program. If not, see -C . -C -C PURPOSE -C -C To compute an RQ factorization with row pivoting of a -C real m-by-n matrix A: P*A = R*Q. -C -C ARGUMENTS -C -C Input/Output Parameters -C -C M (input) INTEGER -C The number of rows of the matrix A. M >= 0. -C -C N (input) INTEGER -C The number of columns of the matrix A. N >= 0. -C -C A (input/output) DOUBLE PRECISION array, dimension (LDA,N) -C On entry, the m-by-n matrix A. -C On exit, -C if m <= n, the upper triangle of the subarray -C A(1:m,n-m+1:n) contains the m-by-m upper triangular -C matrix R; -C if m >= n, the elements on and above the (m-n)-th -C subdiagonal contain the m-by-n upper trapezoidal matrix R; -C the remaining elements, with the array TAU, represent the -C orthogonal matrix Q as a product of min(m,n) elementary -C reflectors (see METHOD). -C -C LDA INTEGER -C The leading dimension of the array A. LDA >= max(1,M). -C -C JPVT (input/output) INTEGER array, dimension (M) -C On entry, if JPVT(i) .ne. 0, the i-th row of A is permuted -C to the bottom of P*A (a trailing row); if JPVT(i) = 0, -C the i-th row of A is a free row. -C On exit, if JPVT(i) = k, then the i-th row of P*A -C was the k-th row of A. -C -C TAU (output) DOUBLE PRECISION array, dimension (min(M,N)) -C The scalar factors of the elementary reflectors. -C -C Workspace -C -C DWORK DOUBLE PRECISION array, dimension (3*M) -C -C Error Indicator -C -C INFO INTEGER -C = 0: successful exit -C < 0: if INFO = -i, the i-th argument had an illegal -C value. -C -C METHOD -C -C The matrix Q is represented as a product of elementary reflectors -C -C Q = H(1) H(2) . . . H(k), where k = min(m,n). -C -C Each H(i) has the form -C -C H = I - tau * v * v' -C -C where tau is a real scalar, and v is a real vector with -C v(n-k+i+1:n) = 0 and v(n-k+i) = 1; v(1:n-k+i-1) is stored on exit -C in A(m-k+i,1:n-k+i-1), and tau in TAU(i). -C -C The matrix P is represented in jpvt as follows: If -C jpvt(j) = i -C then the jth row of P is the ith canonical unit vector. -C -C REFERENCES -C -C [1] Anderson, E., Bai, Z., Bischof, C., Demmel, J., Dongarra, J., -C Du Croz, J., Greenbaum, A., Hammarling, S., McKenney, A., -C Ostrouchov, S., and Sorensen, D. -C LAPACK Users' Guide: Second Edition. -C SIAM, Philadelphia, 1995. -C -C NUMERICAL ASPECTS -C -C The algorithm is backward stable. -C -C CONTRIBUTOR -C -C V. Sima, Katholieke Univ. Leuven, Belgium, Sep. 1997. -C Based on LAPACK Library routines DGEQPF and DGERQ2. -C -C REVISIONS -C -C - -C -C KEYWORDS -C -C Factorization, matrix algebra, matrix operations, orthogonal -C transformation, triangular form. -C -C ****************************************************************** -C -C .. Parameters .. - DOUBLE PRECISION ZERO, ONE, P05 - PARAMETER ( ZERO = 0.0D+0, ONE = 1.0D+0, P05 = 0.05D+0 ) -C .. -C .. Scalar Arguments .. - INTEGER INFO, LDA, M, N -C .. -C .. Array Arguments .. - INTEGER JPVT( * ) - DOUBLE PRECISION A( LDA, * ), DWORK( * ), TAU( * ) -C .. -C .. Local Scalars .. - INTEGER I, ITEMP, J, K, MA, MKI, NFREE, NKI, PVT - DOUBLE PRECISION AII, TEMP, TEMP2 -C .. -C .. External Functions .. - INTEGER IDAMAX - DOUBLE PRECISION DNRM2 - EXTERNAL DNRM2, IDAMAX -C .. -C .. External Subroutines .. - EXTERNAL DGERQ2, DLARF, DLARFG, DORMR2, DSWAP, XERBLA -C .. -C .. Intrinsic Functions .. - INTRINSIC ABS, MAX, MIN, SQRT -C .. -C .. Executable Statements .. -C -C Test the input scalar arguments. -C - INFO = 0 - IF( M.LT.0 ) THEN - INFO = -1 - ELSE IF( N.LT.0 ) THEN - INFO = -2 - ELSE IF( LDA.LT.MAX( 1, M ) ) THEN - INFO = -4 - END IF - IF( INFO.NE.0 ) THEN - CALL XERBLA( 'MB04GD', -INFO ) - RETURN - END IF -C - K = MIN( M, N ) -C -C Move non-free rows bottom. -C - ITEMP = M - DO 10 I = M, 1, -1 - IF( JPVT( I ).NE.0 ) THEN - IF( I.NE.ITEMP ) THEN - CALL DSWAP( N, A( I, 1 ), LDA, A( ITEMP, 1 ), LDA ) - JPVT( I ) = JPVT( ITEMP ) - JPVT( ITEMP ) = I - ELSE - JPVT( I ) = I - END IF - ITEMP = ITEMP - 1 - ELSE - JPVT( I ) = I - END IF - 10 CONTINUE - NFREE = M - ITEMP -C -C Compute the RQ factorization and update remaining rows. -C - IF( NFREE.GT.0 ) THEN - MA = MIN( NFREE, N ) - CALL DGERQ2( MA, N, A(M-MA+1,1), LDA, TAU(K-MA+1), DWORK, - $ INFO ) - CALL DORMR2( 'Right', 'Transpose', M-MA, N, MA, A(M-MA+1,1), - $ LDA, TAU(K-MA+1), A, LDA, DWORK, INFO ) - END IF -C - IF( NFREE.LT.K ) THEN -C -C Initialize partial row norms. The first ITEMP elements of -C DWORK store the exact row norms. (Here, ITEMP is the number of -C free rows, which have been permuted to be the first ones.) -C - DO 20 I = 1, ITEMP - DWORK( I ) = DNRM2( N-NFREE, A( I, 1 ), LDA ) - DWORK( M+I ) = DWORK( I ) - 20 CONTINUE -C -C Compute factorization. -C - DO 40 I = K-NFREE, 1, -1 -C -C Determine ith pivot row and swap if necessary. -C - MKI = M - K + I - NKI = N - K + I - PVT = IDAMAX( MKI, DWORK, 1 ) -C - IF( PVT.NE.MKI ) THEN - CALL DSWAP( N, A( PVT, 1 ), LDA, A( MKI, 1 ), LDA ) - ITEMP = JPVT( PVT ) - JPVT( PVT ) = JPVT( MKI ) - JPVT( MKI ) = ITEMP - DWORK( PVT ) = DWORK( MKI ) - DWORK( M+PVT ) = DWORK( M+MKI ) - END IF -C -C Generate elementary reflector H(i) to annihilate -C A(m-k+i,1:n-k+i-1), k = min(m,n). -C - CALL DLARFG( NKI, A( MKI, NKI ), A( MKI, 1 ), LDA, TAU( I ) - $ ) -C -C Apply H(i) to A(1:m-k+i-1,1:n-k+i) from the right. -C - AII = A( MKI, NKI ) - A( MKI, NKI ) = ONE - CALL DLARF( 'Right', MKI-1, NKI, A( MKI, 1 ), LDA, - $ TAU( I ), A, LDA, DWORK( 2*M+1 ) ) - A( MKI, NKI ) = AII -C -C Update partial row norms. -C - DO 30 J = 1, MKI - 1 - IF( DWORK( J ).NE.ZERO ) THEN - TEMP = ONE - ( ABS( A( J, NKI ) ) / DWORK( J ) )**2 - TEMP = MAX( TEMP, ZERO ) - TEMP2 = ONE + P05*TEMP* - $ ( DWORK( J ) / DWORK( M+J ) )**2 - IF( TEMP2.EQ.ONE ) THEN - DWORK( J ) = DNRM2( NKI-1, A( J, 1 ), LDA ) - DWORK( M+J ) = DWORK( J ) - ELSE - DWORK( J ) = DWORK( J )*SQRT( TEMP ) - END IF - END IF - 30 CONTINUE -C - 40 CONTINUE - END IF -C - RETURN -C *** Last line of MB04GD *** - END diff --git a/mex/sources/libslicot/MB04ID.f b/mex/sources/libslicot/MB04ID.f deleted file mode 100644 index d28929f2f..000000000 --- a/mex/sources/libslicot/MB04ID.f +++ /dev/null @@ -1,278 +0,0 @@ - SUBROUTINE MB04ID( N, M, P, L, A, LDA, B, LDB, TAU, DWORK, LDWORK, - $ INFO ) -C -C SLICOT RELEASE 5.0. -C -C Copyright (c) 2002-2009 NICONET e.V. -C -C This program is free software: you can redistribute it and/or -C modify it under the terms of the GNU General Public License as -C published by the Free Software Foundation, either version 2 of -C the License, or (at your option) any later version. -C -C This program is distributed in the hope that it will be useful, -C but WITHOUT ANY WARRANTY; without even the implied warranty of -C MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the -C GNU General Public License for more details. -C -C You should have received a copy of the GNU General Public License -C along with this program. If not, see -C . -C -C PURPOSE -C -C To compute a QR factorization of an n-by-m matrix A (A = Q * R), -C having a p-by-min(p,m) zero triangle in the lower left-hand side -C corner, as shown below, for n = 8, m = 7, and p = 2: -C -C [ x x x x x x x ] -C [ x x x x x x x ] -C [ x x x x x x x ] -C [ x x x x x x x ] -C A = [ x x x x x x x ], -C [ x x x x x x x ] -C [ 0 x x x x x x ] -C [ 0 0 x x x x x ] -C -C and optionally apply the transformations to an n-by-l matrix B -C (from the left). The problem structure is exploited. This -C computation is useful, for instance, in combined measurement and -C time update of one iteration of the time-invariant Kalman filter -C (square root information filter). -C -C ARGUMENTS -C -C Input/Output Parameters -C -C N (input) INTEGER -C The number of rows of the matrix A. N >= 0. -C -C M (input) INTEGER -C The number of columns of the matrix A. M >= 0. -C -C P (input) INTEGER -C The order of the zero triagle. P >= 0. -C -C L (input) INTEGER -C The number of columns of the matrix B. L >= 0. -C -C A (input/output) DOUBLE PRECISION array, dimension (LDA,M) -C On entry, the leading N-by-M part of this array must -C contain the matrix A. The elements corresponding to the -C zero P-by-MIN(P,M) lower trapezoidal/triangular part -C (if P > 0) are not referenced. -C On exit, the elements on and above the diagonal of this -C array contain the MIN(N,M)-by-M upper trapezoidal matrix -C R (R is upper triangular, if N >= M) of the QR -C factorization, and the relevant elements below the -C diagonal contain the trailing components (the vectors v, -C see Method) of the elementary reflectors used in the -C factorization. -C -C LDA INTEGER -C The leading dimension of array A. LDA >= MAX(1,N). -C -C B (input/output) DOUBLE PRECISION array, dimension (LDB,L) -C On entry, the leading N-by-L part of this array must -C contain the matrix B. -C On exit, the leading N-by-L part of this array contains -C the updated matrix B. -C If L = 0, this array is not referenced. -C -C LDB INTEGER -C The leading dimension of array B. -C LDB >= MAX(1,N) if L > 0; -C LDB >= 1 if L = 0. -C -C TAU (output) DOUBLE PRECISION array, dimension MIN(N,M) -C The scalar factors of the elementary reflectors used. -C -C Workspace -C -C DWORK DOUBLE PRECISION array, dimension (LDWORK) -C On exit, if INFO = 0, DWORK(1) returns the optimal value -C of LDWORK. -C -C LDWORK The length of the array DWORK. -C LDWORK >= MAX(1,M-1,M-P,L). -C For optimum performance LDWORK should be larger. -C -C If LDWORK = -1, then a workspace query is assumed; -C the routine only calculates the optimal size of the -C DWORK array, returns this value as the first entry of -C the DWORK array, and no error message related to LDWORK -C is issued by XERBLA. -C -C Error Indicator -C -C INFO INTEGER -C = 0: successful exit; -C < 0: if INFO = -i, the i-th argument had an illegal -C value. -C -C METHOD -C -C The routine uses min(N,M) Householder transformations exploiting -C the zero pattern of the matrix. A Householder matrix has the form -C -C ( 1 ), -C H = I - tau *u *u', u = ( v ) -C i i i i i ( i) -C -C where v is an (N-P+I-2)-vector. The components of v are stored -C i i -C in the i-th column of A, beginning from the location i+1, and -C tau is stored in TAU(i). -C i -C -C NUMERICAL ASPECTS -C -C The algorithm is backward stable. -C -C CONTRIBUTORS -C -C V. Sima, Katholieke Univ. Leuven, Belgium, Feb. 1997. -C -C REVISIONS -C -C V. Sima, Research Institute for Informatics, Bucharest, Jan. 2009, -C Apr. 2009. -C -C KEYWORDS -C -C Elementary reflector, QR factorization, orthogonal transformation. -C -C ****************************************************************** -C -C .. Parameters .. - DOUBLE PRECISION ZERO, ONE - PARAMETER ( ZERO = 0.0D0, ONE = 1.0D0 ) -C .. Scalar Arguments .. - INTEGER INFO, L, LDA, LDB, LDWORK, M, N, P -C .. Array Arguments .. - DOUBLE PRECISION A(LDA,*), B(LDB,*), DWORK(*), TAU(*) -C .. Local Scalars .. - LOGICAL LQUERY - INTEGER I, NB, WRKOPT - DOUBLE PRECISION FIRST -C .. External Functions .. - INTEGER ILAENV - EXTERNAL ILAENV -C .. External Subroutines .. - EXTERNAL DGEQRF, DLARF, DLARFG, DORMQR, XERBLA -C .. Intrinsic Functions .. - INTRINSIC INT, MAX, MIN -C .. Executable Statements .. -C -C Test the input scalar arguments. -C - INFO = 0 - LQUERY = ( LDWORK.EQ.-1 ) - IF( N.LT.0 ) THEN - INFO = -1 - ELSE IF( M.LT.0 ) THEN - INFO = -2 - ELSE IF( P.LT.0 ) THEN - INFO = -3 - ELSE IF( L.LT.0 ) THEN - INFO = -4 - ELSE IF( LDA.LT.MAX( 1, N ) ) THEN - INFO = -6 - ELSE IF( LDB.LT.1 .OR. ( L.GT.0 .AND. LDB.LT.N ) ) THEN - INFO = -8 - ELSE - I = MAX( 1, M - 1, M - P, L ) - IF( LQUERY ) THEN - IF( M.GT.P ) THEN - NB = ILAENV( 1, 'DGEQRF', ' ', N-P, M-P, -1, -1 ) - WRKOPT = MAX( I, ( M - P )*NB ) - IF ( L.GT.0 ) THEN - NB = MIN( 64, ILAENV( 1, 'DORMQR', 'LT', N-P, L, - $ MIN(N,M)-P, -1 ) ) - WRKOPT = MAX( WRKOPT, MAX( 1, L )*NB ) - END IF - END IF - ELSE IF( LDWORK.LT.I ) THEN - INFO = -11 - END IF - END IF -C - IF( INFO.NE.0 ) THEN -C -C Error return. -C - CALL XERBLA( 'MB04ID', -INFO ) - RETURN - ELSE IF( LQUERY ) THEN - DWORK(1) = WRKOPT - RETURN - END IF -C -C Quick return if possible. -C - IF( MIN( M, N ).EQ.0 ) THEN - DWORK(1) = ONE - RETURN - ELSE IF( N.LE.P+1 ) THEN - DO 5 I = 1, MIN( N, M ) - TAU(I) = ZERO - 5 CONTINUE - DWORK(1) = ONE - RETURN - END IF -C -C Annihilate the subdiagonal elements of A and apply the -C transformations to B, if L > 0. -C Workspace: need MAX(M-1,L). -C -C (Note: Comments in the code beginning "Workspace:" describe the -C minimal amount of real workspace needed at that point in the -C code, as well as the preferred amount for good performance. -C NB refers to the optimal block size for the immediately -C following subroutine, as returned by ILAENV.) -C - DO 10 I = 1, MIN( P, M ) -C -C Exploit the structure of the I-th column of A. -C - CALL DLARFG( N-P, A(I,I), A(I+1,I), 1, TAU(I) ) - IF( TAU(I).NE.ZERO ) THEN -C - FIRST = A(I,I) - A(I,I) = ONE -C - IF ( I.LT.M ) CALL DLARF( 'Left', N-P, M-I, A(I,I), 1, - $ TAU(I), A(I,I+1), LDA, DWORK ) - IF ( L.GT.0 ) CALL DLARF( 'Left', N-P, L, A(I,I), 1, TAU(I), - $ B(I,1), LDB, DWORK ) -C - A(I,I) = FIRST - END IF - 10 CONTINUE -C - WRKOPT = MAX( 1, M - 1, L ) -C -C Fast QR factorization of the remaining right submatrix, if any. -C Workspace: need M-P; prefer (M-P)*NB. -C - IF( M.GT.P ) THEN - CALL DGEQRF( N-P, M-P, A(P+1,P+1), LDA, TAU(P+1), DWORK, - $ LDWORK, INFO ) - WRKOPT = MAX( WRKOPT, INT( DWORK(1) ) ) -C - IF ( L.GT.0 ) THEN -C -C Apply the transformations to B. -C Workspace: need L; prefer L*NB. -C - CALL DORMQR( 'Left', 'Transpose', N-P, L, MIN(N,M)-P, - $ A(P+1,P+1), LDA, TAU(P+1), B(P+1,1), LDB, - $ DWORK, LDWORK, INFO ) - WRKOPT = MAX( WRKOPT, INT( DWORK(1) ) ) - END IF - END IF -C - DWORK(1) = WRKOPT - RETURN -C *** Last line of MB04ID *** - END diff --git a/mex/sources/libslicot/MB04IY.f b/mex/sources/libslicot/MB04IY.f deleted file mode 100644 index 4b07b2c35..000000000 --- a/mex/sources/libslicot/MB04IY.f +++ /dev/null @@ -1,327 +0,0 @@ - SUBROUTINE MB04IY( SIDE, TRANS, N, M, K, P, A, LDA, TAU, C, LDC, - $ DWORK, LDWORK, INFO ) -C -C SLICOT RELEASE 5.0. -C -C Copyright (c) 2002-2009 NICONET e.V. -C -C This program is free software: you can redistribute it and/or -C modify it under the terms of the GNU General Public License as -C published by the Free Software Foundation, either version 2 of -C the License, or (at your option) any later version. -C -C This program is distributed in the hope that it will be useful, -C but WITHOUT ANY WARRANTY; without even the implied warranty of -C MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the -C GNU General Public License for more details. -C -C You should have received a copy of the GNU General Public License -C along with this program. If not, see -C . -C -C PURPOSE -C -C To overwrite the real n-by-m matrix C with Q' * C, Q * C, -C C * Q', or C * Q, according to the following table -C -C SIDE = 'L' SIDE = 'R' -C TRANS = 'N': Q * C C * Q -C TRANS = 'T': Q'* C C * Q' -C -C where Q is a real orthogonal matrix defined as the product of -C k elementary reflectors -C -C Q = H(1) H(2) . . . H(k) -C -C as returned by SLICOT Library routine MB04ID. Q is of order n -C if SIDE = 'L' and of order m if SIDE = 'R'. -C -C ARGUMENTS -C -C Mode Parameters -C -C SIDE CHARACTER*1 -C Specify if Q or Q' is applied from the left or right, -C as follows: -C = 'L': apply Q or Q' from the left; -C = 'R': apply Q or Q' from the right. -C -C TRANS CHARACTER*1 -C Specify if Q or Q' is to be applied, as follows: -C = 'N': apply Q (No transpose); -C = 'T': apply Q' (Transpose). -C -C Input/Output Parameters -C -C N (input) INTEGER -C The number of rows of the matrix C. N >= 0. -C -C M (input) INTEGER -C The number of columns of the matrix C. M >= 0. -C -C K (input) INTEGER -C The number of elementary reflectors whose product defines -C the matrix Q. -C N >= K >= 0, if SIDE = 'L'; -C M >= K >= 0, if SIDE = 'R'. -C -C P (input) INTEGER -C The order of the zero triagle (or the number of rows of -C the zero trapezoid) in the matrix triangularized by SLICOT -C Library routine MB04ID. P >= 0. -C -C A (input) DOUBLE PRECISION array, dimension (LDA,K) -C On input, the elements in the rows i+1:min(n,n-p-1+i) of -C the i-th column, and TAU(i), represent the orthogonal -C reflector H(i), so that matrix Q is the product of -C elementary reflectors: Q = H(1) H(2) . . . H(k). -C A is modified by the routine but restored on exit. -C -C LDA INTEGER -C The leading dimension of the array A. -C LDA >= max(1,N), if SIDE = 'L'; -C LDA >= max(1,M), if SIDE = 'R'. -C -C TAU (input) DOUBLE PRECISION array, dimension (K) -C The scalar factors of the elementary reflectors. -C -C C (input/output) DOUBLE PRECISION array, dimension (LDC,M) -C On entry, the leading N-by-M part of this array must -C contain the matrix C. -C On exit, the leading N-by-M part of this array contains -C the updated matrix C. -C -C LDC INTEGER -C The leading dimension of the array C. LDC >= max(1,N). -C -C Workspace -C -C DWORK DOUBLE PRECISION array, dimension (LDWORK) -C On exit, if INFO = 0, DWORK(1) returns the optimal value -C of LDWORK. -C -C LDWORK INTEGER -C The length of the array DWORK. -C LDWORK >= MAX(1,M), if SIDE = 'L'; -C LDWORK >= MAX(1,N), if SIDE = 'R'. -C For optimum performance LDWORK >= M*NB if SIDE = 'L', -C or LDWORK >= N*NB if SIDE = 'R', where NB is the optimal -C block size. -C -C Error Indicator -C -C INFO INTEGER -C = 0: successful exit; -C < 0: if INFO = -i, the i-th argument had an illegal -C value. -C -C METHOD -C -C If SIDE = 'L', each elementary reflector H(i) modifies -C n-p elements of each column of C, for i = 1:p+1, and -C n-i+1 elements, for i = p+2:k. -C If SIDE = 'R', each elementary reflector H(i) modifies -C m-p elements of each row of C, for i = 1:p+1, and -C m-i+1 elements, for i = p+2:k. -C -C NUMERICAL ASPECTS -C -C The implemented method is numerically stable. -C -C CONTRIBUTOR -C -C V. Sima, Research Institute for Informatics, Bucharest, Aug. 1999. -C -C REVISIONS -C -C - -C -C KEYWORDS -C -C Matrix operations, QR decomposition. -C -C ****************************************************************** -C -C .. Parameters .. - DOUBLE PRECISION ONE - PARAMETER ( ONE = 1.0D+0 ) -C .. Scalar Arguments .. - INTEGER INFO, K, LDA, LDC, LDWORK, M, N, P - CHARACTER SIDE, TRANS -C .. Array Arguments .. - DOUBLE PRECISION A( LDA, * ), C( LDC, * ), DWORK( * ), TAU( * ) -C .. Local Scalars .. - LOGICAL LEFT, TRAN - INTEGER I - DOUBLE PRECISION AII, WRKOPT -C .. External Functions .. - LOGICAL LSAME - EXTERNAL LSAME -C .. External Subroutines .. - EXTERNAL DLARF, DORMQR, XERBLA -C .. Intrinsic Functions .. - INTRINSIC DBLE, MAX, MIN -C .. Executable Statements .. -C -C Check the scalar input arguments. -C - INFO = 0 - LEFT = LSAME( SIDE, 'L' ) - TRAN = LSAME( TRANS, 'T' ) -C - IF( .NOT.LEFT .AND. .NOT.LSAME( SIDE, 'R' ) ) THEN - INFO = -1 - ELSE IF( .NOT.TRAN .AND. .NOT.LSAME( TRANS, 'N' ) ) THEN - INFO = -2 - ELSE IF( N.LT.0 ) THEN - INFO = -3 - ELSE IF( M.LT.0 ) THEN - INFO = -4 - ELSE IF( K.LT.0 .OR. ( LEFT .AND. K.GT.N ) .OR. - $ ( .NOT.LEFT .AND. K.GT.M ) ) THEN - INFO = -5 - ELSE IF( P.LT.0 ) THEN - INFO = -6 - ELSE IF( ( LEFT .AND. LDA.LT.MAX( 1, N ) ) .OR. - $ ( .NOT.LEFT .AND. LDA.LT.MAX( 1, M ) ) ) THEN - INFO = -8 - ELSE IF( LDC.LT.MAX( 1, N ) ) THEN - INFO = -11 - ELSE IF( ( LEFT .AND. LDWORK.LT.MAX( 1, M ) ) .OR. - $ ( .NOT.LEFT .AND. LDWORK.LT.MAX( 1, N ) ) ) THEN - INFO = -13 - END IF -C - IF( INFO.NE.0 ) THEN - CALL XERBLA( 'MB04IY', -INFO ) - RETURN - END IF -C -C Quick return if possible. -C - IF( M.EQ.0 .OR. N.EQ.0 .OR. K.EQ.0 .OR. ( LEFT .AND. N.LT.P ) - $ .OR. ( .NOT.LEFT .AND. M.LT.P ) ) THEN - DWORK(1) = ONE - RETURN - END IF -C -C (Note: Comments in the code beginning "Workspace:" describe the -C minimal amount of real workspace needed at that point in the -C code, as well as the preferred amount for good performance. -C NB refers to the optimal block size for the immediately -C following subroutine, as returned by ILAENV.) -C - IF( LEFT ) THEN - WRKOPT = DBLE( M ) - IF( TRAN ) THEN -C - DO 10 I = 1, MIN( K, P ) -C -C Apply H(i) to C(i:i+n-p-1,1:m), from the left. -C Workspace: need M. -C - AII = A( I, I ) - A( I, I ) = ONE - CALL DLARF( SIDE, N-P, M, A( I, I ), 1, TAU( I ), - $ C( I, 1 ), LDC, DWORK ) - A( I, I ) = AII - 10 CONTINUE -C - IF ( P.LE.MIN( N, K ) ) THEN -C -C Apply H(i) to C, i = p+1:k, from the left. -C Workspace: need M; prefer M*NB. -C - CALL DORMQR( SIDE, TRANS, N-P, M, K-P, A( P+1, P+1 ), - $ LDA, TAU( P+1 ), C( P+1, 1 ), LDC, DWORK, - $ LDWORK, I ) - WRKOPT = MAX( WRKOPT, DWORK( 1 ) ) - END IF -C - ELSE -C - IF ( P.LE.MIN( N, K ) ) THEN -C -C Apply H(i) to C, i = k:p+1:-1, from the left. -C Workspace: need M; prefer M*NB. -C - CALL DORMQR( SIDE, TRANS, N-P, M, K-P, A( P+1, P+1 ), - $ LDA, TAU( P+1 ), C( P+1, 1 ), LDC, DWORK, - $ LDWORK, I ) - WRKOPT = MAX( WRKOPT, DWORK( 1 ) ) - END IF -C - DO 20 I = MIN( K, P ), 1, -1 -C -C Apply H(i) to C(i:i+n-p-1,1:m), from the left. -C Workspace: need M. -C - AII = A( I, I ) - A( I, I ) = ONE - CALL DLARF( SIDE, N-P, M, A( I, I ), 1, TAU( I ), - $ C( I, 1 ), LDC, DWORK ) - A( I, I ) = AII - 20 CONTINUE - END IF -C - ELSE -C - WRKOPT = DBLE( N ) - IF( TRAN ) THEN -C - IF ( P.LE.MIN( M, K ) ) THEN -C -C Apply H(i) to C, i = k:p+1:-1, from the right. -C Workspace: need N; prefer N*NB. -C - CALL DORMQR( SIDE, TRANS, N, M-P, K-P, A( P+1, P+1 ), - $ LDA, TAU( P+1 ), C( 1, P+1 ), LDC, DWORK, - $ LDWORK, I ) - WRKOPT = MAX( WRKOPT, DWORK( 1 ) ) - END IF -C - DO 30 I = MIN( K, P ), 1, -1 -C -C Apply H(i) to C(1:n,i:i+m-p-1), from the right. -C Workspace: need N. -C - AII = A( I, I ) - A( I, I ) = ONE - CALL DLARF( SIDE, N, M-P, A( I, I ), 1, TAU( I ), - $ C( 1, I ), LDC, DWORK ) - A( I, I ) = AII - 30 CONTINUE -C - ELSE -C - DO 40 I = 1, MIN( K, P ) -C -C Apply H(i) to C(1:n,i:i+m-p-1), from the right. -C Workspace: need N. -C - AII = A( I, I ) - A( I, I ) = ONE - CALL DLARF( SIDE, N, M-P, A( I, I ), 1, TAU( I ), - $ C( 1, I ), LDC, DWORK ) - A( I, I ) = AII - 40 CONTINUE -C - IF ( P.LE.MIN( M, K ) ) THEN -C -C Apply H(i) to C, i = p+1:k, from the right. -C Workspace: need N; prefer N*NB. -C - CALL DORMQR( SIDE, TRANS, N, M-P, K-P, A( P+1, P+1 ), - $ LDA, TAU( P+1 ), C( 1, P+1 ), LDC, DWORK, - $ LDWORK, I ) - WRKOPT = MAX( WRKOPT, DWORK( 1 ) ) - END IF -C - END IF - END IF -C - DWORK( 1 ) = WRKOPT - RETURN -C -C *** Last line of MB04IY *** - END diff --git a/mex/sources/libslicot/MB04IZ.f b/mex/sources/libslicot/MB04IZ.f deleted file mode 100644 index c9654a6a5..000000000 --- a/mex/sources/libslicot/MB04IZ.f +++ /dev/null @@ -1,282 +0,0 @@ - SUBROUTINE MB04IZ( N, M, P, L, A, LDA, B, LDB, TAU, ZWORK, LZWORK, - $ INFO ) -C -C SLICOT RELEASE 5.0. -C -C Copyright (c) 2002-2009 NICONET e.V. -C -C This program is free software: you can redistribute it and/or -C modify it under the terms of the GNU General Public License as -C published by the Free Software Foundation, either version 2 of -C the License, or (at your option) any later version. -C -C This program is distributed in the hope that it will be useful, -C but WITHOUT ANY WARRANTY; without even the implied warranty of -C MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the -C GNU General Public License for more details. -C -C You should have received a copy of the GNU General Public License -C along with this program. If not, see -C . -C -C PURPOSE -C -C To compute a QR factorization of an n-by-m matrix A (A = Q * R), -C having a p-by-min(p,m) zero triangle in the lower left-hand side -C corner, as shown below, for n = 8, m = 7, and p = 2: -C -C [ x x x x x x x ] -C [ x x x x x x x ] -C [ x x x x x x x ] -C [ x x x x x x x ] -C A = [ x x x x x x x ], -C [ x x x x x x x ] -C [ 0 x x x x x x ] -C [ 0 0 x x x x x ] -C -C and optionally apply the transformations to an n-by-l matrix B -C (from the left). The problem structure is exploited. This -C computation is useful, for instance, in combined measurement and -C time update of one iteration of the time-invariant Kalman filter -C (square root information filter). -C -C ARGUMENTS -C -C Input/Output Parameters -C -C N (input) INTEGER -C The number of rows of the matrix A. N >= 0. -C -C M (input) INTEGER -C The number of columns of the matrix A. M >= 0. -C -C P (input) INTEGER -C The order of the zero triagle. P >= 0. -C -C L (input) INTEGER -C The number of columns of the matrix B. L >= 0. -C -C A (input/output) COMPLEX*16 array, dimension (LDA,M) -C On entry, the leading N-by-M part of this array must -C contain the matrix A. The elements corresponding to the -C zero P-by-MIN(P,M) lower trapezoidal/triangular part -C (if P > 0) are not referenced. -C On exit, the elements on and above the diagonal of this -C array contain the MIN(N,M)-by-M upper trapezoidal matrix -C R (R is upper triangular, if N >= M) of the QR -C factorization, and the relevant elements below the -C diagonal contain the trailing components (the vectors v, -C see Method) of the elementary reflectors used in the -C factorization. -C -C LDA INTEGER -C The leading dimension of array A. LDA >= MAX(1,N). -C -C B (input/output) COMPLEX*16 array, dimension (LDB,L) -C On entry, the leading N-by-L part of this array must -C contain the matrix B. -C On exit, the leading N-by-L part of this array contains -C the updated matrix B. -C If L = 0, this array is not referenced. -C -C LDB INTEGER -C The leading dimension of array B. -C LDB >= MAX(1,N) if L > 0; -C LDB >= 1 if L = 0. -C -C TAU (output) COMPLEX*16 array, dimension MIN(N,M) -C The scalar factors of the elementary reflectors used. -C -C Workspace -C -C ZWORK COMPLEX*16 array, dimension (LZWORK) -C On exit, if INFO = 0, ZWORK(1) returns the optimal value -C of LZWORK. -C -C LZWORK The length of the array ZWORK. -C LZWORK >= MAX(1,M-1,M-P,L). -C For optimum performance LZWORK should be larger. -C -C If LZWORK = -1, then a workspace query is assumed; -C the routine only calculates the optimal size of the -C ZWORK array, returns this value as the first entry of -C the ZWORK array, and no error message related to LZWORK -C is issued by XERBLA. -C -C Error Indicator -C -C INFO INTEGER -C = 0: successful exit; -C < 0: if INFO = -i, the i-th argument had an illegal -C value. -C -C METHOD -C -C The routine uses min(N,M) Householder transformations exploiting -C the zero pattern of the matrix. A Householder matrix has the form -C -C ( 1 ), -C H = I - tau *u *u', u = ( v ) -C i i i i i ( i) -C -C where v is an (N-P+I-2)-vector. The components of v are stored -C i i -C in the i-th column of A, beginning from the location i+1, and -C tau is stored in TAU(i). -C i -C -C NUMERICAL ASPECTS -C -C The algorithm is backward stable. -C -C CONTRIBUTORS -C -C V. Sima, Katholieke Univ. Leuven, Belgium, Feb. 1997. -C Complex version: V. Sima, Research Institute for Informatics, -C Bucharest, Nov. 2008. -C -C REVISIONS -C -C V. Sima, Research Institute for Informatics, Bucharest, Apr. 2009. -C -C KEYWORDS -C -C Elementary reflector, QR factorization, unitary transformation. -C -C ****************************************************************** -C -C .. Parameters .. - COMPLEX*16 ZERO, ONE - PARAMETER ( ZERO = ( 0.0D+0, 0.0D+0 ), - $ ONE = ( 1.0D+0, 0.0D+0 ) ) -C .. Scalar Arguments .. - INTEGER INFO, L, LDA, LDB, LZWORK, M, N, P -C .. Array Arguments .. - COMPLEX*16 A(LDA,*), B(LDB,*), TAU(*), ZWORK(*) -C .. Local Scalars .. - LOGICAL LQUERY - INTEGER I, NB, WRKOPT - COMPLEX*16 FIRST -C .. External Functions .. - INTEGER ILAENV - EXTERNAL ILAENV -C .. External Subroutines .. - EXTERNAL XERBLA, ZGEQRF, ZLARF, ZLARFG, ZUNMQR -C .. Intrinsic Functions .. - INTRINSIC DCONJG, INT, MAX, MIN -C .. Executable Statements .. -C -C Test the input scalar arguments. -C - INFO = 0 - LQUERY = ( LZWORK.EQ.-1 ) - IF( N.LT.0 ) THEN - INFO = -1 - ELSE IF( M.LT.0 ) THEN - INFO = -2 - ELSE IF( P.LT.0 ) THEN - INFO = -3 - ELSE IF( L.LT.0 ) THEN - INFO = -4 - ELSE IF( LDA.LT.MAX( 1, N ) ) THEN - INFO = -6 - ELSE IF( LDB.LT.1 .OR. ( L.GT.0 .AND. LDB.LT.N ) ) THEN - INFO = -8 - ELSE - I = MAX( 1, M - 1, M - P, L ) - IF( LQUERY ) THEN - IF( M.GT.P ) THEN - NB = ILAENV( 1, 'ZGEQRF', ' ', N-P, M-P, -1, -1 ) - WRKOPT = MAX( I, ( M - P )*NB ) - IF ( L.GT.0 ) THEN - NB = MIN( 64, ILAENV( 1, 'ZUNMQR', 'LC', N-P, L, - $ MIN(N,M)-P, -1 ) ) - WRKOPT = MAX( WRKOPT, MAX( 1, L )*NB ) - END IF - END IF - ELSE IF( LZWORK.LT.I ) THEN - INFO = -11 - END IF - END IF -C - IF( INFO.NE.0 ) THEN -C -C Error return. -C - CALL XERBLA( 'MB04IZ', -INFO ) - RETURN - ELSE IF( LQUERY ) THEN - ZWORK(1) = WRKOPT - RETURN - END IF -C -C Quick return if possible. -C - IF( MIN( M, N ).EQ.0 ) THEN - ZWORK(1) = ONE - RETURN - ELSE IF( N.LE.P+1 ) THEN - DO 5 I = 1, MIN( N, M ) - TAU(I) = ZERO - 5 CONTINUE - ZWORK(1) = ONE - RETURN - END IF -C -C Annihilate the subdiagonal elements of A and apply the -C transformations to B, if L > 0. -C Workspace: need MAX(M-1,L). -C -C (Note: Comments in the code beginning "Workspace:" describe the -C minimal amount of complex workspace needed at that point in the -C code, as well as the preferred amount for good performance. -C NB refers to the optimal block size for the immediately -C following subroutine, as returned by ILAENV.) -C - DO 10 I = 1, MIN( P, M ) -C -C Exploit the structure of the I-th column of A. -C - CALL ZLARFG( N-P, A(I,I), A(I+1,I), 1, TAU(I) ) - IF( TAU(I).NE.ZERO ) THEN -C - FIRST = A(I,I) - A(I,I) = ONE -C - IF ( I.LT.M ) CALL ZLARF( 'Left', N-P, M-I, A(I,I), 1, - $ DCONJG( TAU(I) ), A(I,I+1), LDA, - $ ZWORK ) - IF ( L.GT.0 ) CALL ZLARF( 'Left', N-P, L, A(I,I), 1, - $ DCONJG( TAU(I) ), B(I,1), LDB, - $ ZWORK ) -C - A(I,I) = FIRST - END IF - 10 CONTINUE -C - WRKOPT = MAX( 1, M - 1, L ) -C -C Fast QR factorization of the remaining right submatrix, if any. -C Workspace: need M-P; prefer (M-P)*NB. -C - IF( M.GT.P ) THEN - CALL ZGEQRF( N-P, M-P, A(P+1,P+1), LDA, TAU(P+1), ZWORK, - $ LZWORK, INFO ) - WRKOPT = MAX( WRKOPT, INT( ZWORK(1) ) ) -C - IF ( L.GT.0 ) THEN -C -C Apply the transformations to B. -C Workspace: need L; prefer L*NB. -C - CALL ZUNMQR( 'Left', 'Conjugate', N-P, L, MIN(N,M)-P, - $ A(P+1,P+1), LDA, TAU(P+1), B(P+1,1), LDB, - $ ZWORK, LZWORK, INFO ) - WRKOPT = MAX( WRKOPT, INT( ZWORK(1) ) ) - END IF - END IF -C - ZWORK(1) = WRKOPT - RETURN -C *** Last line of MB04IZ *** - END diff --git a/mex/sources/libslicot/MB04JD.f b/mex/sources/libslicot/MB04JD.f deleted file mode 100644 index 8dc1a3b9b..000000000 --- a/mex/sources/libslicot/MB04JD.f +++ /dev/null @@ -1,248 +0,0 @@ - SUBROUTINE MB04JD( N, M, P, L, A, LDA, B, LDB, TAU, DWORK, LDWORK, - $ INFO ) -C -C SLICOT RELEASE 5.0. -C -C Copyright (c) 2002-2009 NICONET e.V. -C -C This program is free software: you can redistribute it and/or -C modify it under the terms of the GNU General Public License as -C published by the Free Software Foundation, either version 2 of -C the License, or (at your option) any later version. -C -C This program is distributed in the hope that it will be useful, -C but WITHOUT ANY WARRANTY; without even the implied warranty of -C MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the -C GNU General Public License for more details. -C -C You should have received a copy of the GNU General Public License -C along with this program. If not, see -C . -C -C PURPOSE -C -C To compute an LQ factorization of an n-by-m matrix A (A = L * Q), -C having a min(n,p)-by-p zero triangle in the upper right-hand side -C corner, as shown below, for n = 8, m = 7, and p = 2: -C -C [ x x x x x 0 0 ] -C [ x x x x x x 0 ] -C [ x x x x x x x ] -C [ x x x x x x x ] -C A = [ x x x x x x x ], -C [ x x x x x x x ] -C [ x x x x x x x ] -C [ x x x x x x x ] -C -C and optionally apply the transformations to an l-by-m matrix B -C (from the right). The problem structure is exploited. This -C computation is useful, for instance, in combined measurement and -C time update of one iteration of the time-invariant Kalman filter -C (square root covariance filter). -C -C ARGUMENTS -C -C Input/Output Parameters -C -C N (input) INTEGER -C The number of rows of the matrix A. N >= 0. -C -C M (input) INTEGER -C The number of columns of the matrix A. M >= 0. -C -C P (input) INTEGER -C The order of the zero triagle. P >= 0. -C -C L (input) INTEGER -C The number of rows of the matrix B. L >= 0. -C -C A (input/output) DOUBLE PRECISION array, dimension (LDA,M) -C On entry, the leading N-by-M part of this array must -C contain the matrix A. The elements corresponding to the -C zero MIN(N,P)-by-P upper trapezoidal/triangular part -C (if P > 0) are not referenced. -C On exit, the elements on and below the diagonal of this -C array contain the N-by-MIN(N,M) lower trapezoidal matrix -C L (L is lower triangular, if N <= M) of the LQ -C factorization, and the relevant elements above the -C diagonal contain the trailing components (the vectors v, -C see Method) of the elementary reflectors used in the -C factorization. -C -C LDA INTEGER -C The leading dimension of array A. LDA >= MAX(1,N). -C -C B (input/output) DOUBLE PRECISION array, dimension (LDB,M) -C On entry, the leading L-by-M part of this array must -C contain the matrix B. -C On exit, the leading L-by-M part of this array contains -C the updated matrix B. -C If L = 0, this array is not referenced. -C -C LDB INTEGER -C The leading dimension of array B. LDB >= MAX(1,L). -C -C TAU (output) DOUBLE PRECISION array, dimension MIN(N,M) -C The scalar factors of the elementary reflectors used. -C -C Workspace -C -C DWORK DOUBLE PRECISION array, dimension (LDWORK) -C On exit, if INFO = 0, DWORK(1) returns the optimal value -C of LDWORK. -C -C LDWORK The length of the array DWORK. -C LDWORK >= MAX(1,N-1,N-P,L). -C For optimum performance LDWORK should be larger. -C -C Error Indicator -C -C INFO INTEGER -C = 0: successful exit; -C < 0: if INFO = -i, the i-th argument had an illegal -C value. -C -C METHOD -C -C The routine uses min(N,M) Householder transformations exploiting -C the zero pattern of the matrix. A Householder matrix has the form -C -C ( 1 ), -C H = I - tau *u *u', u = ( v ) -C i i i i i ( i) -C -C where v is an (M-P+I-2)-vector. The components of v are stored -C i i -C in the i-th row of A, beginning from the location i+1, and tau -C i -C is stored in TAU(i). -C -C NUMERICAL ASPECTS -C -C The algorithm is backward stable. -C -C CONTRIBUTORS -C -C V. Sima, Katholieke Univ. Leuven, Belgium, Feb. 1997. -C -C REVISIONS -C -C - -C -C KEYWORDS -C -C Elementary reflector, LQ factorization, orthogonal transformation. -C -C ****************************************************************** -C -C .. Parameters .. - DOUBLE PRECISION ZERO, ONE - PARAMETER ( ZERO = 0.0D0, ONE = 1.0D0 ) -C .. Scalar Arguments .. - INTEGER INFO, L, LDA, LDB, LDWORK, M, N, P -C .. Array Arguments .. - DOUBLE PRECISION A(LDA,*), B(LDB,*), DWORK(*), TAU(*) -C .. Local Scalars .. - INTEGER I - DOUBLE PRECISION FIRST, WRKOPT -C .. External Subroutines .. - EXTERNAL DGELQF, DLARF, DLARFG, DORMLQ, XERBLA -C .. Intrinsic Functions .. - INTRINSIC DBLE, MAX, MIN -C .. Executable Statements .. -C -C Test the input scalar arguments. -C - INFO = 0 - IF( N.LT.0 ) THEN - INFO = -1 - ELSE IF( M.LT.0 ) THEN - INFO = -2 - ELSE IF( P.LT.0 ) THEN - INFO = -3 - ELSE IF( L.LT.0 ) THEN - INFO = -4 - ELSE IF( LDA.LT.MAX( 1, N ) ) THEN - INFO = -6 - ELSE IF( LDB.LT.MAX( 1, L ) ) THEN - INFO = -8 - ELSE IF( LDWORK.LT.MAX( 1, N - 1, N - P, L ) ) THEN - INFO = -11 - END IF -C - IF ( INFO.NE.0 ) THEN -C -C Error return. -C - CALL XERBLA( 'MB04JD', -INFO ) - RETURN - END IF -C -C Quick return if possible. -C - IF( MIN( M, N ).EQ.0 ) THEN - DWORK(1) = ONE - RETURN - ELSE IF( M.LE.P+1 ) THEN - DO 5 I = 1, MIN( N, M ) - TAU(I) = ZERO - 5 CONTINUE - DWORK(1) = ONE - RETURN - END IF -C -C Annihilate the superdiagonal elements of A and apply the -C transformations to B, if L > 0. -C Workspace: need MAX(N-1,L). -C -C (Note: Comments in the code beginning "Workspace:" describe the -C minimal amount of real workspace needed at that point in the -C code, as well as the preferred amount for good performance. -C NB refers to the optimal block size for the immediately -C following subroutine, as returned by ILAENV.) -C - DO 10 I = 1, MIN( N, P ) -C -C Exploit the structure of the I-th row of A. -C - CALL DLARFG( M-P, A(I,I), A(I,I+1), LDA, TAU(I) ) - IF( TAU(I).NE.ZERO ) THEN -C - FIRST = A(I,I) - A(I,I) = ONE -C - IF ( I.LT.N ) CALL DLARF( 'Right', N-I, M-P, A(I,I), LDA, - $ TAU(I), A(I+1,I), LDA, DWORK ) - IF ( L.GT.0 ) CALL DLARF( 'Right', L, M-P, A(I,I), LDA, - $ TAU(I), B(1,I), LDB, DWORK ) -C - A(I,I) = FIRST - END IF - 10 CONTINUE -C - WRKOPT = MAX( ONE, DBLE( N - 1 ), DBLE( L ) ) -C -C Fast LQ factorization of the remaining trailing submatrix, if any. -C Workspace: need N-P; prefer (N-P)*NB. -C - IF( N.GT.P ) THEN - CALL DGELQF( N-P, M-P, A(P+1,P+1), LDA, TAU(P+1), DWORK, - $ LDWORK, INFO ) - WRKOPT = MAX( WRKOPT, DWORK(1) ) -C - IF ( L.GT.0 ) THEN -C -C Apply the transformations to B. -C Workspace: need L; prefer L*NB. -C - CALL DORMLQ( 'Right', 'Transpose', L, M-P, MIN(N,M)-P, - $ A(P+1,P+1), LDA, TAU(P+1), B(1,P+1), LDB, - $ DWORK, LDWORK, INFO ) - WRKOPT = MAX( WRKOPT, DWORK(1) ) - END IF - END IF -C - DWORK(1) = WRKOPT - RETURN -C *** Last line of MB04JD *** - END diff --git a/mex/sources/libslicot/MB04KD.f b/mex/sources/libslicot/MB04KD.f deleted file mode 100644 index adcdcb6f9..000000000 --- a/mex/sources/libslicot/MB04KD.f +++ /dev/null @@ -1,209 +0,0 @@ - SUBROUTINE MB04KD( UPLO, N, M, P, R, LDR, A, LDA, B, LDB, C, LDC, - $ TAU, DWORK ) -C -C SLICOT RELEASE 5.0. -C -C Copyright (c) 2002-2009 NICONET e.V. -C -C This program is free software: you can redistribute it and/or -C modify it under the terms of the GNU General Public License as -C published by the Free Software Foundation, either version 2 of -C the License, or (at your option) any later version. -C -C This program is distributed in the hope that it will be useful, -C but WITHOUT ANY WARRANTY; without even the implied warranty of -C MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the -C GNU General Public License for more details. -C -C You should have received a copy of the GNU General Public License -C along with this program. If not, see -C . -C -C PURPOSE -C -C To calculate a QR factorization of the first block column and -C apply the orthogonal transformations (from the left) also to the -C second block column of a structured matrix, as follows -C _ -C [ R 0 ] [ R C ] -C Q' * [ ] = [ ] -C [ A B ] [ 0 D ] -C _ -C where R and R are upper triangular. The matrix A can be full or -C upper trapezoidal/triangular. The problem structure is exploited. -C This computation is useful, for instance, in combined measurement -C and time update of one iteration of the Kalman filter (square -C root information filter). -C -C ARGUMENTS -C -C Mode Parameters -C -C UPLO CHARACTER*1 -C Indicates if the matrix A is or not triangular as follows: -C = 'U': Matrix A is upper trapezoidal/triangular; -C = 'F': Matrix A is full. -C -C Input/Output Parameters -C -C N (input) INTEGER _ -C The order of the matrices R and R. N >= 0. -C -C M (input) INTEGER -C The number of columns of the matrices B, C and D. M >= 0. -C -C P (input) INTEGER -C The number of rows of the matrices A, B and D. P >= 0. -C -C R (input/output) DOUBLE PRECISION array, dimension (LDR,N) -C On entry, the leading N-by-N upper triangular part of this -C array must contain the upper triangular matrix R. -C On exit, the leading N-by-N upper triangular part of this -C _ -C array contains the upper triangular matrix R. -C The strict lower triangular part of this array is not -C referenced. -C -C LDR INTEGER -C The leading dimension of array R. LDR >= MAX(1,N). -C -C A (input/output) DOUBLE PRECISION array, dimension (LDA,N) -C On entry, if UPLO = 'F', the leading P-by-N part of this -C array must contain the matrix A. If UPLO = 'U', the -C leading MIN(P,N)-by-N part of this array must contain the -C upper trapezoidal (upper triangular if P >= N) matrix A, -C and the elements below the diagonal are not referenced. -C On exit, the leading P-by-N part (upper trapezoidal or -C triangular, if UPLO = 'U') of this array contains the -C trailing components (the vectors v, see Method) of the -C elementary reflectors used in the factorization. -C -C LDA INTEGER -C The leading dimension of array A. LDA >= MAX(1,P). -C -C B (input/output) DOUBLE PRECISION array, dimension (LDB,M) -C On entry, the leading P-by-M part of this array must -C contain the matrix B. -C On exit, the leading P-by-M part of this array contains -C the computed matrix D. -C -C LDB INTEGER -C The leading dimension of array B. LDB >= MAX(1,P). -C -C C (output) DOUBLE PRECISION array, dimension (LDC,M) -C The leading N-by-M part of this array contains the -C computed matrix C. -C -C LDC INTEGER -C The leading dimension of array C. LDC >= MAX(1,N). -C -C TAU (output) DOUBLE PRECISION array, dimension (N) -C The scalar factors of the elementary reflectors used. -C -C Workspace -C -C DWORK DOUBLE PRECISION array, dimension (N) -C -C METHOD -C -C The routine uses N Householder transformations exploiting the zero -C pattern of the block matrix. A Householder matrix has the form -C -C ( 1 ), -C H = I - tau *u *u', u = ( v ) -C i i i i i ( i) -C -C where v is a P-vector, if UPLO = 'F', or an min(i,P)-vector, if -C i -C UPLO = 'U'. The components of v are stored in the i-th column -C i -C of A, and tau is stored in TAU(i). -C i -C -C NUMERICAL ASPECTS -C -C The algorithm is backward stable. -C -C CONTRIBUTORS -C -C V. Sima, Katholieke Univ. Leuven, Belgium, Feb. 1997. -C -C REVISIONS -C -C - -C -C KEYWORDS -C -C Elementary reflector, QR factorization, orthogonal transformation. -C -C ****************************************************************** -C -C .. Parameters .. - DOUBLE PRECISION ZERO, ONE - PARAMETER ( ZERO = 0.0D0, ONE = 1.0D0 ) -C .. Scalar Arguments .. - CHARACTER UPLO - INTEGER LDA, LDB, LDC, LDR, M, N, P -C .. Array Arguments .. - DOUBLE PRECISION A(LDA,*), B(LDB,*), C(LDC,*), DWORK(*), - $ R(LDR,*), TAU(*) -C .. Local Scalars .. - LOGICAL LUPLO - INTEGER I, IM -C .. External Functions .. - LOGICAL LSAME - EXTERNAL LSAME -C .. External Subroutines .. - EXTERNAL DAXPY, DCOPY, DGEMV, DGER, DLARFG, DSCAL -C .. Intrinsic Functions .. - INTRINSIC MIN -C .. Executable Statements .. -C - IF( MIN( N, P ).EQ.0 ) - $ RETURN -C - LUPLO = LSAME( UPLO, 'U' ) - IM = P -C - DO 10 I = 1, N -C -C Annihilate the I-th column of A and apply the transformations -C to the entire block matrix, exploiting its structure. -C - IF( LUPLO ) IM = MIN( I, P ) - CALL DLARFG( IM+1, R(I,I), A(1,I), 1, TAU(I) ) - IF( TAU(I).NE.ZERO ) THEN -C -C [ R(I,I+1:N) 0 ] -C [ w C(I,:) ] := [ 1 v' ] * [ ] -C [ A(1:IM,I+1:N) B(1:IM,:) ] -C - IF( I.LT.N ) THEN - CALL DCOPY( N-I, R(I,I+1), LDR, DWORK, 1 ) - CALL DGEMV( 'Transpose', IM, N-I, ONE, A(1,I+1), LDA, - $ A(1,I), 1, ONE, DWORK, 1 ) - END IF - CALL DGEMV( 'Transpose', IM, M, ONE, B, LDB, A(1,I), 1, - $ ZERO, C(I,1), LDC ) -C -C [ R(I,I+1:N) C(I,:) ] [ R(I,I+1:N) 0 ] -C [ ] := [ ] -C [ A(1:IM,I+1:N) D(1:IM,:) ] [ A(1:IM,I+1:N) B(1:IM,:) ] -C -C [ 1 ] -C - tau * [ ] * [ w C(I,:) ] -C [ v ] -C - IF( I.LT.N ) THEN - CALL DAXPY( N-I, -TAU(I), DWORK, 1, R(I,I+1), LDR ) - CALL DGER( IM, N-I, -TAU(I), A(1,I), 1, DWORK, 1, - $ A(1,I+1), LDA ) - END IF - CALL DSCAL( M, -TAU(I), C(I,1), LDC ) - CALL DGER( IM, M, ONE, A(1,I), 1, C(I,1), LDC, B, LDB ) - END IF - 10 CONTINUE -C - RETURN -C *** Last line of MB04KD *** - END diff --git a/mex/sources/libslicot/MB04LD.f b/mex/sources/libslicot/MB04LD.f deleted file mode 100644 index 7931437f5..000000000 --- a/mex/sources/libslicot/MB04LD.f +++ /dev/null @@ -1,209 +0,0 @@ - SUBROUTINE MB04LD( UPLO, N, M, P, L, LDL, A, LDA, B, LDB, C, LDC, - $ TAU, DWORK ) -C -C SLICOT RELEASE 5.0. -C -C Copyright (c) 2002-2009 NICONET e.V. -C -C This program is free software: you can redistribute it and/or -C modify it under the terms of the GNU General Public License as -C published by the Free Software Foundation, either version 2 of -C the License, or (at your option) any later version. -C -C This program is distributed in the hope that it will be useful, -C but WITHOUT ANY WARRANTY; without even the implied warranty of -C MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the -C GNU General Public License for more details. -C -C You should have received a copy of the GNU General Public License -C along with this program. If not, see -C . -C -C PURPOSE -C -C To calculate an LQ factorization of the first block row and apply -C the orthogonal transformations (from the right) also to the second -C block row of a structured matrix, as follows -C _ -C [ L A ] [ L 0 ] -C [ ]*Q = [ ] -C [ 0 B ] [ C D ] -C _ -C where L and L are lower triangular. The matrix A can be full or -C lower trapezoidal/triangular. The problem structure is exploited. -C This computation is useful, for instance, in combined measurement -C and time update of one iteration of the Kalman filter (square -C root covariance filter). -C -C ARGUMENTS -C -C Mode Parameters -C -C UPLO CHARACTER*1 -C Indicates if the matrix A is or not triangular as follows: -C = 'L': Matrix A is lower trapezoidal/triangular; -C = 'F': Matrix A is full. -C -C Input/Output Parameters -C -C N (input) INTEGER _ -C The order of the matrices L and L. N >= 0. -C -C M (input) INTEGER -C The number of columns of the matrices A, B and D. M >= 0. -C -C P (input) INTEGER -C The number of rows of the matrices B, C and D. P >= 0. -C -C L (input/output) DOUBLE PRECISION array, dimension (LDL,N) -C On entry, the leading N-by-N lower triangular part of this -C array must contain the lower triangular matrix L. -C On exit, the leading N-by-N lower triangular part of this -C _ -C array contains the lower triangular matrix L. -C The strict upper triangular part of this array is not -C referenced. -C -C LDL INTEGER -C The leading dimension of array L. LDL >= MAX(1,N). -C -C A (input/output) DOUBLE PRECISION array, dimension (LDA,M) -C On entry, if UPLO = 'F', the leading N-by-M part of this -C array must contain the matrix A. If UPLO = 'L', the -C leading N-by-MIN(N,M) part of this array must contain the -C lower trapezoidal (lower triangular if N <= M) matrix A, -C and the elements above the diagonal are not referenced. -C On exit, the leading N-by-M part (lower trapezoidal or -C triangular, if UPLO = 'L') of this array contains the -C trailing components (the vectors v, see Method) of the -C elementary reflectors used in the factorization. -C -C LDA INTEGER -C The leading dimension of array A. LDA >= MAX(1,N). -C -C B (input/output) DOUBLE PRECISION array, dimension (LDB,M) -C On entry, the leading P-by-M part of this array must -C contain the matrix B. -C On exit, the leading P-by-M part of this array contains -C the computed matrix D. -C -C LDB INTEGER -C The leading dimension of array B. LDB >= MAX(1,P). -C -C C (output) DOUBLE PRECISION array, dimension (LDC,N) -C The leading P-by-N part of this array contains the -C computed matrix C. -C -C LDC INTEGER -C The leading dimension of array C. LDC >= MAX(1,P). -C -C TAU (output) DOUBLE PRECISION array, dimension (N) -C The scalar factors of the elementary reflectors used. -C -C Workspace -C -C DWORK DOUBLE PRECISION array, dimension (N) -C -C METHOD -C -C The routine uses N Householder transformations exploiting the zero -C pattern of the block matrix. A Householder matrix has the form -C -C ( 1 ), -C H = I - tau *u *u', u = ( v ) -C i i i i i ( i) -C -C where v is an M-vector, if UPLO = 'F', or an min(i,M)-vector, if -C i -C UPLO = 'L'. The components of v are stored in the i-th row of A, -C i -C and tau is stored in TAU(i). -C i -C -C NUMERICAL ASPECTS -C -C The algorithm is backward stable. -C -C CONTRIBUTORS -C -C V. Sima, Katholieke Univ. Leuven, Belgium, Feb. 1997. -C -C REVISIONS -C -C - -C -C KEYWORDS -C -C Elementary reflector, LQ factorization, orthogonal transformation. -C -C ****************************************************************** -C -C .. Parameters .. - DOUBLE PRECISION ZERO, ONE - PARAMETER ( ZERO = 0.0D0, ONE = 1.0D0 ) -C .. Scalar Arguments .. - CHARACTER UPLO - INTEGER LDA, LDB, LDC, LDL, M, N, P -C .. Array Arguments .. - DOUBLE PRECISION A(LDA,*), B(LDB,*), C(LDC,*), DWORK(*), - $ L(LDL,*), TAU(*) -C .. Local Scalars .. - LOGICAL LUPLO - INTEGER I, IM -C .. External Functions .. - LOGICAL LSAME - EXTERNAL LSAME -C .. External Subroutines .. - EXTERNAL DAXPY, DCOPY, DGEMV, DGER, DLARFG, DSCAL -C .. Intrinsic Functions .. - INTRINSIC MIN -C .. Executable Statements .. -C - IF( MIN( M, N ).EQ.0 ) - $ RETURN -C - LUPLO = LSAME( UPLO, 'L' ) - IM = M -C - DO 10 I = 1, N -C -C Annihilate the I-th row of A and apply the transformations to -C the entire block matrix, exploiting its structure. -C - IF( LUPLO ) IM = MIN( I, M ) - CALL DLARFG( IM+1, L(I,I), A(I,1), LDA, TAU(I) ) - IF( TAU(I).NE.ZERO ) THEN -C -C [ w ] [ L(I+1:N,I) A(I+1:N,1:IM) ] [ 1 ] -C [ ] := [ ] * [ ] -C [ C(:,I) ] [ 0 B(:,1:IM) ] [ v ] -C - IF( I.LT.N ) THEN - CALL DCOPY( N-I, L(I+1,I), 1, DWORK, 1 ) - CALL DGEMV( 'No transpose', N-I, IM, ONE, A(I+1,1), LDA, - $ A(I,1), LDA, ONE, DWORK, 1 ) - END IF - CALL DGEMV( 'No transpose', P, IM, ONE, B, LDB, A(I,1), - $ LDA, ZERO, C(1,I), 1 ) -C -C [ L(I+1:N,I) A(I+1:N,1:IM) ] [ L(I+1:N,I) A(I+1:N,1:IM) ] -C [ ] := [ ] -C [ C(:,I) D(:,1:IM) ] [ 0 B(:,1:IM) ] -C -C [ w ] -C - tau * [ ] * [ 1 , v'] -C [ C(:,I) ] -C - IF( I.LT.N ) THEN - CALL DAXPY( N-I, -TAU(I), DWORK, 1, L(I+1,I), 1 ) - CALL DGER( N-I, IM, -TAU(I), DWORK, 1, A(I,1), LDA, - $ A(I+1,1), LDA ) - END IF - CALL DSCAL( P, -TAU(I), C(1,I), 1 ) - CALL DGER( P, IM, ONE, C(1,I), 1, A(I,1), LDA, B, LDB ) - END IF - 10 CONTINUE -C - RETURN -C *** Last line of MB04LD *** - END diff --git a/mex/sources/libslicot/MB04MD.f b/mex/sources/libslicot/MB04MD.f deleted file mode 100644 index 8a9055af2..000000000 --- a/mex/sources/libslicot/MB04MD.f +++ /dev/null @@ -1,290 +0,0 @@ - SUBROUTINE MB04MD( N, MAXRED, A, LDA, SCALE, INFO ) -C -C SLICOT RELEASE 5.0. -C -C Copyright (c) 2002-2009 NICONET e.V. -C -C This program is free software: you can redistribute it and/or -C modify it under the terms of the GNU General Public License as -C published by the Free Software Foundation, either version 2 of -C the License, or (at your option) any later version. -C -C This program is distributed in the hope that it will be useful, -C but WITHOUT ANY WARRANTY; without even the implied warranty of -C MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the -C GNU General Public License for more details. -C -C You should have received a copy of the GNU General Public License -C along with this program. If not, see -C . -C -C PURPOSE -C -C To reduce the 1-norm of a general real matrix A by balancing. -C This involves diagonal similarity transformations applied -C iteratively to A to make the rows and columns as close in norm as -C possible. -C -C This routine can be used instead LAPACK Library routine DGEBAL, -C when no reduction of the 1-norm of the matrix is possible with -C DGEBAL, as for upper triangular matrices. LAPACK Library routine -C DGEBAK, with parameters ILO = 1, IHI = N, and JOB = 'S', should -C be used to apply the backward transformation. -C -C ARGUMENTS -C -C Input/Output Parameters -C -C N (input) INTEGER -C The order of the matrix A. N >= 0. -C -C MAXRED (input/output) DOUBLE PRECISION -C On entry, the maximum allowed reduction in the 1-norm of -C A (in an iteration) if zero rows or columns are -C encountered. -C If MAXRED > 0.0, MAXRED must be larger than one (to enable -C the norm reduction). -C If MAXRED <= 0.0, then the value 10.0 for MAXRED is -C used. -C On exit, if the 1-norm of the given matrix A is non-zero, -C the ratio between the 1-norm of the given matrix and the -C 1-norm of the balanced matrix. Usually, this ratio will be -C larger than one, but it can sometimes be one, or even less -C than one (for instance, for some companion matrices). -C -C A (input/output) DOUBLE PRECISION array, dimension (LDA,N) -C On entry, the leading N-by-N part of this array must -C contain the input matrix A. -C On exit, the leading N-by-N part of this array contains -C the balanced matrix. -C -C LDA INTEGER -C The leading dimension of the array A. LDA >= max(1,N). -C -C SCALE (output) DOUBLE PRECISION array, dimension (N) -C The scaling factors applied to A. If D(j) is the scaling -C factor applied to row and column j, then SCALE(j) = D(j), -C for j = 1,...,N. -C -C Error Indicator -C -C INFO INTEGER -C = 0: successful exit. -C < 0: if INFO = -i, the i-th argument had an illegal -C value. -C -C METHOD -C -C Balancing consists of applying a diagonal similarity -C transformation inv(D) * A * D to make the 1-norms of each row -C of A and its corresponding column nearly equal. -C -C Information about the diagonal matrix D is returned in the vector -C SCALE. -C -C REFERENCES -C -C [1] Anderson, E., Bai, Z., Bischof, C., Demmel, J., Dongarra, J., -C Du Croz, J., Greenbaum, A., Hammarling, S., McKenney, A., -C Ostrouchov, S., and Sorensen, D. -C LAPACK Users' Guide: Second Edition. -C SIAM, Philadelphia, 1995. -C -C NUMERICAL ASPECTS -C -C None. -C -C CONTRIBUTOR -C -C Release 3.0: V. Sima, Katholieke Univ. Leuven, Belgium, June 1997. -C Supersedes Release 2.0 routine MB04AD by T.W.C. Williams, -C Kingston Polytechnic, United Kingdom, October 1984. -C This subroutine is based on LAPACK routine DGEBAL, and routine -C BALABC (A. Varga, German Aerospace Research Establishment, DLR). -C -C -C REVISIONS -C -C - -C -C KEYWORDS -C -C Balancing, eigenvalue, matrix algebra, matrix operations, -C similarity transformation. -C -C ********************************************************************* -C -C .. Parameters .. - DOUBLE PRECISION ZERO, ONE - PARAMETER ( ZERO = 0.0D+0, ONE = 1.0D+0 ) - DOUBLE PRECISION SCLFAC - PARAMETER ( SCLFAC = 1.0D+1 ) - DOUBLE PRECISION FACTOR, MAXR - PARAMETER ( FACTOR = 0.95D+0, MAXR = 10.0D+0 ) -C .. -C .. Scalar Arguments .. - INTEGER INFO, LDA, N - DOUBLE PRECISION MAXRED -C .. -C .. Array Arguments .. - DOUBLE PRECISION A( LDA, * ), SCALE( * ) -C .. -C .. Local Scalars .. - LOGICAL NOCONV - INTEGER I, ICA, IRA, J - DOUBLE PRECISION ANORM, C, CA, F, G, MAXNRM, R, RA, S, SFMAX1, - $ SFMAX2, SFMIN1, SFMIN2, SRED -C .. -C .. External Functions .. - INTEGER IDAMAX - DOUBLE PRECISION DLAMCH, DLANGE - EXTERNAL DLAMCH, DLANGE, IDAMAX -C .. -C .. External Subroutines .. - EXTERNAL DSCAL, XERBLA -C .. -C .. Intrinsic Functions .. - INTRINSIC ABS, MAX, MIN -C .. -C .. Executable Statements .. -C -C Test the scalar input arguments. -C - INFO = 0 -C - IF( N.LT.0 ) THEN - INFO = -1 - ELSE IF( MAXRED.GT.ZERO .AND. MAXRED.LT.ONE ) THEN - INFO = -2 - ELSE IF( LDA.LT.MAX( 1, N ) ) THEN - INFO = -4 - END IF - IF( INFO.NE.0 ) THEN - CALL XERBLA( 'MB04MD', -INFO ) - RETURN - END IF -C - IF( N.EQ.0 ) - $ RETURN -C - DO 10 I = 1, N - SCALE( I ) = ONE - 10 CONTINUE -C -C Compute the 1-norm of matrix A and exit if it is zero. -C - ANORM = DLANGE( '1-norm', N, N, A, LDA, SCALE ) - IF( ANORM.EQ.ZERO ) - $ RETURN -C -C Set some machine parameters and the maximum reduction in the -C 1-norm of A if zero rows or columns are encountered. -C - SFMIN1 = DLAMCH( 'S' ) / DLAMCH( 'P' ) - SFMAX1 = ONE / SFMIN1 - SFMIN2 = SFMIN1*SCLFAC - SFMAX2 = ONE / SFMIN2 -C - SRED = MAXRED - IF( SRED.LE.ZERO ) SRED = MAXR -C - MAXNRM = MAX( ANORM/SRED, SFMIN1 ) -C -C Balance the matrix. -C -C Iterative loop for norm reduction. -C - 20 CONTINUE - NOCONV = .FALSE. -C - DO 80 I = 1, N - C = ZERO - R = ZERO -C - DO 30 J = 1, N - IF( J.EQ.I ) - $ GO TO 30 - C = C + ABS( A( J, I ) ) - R = R + ABS( A( I, J ) ) - 30 CONTINUE - ICA = IDAMAX( N, A( 1, I ), 1 ) - CA = ABS( A( ICA, I ) ) - IRA = IDAMAX( N, A( I, 1 ), LDA ) - RA = ABS( A( I, IRA ) ) -C -C Special case of zero C and/or R. -C - IF( C.EQ.ZERO .AND. R.EQ.ZERO ) - $ GO TO 80 - IF( C.EQ.ZERO ) THEN - IF( R.LE.MAXNRM) - $ GO TO 80 - C = MAXNRM - END IF - IF( R.EQ.ZERO ) THEN - IF( C.LE.MAXNRM ) - $ GO TO 80 - R = MAXNRM - END IF -C -C Guard against zero C or R due to underflow. -C - G = R / SCLFAC - F = ONE - S = C + R - 40 CONTINUE - IF( C.GE.G .OR. MAX( F, C, CA ).GE.SFMAX2 .OR. - $ MIN( R, G, RA ).LE.SFMIN2 )GO TO 50 - F = F*SCLFAC - C = C*SCLFAC - CA = CA*SCLFAC - R = R / SCLFAC - G = G / SCLFAC - RA = RA / SCLFAC - GO TO 40 -C - 50 CONTINUE - G = C / SCLFAC - 60 CONTINUE - IF( G.LT.R .OR. MAX( R, RA ).GE.SFMAX2 .OR. - $ MIN( F, C, G, CA ).LE.SFMIN2 )GO TO 70 - F = F / SCLFAC - C = C / SCLFAC - G = G / SCLFAC - CA = CA / SCLFAC - R = R*SCLFAC - RA = RA*SCLFAC - GO TO 60 -C -C Now balance. -C - 70 CONTINUE - IF( ( C+R ).GE.FACTOR*S ) - $ GO TO 80 - IF( F.LT.ONE .AND. SCALE( I ).LT.ONE ) THEN - IF( F*SCALE( I ).LE.SFMIN1 ) - $ GO TO 80 - END IF - IF( F.GT.ONE .AND. SCALE( I ).GT.ONE ) THEN - IF( SCALE( I ).GE.SFMAX1 / F ) - $ GO TO 80 - END IF - G = ONE / F - SCALE( I ) = SCALE( I )*F - NOCONV = .TRUE. -C - CALL DSCAL( N, G, A( I, 1 ), LDA ) - CALL DSCAL( N, F, A( 1, I ), 1 ) -C - 80 CONTINUE -C - IF( NOCONV ) - $ GO TO 20 -C -C Set the norm reduction parameter. -C - MAXRED = ANORM/DLANGE( '1-norm', N, N, A, LDA, SCALE ) -C - RETURN -C *** End of MB04MD *** - END diff --git a/mex/sources/libslicot/MB04ND.f b/mex/sources/libslicot/MB04ND.f deleted file mode 100644 index 2a7e0725e..000000000 --- a/mex/sources/libslicot/MB04ND.f +++ /dev/null @@ -1,257 +0,0 @@ - SUBROUTINE MB04ND( UPLO, N, M, P, R, LDR, A, LDA, B, LDB, C, LDC, - $ TAU, DWORK ) -C -C SLICOT RELEASE 5.0. -C -C Copyright (c) 2002-2009 NICONET e.V. -C -C This program is free software: you can redistribute it and/or -C modify it under the terms of the GNU General Public License as -C published by the Free Software Foundation, either version 2 of -C the License, or (at your option) any later version. -C -C This program is distributed in the hope that it will be useful, -C but WITHOUT ANY WARRANTY; without even the implied warranty of -C MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the -C GNU General Public License for more details. -C -C You should have received a copy of the GNU General Public License -C along with this program. If not, see -C . -C -C PURPOSE -C -C To calculate an RQ factorization of the first block row and -C apply the orthogonal transformations (from the right) also to the -C second block row of a structured matrix, as follows -C _ -C [ A R ] [ 0 R ] -C [ ] * Q' = [ _ _ ] -C [ C B ] [ C B ] -C _ -C where R and R are upper triangular. The matrix A can be full or -C upper trapezoidal/triangular. The problem structure is exploited. -C -C ARGUMENTS -C -C Mode Parameters -C -C UPLO CHARACTER*1 -C Indicates if the matrix A is or not triangular as follows: -C = 'U': Matrix A is upper trapezoidal/triangular; -C = 'F': Matrix A is full. -C -C Input/Output Parameters -C -C N (input) INTEGER _ -C The order of the matrices R and R. N >= 0. -C -C M (input) INTEGER -C The number of rows of the matrices B and C. M >= 0. -C -C P (input) INTEGER -C The number of columns of the matrices A and C. P >= 0. -C -C R (input/output) DOUBLE PRECISION array, dimension (LDR,N) -C On entry, the leading N-by-N upper triangular part of this -C array must contain the upper triangular matrix R. -C On exit, the leading N-by-N upper triangular part of this -C _ -C array contains the upper triangular matrix R. -C The strict lower triangular part of this array is not -C referenced. -C -C LDR INTEGER -C The leading dimension of array R. LDR >= MAX(1,N). -C -C A (input/output) DOUBLE PRECISION array, dimension (LDA,P) -C On entry, if UPLO = 'F', the leading N-by-P part of this -C array must contain the matrix A. For UPLO = 'U', if -C N <= P, the upper triangle of the subarray A(1:N,P-N+1:P) -C must contain the N-by-N upper triangular matrix A, and if -C N >= P, the elements on and above the (N-P)-th subdiagonal -C must contain the N-by-P upper trapezoidal matrix A. -C On exit, if UPLO = 'F', the leading N-by-P part of this -C array contains the trailing components (the vectors v, see -C METHOD) of the elementary reflectors used in the -C factorization. If UPLO = 'U', the upper triangle of the -C subarray A(1:N,P-N+1:P) (if N <= P), or the elements on -C and above the (N-P)-th subdiagonal (if N >= P), contain -C the trailing components (the vectors v, see METHOD) of the -C elementary reflectors used in the factorization. -C The remaining elements are not referenced. -C -C LDA INTEGER -C The leading dimension of array A. LDA >= MAX(1,N). -C -C B (input/output) DOUBLE PRECISION array, dimension (LDB,N) -C On entry, the leading M-by-N part of this array must -C contain the matrix B. -C On exit, the leading M-by-N part of this array contains -C _ -C the computed matrix B. -C -C LDB INTEGER -C The leading dimension of array B. LDB >= MAX(1,M). -C -C C (input/output) DOUBLE PRECISION array, dimension (LDC,P) -C On entry, the leading M-by-P part of this array must -C contain the matrix C. -C On exit, the leading M-by-P part of this array contains -C _ -C the computed matrix C. -C -C LDC INTEGER -C The leading dimension of array C. LDC >= MAX(1,M). -C -C TAU (output) DOUBLE PRECISION array, dimension (N) -C The scalar factors of the elementary reflectors used. -C -C Workspace -C -C DWORK DOUBLE PRECISION array, dimension (MAX(N-1,M)) -C -C METHOD -C -C The routine uses N Householder transformations exploiting the zero -C pattern of the block matrix. A Householder matrix has the form -C -C ( 1 ) -C H = I - tau *u *u', u = ( v ), -C i i i i i ( i) -C -C where v is a P-vector, if UPLO = 'F', or a min(N-i+1,P)-vector, -C i -C if UPLO = 'U'. The components of v are stored in the i-th row -C i -C of A, and tau is stored in TAU(i), i = N,N-1,...,1. -C i -C In-line code for applying Householder transformations is used -C whenever possible (see MB04NY routine). -C -C NUMERICAL ASPECTS -C -C The algorithm is backward stable. -C -C CONTRIBUTORS -C -C V. Sima, Katholieke Univ. Leuven, Belgium, Apr. 1998. -C -C REVISIONS -C -C - -C -C KEYWORDS -C -C Elementary reflector, RQ factorization, orthogonal transformation. -C -C ****************************************************************** -C -C .. Parameters .. - DOUBLE PRECISION ZERO, ONE - PARAMETER ( ZERO = 0.0D0, ONE = 1.0D0 ) -C .. Scalar Arguments .. - CHARACTER UPLO - INTEGER LDA, LDB, LDC, LDR, M, N, P -C .. Array Arguments .. - DOUBLE PRECISION A(LDA,*), B(LDB,*), C(LDC,*), DWORK(*), - $ R(LDR,*), TAU(*) -C .. Local Scalars .. - LOGICAL LUPLO - INTEGER I, IM, IP -C .. External Functions .. - LOGICAL LSAME - EXTERNAL LSAME -C .. External Subroutines .. - EXTERNAL DLARFG, MB04NY -C .. Intrinsic Functions .. - INTRINSIC MIN -C .. Executable Statements .. -C -C For efficiency reasons, the parameters are not checked. -C - IF( MIN( N, P ).EQ.0 ) - $ RETURN -C - LUPLO = LSAME( UPLO, 'U' ) - IF ( LUPLO ) THEN -C - DO 10 I = N, 1, -1 -C -C Annihilate the I-th row of A and apply the transformations -C to the entire block matrix, exploiting its structure. -C - IM = MIN( N-I+1, P ) - IP = MAX( P-N+I, 1 ) - CALL DLARFG( IM+1, R(I,I), A(I,IP), LDA, TAU(I) ) -C -C Compute -C [ 1 ] -C w := [ R(1:I-1,I) A(1:I-1,IP:P) ] * [ ], -C [ v ] -C -C [ R(1:I-1,I) A(1:I-1,IP:P) ] = -C [ R(1:I-1,I) A(1:I-1,IP:P) ] - tau * w * [ 1 v' ]. -C - IF ( I.GT.0 ) -C - $ CALL MB04NY( I-1, IM, A(I,IP), LDA, TAU(I), R(1,I), LDR, - $ A(1,IP), LDA, DWORK ) -C -C Compute -C [ 1 ] -C w := [ B(:,I) C(:,IP:P) ] * [ ], -C [ v ] -C -C [ B(:,I) C(:,IP:P) ] = [ B(:,I) C(:,IP:P) ] - -C tau * w * [ 1 v' ]. -C - IF ( M.GT.0 ) - $ CALL MB04NY( M, IM, A(I,IP), LDA, TAU(I), B(1,I), LDB, - $ C(1,IP), LDC, DWORK ) - 10 CONTINUE -C - ELSE -C - DO 20 I = N, 2 , -1 -C -C Annihilate the I-th row of A and apply the transformations -C to the first block row, exploiting its structure. -C - CALL DLARFG( P+1, R(I,I), A(I,1), LDA, TAU(I) ) -C -C Compute -C [ 1 ] -C w := [ R(1:I-1,I) A(1:I-1,:) ] * [ ], -C [ v ] -C -C [ R(1:I-1,I) A(1:I-1,:) ] = [ R(1:I-1,I) A(1:I-1,:) ] - -C tau * w * [ 1 v' ]. -C - CALL MB04NY( I-1, P, A(I,1), LDA, TAU(I), R(1,I), LDR, A, - $ LDA, DWORK ) - 20 CONTINUE -C - CALL DLARFG( P+1, R(1,1), A(1,1), LDA, TAU(1) ) - IF ( M.GT.0 ) THEN -C -C Apply the transformations to the second block row. -C - DO 30 I = N, 1, -1 -C -C Compute -C [ 1 ] -C w := [ B(:,I) C ] * [ ], -C [ v ] -C -C [ B(:,I) C ] = [ B(:,I) C ] - tau * w * [ 1 v' ]. -C - CALL MB04NY( M, P, A(I,1), LDA, TAU(I), B(1,I), LDB, C, - $ LDC, DWORK ) - 30 CONTINUE -C - END IF - END IF - RETURN -C *** Last line of MB04ND *** - END diff --git a/mex/sources/libslicot/MB04NY.f b/mex/sources/libslicot/MB04NY.f deleted file mode 100644 index 4e884454c..000000000 --- a/mex/sources/libslicot/MB04NY.f +++ /dev/null @@ -1,437 +0,0 @@ - SUBROUTINE MB04NY( M, N, V, INCV, TAU, A, LDA, B, LDB, DWORK ) -C -C SLICOT RELEASE 5.0. -C -C Copyright (c) 2002-2009 NICONET e.V. -C -C This program is free software: you can redistribute it and/or -C modify it under the terms of the GNU General Public License as -C published by the Free Software Foundation, either version 2 of -C the License, or (at your option) any later version. -C -C This program is distributed in the hope that it will be useful, -C but WITHOUT ANY WARRANTY; without even the implied warranty of -C MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the -C GNU General Public License for more details. -C -C You should have received a copy of the GNU General Public License -C along with this program. If not, see -C . -C -C PURPOSE -C -C To apply a real elementary reflector H to a real m-by-(n+1) -C matrix C = [ A B ], from the right, where A has one column. H is -C represented in the form -C ( 1 ) -C H = I - tau * u *u', u = ( ), -C ( v ) -C where tau is a real scalar and v is a real n-vector. -C -C If tau = 0, then H is taken to be the unit matrix. -C -C In-line code is used if H has order < 11. -C -C ARGUMENTS -C -C Input/Output Parameters -C -C M (input) INTEGER -C The number of rows of the matrices A and B. M >= 0. -C -C N (input) INTEGER -C The number of columns of the matrix B. N >= 0. -C -C V (input) DOUBLE PRECISION array, dimension -C (1+(N-1)*ABS( INCV )) -C The vector v in the representation of H. -C -C INCV (input) INTEGER -C The increment between the elements of v. INCV <> 0. -C -C TAU (input) DOUBLE PRECISION -C The scalar factor of the elementary reflector H. -C -C A (input/output) DOUBLE PRECISION array, dimension (LDA,1) -C On entry, the leading M-by-1 part of this array must -C contain the matrix A. -C On exit, the leading M-by-1 part of this array contains -C the updated matrix A (the first column of C * H). -C -C LDA INTEGER -C The leading dimension of array A. LDA >= MAX(1,M). -C -C B (input/output) DOUBLE PRECISION array, dimension (LDB,N) -C On entry, the leading M-by-N part of this array must -C contain the matrix B. -C On exit, the leading M-by-N part of this array contains -C the updated matrix B (the last n columns of C * H). -C -C LDB INTEGER -C The leading dimension of array B. LDB >= MAX(1,M). -C -C Workspace -C -C DWORK DOUBLE PRECISION array, dimension (M) -C DWORK is not referenced if H has order less than 11. -C -C METHOD -C -C The routine applies the elementary reflector H, taking the special -C structure of C into account. -C -C NUMERICAL ASPECTS -C -C The algorithm is backward stable. -C -C CONTRIBUTORS -C -C V. Sima, Katholieke Univ. Leuven, Belgium, Apr. 1998. -C Based on LAPACK routines DLARFX and DLATZM. -C -C REVISIONS -C -C - -C -C KEYWORDS -C -C Elementary matrix operations, elementary reflector, orthogonal -C transformation. -C -C ****************************************************************** -C -C .. Parameters .. - DOUBLE PRECISION ZERO, ONE - PARAMETER ( ZERO = 0.0D0, ONE = 1.0D0 ) -C .. Scalar Arguments .. - INTEGER INCV, LDA, LDB, M, N - DOUBLE PRECISION TAU -C .. Array Arguments .. - DOUBLE PRECISION A( LDA, * ), B( LDB, * ), DWORK( * ), V( * ) -C .. Local Scalars .. - INTEGER IV, J - DOUBLE PRECISION SUM, T1, T2, T3, T4, T5, T6, T7, T8, T9, V1, V2, - $ V3, V4, V5, V6, V7, V8, V9 -C .. External Subroutines .. - EXTERNAL DAXPY, DCOPY, DGEMV, DGER -C -C .. Executable Statements .. -C - IF( TAU.EQ.ZERO ) - $ RETURN -C -C Form C * H, where H has order n+1. -C - GO TO ( 10, 30, 50, 70, 90, 110, 130, 150, - $ 170, 190 ) N+1 -C -C Code for general N. Compute -C -C w := C*u, C := C - tau * w * u'. -C - CALL DCOPY( M, A, 1, DWORK, 1 ) - CALL DGEMV( 'No transpose', M, N, ONE, B, LDB, V, INCV, ONE, - $ DWORK, 1 ) - CALL DAXPY( M, -TAU, DWORK, 1, A, 1 ) - CALL DGER( M, N, -TAU, DWORK, 1, V, INCV, B, LDB ) - GO TO 210 - 10 CONTINUE -C -C Special code for 1 x 1 Householder -C - T1 = ONE - TAU - DO 20 J = 1, M - A( J, 1 ) = T1*A( J, 1 ) - 20 CONTINUE - GO TO 210 - 30 CONTINUE -C -C Special code for 2 x 2 Householder -C - IV = 1 - IF( INCV.LT.0 ) - $ IV = (-N+1)*INCV + 1 - V1 = V( IV ) - T1 = TAU*V1 - DO 40 J = 1, M - SUM = A( J, 1 ) + V1*B( J, 1 ) - A( J, 1 ) = A( J, 1 ) - SUM*TAU - B( J, 1 ) = B( J, 1 ) - SUM*T1 - 40 CONTINUE - GO TO 210 - 50 CONTINUE -C -C Special code for 3 x 3 Householder -C - IV = 1 - IF( INCV.LT.0 ) - $ IV = (-N+1)*INCV + 1 - V1 = V( IV ) - T1 = TAU*V1 - IV = IV + INCV - V2 = V( IV ) - T2 = TAU*V2 - DO 60 J = 1, M - SUM = A( J, 1 ) + V1*B( J, 1 ) + V2*B( J, 2 ) - A( J, 1 ) = A( J, 1 ) - SUM*TAU - B( J, 1 ) = B( J, 1 ) - SUM*T1 - B( J, 2 ) = B( J, 2 ) - SUM*T2 - 60 CONTINUE - GO TO 210 - 70 CONTINUE -C -C Special code for 4 x 4 Householder -C - IV = 1 - IF( INCV.LT.0 ) - $ IV = (-N+1)*INCV + 1 - V1 = V( IV ) - T1 = TAU*V1 - IV = IV + INCV - V2 = V( IV ) - T2 = TAU*V2 - IV = IV + INCV - V3 = V( IV ) - T3 = TAU*V3 - DO 80 J = 1, M - SUM = A( J, 1 ) + V1*B( J, 1 ) + V2*B( J, 2 ) + V3*B( J, 3 ) - A( J, 1 ) = A( J, 1 ) - SUM*TAU - B( J, 1 ) = B( J, 1 ) - SUM*T1 - B( J, 2 ) = B( J, 2 ) - SUM*T2 - B( J, 3 ) = B( J, 3 ) - SUM*T3 - 80 CONTINUE - GO TO 210 - 90 CONTINUE -C -C Special code for 5 x 5 Householder -C - IV = 1 - IF( INCV.LT.0 ) - $ IV = (-N+1)*INCV + 1 - V1 = V( IV ) - T1 = TAU*V1 - IV = IV + INCV - V2 = V( IV ) - T2 = TAU*V2 - IV = IV + INCV - V3 = V( IV ) - T3 = TAU*V3 - IV = IV + INCV - V4 = V( IV ) - T4 = TAU*V4 - DO 100 J = 1, M - SUM = A( J, 1 ) + V1*B( J, 1 ) + V2*B( J, 2 ) + V3*B( J, 3 ) + - $ V4*B( J, 4 ) - A( J, 1 ) = A( J, 1 ) - SUM*TAU - B( J, 1 ) = B( J, 1 ) - SUM*T1 - B( J, 2 ) = B( J, 2 ) - SUM*T2 - B( J, 3 ) = B( J, 3 ) - SUM*T3 - B( J, 4 ) = B( J, 4 ) - SUM*T4 - 100 CONTINUE - GO TO 210 - 110 CONTINUE -C -C Special code for 6 x 6 Householder -C - IV = 1 - IF( INCV.LT.0 ) - $ IV = (-N+1)*INCV + 1 - V1 = V( IV ) - T1 = TAU*V1 - IV = IV + INCV - V2 = V( IV ) - T2 = TAU*V2 - IV = IV + INCV - V3 = V( IV ) - T3 = TAU*V3 - IV = IV + INCV - V4 = V( IV ) - T4 = TAU*V4 - IV = IV + INCV - V5 = V( IV ) - T5 = TAU*V5 - DO 120 J = 1, M - SUM = A( J, 1 ) + V1*B( J, 1 ) + V2*B( J, 2 ) + V3*B( J, 3 ) + - $ V4*B( J, 4 ) + V5*B( J, 5 ) - A( J, 1 ) = A( J, 1 ) - SUM*TAU - B( J, 1 ) = B( J, 1 ) - SUM*T1 - B( J, 2 ) = B( J, 2 ) - SUM*T2 - B( J, 3 ) = B( J, 3 ) - SUM*T3 - B( J, 4 ) = B( J, 4 ) - SUM*T4 - B( J, 5 ) = B( J, 5 ) - SUM*T5 - 120 CONTINUE - GO TO 210 - 130 CONTINUE -C -C Special code for 7 x 7 Householder -C - IV = 1 - IF( INCV.LT.0 ) - $ IV = (-N+1)*INCV + 1 - V1 = V( IV ) - T1 = TAU*V1 - IV = IV + INCV - V2 = V( IV ) - T2 = TAU*V2 - IV = IV + INCV - V3 = V( IV ) - T3 = TAU*V3 - IV = IV + INCV - V4 = V( IV ) - T4 = TAU*V4 - IV = IV + INCV - V5 = V( IV ) - T5 = TAU*V5 - IV = IV + INCV - V6 = V( IV ) - T6 = TAU*V6 - DO 140 J = 1, M - SUM = A( J, 1 ) + V1*B( J, 1 ) + V2*B( J, 2 ) + V3*B( J, 3 ) + - $ V4*B( J, 4 ) + V5*B( J, 5 ) + V6*B( J, 6 ) - A( J, 1 ) = A( J, 1 ) - SUM*TAU - B( J, 1 ) = B( J, 1 ) - SUM*T1 - B( J, 2 ) = B( J, 2 ) - SUM*T2 - B( J, 3 ) = B( J, 3 ) - SUM*T3 - B( J, 4 ) = B( J, 4 ) - SUM*T4 - B( J, 5 ) = B( J, 5 ) - SUM*T5 - B( J, 6 ) = B( J, 6 ) - SUM*T6 - 140 CONTINUE - GO TO 210 - 150 CONTINUE -C -C Special code for 8 x 8 Householder -C - IV = 1 - IF( INCV.LT.0 ) - $ IV = (-N+1)*INCV + 1 - V1 = V( IV ) - T1 = TAU*V1 - IV = IV + INCV - V2 = V( IV ) - T2 = TAU*V2 - IV = IV + INCV - V3 = V( IV ) - T3 = TAU*V3 - IV = IV + INCV - V4 = V( IV ) - T4 = TAU*V4 - IV = IV + INCV - V5 = V( IV ) - T5 = TAU*V5 - IV = IV + INCV - V6 = V( IV ) - T6 = TAU*V6 - IV = IV + INCV - V7 = V( IV ) - T7 = TAU*V7 - DO 160 J = 1, M - SUM = A( J, 1 ) + V1*B( J, 1 ) + V2*B( J, 2 ) + V3*B( J, 3 ) + - $ V4*B( J, 4 ) + V5*B( J, 5 ) + V6*B( J, 6 ) + - $ V7*B( J, 7 ) - A( J, 1 ) = A( J, 1 ) - SUM*TAU - B( J, 1 ) = B( J, 1 ) - SUM*T1 - B( J, 2 ) = B( J, 2 ) - SUM*T2 - B( J, 3 ) = B( J, 3 ) - SUM*T3 - B( J, 4 ) = B( J, 4 ) - SUM*T4 - B( J, 5 ) = B( J, 5 ) - SUM*T5 - B( J, 6 ) = B( J, 6 ) - SUM*T6 - B( J, 7 ) = B( J, 7 ) - SUM*T7 - 160 CONTINUE - GO TO 210 - 170 CONTINUE -C -C Special code for 9 x 9 Householder -C - IV = 1 - IF( INCV.LT.0 ) - $ IV = (-N+1)*INCV + 1 - V1 = V( IV ) - T1 = TAU*V1 - IV = IV + INCV - V2 = V( IV ) - T2 = TAU*V2 - IV = IV + INCV - V3 = V( IV ) - T3 = TAU*V3 - IV = IV + INCV - V4 = V( IV ) - T4 = TAU*V4 - IV = IV + INCV - V5 = V( IV ) - T5 = TAU*V5 - IV = IV + INCV - V6 = V( IV ) - T6 = TAU*V6 - IV = IV + INCV - V7 = V( IV ) - T7 = TAU*V7 - IV = IV + INCV - V8 = V( IV ) - T8 = TAU*V8 - DO 180 J = 1, M - SUM = A( J, 1 ) + V1*B( J, 1 ) + V2*B( J, 2 ) + V3*B( J, 3 ) + - $ V4*B( J, 4 ) + V5*B( J, 5 ) + V6*B( J, 6 ) + - $ V7*B( J, 7 ) + V8*B( J, 8 ) - A( J, 1 ) = A( J, 1 ) - SUM*TAU - B( J, 1 ) = B( J, 1 ) - SUM*T1 - B( J, 2 ) = B( J, 2 ) - SUM*T2 - B( J, 3 ) = B( J, 3 ) - SUM*T3 - B( J, 4 ) = B( J, 4 ) - SUM*T4 - B( J, 5 ) = B( J, 5 ) - SUM*T5 - B( J, 6 ) = B( J, 6 ) - SUM*T6 - B( J, 7 ) = B( J, 7 ) - SUM*T7 - B( J, 8 ) = B( J, 8 ) - SUM*T8 - 180 CONTINUE - GO TO 210 - 190 CONTINUE -C -C Special code for 10 x 10 Householder -C - IV = 1 - IF( INCV.LT.0 ) - $ IV = (-N+1)*INCV + 1 - V1 = V( IV ) - T1 = TAU*V1 - IV = IV + INCV - V2 = V( IV ) - T2 = TAU*V2 - IV = IV + INCV - V3 = V( IV ) - T3 = TAU*V3 - IV = IV + INCV - V4 = V( IV ) - T4 = TAU*V4 - IV = IV + INCV - V5 = V( IV ) - T5 = TAU*V5 - IV = IV + INCV - V6 = V( IV ) - T6 = TAU*V6 - IV = IV + INCV - V7 = V( IV ) - T7 = TAU*V7 - IV = IV + INCV - V8 = V( IV ) - T8 = TAU*V8 - IV = IV + INCV - V9 = V( IV ) - T9 = TAU*V9 - DO 200 J = 1, M - SUM = A( J, 1 ) + V1*B( J, 1 ) + V2*B( J, 2 ) + V3*B( J, 3 ) + - $ V4*B( J, 4 ) + V5*B( J, 5 ) + V6*B( J, 6 ) + - $ V7*B( J, 7 ) + V8*B( J, 8 ) + V9*B( J, 9 ) - A( J, 1 ) = A( J, 1 ) - SUM*TAU - B( J, 1 ) = B( J, 1 ) - SUM*T1 - B( J, 2 ) = B( J, 2 ) - SUM*T2 - B( J, 3 ) = B( J, 3 ) - SUM*T3 - B( J, 4 ) = B( J, 4 ) - SUM*T4 - B( J, 5 ) = B( J, 5 ) - SUM*T5 - B( J, 6 ) = B( J, 6 ) - SUM*T6 - B( J, 7 ) = B( J, 7 ) - SUM*T7 - B( J, 8 ) = B( J, 8 ) - SUM*T8 - B( J, 9 ) = B( J, 9 ) - SUM*T9 - 200 CONTINUE - 210 CONTINUE - RETURN -C *** Last line of MB04NY *** - END diff --git a/mex/sources/libslicot/MB04OD.f b/mex/sources/libslicot/MB04OD.f deleted file mode 100644 index 694c81d75..000000000 --- a/mex/sources/libslicot/MB04OD.f +++ /dev/null @@ -1,257 +0,0 @@ - SUBROUTINE MB04OD( UPLO, N, M, P, R, LDR, A, LDA, B, LDB, C, LDC, - $ TAU, DWORK ) -C -C SLICOT RELEASE 5.0. -C -C Copyright (c) 2002-2009 NICONET e.V. -C -C This program is free software: you can redistribute it and/or -C modify it under the terms of the GNU General Public License as -C published by the Free Software Foundation, either version 2 of -C the License, or (at your option) any later version. -C -C This program is distributed in the hope that it will be useful, -C but WITHOUT ANY WARRANTY; without even the implied warranty of -C MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the -C GNU General Public License for more details. -C -C You should have received a copy of the GNU General Public License -C along with this program. If not, see -C . -C -C PURPOSE -C -C To calculate a QR factorization of the first block column and -C apply the orthogonal transformations (from the left) also to the -C second block column of a structured matrix, as follows -C _ _ -C [ R B ] [ R B ] -C Q' * [ ] = [ _ ] -C [ A C ] [ 0 C ] -C _ -C where R and R are upper triangular. The matrix A can be full or -C upper trapezoidal/triangular. The problem structure is exploited. -C -C ARGUMENTS -C -C Mode Parameters -C -C UPLO CHARACTER*1 -C Indicates if the matrix A is or not triangular as follows: -C = 'U': Matrix A is upper trapezoidal/triangular; -C = 'F': Matrix A is full. -C -C Input/Output Parameters -C -C N (input) INTEGER _ -C The order of the matrices R and R. N >= 0. -C -C M (input) INTEGER -C The number of columns of the matrices B and C. M >= 0. -C -C P (input) INTEGER -C The number of rows of the matrices A and C. P >= 0. -C -C R (input/output) DOUBLE PRECISION array, dimension (LDR,N) -C On entry, the leading N-by-N upper triangular part of this -C array must contain the upper triangular matrix R. -C On exit, the leading N-by-N upper triangular part of this -C _ -C array contains the upper triangular matrix R. -C The strict lower triangular part of this array is not -C referenced. -C -C LDR INTEGER -C The leading dimension of array R. LDR >= MAX(1,N). -C -C A (input/output) DOUBLE PRECISION array, dimension (LDA,N) -C On entry, if UPLO = 'F', the leading P-by-N part of this -C array must contain the matrix A. If UPLO = 'U', the -C leading MIN(P,N)-by-N part of this array must contain the -C upper trapezoidal (upper triangular if P >= N) matrix A, -C and the elements below the diagonal are not referenced. -C On exit, the leading P-by-N part (upper trapezoidal or -C triangular, if UPLO = 'U') of this array contains the -C trailing components (the vectors v, see Method) of the -C elementary reflectors used in the factorization. -C -C LDA INTEGER -C The leading dimension of array A. LDA >= MAX(1,P). -C -C B (input/output) DOUBLE PRECISION array, dimension (LDB,M) -C On entry, the leading N-by-M part of this array must -C contain the matrix B. -C On exit, the leading N-by-M part of this array contains -C _ -C the computed matrix B. -C -C LDB INTEGER -C The leading dimension of array B. LDB >= MAX(1,N). -C -C C (input/output) DOUBLE PRECISION array, dimension (LDC,M) -C On entry, the leading P-by-M part of this array must -C contain the matrix C. -C On exit, the leading P-by-M part of this array contains -C _ -C the computed matrix C. -C -C LDC INTEGER -C The leading dimension of array C. LDC >= MAX(1,P). -C -C TAU (output) DOUBLE PRECISION array, dimension (N) -C The scalar factors of the elementary reflectors used. -C -C Workspace -C -C DWORK DOUBLE PRECISION array, dimension (MAX(N-1,M)) -C -C METHOD -C -C The routine uses N Householder transformations exploiting the zero -C pattern of the block matrix. A Householder matrix has the form -C -C ( 1 ) -C H = I - tau *u *u', u = ( v ), -C i i i i i ( i) -C -C where v is a P-vector, if UPLO = 'F', or a min(i,P)-vector, if -C i -C UPLO = 'U'. The components of v are stored in the i-th column -C i -C of A, and tau is stored in TAU(i). -C i -C In-line code for applying Householder transformations is used -C whenever possible (see MB04OY routine). -C -C NUMERICAL ASPECTS -C -C The algorithm is backward stable. -C -C CONTRIBUTORS -C -C V. Sima, Katholieke Univ. Leuven, Belgium, Feb. 1997. -C -C REVISIONS -C -C Dec. 1997. -C -C KEYWORDS -C -C Elementary reflector, QR factorization, orthogonal transformation. -C -C ****************************************************************** -C -C .. Parameters .. - DOUBLE PRECISION ZERO, ONE - PARAMETER ( ZERO = 0.0D0, ONE = 1.0D0 ) -C .. Scalar Arguments .. - CHARACTER UPLO - INTEGER LDA, LDB, LDC, LDR, M, N, P -C .. Array Arguments .. - DOUBLE PRECISION A(LDA,*), B(LDB,*), C(LDC,*), DWORK(*), - $ R(LDR,*), TAU(*) -C .. Local Scalars .. - LOGICAL LUPLO - INTEGER I, IM -C .. External Functions .. - LOGICAL LSAME - EXTERNAL LSAME -C .. External Subroutines .. - EXTERNAL DLARFG, MB04OY -C .. Intrinsic Functions .. - INTRINSIC MIN -C .. Executable Statements .. -C -C For efficiency reasons, the parameters are not checked. -C - IF( MIN( N, P ).EQ.0 ) - $ RETURN -C - LUPLO = LSAME( UPLO, 'U' ) - IF ( LUPLO ) THEN -C - DO 10 I = 1, N -C -C Annihilate the I-th column of A and apply the -C transformations to the entire block matrix, exploiting -C its structure. -C - IM = MIN( I, P ) - CALL DLARFG( IM+1, R(I,I), A(1,I), 1, TAU(I) ) -C -C Compute -C [ R(I,I+1:N) ] -C w := [ 1 v' ] * [ ], -C [ A(1:IM,I+1:N) ] -C -C [ R(I,I+1:N) ] [ R(I,I+1:N) ] [ 1 ] -C [ ] := [ ] - tau * [ ] * w . -C [ A(1:IM,I+1:N) ] [ A(1:IM,I+1:N) ] [ v ] -C - IF ( N-I.GT.0 ) - $ CALL MB04OY( IM, N-I, A(1,I), TAU(I), R(I,I+1), LDR, - $ A(1,I+1), LDA, DWORK ) -C -C Compute -C [ B(I,:) ] -C w := [ 1 v' ] * [ ], -C [ C(1:IM,:) ] -C -C [ B(I,:) ] [ B(I,:) ] [ 1 ] -C [ ] := [ ] - tau * [ ] * w. -C [ C(1:IM,:) ] [ C(1:IM,:) ] [ v ] -C -C - IF ( M.GT.0 ) - $ CALL MB04OY( IM, M, A(1,I), TAU(I), B(I,1), LDB, C, LDC, - $ DWORK ) - 10 CONTINUE -C - ELSE -C - DO 20 I = 1, N - 1 -C -C Annihilate the I-th column of A and apply the -C transformations to the first block column, exploiting its -C structure. -C - CALL DLARFG( P+1, R(I,I), A(1,I), 1, TAU(I) ) -C -C Compute -C [ R(I,I+1:N) ] -C w := [ 1 v' ] * [ ], -C [ A(:,I+1:N) ] -C -C [ R(I,I+1:N) ] [ R(I,I+1:N) ] [ 1 ] -C [ ] := [ ] - tau * [ ] * w . -C [ A(:,I+1:N) ] [ A(:,I+1:N) ] [ v ] -C - CALL MB04OY( P, N-I, A(1,I), TAU(I), R(I,I+1), LDR, - $ A(1,I+1), LDA, DWORK ) - 20 CONTINUE -C - CALL DLARFG( P+1, R(N,N), A(1,N), 1, TAU(N) ) - IF ( M.GT.0 ) THEN -C -C Apply the transformations to the second block column. -C - DO 30 I = 1, N -C -C Compute -C [ B(I,:) ] -C w := [ 1 v' ] * [ ], -C [ C ] -C -C [ B(I,:) ] [ B(I,:) ] [ 1 ] -C [ ] := [ ] - tau * [ ] * w. -C [ C ] [ C ] [ v ] -C - CALL MB04OY( P, M, A(1,I), TAU(I), B(I,1), LDB, C, LDC, - $ DWORK ) - 30 CONTINUE -C - END IF - END IF - RETURN -C *** Last line of MB04OD *** - END diff --git a/mex/sources/libslicot/MB04OW.f b/mex/sources/libslicot/MB04OW.f deleted file mode 100644 index ab5940943..000000000 --- a/mex/sources/libslicot/MB04OW.f +++ /dev/null @@ -1,251 +0,0 @@ - SUBROUTINE MB04OW( M, N, P, A, LDA, T, LDT, X, INCX, B, LDB, - $ C, LDC, D, INCD ) -C -C SLICOT RELEASE 5.0. -C -C Copyright (c) 2002-2009 NICONET e.V. -C -C This program is free software: you can redistribute it and/or -C modify it under the terms of the GNU General Public License as -C published by the Free Software Foundation, either version 2 of -C the License, or (at your option) any later version. -C -C This program is distributed in the hope that it will be useful, -C but WITHOUT ANY WARRANTY; without even the implied warranty of -C MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the -C GNU General Public License for more details. -C -C You should have received a copy of the GNU General Public License -C along with this program. If not, see -C . -C -C PURPOSE -C -C To perform the QR factorization -C -C ( U ) = Q*( R ), where U = ( U1 U2 ), R = ( R1 R2 ), -C ( x' ) ( 0 ) ( 0 T ) ( 0 R3 ) -C -C where U and R are (m+n)-by-(m+n) upper triangular matrices, x is -C an m+n element vector, U1 is m-by-m, T is n-by-n, stored -C separately, and Q is an (m+n+1)-by-(m+n+1) orthogonal matrix. -C -C The matrix ( U1 U2 ) must be supplied in the m-by-(m+n) upper -C trapezoidal part of the array A and this is overwritten by the -C corresponding part ( R1 R2 ) of R. The remaining upper triangular -C part of R, R3, is overwritten on the array T. -C -C The transformations performed are also applied to the (m+n+1)-by-p -C matrix ( B' C' d )' (' denotes transposition), where B, C, and d' -C are m-by-p, n-by-p, and 1-by-p matrices, respectively. -C -C ARGUMENTS -C -C Input/Output Parameters -C -C M (input) INTEGER -C The number of rows of the matrix ( U1 U2 ). M >= 0. -C -C N (input) INTEGER -C The order of the matrix T. N >= 0. -C -C P (input) INTEGER -C The number of columns of the matrices B and C. P >= 0. -C -C A (input/output) DOUBLE PRECISION array, dimension (LDA,N) -C On entry, the leading M-by-(M+N) upper trapezoidal part of -C this array must contain the upper trapezoidal matrix -C ( U1 U2 ). -C On exit, the leading M-by-(M+N) upper trapezoidal part of -C this array contains the upper trapezoidal matrix ( R1 R2 ). -C The strict lower triangle of A is not referenced. -C -C LDA INTEGER -C The leading dimension of the array A. LDA >= max(1,M). -C -C T (input/output) DOUBLE PRECISION array, dimension (LDT,N) -C On entry, the leading N-by-N upper triangular part of this -C array must contain the upper triangular matrix T. -C On exit, the leading N-by-N upper triangular part of this -C array contains the upper triangular matrix R3. -C The strict lower triangle of T is not referenced. -C -C LDT INTEGER -C The leading dimension of the array T. LDT >= max(1,N). -C -C X (input/output) DOUBLE PRECISION array, dimension -C (1+(M+N-1)*INCX), if M+N > 0, or dimension (0), if M+N = 0. -C On entry, the incremented array X must contain the -C vector x. On exit, the content of X is changed. -C -C INCX (input) INTEGER -C Specifies the increment for the elements of X. INCX > 0. -C -C B (input/output) DOUBLE PRECISION array, dimension (LDB,P) -C On entry, the leading M-by-P part of this array must -C contain the matrix B. -C On exit, the leading M-by-P part of this array contains -C the transformed matrix B. -C If M = 0 or P = 0, this array is not referenced. -C -C LDB INTEGER -C The leading dimension of the array B. -C LDB >= max(1,M), if P > 0; -C LDB >= 1, if P = 0. -C -C C (input/output) DOUBLE PRECISION array, dimension (LDC,P) -C On entry, the leading N-by-P part of this array must -C contain the matrix C. -C On exit, the leading N-by-P part of this array contains -C the transformed matrix C. -C If N = 0 or P = 0, this array is not referenced. -C -C LDC INTEGER -C The leading dimension of the array C. -C LDC >= max(1,N), if P > 0; -C LDC >= 1, if P = 0. -C -C D (input/output) DOUBLE PRECISION array, dimension -C (1+(P-1)*INCD), if P > 0, or dimension (0), if P = 0. -C On entry, the incremented array D must contain the -C vector d. -C On exit, this incremented array contains the transformed -C vector d. -C If P = 0, this array is not referenced. -C -C INCD (input) INTEGER -C Specifies the increment for the elements of D. INCD > 0. -C -C METHOD -C -C Let q = m+n. The matrix Q is formed as a sequence of plane -C rotations in planes (1, q+1), (2, q+1), ..., (q, q+1), the -C rotation in the (j, q+1)th plane, Q(j), being chosen to -C annihilate the jth element of x. -C -C NUMERICAL ASPECTS -C -C The algorithm requires 0((M+N)*(M+N+P)) operations and is backward -C stable. -C -C FURTHER COMMENTS -C -C For P = 0, this routine produces the same result as SLICOT Library -C routine MB04OX, but matrix T may not be stored in the array A. -C -C CONTRIBUTORS -C -C V. Sima, Research Institute for Informatics, Bucharest, Dec. 2001. -C -C REVISIONS -C -C - -C -C KEYWORDS -C -C Matrix operations, plane rotations. -C -C ****************************************************************** -C -C .. Scalar Arguments .. - INTEGER INCD, INCX, LDA, LDB, LDC, LDT, M, N, P -C .. Array Arguments .. - DOUBLE PRECISION A(LDA,*), B(LDB,*), C(LDC,*), D(*), T(LDT,*), - $ X(*) -C .. Local Scalars .. - DOUBLE PRECISION CI, SI, TEMP - INTEGER I, IX, MN -C .. External Subroutines .. - EXTERNAL DLARTG, DROT -C -C .. Executable Statements .. -C -C For efficiency reasons, the parameters are not checked. -C - MN = M + N - IF ( INCX.GT.1 ) THEN -C -C Code for increment INCX > 1. -C - IX = 1 - IF ( M.GT.0 ) THEN -C - DO 10 I = 1, M - 1 - CALL DLARTG( A(I,I), X(IX), CI, SI, TEMP ) - A(I,I) = TEMP - IX = IX + INCX - CALL DROT( MN-I, A(I,I+1), LDA, X(IX), INCX, CI, SI ) - IF ( P.GT.0 ) - $ CALL DROT( P, B(I,1), LDB, D, INCD, CI, SI ) - 10 CONTINUE -C - CALL DLARTG( A(M,M), X(IX), CI, SI, TEMP ) - A(M,M) = TEMP - IX = IX + INCX - IF ( N.GT.0 ) - $ CALL DROT( N, A(M,M+1), LDA, X(IX), INCX, CI, SI ) - IF ( P.GT.0 ) - $ CALL DROT( P, B(M,1), LDB, D, INCD, CI, SI ) - END IF -C - IF ( N.GT.0 ) THEN -C - DO 20 I = 1, N - 1 - CALL DLARTG( T(I,I), X(IX), CI, SI, TEMP ) - T(I,I) = TEMP - IX = IX + INCX - CALL DROT( N-I, T(I,I+1), LDT, X(IX), INCX, CI, SI ) - IF ( P.GT.0 ) - $ CALL DROT( P, C(I,1), LDC, D, INCD, CI, SI ) - 20 CONTINUE -C - CALL DLARTG( T(N,N), X(IX), CI, SI, TEMP ) - T(N,N) = TEMP - IF ( P.GT.0 ) - $ CALL DROT( P, C(N,1), LDC, D, INCD, CI, SI ) - END IF -C - ELSEIF ( INCX.EQ.1 ) THEN -C -C Code for increment INCX = 1. -C - IF ( M.GT.0 ) THEN -C - DO 30 I = 1, M - 1 - CALL DLARTG( A(I,I), X(I), CI, SI, TEMP ) - A(I,I) = TEMP - CALL DROT( MN-I, A(I,I+1), LDA, X(I+1), 1, CI, SI ) - IF ( P.GT.0 ) - $ CALL DROT( P, B(I,1), LDB, D, INCD, CI, SI ) - 30 CONTINUE -C - CALL DLARTG( A(M,M), X(M), CI, SI, TEMP ) - A(M,M) = TEMP - IF ( N.GT.0 ) - $ CALL DROT( N, A(M,M+1), LDA, X(M+1), 1, CI, SI ) - IF ( P.GT.0 ) - $ CALL DROT( P, B(M,1), LDB, D, INCD, CI, SI ) - END IF -C - IF ( N.GT.0 ) THEN - IX = M + 1 -C - DO 40 I = 1, N - 1 - CALL DLARTG( T(I,I), X(IX), CI, SI, TEMP ) - T(I,I) = TEMP - IX = IX + 1 - CALL DROT( N-I, T(I,I+1), LDT, X(IX), 1, CI, SI ) - IF ( P.GT.0 ) - $ CALL DROT( P, C(I,1), LDC, D, INCD, CI, SI ) - 40 CONTINUE -C - CALL DLARTG( T(N,N), X(IX), CI, SI, TEMP ) - T(N,N) = TEMP - IF ( P.GT.0 ) - $ CALL DROT( P, C(N,1), LDC, D, INCD, CI, SI ) - END IF - END IF -C - RETURN -C *** Last line of MB04OW *** - END diff --git a/mex/sources/libslicot/MB04OX.f b/mex/sources/libslicot/MB04OX.f deleted file mode 100644 index b8d02919e..000000000 --- a/mex/sources/libslicot/MB04OX.f +++ /dev/null @@ -1,106 +0,0 @@ - SUBROUTINE MB04OX( N, A, LDA, X, INCX ) -C -C SLICOT RELEASE 5.0. -C -C Copyright (c) 2002-2009 NICONET e.V. -C -C This program is free software: you can redistribute it and/or -C modify it under the terms of the GNU General Public License as -C published by the Free Software Foundation, either version 2 of -C the License, or (at your option) any later version. -C -C This program is distributed in the hope that it will be useful, -C but WITHOUT ANY WARRANTY; without even the implied warranty of -C MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the -C GNU General Public License for more details. -C -C You should have received a copy of the GNU General Public License -C along with this program. If not, see -C . -C -C PURPOSE -C -C To perform the QR factorization -C -C (U ) = Q*(R), -C (x') (0) -C -C where U and R are n-by-n upper triangular matrices, x is an -C n element vector and Q is an (n+1)-by-(n+1) orthogonal matrix. -C -C U must be supplied in the n-by-n upper triangular part of the -C array A and this is overwritten by R. -C -C ARGUMENTS -C -C Input/Output Parameters -C -C N (input) INTEGER -C The number of elements of X and the order of the square -C matrix A. N >= 0. -C -C A (input/output) DOUBLE PRECISION array, dimension (LDA,N) -C On entry, the leading N-by-N upper triangular part of this -C array must contain the upper triangular matrix U. -C On exit, the leading N-by-N upper triangular part of this -C array contains the upper triangular matrix R. -C The strict lower triangle of A is not referenced. -C -C LDA INTEGER -C The leading dimension of the array A. LDA >= max(1,N). -C -C X (input/output) DOUBLE PRECISION array, dimension -C (1+(N-1)*INCX) -C On entry, the incremented array X must contain the -C vector x. On exit, the content of X is changed. -C -C INCX (input) INTEGER. -C Specifies the increment for the elements of X. INCX > 0. -C -C METHOD -C -C The matrix Q is formed as a sequence of plane rotations in planes -C (1, n+1), (2, n+1), ..., (n, n+1), the rotation in the (j, n+1)th -C plane, Q(j), being chosen to annihilate the jth element of x. -C -C CONTRIBUTOR -C -C A. Varga, German Aerospace Center, -C DLR Oberpfaffenhofen, July 1998. -C Based on the RASP routine DUTUPD. -C -C REVISIONS -C -C Nov. 1998, V. Sima, Research Institute for Informatics, Bucharest. -C -C ****************************************************************** -C -C .. Scalar Arguments .. - INTEGER INCX, LDA, N -C .. Array Arguments .. - DOUBLE PRECISION A(LDA,*), X(*) -C .. Local Scalars .. - DOUBLE PRECISION CI, SI, TEMP - INTEGER I, IX -C .. External Subroutines .. - EXTERNAL DLARTG, DROT -C -C .. Executable Statements .. -C -C For efficiency reasons, the parameters are not checked. -C - IX = 1 -C - DO 20 I = 1, N - 1 - CALL DLARTG( A(I,I), X(IX), CI, SI, TEMP ) - A(I,I) = TEMP - IX = IX + INCX - CALL DROT( N-I, A(I,I+1), LDA, X(IX), INCX, CI, SI ) - 20 CONTINUE -C - CALL DLARTG( A(N,N), X(IX), CI, SI, TEMP ) - A(N,N) = TEMP -C - RETURN -C *** Last line of MB04OX *** - END diff --git a/mex/sources/libslicot/MB04OY.f b/mex/sources/libslicot/MB04OY.f deleted file mode 100644 index d77d28372..000000000 --- a/mex/sources/libslicot/MB04OY.f +++ /dev/null @@ -1,370 +0,0 @@ - SUBROUTINE MB04OY( M, N, V, TAU, A, LDA, B, LDB, DWORK ) -C -C SLICOT RELEASE 5.0. -C -C Copyright (c) 2002-2009 NICONET e.V. -C -C This program is free software: you can redistribute it and/or -C modify it under the terms of the GNU General Public License as -C published by the Free Software Foundation, either version 2 of -C the License, or (at your option) any later version. -C -C This program is distributed in the hope that it will be useful, -C but WITHOUT ANY WARRANTY; without even the implied warranty of -C MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the -C GNU General Public License for more details. -C -C You should have received a copy of the GNU General Public License -C along with this program. If not, see -C . -C -C PURPOSE -C -C To apply a real elementary reflector H to a real (m+1)-by-n -C matrix C = [ A ], from the left, where A has one row. H is -C [ B ] -C represented in the form -C ( 1 ) -C H = I - tau * u *u', u = ( ), -C ( v ) -C where tau is a real scalar and v is a real m-vector. -C -C If tau = 0, then H is taken to be the unit matrix. -C -C In-line code is used if H has order < 11. -C -C ARGUMENTS -C -C Input/Output Parameters -C -C M (input) INTEGER -C The number of rows of the matrix B. M >= 0. -C -C N (input) INTEGER -C The number of columns of the matrices A and B. N >= 0. -C -C V (input) DOUBLE PRECISION array, dimension (M) -C The vector v in the representation of H. -C -C TAU (input) DOUBLE PRECISION -C The scalar factor of the elementary reflector H. -C -C A (input/output) DOUBLE PRECISION array, dimension (LDA,N) -C On entry, the leading 1-by-N part of this array must -C contain the matrix A. -C On exit, the leading 1-by-N part of this array contains -C the updated matrix A (the first row of H * C). -C -C LDA INTEGER -C The leading dimension of array A. LDA >= 1. -C -C B (input/output) DOUBLE PRECISION array, dimension (LDB,N) -C On entry, the leading M-by-N part of this array must -C contain the matrix B. -C On exit, the leading M-by-N part of this array contains -C the updated matrix B (the last m rows of H * C). -C -C LDB INTEGER -C The leading dimension of array B. LDB >= MAX(1,M). -C -C Workspace -C -C DWORK DOUBLE PRECISION array, dimension (N) -C DWORK is not referenced if H has order less than 11. -C -C METHOD -C -C The routine applies the elementary reflector H, taking the special -C structure of C into account. -C -C NUMERICAL ASPECTS -C -C The algorithm is backward stable. -C -C CONTRIBUTORS -C -C V. Sima, Katholieke Univ. Leuven, Belgium, Feb. 1997. -C Based on LAPACK routines DLARFX and DLATZM. -C -C REVISIONS -C -C Dec. 1997. -C -C KEYWORDS -C -C Elementary matrix operations, elementary reflector, orthogonal -C transformation. -C -C ****************************************************************** -C -C .. Parameters .. - DOUBLE PRECISION ZERO, ONE - PARAMETER ( ZERO = 0.0D0, ONE = 1.0D0 ) -C .. Scalar Arguments .. - INTEGER LDA, LDB, M, N - DOUBLE PRECISION TAU -C .. Array Arguments .. - DOUBLE PRECISION A( LDA, * ), B( LDB, * ), DWORK( * ), V( * ) -C .. Local Scalars .. - INTEGER J - DOUBLE PRECISION SUM, T1, T2, T3, T4, T5, T6, T7, T8, T9, V1, V2, - $ V3, V4, V5, V6, V7, V8, V9 -C .. External Subroutines .. - EXTERNAL DAXPY, DCOPY, DGEMV, DGER -C -C .. Executable Statements .. -C - IF( TAU.EQ.ZERO ) - $ RETURN -C -C Form H * C, where H has order m+1. -C - GO TO ( 10, 30, 50, 70, 90, 110, 130, 150, - $ 170, 190 ) M+1 -C -C Code for general M. Compute -C -C w := C'*u, C := C - tau * u * w'. -C - CALL DCOPY( N, A, LDA, DWORK, 1 ) - CALL DGEMV( 'Transpose', M, N, ONE, B, LDB, V, 1, ONE, DWORK, 1 ) - CALL DAXPY( N, -TAU, DWORK, 1, A, LDA ) - CALL DGER( M, N, -TAU, V, 1, DWORK, 1, B, LDB ) - GO TO 210 - 10 CONTINUE -C -C Special code for 1 x 1 Householder -C - T1 = ONE - TAU - DO 20 J = 1, N - A( 1, J ) = T1*A( 1, J ) - 20 CONTINUE - GO TO 210 - 30 CONTINUE -C -C Special code for 2 x 2 Householder -C - V1 = V( 1 ) - T1 = TAU*V1 - DO 40 J = 1, N - SUM = A( 1, J ) + V1*B( 1, J ) - A( 1, J ) = A( 1, J ) - SUM*TAU - B( 1, J ) = B( 1, J ) - SUM*T1 - 40 CONTINUE - GO TO 210 - 50 CONTINUE -C -C Special code for 3 x 3 Householder -C - V1 = V( 1 ) - T1 = TAU*V1 - V2 = V( 2 ) - T2 = TAU*V2 - DO 60 J = 1, N - SUM = A( 1, J ) + V1*B( 1, J ) + V2*B( 2, J ) - A( 1, J ) = A( 1, J ) - SUM*TAU - B( 1, J ) = B( 1, J ) - SUM*T1 - B( 2, J ) = B( 2, J ) - SUM*T2 - 60 CONTINUE - GO TO 210 - 70 CONTINUE -C -C Special code for 4 x 4 Householder -C - V1 = V( 1 ) - T1 = TAU*V1 - V2 = V( 2 ) - T2 = TAU*V2 - V3 = V( 3 ) - T3 = TAU*V3 - DO 80 J = 1, N - SUM = A( 1, J ) + V1*B( 1, J ) + V2*B( 2, J ) + V3*B( 3, J ) - A( 1, J ) = A( 1, J ) - SUM*TAU - B( 1, J ) = B( 1, J ) - SUM*T1 - B( 2, J ) = B( 2, J ) - SUM*T2 - B( 3, J ) = B( 3, J ) - SUM*T3 - 80 CONTINUE - GO TO 210 - 90 CONTINUE -C -C Special code for 5 x 5 Householder -C - V1 = V( 1 ) - T1 = TAU*V1 - V2 = V( 2 ) - T2 = TAU*V2 - V3 = V( 3 ) - T3 = TAU*V3 - V4 = V( 4 ) - T4 = TAU*V4 - DO 100 J = 1, N - SUM = A( 1, J ) + V1*B( 1, J ) + V2*B( 2, J ) + V3*B( 3, J ) + - $ V4*B( 4, J ) - A( 1, J ) = A( 1, J ) - SUM*TAU - B( 1, J ) = B( 1, J ) - SUM*T1 - B( 2, J ) = B( 2, J ) - SUM*T2 - B( 3, J ) = B( 3, J ) - SUM*T3 - B( 4, J ) = B( 4, J ) - SUM*T4 - 100 CONTINUE - GO TO 210 - 110 CONTINUE -C -C Special code for 6 x 6 Householder -C - V1 = V( 1 ) - T1 = TAU*V1 - V2 = V( 2 ) - T2 = TAU*V2 - V3 = V( 3 ) - T3 = TAU*V3 - V4 = V( 4 ) - T4 = TAU*V4 - V5 = V( 5 ) - T5 = TAU*V5 - DO 120 J = 1, N - SUM = A( 1, J ) + V1*B( 1, J ) + V2*B( 2, J ) + V3*B( 3, J ) + - $ V4*B( 4, J ) + V5*B( 5, J ) - A( 1, J ) = A( 1, J ) - SUM*TAU - B( 1, J ) = B( 1, J ) - SUM*T1 - B( 2, J ) = B( 2, J ) - SUM*T2 - B( 3, J ) = B( 3, J ) - SUM*T3 - B( 4, J ) = B( 4, J ) - SUM*T4 - B( 5, J ) = B( 5, J ) - SUM*T5 - 120 CONTINUE - GO TO 210 - 130 CONTINUE -C -C Special code for 7 x 7 Householder -C - V1 = V( 1 ) - T1 = TAU*V1 - V2 = V( 2 ) - T2 = TAU*V2 - V3 = V( 3 ) - T3 = TAU*V3 - V4 = V( 4 ) - T4 = TAU*V4 - V5 = V( 5 ) - T5 = TAU*V5 - V6 = V( 6 ) - T6 = TAU*V6 - DO 140 J = 1, N - SUM = A( 1, J ) + V1*B( 1, J ) + V2*B( 2, J ) + V3*B( 3, J ) + - $ V4*B( 4, J ) + V5*B( 5, J ) + V6*B( 6, J ) - A( 1, J ) = A( 1, J ) - SUM*TAU - B( 1, J ) = B( 1, J ) - SUM*T1 - B( 2, J ) = B( 2, J ) - SUM*T2 - B( 3, J ) = B( 3, J ) - SUM*T3 - B( 4, J ) = B( 4, J ) - SUM*T4 - B( 5, J ) = B( 5, J ) - SUM*T5 - B( 6, J ) = B( 6, J ) - SUM*T6 - 140 CONTINUE - GO TO 210 - 150 CONTINUE -C -C Special code for 8 x 8 Householder -C - V1 = V( 1 ) - T1 = TAU*V1 - V2 = V( 2 ) - T2 = TAU*V2 - V3 = V( 3 ) - T3 = TAU*V3 - V4 = V( 4 ) - T4 = TAU*V4 - V5 = V( 5 ) - T5 = TAU*V5 - V6 = V( 6 ) - T6 = TAU*V6 - V7 = V( 7 ) - T7 = TAU*V7 - DO 160 J = 1, N - SUM = A( 1, J ) + V1*B( 1, J ) + V2*B( 2, J ) + V3*B( 3, J ) + - $ V4*B( 4, J ) + V5*B( 5, J ) + V6*B( 6, J ) + - $ V7*B( 7, J ) - A( 1, J ) = A( 1, J ) - SUM*TAU - B( 1, J ) = B( 1, J ) - SUM*T1 - B( 2, J ) = B( 2, J ) - SUM*T2 - B( 3, J ) = B( 3, J ) - SUM*T3 - B( 4, J ) = B( 4, J ) - SUM*T4 - B( 5, J ) = B( 5, J ) - SUM*T5 - B( 6, J ) = B( 6, J ) - SUM*T6 - B( 7, J ) = B( 7, J ) - SUM*T7 - 160 CONTINUE - GO TO 210 - 170 CONTINUE -C -C Special code for 9 x 9 Householder -C - V1 = V( 1 ) - T1 = TAU*V1 - V2 = V( 2 ) - T2 = TAU*V2 - V3 = V( 3 ) - T3 = TAU*V3 - V4 = V( 4 ) - T4 = TAU*V4 - V5 = V( 5 ) - T5 = TAU*V5 - V6 = V( 6 ) - T6 = TAU*V6 - V7 = V( 7 ) - T7 = TAU*V7 - V8 = V( 8 ) - T8 = TAU*V8 - DO 180 J = 1, N - SUM = A( 1, J ) + V1*B( 1, J ) + V2*B( 2, J ) + V3*B( 3, J ) + - $ V4*B( 4, J ) + V5*B( 5, J ) + V6*B( 6, J ) + - $ V7*B( 7, J ) + V8*B( 8, J ) - A( 1, J ) = A( 1, J ) - SUM*TAU - B( 1, J ) = B( 1, J ) - SUM*T1 - B( 2, J ) = B( 2, J ) - SUM*T2 - B( 3, J ) = B( 3, J ) - SUM*T3 - B( 4, J ) = B( 4, J ) - SUM*T4 - B( 5, J ) = B( 5, J ) - SUM*T5 - B( 6, J ) = B( 6, J ) - SUM*T6 - B( 7, J ) = B( 7, J ) - SUM*T7 - B( 8, J ) = B( 8, J ) - SUM*T8 - 180 CONTINUE - GO TO 210 - 190 CONTINUE -C -C Special code for 10 x 10 Householder -C - V1 = V( 1 ) - T1 = TAU*V1 - V2 = V( 2 ) - T2 = TAU*V2 - V3 = V( 3 ) - T3 = TAU*V3 - V4 = V( 4 ) - T4 = TAU*V4 - V5 = V( 5 ) - T5 = TAU*V5 - V6 = V( 6 ) - T6 = TAU*V6 - V7 = V( 7 ) - T7 = TAU*V7 - V8 = V( 8 ) - T8 = TAU*V8 - V9 = V( 9 ) - T9 = TAU*V9 - DO 200 J = 1, N - SUM = A( 1, J ) + V1*B( 1, J ) + V2*B( 2, J ) + V3*B( 3, J ) + - $ V4*B( 4, J ) + V5*B( 5, J ) + V6*B( 6, J ) + - $ V7*B( 7, J ) + V8*B( 8, J ) + V9*B( 9, J ) - A( 1, J ) = A( 1, J ) - SUM*TAU - B( 1, J ) = B( 1, J ) - SUM*T1 - B( 2, J ) = B( 2, J ) - SUM*T2 - B( 3, J ) = B( 3, J ) - SUM*T3 - B( 4, J ) = B( 4, J ) - SUM*T4 - B( 5, J ) = B( 5, J ) - SUM*T5 - B( 6, J ) = B( 6, J ) - SUM*T6 - B( 7, J ) = B( 7, J ) - SUM*T7 - B( 8, J ) = B( 8, J ) - SUM*T8 - B( 9, J ) = B( 9, J ) - SUM*T9 - 200 CONTINUE - 210 CONTINUE - RETURN -C *** Last line of MB04OY *** - END diff --git a/mex/sources/libslicot/MB04PA.f b/mex/sources/libslicot/MB04PA.f deleted file mode 100644 index 8ee27d01e..000000000 --- a/mex/sources/libslicot/MB04PA.f +++ /dev/null @@ -1,1105 +0,0 @@ - SUBROUTINE MB04PA( LHAM, N, K, NB, A, LDA, QG, LDQG, XA, LDXA, - $ XG, LDXG, XQ, LDXQ, YA, LDYA, CS, TAU, DWORK ) -C -C SLICOT RELEASE 5.0. -C -C Copyright (c) 2002-2009 NICONET e.V. -C -C This program is free software: you can redistribute it and/or -C modify it under the terms of the GNU General Public License as -C published by the Free Software Foundation, either version 2 of -C the License, or (at your option) any later version. -C -C This program is distributed in the hope that it will be useful, -C but WITHOUT ANY WARRANTY; without even the implied warranty of -C MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the -C GNU General Public License for more details. -C -C You should have received a copy of the GNU General Public License -C along with this program. If not, see -C . -C -C PURPOSE -C -C To reduce a Hamiltonian like matrix -C -C [ A G ] T T -C H = [ T ] , G = G , Q = Q, -C [ Q -A ] -C -C or a skew-Hamiltonian like matrix -C -C [ A G ] T T -C W = [ T ] , G = -G , Q = -Q, -C [ Q A ] -C -C so that elements below the (k+1)-th subdiagonal in the first nb -C columns of the (k+n)-by-n matrix A, and offdiagonal elements -C in the first nb columns and rows of the n-by-n matrix Q are zero. -C -C The reduction is performed by an orthogonal symplectic -C transformation UU'*H*UU and matrices U, XA, XG, XQ, and YA are -C returned so that -C -C [ Aout + U*XA'+ YA*U' Gout + U*XG'+ XG*U' ] -C UU'*H*UU = [ ]. -C [ Qout + U*XQ'+ XQ*U' -Aout'- XA*U'- U*YA' ] -C -C Similarly, -C -C [ Aout + U*XA'+ YA*U' Gout + U*XG'- XG*U' ] -C UU'*W*UU = [ ]. -C [ Qout + U*XQ'- XQ*U' Aout'+ XA*U'+ U*YA' ] -C -C This is an auxiliary routine called by MB04PB. -C -C ARGUMENTS -C -C Mode Parameters -C -C LHAM LOGICAL -C Specifies the type of matrix to be reduced: -C = .FALSE. : skew-Hamiltonian like W; -C = .TRUE. : Hamiltonian like H. -C -C Input/Output Parameters -C -C N (input) INTEGER -C The number of columns of the matrix A. N >= 0. -C -C K (input) INTEGER -C The offset of the reduction. Elements below the (K+1)-th -C subdiagonal in the first NB columns of A are reduced -C to zero. K >= 0. -C -C NB (input) INTEGER -C The number of columns/rows to be reduced. N > NB >= 0. -C -C A (input/output) DOUBLE PRECISION array, dimension (LDA,N) -C On entry, the leading (K+N)-by-N part of this array must -C contain the matrix A. -C On exit, the leading (K+N)-by-N part of this array -C contains the matrix Aout and in the zero part -C information about the elementary reflectors used to -C compute the reduction. -C -C LDA INTEGER -C The leading dimension of the array A. LDA >= MAX(1,K+N). -C -C QG (input/output) DOUBLE PRECISION array, dimension -C (LDQG,N+1) -C On entry, the leading N+K-by-N+1 part of this array must -C contain in the bottom left part the lower triangular part -C of the N-by-N matrix Q and in the remainder the upper -C trapezoidal part of the last N columns of the N+K-by-N+K -C matrix G. -C On exit, the leading N+K-by-N+1 part of this array -C contains parts of the matrices Q and G in the same fashion -C as on entry only that the zero parts of Q contain -C information about the elementary reflectors used to -C compute the reduction. Note that if LHAM = .FALSE. then -C the (K-1)-th and K-th subdiagonals are not referenced. -C -C LDQG INTEGER -C The leading dimension of the array QG. LDQG >= MAX(1,N+K). -C -C XA (output) DOUBLE PRECISION array, dimension (LDXA,2*NB) -C On exit, the leading N-by-(2*NB) part of this array -C contains the matrix XA. -C -C LDXA INTEGER -C The leading dimension of the array XA. LDXA >= MAX(1,N). -C -C XG (output) DOUBLE PRECISION array, dimension (LDXG,2*NB) -C On exit, the leading (K+N)-by-(2*NB) part of this array -C contains the matrix XG. -C -C LDXG INTEGER -C The leading dimension of the array XG. LDXG >= MAX(1,K+N). -C -C XQ (output) DOUBLE PRECISION array, dimension (LDXQ,2*NB) -C On exit, the leading N-by-(2*NB) part of this array -C contains the matrix XQ. -C -C LDXQ INTEGER -C The leading dimension of the array XQ. LDXQ >= MAX(1,N). -C -C YA (output) DOUBLE PRECISION array, dimension (LDYA,2*NB) -C On exit, the leading (K+N)-by-(2*NB) part of this array -C contains the matrix YA. -C -C LDYA INTEGER -C The leading dimension of the array YA. LDYA >= MAX(1,K+N). -C -C CS (output) DOUBLE PRECISION array, dimension (2*NB) -C On exit, the first 2*NB elements of this array contain the -C cosines and sines of the symplectic Givens rotations used -C to compute the reduction. -C -C TAU (output) DOUBLE PRECISION array, dimension (NB) -C On exit, the first NB elements of this array contain the -C scalar factors of some of the elementary reflectors. -C -C Workspace -C -C DWORK DOUBLE PRECISION array, dimension (3*NB) -C -C METHOD -C -C For details regarding the representation of the orthogonal -C symplectic matrix UU within the arrays A, QG, CS, TAU see the -C description of MB04PU. -C -C The contents of A and QG on exit are illustrated by the following -C example with n = 5, k = 2 and nb = 2: -C -C ( a r r a a ) ( g g r r g g ) -C ( a r r a a ) ( g g r r g g ) -C ( a r r a a ) ( q g r r g g ) -C A = ( r r r r r ), QG = ( t r r r r r ), -C ( u2 r r r r ) ( u1 t r r r r ) -C ( u2 u2 r a a ) ( u1 u1 r q g g ) -C ( u2 u2 r a a ) ( u1 u1 r q q g ) -C -C where a, g and q denote elements of the original matrices, r -C denotes a modified element, t denotes a scalar factor of an -C applied elementary reflector and ui denote elements of the -C matrix U. -C -C REFERENCES -C -C [1] C. F. VAN LOAN: -C A symplectic method for approximating all the eigenvalues of -C a Hamiltonian matrix. -C Linear Algebra and its Applications, 61, pp. 233-251, 1984. -C -C [2] D. KRESSNER: -C Block algorithms for orthogonal symplectic factorizations. -C BIT, 43 (4), pp. 775-790, 2003. -C -C CONTRIBUTORS -C -C D. Kressner (Technical Univ. Berlin, Germany) and -C P. Benner (Technical Univ. Chemnitz, Germany), December 2003. -C -C REVISIONS -C -C V. Sima, Nov. 2008 (SLICOT version of the HAPACK routine DLAPVL). -C -C KEYWORDS -C -C Elementary matrix operations, Hamiltonian matrix, -C skew-Hamiltonian matrix. -C -C ****************************************************************** -C -C .. Parameters .. - DOUBLE PRECISION ZERO, ONE, HALF - PARAMETER ( ZERO = 0.0D0, ONE = 1.0D0, HALF = 0.5D+0 ) -C .. Scalar Arguments .. - LOGICAL LHAM - INTEGER K, LDA, LDQG, LDXA, LDXG, LDXQ, LDYA, N, NB -C .. Array Arguments .. - DOUBLE PRECISION A(LDA,*), CS(*), DWORK(*), QG(LDQG,*), TAU(*), - $ XA(LDXA,*), XG(LDXG,*), XQ(LDXQ,*), YA(LDYA,*) -C .. Local Scalars .. - INTEGER I, J, NB1, NB2 - DOUBLE PRECISION AKI, ALPHA, C, S, TAUQ, TEMP, TTEMP -C .. External Functions .. - DOUBLE PRECISION DDOT - EXTERNAL DDOT -C .. External Subroutines .. - EXTERNAL DAXPY, DGEMV, DLARFG, DLARTG, DROT, DSCAL, - $ DSYMV, MB01MD -C .. Intrinsic Functions .. - INTRINSIC MIN -C -C .. Executable Statements .. -C -C Quick return if possible. -C - IF ( N+K.LE.0 ) THEN - DWORK(1) = ONE - RETURN - END IF -C - NB1 = NB + 1 - NB2 = NB + NB1 -C - IF ( LHAM ) THEN - DO 50 I = 1, NB -C -C Transform i-th columns of A and Q. See routine MB04PU. -C - ALPHA = QG(K+I+1,I) - CALL DLARFG( N-I, ALPHA, QG(K+MIN( I+2, N ),I), 1, TAUQ ) - QG(K+I+1,I) = ONE - TEMP = -TAUQ*DDOT( N-I, QG(K+I+1,I), 1, A(K+I+1,I), 1 ) - CALL DAXPY( N-I, TEMP, QG(K+I+1,I), 1, A(K+I+1,I), 1 ) - AKI = A(K+I+1,I) - CALL DLARTG( AKI, ALPHA, C, S, A(K+I+1,I) ) - AKI = A(K+I+1,I) - CALL DLARFG( N-I, AKI, A(K+MIN( I+2, N ),I), 1, TAU(I) ) - A(K+I+1,I) = ONE -C -C Update XA with first Householder reflection. -C -C xa = H(1:n,1:n)'*u1 - CALL DGEMV( 'Transpose', N-I, N-I, ONE, A(K+I+1,I+1), LDA, - $ QG(K+I+1,I), 1, ZERO, XA(I+1,I), 1 ) -C w1 = U1'*u1 - CALL DGEMV( 'Transpose', N-I, I-1, ONE, QG(K+I+1,1), LDQG, - $ QG(K+I+1,I), 1, ZERO, DWORK, 1 ) -C xa = xa + XA1*w1 - CALL DGEMV( 'No transpose', N-I, I-1, ONE, XA(I+1,1), LDXA, - $ DWORK, 1, ONE, XA(I+1,I), 1 ) -C w2 = U2'*u1 - CALL DGEMV( 'Transpose', N-I, I-1, ONE, A(K+I+1,1), LDA, - $ QG(K+I+1,I), 1, ZERO, DWORK(NB1), 1 ) -C xa = xa + XA2*w2 - CALL DGEMV( 'No transpose', N-I, I-1, ONE, XA(I+1,NB1), - $ LDXA, DWORK(NB1), 1, ONE, XA(I+1,I), 1 ) -C temp = YA1'*u1 - CALL DGEMV( 'Transpose', N-I, I-1, ONE, YA(K+I+1,1), LDYA, - $ QG(K+I+1,I), 1, ZERO, XA(1,I), 1 ) -C xa = xa + U1*temp - CALL DGEMV( 'No Transpose', N-I, I-1, ONE, QG(K+I+1,1), - $ LDQG, XA(1,I), 1, ONE, XA(I+1,I), 1 ) -C temp = YA2'*u1 - CALL DGEMV( 'Transpose', N-I, I-1, ONE, YA(K+I+1,NB1), LDYA, - $ QG(K+I+1,I), 1, ZERO, XA(1,I), 1 ) -C xa = xa + U2*temp - CALL DGEMV( 'No Transpose', N-I, I-1, ONE, A(K+I+1,1), LDA, - $ XA(1,I), 1, ONE, XA(I+1,I), 1 ) -C xa = -tauq*xa - CALL DSCAL( N-I, -TAUQ, XA(I+1,I), 1 ) -C -C Update YA with first Householder reflection. -C -C ya = H(1:n,1:n)*u1 - CALL DGEMV( 'No transpose', K+N, N-I, ONE, A(1,I+1), LDA, - $ QG(K+I+1,I), 1, ZERO, YA(1,I), 1 ) -C temp = XA1'*u1 - CALL DGEMV( 'Transpose', N-I, I-1, ONE, XA(I+1,1), LDXA, - $ QG(K+I+1,I), 1, ZERO, DWORK(NB2), 1 ) -C ya = ya + U1*temp - CALL DGEMV( 'No transpose', N-I, I-1, ONE, QG(K+I+1,1), - $ LDQG, DWORK(NB2), 1, ONE, YA(K+I+1,I), 1 ) -C temp = XA2'*u1 - CALL DGEMV( 'Transpose', N-I, I-1, ONE, XA(I+1,NB1), LDXA, - $ QG(K+I+1,I), 1, ZERO, DWORK(NB2), 1 ) -C ya = ya + U2*temp - CALL DGEMV( 'No transpose', N-I, I-1, ONE, A(K+I+1,1), LDA, - $ DWORK(NB2), 1, ONE, YA(K+I+1,I), 1 ) -C ya = ya + YA1*w1 - CALL DGEMV( 'No transpose', K+N, I-1, ONE, YA, LDYA, - $ DWORK, 1, ONE, YA(1,I), 1 ) -C ya = ya + YA2*w2 - CALL DGEMV( 'No transpose', K+N, I-1, ONE, YA(1,NB1), LDYA, - $ DWORK(NB1), 1, ONE, YA(1,I), 1 ) -C ya = -tauq*ya - CALL DSCAL( K+N, -TAUQ, YA(1,I), 1 ) -C temp = -tauq*ya'*u1 - TEMP = -TAUQ*DDOT( N-I, QG(K+I+1,I), 1, YA(K+I+1,I), 1 ) -C ya = ya + temp*u1 - CALL DAXPY( N-I, TEMP, QG(K+I+1,I), 1, YA(K+I+1,I), 1 ) -C -C Update (i+1)-th column of A. -C -C A(:,i+1) = A(:,i+1) + U1 * XA1(i+1,:)'; - CALL DGEMV( 'No transpose', N-I, I, ONE, QG(K+I+1,1), LDQG, - $ XA(I+1,1), LDXA, ONE, A(K+I+1,I+1), 1 ) -C A(:,i+1) = A(:,i+1) + U2 * XA2(i+1,:)'; - CALL DGEMV( 'No transpose', N-I, I-1, ONE, A(K+I+1,1), LDA, - $ XA(I+1,NB1), LDXA, ONE, A(K+I+1,I+1), 1 ) -C A(:,i+1) = A(:,i+1) + YA1 * U1(i+1,:)'; - CALL DGEMV( 'No transpose', N+K, I, ONE, YA, LDYA, - $ QG(K+I+1,1), LDQG, ONE, A(1,I+1), 1 ) -C A(:,i+1) = A(:,i+1) + YA2 * U2(i+1,:)'; - CALL DGEMV( 'No transpose', N+K, I-1, ONE, YA(1,NB1), LDYA, - $ A(K+I+1,1), LDA, ONE, A(1,I+1), 1 ) -C -C Update (i+1)-th row of A. -C - IF ( N.GT.I+1 ) THEN -C A(i+1,i+2:n) = A(i+1,i+2:n) + U1(i+1,:)*XA1(i+2:n,:)' - CALL DGEMV( 'No transpose', N-I-1, I, ONE, XA(I+2,1), - $ LDXA, QG(K+I+1,1), LDQG, ONE, A(K+I+1,I+2), - $ LDA ) -C A(i+1,i+2:n) = A(i+1,i+2:n) + U2(i+1,:)*XA2(i+2:n,:)' - CALL DGEMV( 'No transpose', N-I-1, I-1, ONE, XA(I+2,NB1), - $ LDXA, A(K+I+1,1), LDA, ONE, A(K+I+1,I+2), - $ LDA ) -C A(i+1,i+2:n) = A(i+1,i+2:n) + YA1(i+1,:) * U1(i+2:n,:)' - CALL DGEMV( 'No transpose', N-I-1, I, ONE, QG(K+I+2,1), - $ LDQG, YA(K+I+1,1), LDYA, ONE, A(K+I+1,I+2), - $ LDA ) -C A(i+1,i+2:n) = A(i+1,i+2:n) + YA2(i+1,:) * U2(i+2:n,:)' - CALL DGEMV( 'No transpose', N-I-1, I-1, ONE, A(K+I+2,1), - $ LDA, YA(K+I+1,NB1), LDYA, ONE, A(K+I+1,I+2), - $ LDA ) - END IF -C -C Annihilate updated parts in YA. -C - DO 10 J = 1, I - YA(K+I+1,J) = ZERO - 10 CONTINUE - DO 20 J = 1, I-1 - YA(K+I+1,NB+J) = ZERO - 20 CONTINUE -C -C Update XQ with first Householder reflection. -C -C xq = Q*u1 - CALL DSYMV( 'Lower', N-I, ONE, QG(K+I+1,I+1), LDQG, - $ QG(K+I+1,I), 1, ZERO, XQ(I+1,I), 1 ) -C xq = xq + XQ1*w1 - CALL DGEMV( 'No transpose', N-I, I-1, ONE, XQ(I+1,1), LDXQ, - $ DWORK, 1, ONE, XQ(I+1,I), 1 ) -C xq = xq + XQ2*w2 - CALL DGEMV( 'No transpose', N-I, I-1, ONE, XQ(I+1,NB1), - $ LDXQ, DWORK(NB1), 1, ONE, XQ(I+1,I), 1 ) -C temp = XQ1'*u1 - CALL DGEMV( 'Transpose', N-I, I-1, ONE, XQ(I+1,1), LDXQ, - $ QG(K+I+1,I), 1, ZERO, XQ(1,I), 1 ) -C xq = xq + U1*temp - CALL DGEMV( 'No Transpose', N-I, I-1, ONE, QG(K+I+1,1), - $ LDQG, XQ(1,I), 1, ONE, XQ(I+1,I), 1 ) -C temp = XQ2'*u1 - CALL DGEMV( 'Transpose', N-I, I-1, ONE, XQ(I+1,NB1), LDXQ, - $ QG(K+I+1,I), 1, ZERO, XQ(1,I), 1 ) -C xq = xq + U2*temp - CALL DGEMV( 'No Transpose', N-I, I-1, ONE, A(K+I+1,1), LDA, - $ XQ(1,I), 1, ONE, XQ(I+1,I), 1 ) -C xq = -tauq*xq - CALL DSCAL( N-I, -TAUQ, XQ(I+1,I), 1 ) -C temp = -tauq/2*xq'*u1 - TEMP = -HALF*TAUQ*DDOT( N-I, QG(K+I+1,I), 1, XQ(I+1,I), 1 ) -C xq = xq + temp*u1 - CALL DAXPY( N-I, TEMP, QG(K+I+1,I), 1, XQ(I+1,I), 1 ) -C -C Update (i+1)-th column and row of Q. -C -C Q(:,i+1) = Q(:,i+1) + U1 * XQ1(i+1,:)'; - CALL DGEMV( 'No transpose', N-I, I, ONE, QG(K+I+1,1), LDQG, - $ XQ(I+1,1), LDXQ, ONE, QG(K+I+1,I+1), 1 ) -C Q(:,i+1) = Q(:,i+1) + U2 * XQ2(i+1,:)'; - CALL DGEMV( 'No transpose', N-I, I-1, ONE, A(K+I+1,1), LDA, - $ XQ(I+1,NB1), LDXQ, ONE, QG(K+I+1,I+1), 1 ) -C Q(:,i+1) = Q(:,i+1) + XQ1 * U1(i+1,:)'; - CALL DGEMV( 'No transpose', N-I, I, ONE, XQ(I+1,1), LDXQ, - $ QG(K+I+1,1), LDQG, ONE, QG(K+I+1,I+1), 1 ) -C Q(:,i+1) = Q(:,i+1) + XQ2 * U2(i+1,:)'; - CALL DGEMV( 'No transpose', N-I, I-1, ONE, XQ(I+1,NB1), - $ LDXQ, A(K+I+1,1), LDA, ONE, QG(K+I+1,I+1), 1 ) -C -C Update XG with first Householder reflection. -C -C xg = G*u1 - CALL DGEMV( 'No transpose', K+I, N-I, ONE, QG(1,I+2), LDQG, - $ QG(K+I+1,I), 1, ZERO, XG(1,I), 1 ) - CALL DSYMV( 'Upper', N-I, ONE, QG(K+I+1,I+2), LDQG, - $ QG(K+I+1,I), 1, ZERO, XG(K+I+1,I), 1 ) -C xg = xg + XG1*w1 - CALL DGEMV( 'No transpose', K+N, I-1, ONE, XG, LDXG, - $ DWORK, 1, ONE, XG(1,I), 1 ) -C xg = xg + XG2*w2 - CALL DGEMV( 'No transpose', K+N, I-1, ONE, XG(1,NB1), - $ LDXG, DWORK(NB1), 1, ONE, XG(1,I), 1 ) -C temp = XG1'*u1 - CALL DGEMV( 'Transpose', N-I, I-1, ONE, XG(K+I+1,1), LDXQ, - $ QG(K+I+1,I), 1, ZERO, DWORK(NB2), 1 ) -C xg = xg + U1*temp - CALL DGEMV( 'No Transpose', N-I, I-1, ONE, QG(K+I+1,1), - $ LDQG, DWORK(NB2), 1, ONE, XG(K+I+1,I), 1 ) -C temp = XG2'*u1 - CALL DGEMV( 'Transpose', N-I, I-1, ONE, XG(K+I+1,NB1), - $ LDXQ, QG(K+I+1,I), 1, ZERO, DWORK(NB2), 1 ) -C xg = xg + U2*temp - CALL DGEMV( 'No Transpose', N-I, I-1, ONE, A(K+I+1,1), LDA, - $ DWORK(NB2), 1, ONE, XG(K+I+1,I), 1 ) -C xg = -tauq*xg - CALL DSCAL( N+K, -TAUQ, XG(1,I), 1 ) -C temp = -tauq/2*xq'*u1 - TEMP = -HALF*TAUQ*DDOT( N-I, QG(K+I+1,I), 1, XG(K+I+1,I), - $ 1 ) -C xg = xg + temp*u1 - CALL DAXPY( N-I, TEMP, QG(K+I+1,I), 1, XG(K+I+1,I), 1 ) -C -C Update (i+1)-th column and row of G. -C -C G(:,i+1) = G(:,i+1) + XG1 * U1(i+1,:)'; - CALL DGEMV( 'No transpose', K+I, I, ONE, XG, LDXG, - $ QG(K+I+1,1), LDQG, ONE, QG(1,I+2), 1 ) -C G(:,i+1) = G(:,i+1) + XG2 * U2(i+1,:)'; - CALL DGEMV( 'No transpose', K+I, I-1, ONE, XG(1,NB1), LDXG, - $ A(K+I+1,1), LDA, ONE, QG(1,I+2), 1 ) -C G(:,i+1) = G(:,i+1) + XG1 * U1(i+1,:)'; - CALL DGEMV( 'No transpose', N-I, I, ONE, XG(K+I+1,1), LDXG, - $ QG(K+I+1,1), LDQG, ONE, QG(K+I+1,I+2), LDQG ) -C G(:,i+1) = G(:,i+1) + XG2 * U2(i+1,:)'; - CALL DGEMV( 'No transpose', N-I, I-1, ONE, XG(K+I+1,NB1), - $ LDXG, A(K+I+1,1), LDA, ONE, QG(K+I+1,I+2), - $ LDQG ) -C G(:,i+1) = G(:,i+1) + U1 * XG1(i+1,:)'; - CALL DGEMV( 'No transpose', N-I, I, ONE, QG(K+I+1,1), LDQG, - $ XG(K+I+1,1), LDXG, ONE, QG(K+I+1,I+2), LDQG ) -C G(:,i+1) = G(:,i+1) + U2 * XG2(i+1,:)'; - CALL DGEMV( 'No transpose', N-I, I-1, ONE, A(K+I+1,1), LDA, - $ XG(K+I+1,NB1), LDXG, ONE, QG(K+I+1,I+2), LDQG ) -C -C Annihilate updated parts in XG. -C - DO 30 J = 1, I - XG(K+I+1,J) = ZERO - 30 CONTINUE - DO 40 J = 1, I-1 - XG(K+I+1,NB+J) = ZERO - 40 CONTINUE -C -C Apply orthogonal symplectic Givens rotation. -C - CALL DROT( K+I, A(1,I+1), 1, QG(1,I+2), 1, C, S ) - IF ( N.GT.I+1 ) THEN - CALL DROT( N-I-1, A(K+I+2,I+1), 1, QG(K+I+1,I+3), LDQG, - $ C, S ) - CALL DROT( N-I-1, A(K+I+1,I+2), LDA, QG(K+I+2,I+1), 1, C, - $ S ) - END IF - TEMP = A(K+I+1,I+1) - TTEMP = QG(K+I+1,I+2) - A(K+I+1,I+1) = C*TEMP + S*QG(K+I+1,I+1) - QG(K+I+1,I+2) = C*TTEMP - S*TEMP - QG(K+I+1,I+1) = -S*TEMP + C*QG(K+I+1,I+1) - TTEMP = -S*TTEMP - C*TEMP - TEMP = A(K+I+1,I+1) - QG(K+I+1,I+1) = C*QG(K+I+1,I+1) + S*TTEMP - A(K+I+1,I+1) = C*TEMP + S*QG(K+I+1,I+2) - QG(K+I+1,I+2) = -S*TEMP + C*QG(K+I+1,I+2) - CS(2*I-1) = C - CS(2*I) = S - QG(K+I+1,I) = TAUQ -C -C Update XA with second Householder reflection. -C -C xa = H(1:n,1:n)'*u2 - CALL DGEMV( 'Transpose', N-I, N-I, ONE, A(K+I+1,I+1), LDA, - $ A(K+I+1,I), 1, ZERO, XA(I+1,NB+I), 1 ) - IF ( N.GT.I+1 ) THEN -C w1 = U1'*u2 - CALL DGEMV( 'Transpose', N-I-1, I, ONE, QG(K+I+2,1), - $ LDQG, A(K+I+2,I), 1, ZERO, DWORK, 1 ) -C xa = xa + XA1*w1 - CALL DGEMV( 'No transpose', N-I-1, I, ONE, XA(I+2,1), - $ LDXA, DWORK, 1, ONE, XA(I+2,NB+I), 1 ) -C w2 = U2'*u2 - CALL DGEMV( 'Transpose', N-I-1, I-1, ONE, A(K+I+2,1), - $ LDA, A(K+I+2,I), 1, ZERO, DWORK(NB1), 1 ) -C xa = xa + XA2*w2 - CALL DGEMV( 'No transpose', N-I-1, I-1, ONE, XA(I+2,NB1), - $ LDXA, DWORK(NB1), 1, ONE, XA(I+2,NB+I), 1 ) -C temp = YA1'*u2 - CALL DGEMV( 'Transpose', N-I-1, I, ONE, YA(K+I+2,1), - $ LDYA, A(K+I+2,I), 1, ZERO, XA(1,NB+I), 1 ) -C xa = xa + U1*temp - CALL DGEMV( 'No Transpose', N-I-1, I, ONE, QG(K+I+2,1), - $ LDQG, XA(1,NB+I), 1, ONE, XA(I+2,NB+I), 1 ) -C temp = YA2'*u1 - CALL DGEMV( 'Transpose', N-I-1, I-1, ONE, YA(K+I+2,NB1), - $ LDYA, A(K+I+2,I), 1, ZERO, XA(1,NB+I), 1 ) -C xa = xa + U2*temp - CALL DGEMV( 'No Transpose', N-I-1, I-1, ONE, A(K+I+2,1), - $ LDA, XA(1,NB+I), 1, ONE, XA(I+2,NB+I), 1 ) - END IF -C xa = -tau*xa - CALL DSCAL( N-I, -TAU(I), XA(I+1,NB+I), 1 ) -C -C Update YA with second Householder reflection. -C -C ya = H(1:n,1:n)*u2 - CALL DGEMV( 'No transpose', K+N, N-I, ONE, A(1,I+1), LDA, - $ A(K+I+1,I), 1, ZERO, YA(1,NB+I), 1 ) - IF ( N.GT.I+1 ) THEN -C temp = XA1'*u2 - CALL DGEMV( 'Transpose', N-I-1, I, ONE, XA(I+2,1), LDXA, - $ A(K+I+2,I), 1, ZERO, DWORK(NB2), 1 ) -C ya = ya + U1*temp - CALL DGEMV( 'No transpose', N-I-1, I, ONE, QG(K+I+2,1), - $ LDQG, DWORK(NB2), 1, ONE, YA(K+I+2,NB+I), 1 ) -C temp = XA2'*u1 - CALL DGEMV( 'Transpose', N-I-1, I-1, ONE, XA(I+2,NB1), - $ LDXA, A(K+I+2,I), 1, ZERO, DWORK(NB2), 1 ) -C ya = ya + U2*temp - CALL DGEMV( 'No transpose', N-I-1, I-1, ONE, A(K+I+2,1), - $ LDA, DWORK(NB2), 1, ONE, YA(K+I+2,NB+I), 1 ) - END IF -C ya = ya + YA1*w1 - CALL DGEMV( 'No transpose', K+N, I, ONE, YA, LDYA, - $ DWORK, 1, ONE, YA(1,NB+I), 1 ) -C ya = ya + YA2*w2 - CALL DGEMV( 'No transpose', K+N, I-1, ONE, YA(1,NB1), LDYA, - $ DWORK(NB1), 1, ONE, YA(1,NB+I), 1 ) -C ya = -tau*ya - CALL DSCAL( K+N, -TAU(I), YA(1,NB+I), 1 ) -C temp = -tau*ya'*u2 - TEMP = -TAU(I)*DDOT( N-I, A(K+I+1,I), 1, YA(K+I+1,NB+I), 1 ) -C ya = ya + temp*u2 - CALL DAXPY( N-I, TEMP, A(K+I+1,I), 1, YA(K+I+1,NB+I), 1 ) -C -C Update (i+1)-th column of A. -C -C H(1:n,i+1) = H(1:n,i+1) + ya - CALL DAXPY( K+N, ONE, YA(1,NB+I), 1, A(1,I+1), 1 ) -C H(1:n,i+1) = H(1:n,i+1) + xa(i+1)*u2 - CALL DAXPY( N-I, XA(I+1,NB+I), A(K+I+1,I), 1, A(K+I+1,I+1), - $ 1 ) -C -C Update (i+1)-th row of A. -C - IF ( N.GT.I+1 ) THEN -C H(i+1,i+2:n) = H(i+1,i+2:n) + xa(i+2:n)'; - CALL DAXPY( N-I-1, ONE, XA(I+2,NB+I), 1, A(K+I+1,I+2), - $ LDA ) -C H(i+1,i+2:n) = H(i+1,i+2:n) + YA(i+1,:) * U(i+2:n,:)' - CALL DAXPY( N-I-1, YA(K+I+1,NB+I), A(K+I+2,I), 1, - $ A(K+I+1,I+2), LDA ) - END IF -C -C Annihilate updated parts in YA. -C - YA(K+I+1,NB+I) = ZERO -C -C Update XQ with second Householder reflection. -C -C xq = Q*u2 - CALL DSYMV( 'Lower', N-I, ONE, QG(K+I+1,I+1), LDQG, - $ A(K+I+1,I), 1, ZERO, XQ(I+1,NB+I), 1 ) - IF ( N.GT.I+1 ) THEN -C xq = xq + XQ1*w1 - CALL DGEMV( 'No transpose', N-I-1, I, ONE, XQ(I+2,1), - $ LDXQ, DWORK, 1, ONE, XQ(I+2,NB+I), 1 ) -C xq = xq + XQ2*w2 - CALL DGEMV( 'No transpose', N-I-1, I-1, ONE, XQ(I+2,NB1), - $ LDXQ, DWORK(NB1), 1, ONE, XQ(I+2,NB+I), 1 ) -C temp = XQ1'*u2 - CALL DGEMV( 'Transpose', N-I-1, I, ONE, XQ(I+2,1), LDXQ, - $ A(K+I+2,I), 1, ZERO, XQ(1,NB+I), 1 ) -C xq = xq + U1*temp - CALL DGEMV( 'No Transpose', N-I-1, I, ONE, QG(K+I+2,1), - $ LDQG, XQ(1,NB+I), 1, ONE, XQ(I+2,NB+I), 1 ) -C temp = XQ2'*u2 - CALL DGEMV( 'Transpose', N-I-1, I-1, ONE, XQ(I+2,NB1), - $ LDXQ, A(K+I+2,I), 1, ZERO, XQ(1,NB+I), 1 ) -C xq = xq + U2*temp - CALL DGEMV( 'No Transpose', N-I-1, I-1, ONE, A(K+I+2,1), - $ LDA, XQ(1,NB+I), 1, ONE, XQ(I+2,NB+I), 1 ) - END IF -C xq = -tauq*xq - CALL DSCAL( N-I, -TAU(I), XQ(I+1,NB+I), 1 ) -C temp = -tauq/2*xq'*u2 - TEMP = -HALF*TAU(I)*DDOT( N-I, A(K+I+1,I), 1, XQ(I+1,NB+I), - $ 1 ) -C xq = xq + temp*u2 - CALL DAXPY( N-I, TEMP, A(K+I+1,I), 1, XQ(I+1,NB+I), 1 ) -C -C Update (i+1)-th column and row of Q. -C - CALL DAXPY( N-I, ONE, XQ(I+1,NB+I), 1, QG(K+I+1,I+1), 1 ) -C H(1:n,n+i+1) = H(1:n,n+i+1) + U * XQ(i+1,:)'; - CALL DAXPY( N-I, XQ(I+1,NB+I), A(K+I+1,I), 1, - $ QG(K+I+1,I+1), 1 ) -C -C Update XG with second Householder reflection. -C -C xg = G*u2 - CALL DGEMV( 'No transpose', K+I, N-I, ONE, QG(1,I+2), LDQG, - $ A(K+I+1,I), 1, ZERO, XG(1,NB+I), 1 ) - CALL DSYMV( 'Upper', N-I, ONE, QG(K+I+1,I+2), LDQG, - $ A(K+I+1,I), 1, ZERO, XG(K+I+1,NB+I), 1 ) -C xg = xg + XG1*w1 - CALL DGEMV( 'No transpose', K+N, I, ONE, XG, LDXG, - $ DWORK, 1, ONE, XG(1,NB+I), 1 ) -C xg = xg + XG2*w2 - CALL DGEMV( 'No transpose', K+N, I-1, ONE, XG(1,NB1), - $ LDXG, DWORK(NB1), 1, ONE, XG(1,NB+I), 1 ) - IF ( N.GT.I+1 ) THEN -C temp = XG1'*u2 - CALL DGEMV( 'Transpose', N-I-1, I, ONE, XG(K+I+2,1), - $ LDXQ, A(K+I+2,I), 1, ZERO, DWORK(NB2), 1 ) -C xg = xg + U1*temp - CALL DGEMV( 'No Transpose', N-I-1, I, ONE, QG(K+I+2,1), - $ LDQG, DWORK(NB2), 1, ONE, XG(K+I+2,NB+I), 1 ) -C temp = XG2'*u2 - CALL DGEMV( 'Transpose', N-I-1, I-1, ONE, XG(K+I+2,NB1), - $ LDXQ, A(K+I+2,I), 1, ZERO, DWORK(NB2), 1 ) -C xg = xg + U2*temp - CALL DGEMV( 'No Transpose', N-I-1, I-1, ONE, A(K+I+2,1), - $ LDA, DWORK(NB2), 1, ONE, XG(K+I+2,NB+I), 1 ) - END IF -C xg = -tauq*xg - CALL DSCAL( N+K, -TAU(I), XG(1,NB+I), 1 ) -C temp = -tauq/2*xg'*u1 - TEMP = -HALF*TAU(I)*DDOT( N-I, A(K+I+1,I), 1, - $ XG(K+I+1,NB+I), 1 ) -C xg = xg + temp*u1 - CALL DAXPY( N-I, TEMP, A(K+I+1,I), 1, XG(K+I+1,NB+I), 1 ) -C -C Update (i+1)-th column and row of G. -C - CALL DAXPY( K+I, ONE, XG(1,NB+I), 1, QG(1,I+2), 1 ) - CALL DAXPY( N-I, ONE, XG(K+I+1,NB+I), 1, QG(K+I+1,I+2), - $ LDQG ) - CALL DAXPY( N-I, XG(K+I+1,NB+I), A(K+I+1,I), 1, - $ QG(K+I+1,I+2), LDQG ) -C -C Annihilate updated parts in XG. -C - XG(K+I+1,NB+I) = ZERO -C - A(K+I+1,I) = AKI - 50 CONTINUE - ELSE - DO 100 I = 1, NB -C -C Transform i-th columns of A and Q. -C - ALPHA = QG(K+I+1,I) - CALL DLARFG( N-I, ALPHA, QG(K+MIN( I+2, N ),I), 1, TAUQ ) - QG(K+I+1,I) = ONE - TEMP = -TAUQ*DDOT( N-I, QG(K+I+1,I), 1, A(K+I+1,I), 1 ) - CALL DAXPY( N-I, TEMP, QG(K+I+1,I), 1, A(K+I+1,I), 1 ) - AKI = A(K+I+1,I) - CALL DLARTG( AKI, ALPHA, C, S, A(K+I+1,I) ) - AKI = A(K+I+1,I) - CALL DLARFG( N-I, AKI, A(K+MIN( I+2, N ),I), 1, TAU(I) ) - A(K+I+1,I) = ONE -C -C Update XA with first Householder reflection. -C -C xa = H(1:n,1:n)'*u1 - CALL DGEMV( 'Transpose', N-I, N-I, ONE, A(K+I+1,I+1), LDA, - $ QG(K+I+1,I), 1, ZERO, XA(I+1,I), 1 ) -C w1 = U1'*u1 - CALL DGEMV( 'Transpose', N-I, I-1, ONE, QG(K+I+1,1), LDQG, - $ QG(K+I+1,I), 1, ZERO, DWORK, 1 ) -C xa = xa + XA1*w1 - CALL DGEMV( 'No transpose', N-I, I-1, ONE, XA(I+1,1), LDXA, - $ DWORK, 1, ONE, XA(I+1,I), 1 ) -C w2 = U2'*u1 - CALL DGEMV( 'Transpose', N-I, I-1, ONE, A(K+I+1,1), LDA, - $ QG(K+I+1,I), 1, ZERO, DWORK(NB1), 1 ) -C xa = xa + XA2*w2 - CALL DGEMV( 'No transpose', N-I, I-1, ONE, XA(I+1,NB1), - $ LDXA, DWORK(NB1), 1, ONE, XA(I+1,I), 1 ) -C temp = YA1'*u1 - CALL DGEMV( 'Transpose', N-I, I-1, ONE, YA(K+I+1,1), LDYA, - $ QG(K+I+1,I), 1, ZERO, XA(1,I), 1 ) -C xa = xa + U1*temp - CALL DGEMV( 'No Transpose', N-I, I-1, ONE, QG(K+I+1,1), - $ LDQG, XA(1,I), 1, ONE, XA(I+1,I), 1 ) -C temp = YA2'*u1 - CALL DGEMV( 'Transpose', N-I, I-1, ONE, YA(K+I+1,NB1), LDYA, - $ QG(K+I+1,I), 1, ZERO, XA(1,I), 1 ) -C xa = xa + U2*temp - CALL DGEMV( 'No Transpose', N-I, I-1, ONE, A(K+I+1,1), LDA, - $ XA(1,I), 1, ONE, XA(I+1,I), 1 ) -C xa = -tauq*xa - CALL DSCAL( N-I, -TAUQ, XA(I+1,I), 1 ) -C -C Update YA with first Householder reflection. -C -C ya = H(1:n,1:n)*u1 - CALL DGEMV( 'No transpose', K+N, N-I, ONE, A(1,I+1), LDA, - $ QG(K+I+1,I), 1, ZERO, YA(1,I), 1 ) -C temp = XA1'*u1 - CALL DGEMV( 'Transpose', N-I, I-1, ONE, XA(I+1,1), LDXA, - $ QG(K+I+1,I), 1, ZERO, DWORK(NB2), 1 ) -C ya = ya + U1*temp - CALL DGEMV( 'No transpose', N-I, I-1, ONE, QG(K+I+1,1), - $ LDQG, DWORK(NB2), 1, ONE, YA(K+I+1,I), 1 ) -C temp = XA2'*u1 - CALL DGEMV( 'Transpose', N-I, I-1, ONE, XA(I+1,NB1), LDXA, - $ QG(K+I+1,I), 1, ZERO, DWORK(NB2), 1 ) -C ya = ya + U2*temp - CALL DGEMV( 'No transpose', N-I, I-1, ONE, A(K+I+1,1), LDA, - $ DWORK(NB2), 1, ONE, YA(K+I+1,I), 1 ) -C ya = ya + YA1*w1 - CALL DGEMV( 'No transpose', K+N, I-1, ONE, YA, LDYA, - $ DWORK, 1, ONE, YA(1,I), 1 ) -C ya = ya + YA2*w2 - CALL DGEMV( 'No transpose', K+N, I-1, ONE, YA(1,NB1), LDYA, - $ DWORK(NB1), 1, ONE, YA(1,I), 1 ) -C ya = -tauq*ya - CALL DSCAL( K+N, -TAUQ, YA(1,I), 1 ) -C temp = -tauq*ya'*u1 - TEMP = -TAUQ*DDOT( N-I, QG(K+I+1,I), 1, YA(K+I+1,I), 1 ) -C ya = ya + temp*u1 - CALL DAXPY( N-I, TEMP, QG(K+I+1,I), 1, YA(K+I+1,I), 1 ) -C -C Update (i+1)-th column of A. -C -C A(:,i+1) = A(:,i+1) + U1 * XA1(i+1,:)'; - CALL DGEMV( 'No transpose', N-I, I, ONE, QG(K+I+1,1), LDQG, - $ XA(I+1,1), LDXA, ONE, A(K+I+1,I+1), 1 ) -C A(:,i+1) = A(:,i+1) + U2 * XA2(i+1,:)'; - CALL DGEMV( 'No transpose', N-I, I-1, ONE, A(K+I+1,1), LDA, - $ XA(I+1,NB1), LDXA, ONE, A(K+I+1,I+1), 1 ) -C A(:,i+1) = A(:,i+1) + YA1 * U1(i+1,:)'; - CALL DGEMV( 'No transpose', N+K, I, ONE, YA, LDYA, - $ QG(K+I+1,1), LDQG, ONE, A(1,I+1), 1 ) -C A(:,i+1) = A(:,i+1) + YA2 * U2(i+1,:)'; - CALL DGEMV( 'No transpose', N+K, I-1, ONE, YA(1,NB1), LDYA, - $ A(K+I+1,1), LDA, ONE, A(1,I+1), 1 ) -C -C Update (i+1)-th row of A. -C - IF ( N.GT.I+1 ) THEN -C A(i+1,i+2:n) = A(i+1,i+2:n) + U1(i+1,:)*XA1(i+2:n,:)' - CALL DGEMV( 'No transpose', N-I-1, I, ONE, XA(I+2,1), - $ LDXA, QG(K+I+1,1), LDQG, ONE, A(K+I+1,I+2), - $ LDA ) -C A(i+1,i+2:n) = A(i+1,i+2:n) + U2(i+1,:)*XA2(i+2:n,:)' - CALL DGEMV( 'No transpose', N-I-1, I-1, ONE, XA(I+2,NB1), - $ LDXA, A(K+I+1,1), LDA, ONE, A(K+I+1,I+2), - $ LDA ) -C A(i+1,i+2:n) = A(i+1,i+2:n) + YA1(i+1,:) * U1(i+2:n,:)' - CALL DGEMV( 'No transpose', N-I-1, I, ONE, QG(K+I+2,1), - $ LDQG, YA(K+I+1,1), LDYA, ONE, A(K+I+1,I+2), - $ LDA ) -C A(i+1,i+2:n) = A(i+1,i+2:n) + YA2(i+1,:) * U2(i+2:n,:)' - CALL DGEMV( 'No transpose', N-I-1, I-1, ONE, A(K+I+2,1), - $ LDA, YA(K+I+1,NB1), LDYA, ONE, A(K+I+1,I+2), - $ LDA ) - END IF -C -C Annihilate updated parts in YA. -C - DO 60 J = 1, I - YA(K+I+1,J) = ZERO - 60 CONTINUE - DO 70 J = 1, I-1 - YA(K+I+1,NB+J) = ZERO - 70 CONTINUE -C -C Update XQ with first Householder reflection. -C -C xq = Q*u1 - CALL MB01MD( 'Lower', N-I, ONE, QG(K+I+1,I+1), LDQG, - $ QG(K+I+1,I), 1, ZERO, XQ(I+1,I), 1 ) -C xq = xq + XQ1*w1 - CALL DGEMV( 'No transpose', N-I, I-1, ONE, XQ(I+1,1), LDXQ, - $ DWORK, 1, ONE, XQ(I+1,I), 1 ) -C xq = xq + XQ2*w2 - CALL DGEMV( 'No transpose', N-I, I-1, ONE, XQ(I+1,NB1), - $ LDXQ, DWORK(NB1), 1, ONE, XQ(I+1,I), 1 ) -C temp = XQ1'*u1 - CALL DGEMV( 'Transpose', N-I, I-1, ONE, XQ(I+1,1), LDXQ, - $ QG(K+I+1,I), 1, ZERO, XQ(1,I), 1 ) -C xq = xq - U1*temp - CALL DGEMV( 'No Transpose', N-I, I-1, -ONE, QG(K+I+1,1), - $ LDQG, XQ(1,I), 1, ONE, XQ(I+1,I), 1 ) -C temp = XQ2'*u1 - CALL DGEMV( 'Transpose', N-I, I-1, ONE, XQ(I+1,NB1), LDXQ, - $ QG(K+I+1,I), 1, ZERO, XQ(1,I), 1 ) -C xq = xq - U2*temp - CALL DGEMV( 'No Transpose', N-I, I-1, -ONE, A(K+I+1,1), LDA, - $ XQ(1,I), 1, ONE, XQ(I+1,I), 1 ) -C xq = -tauq*xq - CALL DSCAL( N-I, -TAUQ, XQ(I+1,I), 1 ) -C temp = -tauq/2*xq'*u1 - TEMP = -HALF*TAUQ*DDOT( N-I, QG(K+I+1,I), 1, XQ(I+1,I), 1 ) -C xq = xq + temp*u1 - CALL DAXPY( N-I, TEMP, QG(K+I+1,I), 1, XQ(I+1,I), 1 ) -C -C Update (i+1)-th column and row of Q. -C - IF ( N.GT.I+1 ) THEN -C Q(:,i+1) = Q(:,i+1) - U1 * XQ1(i+1,:)'; - CALL DGEMV( 'No transpose', N-I-1, I, -ONE, QG(K+I+2,1), - $ LDQG, XQ(I+1,1), LDXQ, ONE, QG(K+I+2,I+1), - $ 1 ) -C Q(:,i+1) = Q(:,i+1) - U2 * XQ2(i+1,:)'; - CALL DGEMV( 'No transpose', N-I-1, I-1, -ONE, A(K+I+2,1), - $ LDA, XQ(I+1,NB1), LDXQ, ONE, QG(K+I+2,I+1), - $ 1 ) -C Q(:,i+1) = Q(:,i+1) + XQ1 * U1(i+1,:)'; - CALL DGEMV( 'No transpose', N-I-1, I, ONE, XQ(I+2,1), - $ LDXQ, QG(K+I+1,1), LDQG, ONE, QG(K+I+2,I+1), - $ 1 ) -C Q(:,i+1) = Q(:,i+1) + XQ2 * U2(i+1,:)'; - CALL DGEMV( 'No transpose', N-I-1, I-1, ONE, XQ(I+2,NB1), - $ LDXQ, A(K+I+1,1), LDA, ONE, QG(K+I+2,I+1), - $ 1 ) - END IF -C -C Update XG with first Householder reflection. -C -C xg = G*u1 - CALL DGEMV( 'No transpose', K+I, N-I, ONE, QG(1,I+2), LDQG, - $ QG(K+I+1,I), 1, ZERO, XG(1,I), 1 ) - CALL MB01MD( 'Upper', N-I, ONE, QG(K+I+1,I+2), LDQG, - $ QG(K+I+1,I), 1, ZERO, XG(K+I+1,I), 1 ) -C xg = xg + XG1*w1 - CALL DGEMV( 'No transpose', K+N, I-1, ONE, XG, LDXG, - $ DWORK, 1, ONE, XG(1,I), 1 ) -C xg = xg + XG2*w2 - CALL DGEMV( 'No transpose', K+N, I-1, ONE, XG(1,NB1), - $ LDXG, DWORK(NB1), 1, ONE, XG(1,I), 1 ) -C temp = XG1'*u1 - CALL DGEMV( 'Transpose', N-I, I-1, ONE, XG(K+I+1,1), LDXQ, - $ QG(K+I+1,I), 1, ZERO, DWORK(NB2), 1 ) -C xg = xg - U1*temp - CALL DGEMV( 'No Transpose', N-I, I-1, -ONE, QG(K+I+1,1), - $ LDQG, DWORK(NB2), 1, ONE, XG(K+I+1,I), 1 ) -C temp = XG2'*u1 - CALL DGEMV( 'Transpose', N-I, I-1, ONE, XG(K+I+1,NB1), - $ LDXQ, QG(K+I+1,I), 1, ZERO, DWORK(NB2), 1 ) -C xg = xg - U2*temp - CALL DGEMV( 'No Transpose', N-I, I-1, -ONE, A(K+I+1,1), LDA, - $ DWORK(NB2), 1, ONE, XG(K+I+1,I), 1 ) -C xg = -tauq*xg - CALL DSCAL( N+K, -TAUQ, XG(1,I), 1 ) -C temp = -tauq/2*xq'*u1 - TEMP = -HALF*TAUQ*DDOT( N-I, QG(K+I+1,I), 1, XG(K+I+1,I), - $ 1 ) -C xg = xg + temp*u1 - CALL DAXPY( N-I, TEMP, QG(K+I+1,I), 1, XG(K+I+1,I), 1 ) -C -C Update (i+1)-th column and row of G. -C -C G(:,i+1) = G(:,i+1) + XG1 * U1(i+1,:)'; - CALL DGEMV( 'No transpose', K+I, I, ONE, XG, LDXG, - $ QG(K+I+1,1), LDQG, ONE, QG(1,I+2), 1 ) -C G(:,i+1) = G(:,i+1) + XG2 * U2(i+1,:)'; - CALL DGEMV( 'No transpose', K+I, I-1, ONE, XG(1,NB1), LDXG, - $ A(K+I+1,1), LDA, ONE, QG(1,I+2), 1 ) - IF ( N.GT.I+1 ) THEN -C G(:,i+1) = G(:,i+1) + XG1 * U1(i+1,:)'; - CALL DGEMV( 'No transpose', N-I-1, I, -ONE, XG(K+I+2,1), - $ LDXG, QG(K+I+1,1), LDQG, ONE, QG(K+I+1,I+3), - $ LDQG ) -C G(:,i+1) = G(:,i+1) + XG2 * U2(i+1,:)'; - CALL DGEMV( 'No transpose', N-I-1, I-1, -ONE, - $ XG(K+I+2,NB1), LDXG, A(K+I+1,1), LDA, ONE, - $ QG(K+I+1,I+3), LDQG ) -C G(:,i+1) = G(:,i+1) + U1 * XG1(i+1,:)'; - CALL DGEMV( 'No transpose', N-I-1, I, ONE, QG(K+I+2,1), - $ LDQG, XG(K+I+1,1), LDXG, ONE, QG(K+I+1,I+3), - $ LDQG ) -C G(:,i+1) = G(:,i+1) + U2 * XG2(i+1,:)'; - CALL DGEMV( 'No transpose', N-I-1, I-1, ONE, A(K+I+2,1), - $ LDA, XG(K+I+1,NB1), LDXG, ONE, QG(K+I+1,I+3), - $ LDQG ) - END IF -C -C Annihilate updated parts in XG. -C - DO 80 J = 1, I - XG(K+I+1,J) = ZERO - 80 CONTINUE - DO 90 J = 1, I-1 - XG(K+I+1,NB+J) = ZERO - 90 CONTINUE -C -C Apply orthogonal symplectic Givens rotation. -C - CALL DROT( K+I, A(1,I+1), 1, QG(1,I+2), 1, C, S ) - IF ( N.GT.I+1 ) THEN - CALL DROT( N-I-1, A(K+I+2,I+1), 1, QG(K+I+1,I+3), LDQG, - $ C, -S ) - CALL DROT( N-I-1, A(K+I+1,I+2), LDA, QG(K+I+2,I+1), 1, - $ C, -S ) - END IF - CS(2*I-1) = C - CS(2*I) = S - QG(K+I+1,I) = TAUQ -C -C Update XA with second Householder reflection. -C -C xa = H(1:n,1:n)'*u2 - CALL DGEMV( 'Transpose', N-I, N-I, ONE, A(K+I+1,I+1), LDA, - $ A(K+I+1,I), 1, ZERO, XA(I+1,NB+I), 1 ) - IF ( N.GT.I+1 ) THEN -C w1 = U1'*u2 - CALL DGEMV( 'Transpose', N-I-1, I, ONE, QG(K+I+2,1), - $ LDQG, A(K+I+2,I), 1, ZERO, DWORK, 1 ) -C xa = xa + XA1*w1 - CALL DGEMV( 'No transpose', N-I-1, I, ONE, XA(I+2,1), - $ LDXA, DWORK, 1, ONE, XA(I+2,NB+I), 1 ) -C w2 = U2'*u2 - CALL DGEMV( 'Transpose', N-I-1, I-1, ONE, A(K+I+2,1), - $ LDA, A(K+I+2,I), 1, ZERO, DWORK(NB1), 1 ) -C xa = xa + XA2*w2 - CALL DGEMV( 'No transpose', N-I-1, I-1, ONE, XA(I+2,NB1), - $ LDXA, DWORK(NB1), 1, ONE, XA(I+2,NB+I), 1 ) -C temp = YA1'*u2 - CALL DGEMV( 'Transpose', N-I-1, I, ONE, YA(K+I+2,1), - $ LDYA, A(K+I+2,I), 1, ZERO, XA(1,NB+I), 1 ) -C xa = xa + U1*temp - CALL DGEMV( 'No Transpose', N-I-1, I, ONE, QG(K+I+2,1), - $ LDQG, XA(1,NB+I), 1, ONE, XA(I+2,NB+I), 1 ) -C temp = YA2'*u1 - CALL DGEMV( 'Transpose', N-I-1, I-1, ONE, YA(K+I+2,NB1), - $ LDYA, A(K+I+2,I), 1, ZERO, XA(1,NB+I), 1 ) -C xa = xa + U2*temp - CALL DGEMV( 'No Transpose', N-I-1, I-1, ONE, A(K+I+2,1), - $ LDA, XA(1,NB+I), 1, ONE, XA(I+2,NB+I), 1 ) - END IF -C xa = -tau*xa - CALL DSCAL( N-I, -TAU(I), XA(I+1,NB+I), 1 ) -C -C Update YA with second Householder reflection. -C -C ya = H(1:n,1:n)*u2 - CALL DGEMV( 'No transpose', K+N, N-I, ONE, A(1,I+1), LDA, - $ A(K+I+1,I), 1, ZERO, YA(1,NB+I), 1 ) - IF ( N.GT.I+1 ) THEN -C temp = XA1'*u2 - CALL DGEMV( 'Transpose', N-I-1, I, ONE, XA(I+2,1), LDXA, - $ A(K+I+2,I), 1, ZERO, DWORK(NB2), 1 ) -C ya = ya + U1*temp - CALL DGEMV( 'No transpose', N-I-1, I, ONE, QG(K+I+2,1), - $ LDQG, DWORK(NB2), 1, ONE, YA(K+I+2,NB+I), 1 ) -C temp = XA2'*u1 - CALL DGEMV( 'Transpose', N-I-1, I-1, ONE, XA(I+2,NB1), - $ LDXA, A(K+I+2,I), 1, ZERO, DWORK(NB2), 1 ) -C ya = ya + U2*temp - CALL DGEMV( 'No transpose', N-I-1, I-1, ONE, A(K+I+2,1), - $ LDA, DWORK(NB2), 1, ONE, YA(K+I+2,NB+I), 1 ) - END IF -C ya = ya + YA1*w1 - CALL DGEMV( 'No transpose', K+N, I, ONE, YA, LDYA, - $ DWORK, 1, ONE, YA(1,NB+I), 1 ) -C ya = ya + YA2*w2 - CALL DGEMV( 'No transpose', K+N, I-1, ONE, YA(1,NB1), LDYA, - $ DWORK(NB1), 1, ONE, YA(1,NB+I), 1 ) -C ya = -tau*ya - CALL DSCAL( K+N, -TAU(I), YA(1,NB+I), 1 ) -C temp = -tau*ya'*u2 - TEMP = -TAU(I)*DDOT( N-I, A(K+I+1,I), 1, YA(K+I+1,NB+I), 1 ) -C ya = ya + temp*u2 - CALL DAXPY( N-I, TEMP, A(K+I+1,I), 1, YA(K+I+1,NB+I), 1 ) -C -C Update (i+1)-th column of A. -C -C H(1:n,i+1) = H(1:n,i+1) + ya - CALL DAXPY( K+N, ONE, YA(1,NB+I), 1, A(1,I+1), 1 ) -C H(1:n,i+1) = H(1:n,i+1) + xa(i+1)*u2 - CALL DAXPY( N-I, XA(I+1,NB+I), A(K+I+1,I), 1, A(K+I+1,I+1), - $ 1 ) -C -C Update (i+1)-th row of A. -C - IF ( N.GT.I+1 ) THEN -C H(i+1,i+2:n) = H(i+1,i+2:n) + xa(i+2:n)'; - CALL DAXPY( N-I-1, ONE, XA(I+2,NB+I), 1, A(K+I+1,I+2), - $ LDA ) -C H(i+1,i+2:n) = H(i+1,i+2:n) + YA(i+1,:) * U(i+2:n,:)' - CALL DAXPY( N-I-1, YA(K+I+1,NB+I), A(K+I+2,I), 1, - $ A(K+I+1,I+2), LDA ) - END IF -C -C Annihilate updated parts in YA. -C - YA(K+I+1,NB+I) = ZERO -C -C Update XQ with second Householder reflection. -C -C xq = Q*u2 - CALL MB01MD( 'Lower', N-I, ONE, QG(K+I+1,I+1), LDQG, - $ A(K+I+1,I), 1, ZERO, XQ(I+1,NB+I), 1 ) - IF ( N.GT.I+1 ) THEN -C xq = xq + XQ1*w1 - CALL DGEMV( 'No transpose', N-I-1, I, ONE, XQ(I+2,1), - $ LDXQ, DWORK, 1, ONE, XQ(I+2,NB+I), 1 ) -C xq = xq + XQ2*w2 - CALL DGEMV( 'No transpose', N-I-1, I-1, ONE, XQ(I+2,NB1), - $ LDXQ, DWORK(NB1), 1, ONE, XQ(I+2,NB+I), 1 ) -C temp = XQ1'*u2 - CALL DGEMV( 'Transpose', N-I-1, I, ONE, XQ(I+2,1), LDXQ, - $ A(K+I+2,I), 1, ZERO, XQ(1,NB+I), 1 ) -C xq = xq - U1*temp - CALL DGEMV( 'No Transpose', N-I-1, I, -ONE, QG(K+I+2,1), - $ LDQG, XQ(1,NB+I), 1, ONE, XQ(I+2,NB+I), 1 ) -C temp = XQ2'*u2 - CALL DGEMV( 'Transpose', N-I-1, I-1, ONE, XQ(I+2,NB1), - $ LDXQ, A(K+I+2,I), 1, ZERO, XQ(1,NB+I), 1 ) -C xq = xq - U2*temp - CALL DGEMV( 'No Transpose', N-I-1, I-1, -ONE, A(K+I+2,1), - $ LDA, XQ(1,NB+I), 1, ONE, XQ(I+2,NB+I), 1 ) - END IF -C xq = -tauq*xq - CALL DSCAL( N-I, -TAU(I), XQ(I+1,NB+I), 1 ) -C temp = -tauq/2*xq'*u2 - TEMP = -HALF*TAU(I)*DDOT( N-I, A(K+I+1,I), 1, XQ(I+1,NB+I), - $ 1 ) -C xq = xq + temp*u2 - CALL DAXPY( N-I, TEMP, A(K+I+1,I), 1, XQ(I+1,NB+I), 1 ) -C -C Update (i+1)-th column and row of Q. -C - IF ( N.GT.I+1 ) THEN - CALL DAXPY( N-I-1, ONE, XQ(I+2,NB+I), 1, QG(K+I+2,I+1), - $ 1 ) -C H(1:n,n+i+1) = H(1:n,n+i+1) - U * XQ(i+1,:)'; - CALL DAXPY( N-I-1, -XQ(I+1,NB+I), A(K+I+2,I), 1, - $ QG(K+I+2,I+1), 1 ) - END IF -C -C Update XG with second Householder reflection. -C -C xg = G*u2 - CALL DGEMV( 'No transpose', K+I, N-I, ONE, QG(1,I+2), LDQG, - $ A(K+I+1,I), 1, ZERO, XG(1,NB+I), 1 ) - CALL MB01MD( 'Upper', N-I, ONE, QG(K+I+1,I+2), LDQG, - $ A(K+I+1,I), 1, ZERO, XG(K+I+1,NB+I), 1 ) -C xg = xg + XG1*w1 - CALL DGEMV( 'No transpose', K+N, I, ONE, XG, LDXG, - $ DWORK, 1, ONE, XG(1,NB+I), 1 ) -C xg = xg + XG2*w2 - CALL DGEMV( 'No transpose', K+N, I-1, ONE, XG(1,NB1), - $ LDXG, DWORK(NB1), 1, ONE, XG(1,NB+I), 1 ) - IF ( N.GT.I+1 ) THEN -C temp = XG1'*u2 - CALL DGEMV( 'Transpose', N-I-1, I, ONE, XG(K+I+2,1), - $ LDXQ, A(K+I+2,I), 1, ZERO, DWORK(NB2), 1 ) -C xg = xg - U1*temp - CALL DGEMV( 'No Transpose', N-I-1, I, -ONE, QG(K+I+2,1), - $ LDQG, DWORK(NB2), 1, ONE, XG(K+I+2,NB+I), 1 ) -C temp = XG2'*u2 - CALL DGEMV( 'Transpose', N-I-1, I-1, ONE, XG(K+I+2,NB1), - $ LDXQ, A(K+I+2,I), 1, ZERO, DWORK(NB2), 1 ) -C xg = xg - U2*temp - CALL DGEMV( 'No Transpose', N-I-1, I-1, -ONE, A(K+I+2,1), - $ LDA, DWORK(NB2), 1, ONE, XG(K+I+2,NB+I), 1 ) - END IF -C xg = -tauq*xg - CALL DSCAL( N+K, -TAU(I), XG(1,NB+I), 1 ) -C temp = -tauq/2*xg'*u1 - TEMP = -HALF*TAU(I)*DDOT( N-I, A(K+I+1,I), 1, - $ XG(K+I+1,NB+I), 1 ) -C xg = xg + temp*u1 - CALL DAXPY( N-I, TEMP, A(K+I+1,I), 1, XG(K+I+1,NB+I), 1 ) -C -C Update (i+1)-th column and row of G. -C - CALL DAXPY( K+I, ONE, XG(1,NB+I), 1, QG(1,I+2), 1 ) - IF ( N.GT.I+1 ) THEN - CALL DAXPY( N-I-1, -ONE, XG(K+I+2,NB+I), 1, - $ QG(K+I+1,I+3), LDQG ) - CALL DAXPY( N-I-1, XG(K+I+1,NB+I), A(K+I+2,I), 1, - $ QG(K+I+1,I+3), LDQG ) - END IF -C -C Annihilate updated parts in XG. -C - XG(K+I+1,NB+I) = ZERO -C - A(K+I+1,I) = AKI - 100 CONTINUE - END IF -C - RETURN -C *** Last line of MB04PA *** - END diff --git a/mex/sources/libslicot/MB04PB.f b/mex/sources/libslicot/MB04PB.f deleted file mode 100644 index 3948eee1e..000000000 --- a/mex/sources/libslicot/MB04PB.f +++ /dev/null @@ -1,333 +0,0 @@ - SUBROUTINE MB04PB( N, ILO, A, LDA, QG, LDQG, CS, TAU, DWORK, - $ LDWORK, INFO ) -C -C SLICOT RELEASE 5.0. -C -C Copyright (c) 2002-2009 NICONET e.V. -C -C This program is free software: you can redistribute it and/or -C modify it under the terms of the GNU General Public License as -C published by the Free Software Foundation, either version 2 of -C the License, or (at your option) any later version. -C -C This program is distributed in the hope that it will be useful, -C but WITHOUT ANY WARRANTY; without even the implied warranty of -C MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the -C GNU General Public License for more details. -C -C You should have received a copy of the GNU General Public License -C along with this program. If not, see -C . -C -C PURPOSE -C -C To reduce a Hamiltonian matrix, -C -C [ A G ] -C H = [ T ] , -C [ Q -A ] -C -C where A is an N-by-N matrix and G,Q are N-by-N symmetric matrices, -C to Paige/Van Loan (PVL) form. That is, an orthogonal symplectic U -C is computed so that -C -C T [ Aout Gout ] -C U H U = [ T ] , -C [ Qout -Aout ] -C -C where Aout is upper Hessenberg and Qout is diagonal. -C Blocked version. -C -C ARGUMENTS -C -C Input/Output Parameters -C -C N (input) INTEGER -C The order of the matrix A. N >= 0. -C -C ILO (input) INTEGER -C It is assumed that A is already upper triangular and Q is -C zero in rows and columns 1:ILO-1. ILO is normally set by a -C previous call to MB04DD; otherwise it should be set to 1. -C 1 <= ILO <= N, if N > 0; ILO = 1, if N = 0. -C -C A (input/output) DOUBLE PRECISION array, dimension (LDA,N) -C On entry, the leading N-by-N part of this array must -C contain the matrix A. -C On exit, the leading N-by-N part of this array contains -C the matrix Aout and, in the zero part of Aout, -C information about the elementary reflectors used to -C compute the PVL factorization. -C -C LDA INTEGER -C The leading dimension of the array A. LDA >= MAX(1,N). -C -C QG (input/output) DOUBLE PRECISION array, dimension -C (LDQG,N+1) -C On entry, the leading N-by-N+1 part of this array must -C contain the lower triangular part of the matrix Q and -C the upper triangular part of the matrix G. -C On exit, the leading N-by-N+1 part of this array contains -C the diagonal of the matrix Qout, the upper triangular part -C of the matrix Gout and, in the zero parts of Qout, -C information about the elementary reflectors used to -C compute the PVL factorization. -C -C LDQG INTEGER -C The leading dimension of the array QG. LDQG >= MAX(1,N). -C -C CS (output) DOUBLE PRECISION array, dimension (2N-2) -C On exit, the first 2N-2 elements of this array contain the -C cosines and sines of the symplectic Givens rotations used -C to compute the PVL factorization. -C -C TAU (output) DOUBLE PRECISION array, dimension (N-1) -C On exit, the first N-1 elements of this array contain the -C scalar factors of some of the elementary reflectors. -C -C Workspace -C -C DWORK DOUBLE PRECISION array, dimension (LDWORK) -C On exit, if INFO = 0, DWORK(1) returns the optimal -C value of LDWORK, 8*N*NB + 3*NB, where NB is the optimal -C block size determined by the function UE01MD. -C On exit, if INFO = -10, DWORK(1) returns the minimum -C value of LDWORK. -C -C LDWORK INTEGER -C The length of the array DWORK. LDWORK >= MAX(1,N-1). -C -C Error Indicator -C -C INFO INTEGER -C = 0: successful exit; -C < 0: if INFO = -i, the i-th argument had an illegal -C value. -C -C METHOD -C -C The matrix U is represented as a product of symplectic reflectors -C and Givens rotators -C -C U = diag( H(1),H(1) ) G(1) diag( F(1),F(1) ) -C diag( H(2),H(2) ) G(2) diag( F(2),F(2) ) -C .... -C diag( H(n-1),H(n-1) ) G(n-1) diag( F(n-1),F(n-1) ). -C -C Each H(i) has the form -C -C H(i) = I - tau * v * v' -C -C where tau is a real scalar, and v is a real vector with -C v(1:i) = 0 and v(i+1) = 1; v(i+2:n) is stored on exit in -C QG(i+2:n,i), and tau in QG(i+1,i). -C -C Each F(i) has the form -C -C F(i) = I - nu * w * w' -C -C where nu is a real scalar, and w is a real vector with -C w(1:i) = 0 and w(i+1) = 1; w(i+2:n) is stored on exit in -C A(i+2:n,i), and nu in TAU(i). -C -C Each G(i) is a Givens rotator acting on rows i+1 and n+i+1, -C where the cosine is stored in CS(2*i-1) and the sine in -C CS(2*i). -C -C NUMERICAL ASPECTS -C -C The algorithm requires O(N**3) floating point operations and is -C strongly backward stable. -C -C REFERENCES -C -C [1] C. F. VAN LOAN: -C A symplectic method for approximating all the eigenvalues of -C a Hamiltonian matrix. -C Linear Algebra and its Applications, 61, pp. 233-251, 1984. -C -C [2] D. KRESSNER: -C Block algorithms for orthogonal symplectic factorizations. -C BIT, 43 (4), pp. 775-790, 2003. -C -C CONTRIBUTORS -C -C D. Kressner (Technical Univ. Berlin, Germany) and -C P. Benner (Technical Univ. Chemnitz, Germany), December 2003. -C -C REVISIONS -C -C V. Sima, Nov. 2008 (SLICOT version of the HAPACK routine DHAPVB). -C -C KEYWORDS -C -C Elementary matrix operations, Hamiltonian matrix. -C -C ****************************************************************** -C -C .. Parameters .. - DOUBLE PRECISION ZERO, ONE - PARAMETER ( ZERO = 0.0D0, ONE = 1.0D0 ) -C .. Scalar Arguments .. - INTEGER ILO, INFO, LDA, LDQG, LDWORK, N -C .. Array Arguments .. - DOUBLE PRECISION A(LDA,*), CS(*), DWORK(*), QG(LDQG,*), TAU(*) -C .. Local Scalars .. - INTEGER I, IB, IERR, NB, NBMIN, NH, NIB, NNB, NX, PDW, - $ PXA, PXG, PXQ, PYA, WRKOPT -C .. External Functions .. - INTEGER UE01MD - EXTERNAL UE01MD -C .. External Subroutines .. - EXTERNAL DGEMM, DSYR2K, MB04PA, MB04PU, XERBLA -C .. Intrinsic Functions .. - INTRINSIC DBLE, MAX, MIN -C -C .. Executable Statements .. -C -C Check the scalar input parameters. -C - INFO = 0 - IF ( N.LT.0 ) THEN - INFO = -1 - ELSE IF ( ILO.LT.1 .OR. ILO.GT.MAX( 1, N ) ) THEN - INFO = -2 - ELSE IF ( LDA.LT.MAX( 1, N ) ) THEN - INFO = -4 - ELSE IF ( LDQG.LT.MAX( 1, N ) ) THEN - INFO = -6 - ELSE IF ( LDWORK.LT.MAX( 1, N-1 ) ) THEN - DWORK(1) = DBLE( MAX( 1, N-1 ) ) - INFO = -10 - END IF -C -C Return if there were illegal values. -C - IF ( INFO.NE.0 ) THEN - CALL XERBLA( 'MB04PB', -INFO ) - RETURN - END IF -C -C Set elements 1:ILO-1 of TAU and CS. -C - DO 10 I = 1, ILO - 1 - TAU( I ) = ZERO - CS(2*I-1) = ONE - CS(2*I) = ZERO - 10 CONTINUE -C -C Quick return if possible. -C - IF ( N.LE.ILO ) THEN - DWORK(1) = ONE - RETURN - END IF -C -C Determine the block size. -C - NH = N - ILO + 1 - NB = UE01MD( 1, 'MB04PB', ' ', N, ILO, -1 ) - NBMIN = 2 - WRKOPT = N-1 - IF ( NB.GT.1 .AND. NB.LT.NH ) THEN -C -C Determine when to cross over from blocked to unblocked code. -C - NX = MAX( NB, UE01MD( 3, 'MB04PB', ' ', N, ILO, -1 ) ) - IF ( NX.LT.NH ) THEN -C -C Check whether workspace is large enough for blocked code. -C - WRKOPT = 8*N*NB + 3*NB - IF ( LDWORK.LT.WRKOPT ) THEN -C -C Not enough workspace available. Determine minimum value -C of NB, and reduce NB. -C - NBMIN = MAX( 2, UE01MD( 2, 'MB04PB', ' ', N, ILO, -1 ) ) - NB = LDWORK / ( 8*N + 3 ) - END IF - END IF - END IF -C - NNB = N*NB - PXA = 1 - PYA = PXA + 2*NNB - PXQ = PYA + 2*NNB - PXG = PXQ + 2*NNB - PDW = PXG + 2*NNB -C - IF ( NB.LT.NBMIN .OR. NB.GE.NH ) THEN -C -C Use unblocked code. -C - I = ILO -C - ELSE - DO 20 I = ILO, N-NX-1, NB - IB = MIN( NB, N-I ) - NIB = N*IB -C -C Reduce rows and columns i:i+nb-1 to PVL form and return the -C matrices XA, XG, XQ, and YA which are needed to update the -C unreduced parts of the matrices. -C - CALL MB04PA( .TRUE., N-I+1, I-1, IB, A(1,I), LDA, QG(1,I), - $ LDQG, DWORK(PXA), N, DWORK(PXG), N, - $ DWORK(PXQ), N, DWORK(PYA), N, CS(2*I-1), - $ TAU(I), DWORK(PDW) ) - IF ( N.GT.I+IB ) THEN -C -C Update the submatrix A(1:n,i+ib+1:n). -C - CALL DGEMM( 'No transpose', 'Transpose', N-I-IB, N-I-IB, - $ IB, ONE, QG(I+IB+1,I), LDQG, DWORK(PXA+IB+1), - $ N, ONE, A(I+IB+1,I+IB+1), LDA ) - CALL DGEMM( 'No transpose', 'Transpose', N-I-IB, N-I-IB, - $ IB, ONE, A(I+IB+1,I), LDA, - $ DWORK(PXA+NIB+IB+1), N, ONE, - $ A(I+IB+1,I+IB+1), LDA ) - CALL DGEMM( 'No transpose', 'Transpose', N, N-I-IB, IB, - $ ONE, DWORK(PYA), N, QG(I+IB+1,I), LDQG, ONE, - $ A(1,I+IB+1), LDA ) - CALL DGEMM( 'No transpose', 'Transpose', N, N-I-IB, IB, - $ ONE, DWORK(PYA+NIB), N, A(I+IB+1,I), LDA, - $ ONE, A(1,I+IB+1), LDA ) -C -C Update the submatrix Q(i+ib+1:n,i+ib+1:n). -C - CALL DSYR2K( 'Lower', 'No Transpose', N-I-IB, IB, ONE, - $ DWORK(PXQ+IB+1), N, QG(I+IB+1,I), LDQG, ONE, - $ QG(I+IB+1,I+IB+1), LDQG ) - CALL DSYR2K( 'Lower', 'No Transpose', N-I-IB, IB, ONE, - $ DWORK(PXQ+NIB+IB+1), N, A(I+IB+1,I), LDA, - $ ONE, QG(I+IB+1,I+IB+1), LDQG ) -C -C Update the submatrix G(1:n,1:n). -C - CALL DGEMM( 'No transpose', 'Transpose', I+IB, N-I-IB, - $ IB, ONE, DWORK(PXG), N, QG(I+IB+1,I), LDQG, - $ ONE, QG(1,I+IB+2), LDQG ) - CALL DGEMM( 'No transpose', 'Transpose', I+IB, N-I-IB, - $ IB, ONE, DWORK(PXG+NIB), N, A(I+IB+1,I), LDA, - $ ONE, QG(1,I+IB+2), LDQG ) - CALL DSYR2K( 'Upper', 'No Transpose', N-I-IB, IB, ONE, - $ DWORK(PXG+IB+I), N, QG(I+IB+1,I), LDQG, ONE, - $ QG(I+IB+1,I+IB+2), LDQG ) - CALL DSYR2K( 'Upper', 'No Transpose', N-I-IB, IB, ONE, - $ DWORK(PXG+NIB+IB+I), N, A(I+IB+1,I), LDA, - $ ONE, QG(I+IB+1,I+IB+2), LDQG ) - END IF - 20 CONTINUE - END IF -C -C Unblocked code to reduce the rest of the matrices. -C - CALL MB04PU( N, I, A, LDA, QG, LDQG, CS, TAU, DWORK, LDWORK, - $ IERR ) -C - DWORK( 1 ) = DBLE( WRKOPT ) -C - RETURN -C *** Last line of MB04PB *** - END diff --git a/mex/sources/libslicot/MB04PU.f b/mex/sources/libslicot/MB04PU.f deleted file mode 100644 index 2c13e6636..000000000 --- a/mex/sources/libslicot/MB04PU.f +++ /dev/null @@ -1,369 +0,0 @@ - SUBROUTINE MB04PU( N, ILO, A, LDA, QG, LDQG, CS, TAU, DWORK, - $ LDWORK, INFO ) -C -C SLICOT RELEASE 5.0. -C -C Copyright (c) 2002-2009 NICONET e.V. -C -C This program is free software: you can redistribute it and/or -C modify it under the terms of the GNU General Public License as -C published by the Free Software Foundation, either version 2 of -C the License, or (at your option) any later version. -C -C This program is distributed in the hope that it will be useful, -C but WITHOUT ANY WARRANTY; without even the implied warranty of -C MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the -C GNU General Public License for more details. -C -C You should have received a copy of the GNU General Public License -C along with this program. If not, see -C . -C -C PURPOSE -C -C To reduce a Hamiltonian matrix, -C -C [ A G ] -C H = [ T ] , -C [ Q -A ] -C -C where A is an N-by-N matrix and G,Q are N-by-N symmetric matrices, -C to Paige/Van Loan (PVL) form. That is, an orthogonal symplectic U -C is computed so that -C -C T [ Aout Gout ] -C U H U = [ T ] , -C [ Qout -Aout ] -C -C where Aout is upper Hessenberg and Qout is diagonal. -C Unblocked version. -C -C ARGUMENTS -C -C Input/Output Parameters -C -C N (input) INTEGER -C The order of the matrix A. N >= 0. -C -C ILO (input) INTEGER -C It is assumed that A is already upper triangular and Q is -C zero in rows and columns 1:ILO-1. ILO is normally set by a -C previous call to MB04DD; otherwise it should be set to 1. -C 1 <= ILO <= N, if N > 0; ILO = 1, if N = 0. -C -C A (input/output) DOUBLE PRECISION array, dimension (LDA,N) -C On entry, the leading N-by-N part of this array must -C contain the matrix A. -C On exit, the leading N-by-N part of this array contains -C the matrix Aout and, in the zero part of Aout, -C information about the elementary reflectors used to -C compute the PVL factorization. -C -C LDA INTEGER -C The leading dimension of the array A. LDA >= MAX(1,N). -C -C QG (input/output) DOUBLE PRECISION array, dimension -C (LDQG,N+1) -C On entry, the leading N-by-N+1 part of this array must -C contain the lower triangular part of the matrix Q and -C the upper triangular part of the matrix G. -C On exit, the leading N-by-N+1 part of this array contains -C the diagonal of the matrix Qout, the upper triangular part -C of the matrix Gout and, in the zero parts of Qout, -C information about the elementary reflectors used to -C compute the PVL factorization. -C -C LDQG INTEGER -C The leading dimension of the array QG. LDQG >= MAX(1,N). -C -C CS (output) DOUBLE PRECISION array, dimension (2N-2) -C On exit, the first 2N-2 elements of this array contain the -C cosines and sines of the symplectic Givens rotations used -C to compute the PVL factorization. -C -C TAU (output) DOUBLE PRECISION array, dimension (N-1) -C On exit, the first N-1 elements of this array contain the -C scalar factors of some of the elementary reflectors. -C -C Workspace -C -C DWORK DOUBLE PRECISION array, dimension (LDWORK) -C On exit, if INFO = 0, DWORK(1) returns the optimal -C value of LDWORK. -C On exit, if INFO = -10, DWORK(1) returns the minimum -C value of LDWORK. -C -C LDWORK INTEGER -C The length of the array DWORK. LDWORK >= MAX(1,N-1). -C -C Error Indicator -C -C INFO INTEGER -C = 0: successful exit; -C < 0: if INFO = -i, the i-th argument had an illegal -C value. -C -C METHOD -C -C The matrix U is represented as a product of symplectic reflectors -C and Givens rotators -C -C U = diag( H(1),H(1) ) G(1) diag( F(1),F(1) ) -C diag( H(2),H(2) ) G(2) diag( F(2),F(2) ) -C .... -C diag( H(n-1),H(n-1) ) G(n-1) diag( F(n-1),F(n-1) ). -C -C Each H(i) has the form -C -C H(i) = I - tau * v * v' -C -C where tau is a real scalar, and v is a real vector with -C v(1:i) = 0 and v(i+1) = 1; v(i+2:n) is stored on exit in -C QG(i+2:n,i), and tau in QG(i+1,i). -C -C Each F(i) has the form -C -C F(i) = I - nu * w * w' -C -C where nu is a real scalar, and w is a real vector with -C w(1:i) = 0 and w(i+1) = 1; w(i+2:n) is stored on exit in -C A(i+2:n,i), and nu in TAU(i). -C -C Each G(i) is a Givens rotator acting on rows i+1 and n+i+1, -C where the cosine is stored in CS(2*i-1) and the sine in -C CS(2*i). -C -C NUMERICAL ASPECTS -C -C The algorithm requires 40/3 N**3 + O(N) floating point operations -C and is strongly backward stable. -C -C REFERENCES -C -C [1] C. F. VAN LOAN: -C A symplectic method for approximating all the eigenvalues of -C a Hamiltonian matrix. -C Linear Algebra and its Applications, 61, pp. 233-251, 1984. -C -C CONTRIBUTORS -C -C D. Kressner (Technical Univ. Berlin, Germany) and -C P. Benner (Technical Univ. Chemnitz, Germany), December 2003. -C -C REVISIONS -C -C V. Sima, Nov. 2008 (SLICOT version of the HAPACK routine DHAPVL). -C -C KEYWORDS -C -C Elementary matrix operations, Hamiltonian matrix. -C -C ****************************************************************** -C -C .. Parameters .. - DOUBLE PRECISION ZERO, HALF, ONE - PARAMETER ( ZERO = 0.0D0, HALF = 0.5D0, ONE = 1.0D0 ) -C .. Scalar Arguments .. - INTEGER ILO, INFO, LDA, LDQG, LDWORK, N -C .. Array Arguments .. - DOUBLE PRECISION A(LDA,*), CS(*), DWORK(*), QG(LDQG,*), TAU(*) -C .. Local Scalars .. - INTEGER I - DOUBLE PRECISION ALPHA, C, MU, NU, S, TEMP, TTEMP -C .. External Functions .. - DOUBLE PRECISION DDOT - EXTERNAL DDOT -C .. External Subroutines .. - EXTERNAL DAXPY, DLARF, DLARFG, DLARTG, DROT, DSYMV, - $ DSYR2, XERBLA -C .. Intrinsic Functions .. - INTRINSIC DBLE, MAX, MIN -C -C .. Executable Statements .. -C -C Check the scalar input parameters. -C - INFO = 0 - IF ( N.LT.0 ) THEN - INFO = -1 - ELSE IF ( ILO.LT.1 .OR. ILO.GT.MAX( 1, N ) ) THEN - INFO = -2 - ELSE IF ( LDA.LT.MAX( 1, N ) ) THEN - INFO = -4 - ELSE IF ( LDQG.LT.MAX( 1, N ) ) THEN - INFO = -6 - ELSE IF ( LDWORK.LT.MAX( 1, N-1 ) ) THEN - DWORK(1) = DBLE( MAX( 1, N-1 ) ) - INFO = -10 - END IF -C -C Return if there were illegal values. -C - IF ( INFO.NE.0 ) THEN - CALL XERBLA( 'MB04PU', -INFO ) - RETURN - END IF -C -C Quick return if possible. -C - IF ( N.LE.ILO ) THEN - DWORK(1) = ONE - RETURN - END IF -C - DO 10 I = ILO, N-1 -C -C Generate elementary reflector H(i) to annihilate QG(i+2:n,i). -C - ALPHA = QG(I+1,I) - CALL DLARFG( N-I, ALPHA, QG(MIN( I+2,N ),I), 1, NU ) - IF ( NU.NE.ZERO ) THEN - QG(I+1,I) = ONE -C -C Apply H(i) from both sides to QG(i+1:n,i+1:n). -C Compute x := nu * QG(i+1:n,i+1:n) * v. -C - CALL DSYMV( 'Lower', N-I, NU, QG(I+1,I+1), LDQG, QG(I+1,I), - $ 1, ZERO, DWORK, 1 ) -C -C Compute w := x - 1/2 * nu * (x'*v) * v. -C - MU = -HALF*NU*DDOT( N-I, DWORK, 1, QG(I+1,I), 1 ) - CALL DAXPY( N-I, MU, QG(I+1,I), 1, DWORK, 1 ) -C -C Apply the transformation as a rank-2 update: -C QG := QG - v * w' - w * v'. -C - CALL DSYR2( 'Lower', N-I, -ONE, QG(I+1,I), 1, DWORK, 1, - $ QG(I+1,I+1), LDQG ) -C -C Apply H(i) from the right hand side to QG(1:i,i+2:n+1). -C - CALL DLARF( 'Right', I, N-I, QG(I+1,I), 1, NU, QG(1,I+2), - $ LDQG, DWORK ) -C -C Apply H(i) from both sides to QG(i+1:n,i+2:n+1). -C Compute x := nu * QG(i+1:n,i+2:n+1) * v. -C - CALL DSYMV( 'Upper', N-I, NU, QG(I+1,I+2), LDQG, QG(I+1,I), - $ 1, ZERO, DWORK, 1 ) -C -C Compute w := x - 1/2 * nu * (x'*v) * v. -C - MU = -HALF*NU*DDOT( N-I, DWORK, 1, QG(I+1,I), 1 ) - CALL DAXPY( N-I, MU, QG(I+1,I), 1, DWORK, 1 ) -C -C Apply the transformation as a rank-2 update: -C QG(i+1:n,i+2:n+1) := QG(i+1:n,i+2:n+1) - v * w' - w * v'. -C - CALL DSYR2( 'Upper', N-I, -ONE, QG(I+1,I), 1, DWORK, 1, - $ QG(I+1,I+2), LDQG ) -C -C Apply H(i) from the left hand side to A(i+1:n,i:n). -C - CALL DLARF( 'Left', N-I, N-I+1, QG(I+1,I), 1, NU, - $ A(I+1,I), LDA, DWORK ) -C -C Apply H(i) from the right hand side to A(1:n,i+1:n). -C - CALL DLARF( 'Right', N, N-I, QG(I+1,I), 1, NU, - $ A(1,I+1), LDA, DWORK ) - END IF - QG(I+1,I) = NU -C -C Generate symplectic Givens rotation G(i) to annihilate -C QG(i+1,i). -C - TEMP = A(I+1,I) - CALL DLARTG( TEMP, ALPHA, C, S, A(I+1,I) ) -C -C Apply G(i) to [A(I+1,I+2:N); QG(I+2:N,I+1)']. -C - CALL DROT( N-I-1, A(I+1,I+2), LDA, QG(I+2,I+1), 1, C, S ) -C -C Apply G(i) to [A(1:I,I+1) QG(1:I,I+2)]. -C - CALL DROT(I, A(1,I+1), 1, QG(1,I+2), 1, C, S ) -C -C Apply G(i) to [A(I+2:N,I+1) QG(I+1, I+3:N+1)'] from the right. -C - CALL DROT(N-I-1, A(I+2,I+1), 1, QG(I+1,I+3), LDQG, C, S ) -C -C Fix the diagonal part. -C - TEMP = A(I+1,I+1) - TTEMP = QG(I+1,I+2) - A(I+1,I+1) = C*TEMP + S*QG(I+1,I+1) - QG(I+1,I+2) = C*TTEMP - S * TEMP - QG(I+1,I+1) = -S*TEMP + C*QG(I+1,I+1) - TTEMP = -S*TTEMP - C*TEMP - TEMP = A(I+1,I+1) - QG(I+1,I+1) = C*QG(I+1,I+1) + S*TTEMP - A(I+1,I+1) = C*TEMP + S*QG(I+1,I+2) - QG(I+1,I+2) = -S*TEMP + C*QG(I+1,I+2) - CS(2*I-1) = C - CS(2*I) = S -C -C Generate elementary reflector F(i) to annihilate A(i+2:n,i). -C - CALL DLARFG( N-I, A(I+1,I), A(MIN( I+2,N ),I), 1, NU ) - IF ( NU.NE.ZERO ) THEN - TEMP = A(I+1,I) - A(I+1,I) = ONE -C -C Apply F(i) from the left hand side to A(i+1:n,i+1:n). -C - CALL DLARF( 'Left', N-I, N-I, A(I+1,I), 1, NU, A(I+1,I+1), - $ LDA, DWORK ) -C -C Apply G(i) from the right hand side to A(1:n,i+1:n). -C - CALL DLARF( 'Right', N, N-I, A(I+1,I), 1, NU, - $ A(1,I+1), LDA, DWORK ) -C -C Apply G(i) from both sides to QG(i+1:n,i+1:n). -C Compute x := nu * QG(i+1:n,i+1:n) * v. -C - CALL DSYMV( 'Lower', N-I, NU, QG(I+1,I+1), LDQG, A(I+1,I), - $ 1, ZERO, DWORK, 1 ) -C -C Compute w := x - 1/2 * tau * (x'*v) * v. -C - MU = -HALF*NU*DDOT( N-I, DWORK, 1, A(I+1,I), 1 ) - CALL DAXPY( N-I, MU, A(I+1,I), 1, DWORK, 1 ) -C -C Apply the transformation as a rank-2 update: -C QG := QG - v * w' - w * v'. -C - CALL DSYR2( 'Lower', N-I, -ONE, A(I+1,I), 1, DWORK, 1, - $ QG(I+1,I+1), LDQG ) -C -C Apply G(i) from the right hand side to QG(1:i,i+2:n+1). -C - CALL DLARF( 'Right', I, N-I, A(I+1,I), 1, NU, QG(1,I+2), - $ LDQG, DWORK ) -C -C Apply G(i) from both sides to QG(i+1:n,i+2:n+1). -C Compute x := nu * QG(i+1:n,i+2:n+1) * v. -C - CALL DSYMV( 'Upper', N-I, NU, QG(I+1,I+2), LDQG, A(I+1,I), - $ 1, ZERO, DWORK, 1 ) -C -C Compute w := x - 1/2 * tau * (x'*v) * v. -C - MU = -HALF*NU*DDOT( N-I, DWORK, 1, A(I+1,I), 1 ) - CALL DAXPY( N-I, MU, A(I+1,I), 1, DWORK, 1 ) -C -C Apply the transformation as a rank-2 update: -C QG(i+1:n,i+2:n+1) := QG(i+1:n,i+2:n+1) - v * w' - w * v'. -C - CALL DSYR2( 'Upper', N-I, -ONE, A(I+1,I), 1, DWORK, 1, - $ QG(I+1,I+2), LDQG ) - A(I+1,I) = TEMP - END IF - TAU(I) = NU - 10 CONTINUE - DWORK(1) = DBLE( MAX( 1, N-1 ) ) - RETURN -C *** Last line of MB04PU *** - END diff --git a/mex/sources/libslicot/MB04PY.f b/mex/sources/libslicot/MB04PY.f deleted file mode 100644 index 09b5a17d7..000000000 --- a/mex/sources/libslicot/MB04PY.f +++ /dev/null @@ -1,648 +0,0 @@ - SUBROUTINE MB04PY( SIDE, M, N, V, TAU, C, LDC, DWORK ) -C -C SLICOT RELEASE 5.0. -C -C Copyright (c) 2002-2009 NICONET e.V. -C -C This program is free software: you can redistribute it and/or -C modify it under the terms of the GNU General Public License as -C published by the Free Software Foundation, either version 2 of -C the License, or (at your option) any later version. -C -C This program is distributed in the hope that it will be useful, -C but WITHOUT ANY WARRANTY; without even the implied warranty of -C MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the -C GNU General Public License for more details. -C -C You should have received a copy of the GNU General Public License -C along with this program. If not, see -C . -C -C PURPOSE -C -C To apply a real elementary reflector H to a real m-by-n matrix -C C, from either the left or the right. H is represented in the form -C ( 1 ) -C H = I - tau * u *u', u = ( ), -C ( v ) -C where tau is a real scalar and v is a real vector. -C -C If tau = 0, then H is taken to be the unit matrix. -C -C In-line code is used if H has order < 11. -C -C ARGUMENTS -C -C Mode Parameters -C -C SIDE CHARACTER*1 -C Indicates whether the elementary reflector should be -C applied from the left or from the right, as follows: -C = 'L': Compute H * C; -C = 'R': Compute C * H. -C -C Input/Output Parameters -C -C M (input) INTEGER -C The number of rows of the matrix C. M >= 0. -C -C N (input) INTEGER -C The number of columns of the matrix C. N >= 0. -C -C V (input) DOUBLE PRECISION array, dimension -C (M-1), if SIDE = 'L', or -C (N-1), if SIDE = 'R'. -C The vector v in the representation of H. -C -C TAU (input) DOUBLE PRECISION -C The scalar factor of the elementary reflector H. -C -C C (input/output) DOUBLE PRECISION array, dimension (LDC,N) -C On entry, the leading M-by-N part of this array must -C contain the matrix C. -C On exit, the leading M-by-N part of this array contains -C the matrix H * C, if SIDE = 'L', or C * H, if SIDE = 'R'. -C -C LDC INTEGER -C The leading dimension of array C. LDC >= MAX(1,M). -C -C Workspace -C -C DWORK DOUBLE PRECISION array, dimension (N), if SIDE = 'L', or -C (M), if SIDE = 'R'. -C DWORK is not referenced if H has order less than 11. -C -C METHOD -C -C The routine applies the elementary reflector H, taking its special -C structure into account. The multiplications by the first component -C of u (which is 1) are avoided, to increase the efficiency. -C -C NUMERICAL ASPECTS -C -C The algorithm is backward stable. -C -C CONTRIBUTORS -C -C V. Sima, Katholieke Univ. Leuven, Belgium, Feb. 1999. -C This is a modification of LAPACK Library routine DLARFX. -* -C REVISIONS -C -C - -C -C KEYWORDS -C -C Elementary matrix operations, elementary reflector, orthogonal -C transformation. -C -C ****************************************************************** -C -C .. Parameters .. - DOUBLE PRECISION ZERO, ONE - PARAMETER ( ZERO = 0.0D+0, ONE = 1.0D+0 ) -C .. -C .. Scalar Arguments .. - CHARACTER SIDE - INTEGER LDC, M, N - DOUBLE PRECISION TAU -C .. -C .. Array Arguments .. - DOUBLE PRECISION C( LDC, * ), DWORK( * ), V( * ) -C .. -C .. Local Scalars .. - INTEGER J - DOUBLE PRECISION SUM, T1, T2, T3, T4, T5, T6, T7, T8, T9, - $ V1, V2, V3, V4, V5, V6, V7, V8, V9 -C .. -C .. External Functions .. - LOGICAL LSAME - EXTERNAL LSAME -C .. -C .. External Subroutines .. - EXTERNAL DAXPY, DCOPY, DGEMV, DGER -C .. -C .. Executable Statements .. -C - IF( TAU.EQ.ZERO ) - $ RETURN - IF( LSAME( SIDE, 'L' ) ) THEN -C -C Form H * C, where H has order m. -C - GO TO ( 10, 30, 50, 70, 90, 110, 130, 150, - $ 170, 190 ) M -C -C Code for general M. -C -C w := C'*u. -C - CALL DCOPY( N, C, LDC, DWORK, 1 ) - CALL DGEMV( 'Transpose', M-1, N, ONE, C( 2, 1 ), LDC, V, 1, - $ ONE, DWORK, 1 ) -C -C C := C - tau * u * w'. -C - CALL DAXPY( N, -TAU, DWORK, 1, C, LDC ) - CALL DGER( M-1, N, -TAU, V, 1, DWORK, 1, C( 2, 1 ), LDC ) - GO TO 410 - 10 CONTINUE -C -C Special code for 1 x 1 Householder. -C - T1 = ONE - TAU - DO 20 J = 1, N - C( 1, J ) = T1*C( 1, J ) - 20 CONTINUE - GO TO 410 - 30 CONTINUE -C -C Special code for 2 x 2 Householder. -C - V1 = V( 1 ) - T1 = TAU*V1 - DO 40 J = 1, N - SUM = C( 1, J ) + V1*C( 2, J ) - C( 1, J ) = C( 1, J ) - SUM*TAU - C( 2, J ) = C( 2, J ) - SUM*T1 - 40 CONTINUE - GO TO 410 - 50 CONTINUE -C -C Special code for 3 x 3 Householder. -C - V1 = V( 1 ) - T1 = TAU*V1 - V2 = V( 2 ) - T2 = TAU*V2 - DO 60 J = 1, N - SUM = C( 1, J ) + V1*C( 2, J ) + V2*C( 3, J ) - C( 1, J ) = C( 1, J ) - SUM*TAU - C( 2, J ) = C( 2, J ) - SUM*T1 - C( 3, J ) = C( 3, J ) - SUM*T2 - 60 CONTINUE - GO TO 410 - 70 CONTINUE -C -C Special code for 4 x 4 Householder. -C - V1 = V( 1 ) - T1 = TAU*V1 - V2 = V( 2 ) - T2 = TAU*V2 - V3 = V( 3 ) - T3 = TAU*V3 - DO 80 J = 1, N - SUM = C( 1, J ) + V1*C( 2, J ) + V2*C( 3, J ) + - $ V3*C( 4, J ) - C( 1, J ) = C( 1, J ) - SUM*TAU - C( 2, J ) = C( 2, J ) - SUM*T1 - C( 3, J ) = C( 3, J ) - SUM*T2 - C( 4, J ) = C( 4, J ) - SUM*T3 - 80 CONTINUE - GO TO 410 - 90 CONTINUE -C -C Special code for 5 x 5 Householder. -C - V1 = V( 1 ) - T1 = TAU*V1 - V2 = V( 2 ) - T2 = TAU*V2 - V3 = V( 3 ) - T3 = TAU*V3 - V4 = V( 4 ) - T4 = TAU*V4 - DO 100 J = 1, N - SUM = C( 1, J ) + V1*C( 2, J ) + V2*C( 3, J ) + - $ V3*C( 4, J ) + V4*C( 5, J ) - C( 1, J ) = C( 1, J ) - SUM*TAU - C( 2, J ) = C( 2, J ) - SUM*T1 - C( 3, J ) = C( 3, J ) - SUM*T2 - C( 4, J ) = C( 4, J ) - SUM*T3 - C( 5, J ) = C( 5, J ) - SUM*T4 - 100 CONTINUE - GO TO 410 - 110 CONTINUE -C -C Special code for 6 x 6 Householder. -C - V1 = V( 1 ) - T1 = TAU*V1 - V2 = V( 2 ) - T2 = TAU*V2 - V3 = V( 3 ) - T3 = TAU*V3 - V4 = V( 4 ) - T4 = TAU*V4 - V5 = V( 5 ) - T5 = TAU*V5 - DO 120 J = 1, N - SUM = C( 1, J ) + V1*C( 2, J ) + V2*C( 3, J ) + - $ V3*C( 4, J ) + V4*C( 5, J ) + V5*C( 6, J ) - C( 1, J ) = C( 1, J ) - SUM*TAU - C( 2, J ) = C( 2, J ) - SUM*T1 - C( 3, J ) = C( 3, J ) - SUM*T2 - C( 4, J ) = C( 4, J ) - SUM*T3 - C( 5, J ) = C( 5, J ) - SUM*T4 - C( 6, J ) = C( 6, J ) - SUM*T5 - 120 CONTINUE - GO TO 410 - 130 CONTINUE -C -C Special code for 7 x 7 Householder. -C - V1 = V( 1 ) - T1 = TAU*V1 - V2 = V( 2 ) - T2 = TAU*V2 - V3 = V( 3 ) - T3 = TAU*V3 - V4 = V( 4 ) - T4 = TAU*V4 - V5 = V( 5 ) - T5 = TAU*V5 - V6 = V( 6 ) - T6 = TAU*V6 - DO 140 J = 1, N - SUM = C( 1, J ) + V1*C( 2, J ) + V2*C( 3, J ) + - $ V3*C( 4, J ) + V4*C( 5, J ) + V5*C( 6, J ) + - $ V6*C( 7, J ) - C( 1, J ) = C( 1, J ) - SUM*TAU - C( 2, J ) = C( 2, J ) - SUM*T1 - C( 3, J ) = C( 3, J ) - SUM*T2 - C( 4, J ) = C( 4, J ) - SUM*T3 - C( 5, J ) = C( 5, J ) - SUM*T4 - C( 6, J ) = C( 6, J ) - SUM*T5 - C( 7, J ) = C( 7, J ) - SUM*T6 - 140 CONTINUE - GO TO 410 - 150 CONTINUE -C -C Special code for 8 x 8 Householder. -C - V1 = V( 1 ) - T1 = TAU*V1 - V2 = V( 2 ) - T2 = TAU*V2 - V3 = V( 3 ) - T3 = TAU*V3 - V4 = V( 4 ) - T4 = TAU*V4 - V5 = V( 5 ) - T5 = TAU*V5 - V6 = V( 6 ) - T6 = TAU*V6 - V7 = V( 7 ) - T7 = TAU*V7 - DO 160 J = 1, N - SUM = C( 1, J ) + V1*C( 2, J ) + V2*C( 3, J ) + - $ V3*C( 4, J ) + V4*C( 5, J ) + V5*C( 6, J ) + - $ V6*C( 7, J ) + V7*C( 8, J ) - C( 1, J ) = C( 1, J ) - SUM*TAU - C( 2, J ) = C( 2, J ) - SUM*T1 - C( 3, J ) = C( 3, J ) - SUM*T2 - C( 4, J ) = C( 4, J ) - SUM*T3 - C( 5, J ) = C( 5, J ) - SUM*T4 - C( 6, J ) = C( 6, J ) - SUM*T5 - C( 7, J ) = C( 7, J ) - SUM*T6 - C( 8, J ) = C( 8, J ) - SUM*T7 - 160 CONTINUE - GO TO 410 - 170 CONTINUE -C -C Special code for 9 x 9 Householder. -C - V1 = V( 1 ) - T1 = TAU*V1 - V2 = V( 2 ) - T2 = TAU*V2 - V3 = V( 3 ) - T3 = TAU*V3 - V4 = V( 4 ) - T4 = TAU*V4 - V5 = V( 5 ) - T5 = TAU*V5 - V6 = V( 6 ) - T6 = TAU*V6 - V7 = V( 7 ) - T7 = TAU*V7 - V8 = V( 8 ) - T8 = TAU*V8 - DO 180 J = 1, N - SUM = C( 1, J ) + V1*C( 2, J ) + V2*C( 3, J ) + - $ V3*C( 4, J ) + V4*C( 5, J ) + V5*C( 6, J ) + - $ V6*C( 7, J ) + V7*C( 8, J ) + V8*C( 9, J ) - C( 1, J ) = C( 1, J ) - SUM*TAU - C( 2, J ) = C( 2, J ) - SUM*T1 - C( 3, J ) = C( 3, J ) - SUM*T2 - C( 4, J ) = C( 4, J ) - SUM*T3 - C( 5, J ) = C( 5, J ) - SUM*T4 - C( 6, J ) = C( 6, J ) - SUM*T5 - C( 7, J ) = C( 7, J ) - SUM*T6 - C( 8, J ) = C( 8, J ) - SUM*T7 - C( 9, J ) = C( 9, J ) - SUM*T8 - 180 CONTINUE - GO TO 410 - 190 CONTINUE -C -C Special code for 10 x 10 Householder. -C - V1 = V( 1 ) - T1 = TAU*V1 - V2 = V( 2 ) - T2 = TAU*V2 - V3 = V( 3 ) - T3 = TAU*V3 - V4 = V( 4 ) - T4 = TAU*V4 - V5 = V( 5 ) - T5 = TAU*V5 - V6 = V( 6 ) - T6 = TAU*V6 - V7 = V( 7 ) - T7 = TAU*V7 - V8 = V( 8 ) - T8 = TAU*V8 - V9 = V( 9 ) - T9 = TAU*V9 - DO 200 J = 1, N - SUM = C( 1, J ) + V1*C( 2, J ) + V2*C( 3, J ) + - $ V3*C( 4, J ) + V4*C( 5, J ) + V5*C( 6, J ) + - $ V6*C( 7, J ) + V7*C( 8, J ) + V8*C( 9, J ) + - $ V9*C( 10, J ) - C( 1, J ) = C( 1, J ) - SUM*TAU - C( 2, J ) = C( 2, J ) - SUM*T1 - C( 3, J ) = C( 3, J ) - SUM*T2 - C( 4, J ) = C( 4, J ) - SUM*T3 - C( 5, J ) = C( 5, J ) - SUM*T4 - C( 6, J ) = C( 6, J ) - SUM*T5 - C( 7, J ) = C( 7, J ) - SUM*T6 - C( 8, J ) = C( 8, J ) - SUM*T7 - C( 9, J ) = C( 9, J ) - SUM*T8 - C( 10, J ) = C( 10, J ) - SUM*T9 - 200 CONTINUE - GO TO 410 - ELSE -C -C Form C * H, where H has order n. -C - GO TO ( 210, 230, 250, 270, 290, 310, 330, 350, - $ 370, 390 ) N -C -C Code for general N. -C -C w := C * u. -C - CALL DCOPY( M, C, 1, DWORK, 1 ) - CALL DGEMV( 'No transpose', M, N-1, ONE, C( 1, 2 ), LDC, V, 1, - $ ONE, DWORK, 1 ) -C -C C := C - tau * w * u'. -C - CALL DAXPY( M, -TAU, DWORK, 1, C, 1 ) - CALL DGER( M, N-1, -TAU, DWORK, 1, V, 1, C( 1, 2 ), LDC ) - GO TO 410 - 210 CONTINUE -C -C Special code for 1 x 1 Householder. -C - T1 = ONE - TAU - DO 220 J = 1, M - C( J, 1 ) = T1*C( J, 1 ) - 220 CONTINUE - GO TO 410 - 230 CONTINUE -C -C Special code for 2 x 2 Householder. -C - V1 = V( 1 ) - T1 = TAU*V1 - DO 240 J = 1, M - SUM = C( J, 1 ) + V1*C( J, 2 ) - C( J, 1 ) = C( J, 1 ) - SUM*TAU - C( J, 2 ) = C( J, 2 ) - SUM*T1 - 240 CONTINUE - GO TO 410 - 250 CONTINUE -C -C Special code for 3 x 3 Householder. -C - V1 = V( 1 ) - T1 = TAU*V1 - V2 = V( 2 ) - T2 = TAU*V2 - DO 260 J = 1, M - SUM = C( J, 1 ) + V1*C( J, 2 ) + V2*C( J, 3 ) - C( J, 1 ) = C( J, 1 ) - SUM*TAU - C( J, 2 ) = C( J, 2 ) - SUM*T1 - C( J, 3 ) = C( J, 3 ) - SUM*T2 - 260 CONTINUE - GO TO 410 - 270 CONTINUE -C -C Special code for 4 x 4 Householder. -C - V1 = V( 1 ) - T1 = TAU*V1 - V2 = V( 2 ) - T2 = TAU*V2 - V3 = V( 3 ) - T3 = TAU*V3 - DO 280 J = 1, M - SUM = C( J, 1 ) + V1*C( J, 2 ) + V2*C( J, 3 ) + - $ V3*C( J, 4 ) - C( J, 1 ) = C( J, 1 ) - SUM*TAU - C( J, 2 ) = C( J, 2 ) - SUM*T1 - C( J, 3 ) = C( J, 3 ) - SUM*T2 - C( J, 4 ) = C( J, 4 ) - SUM*T3 - 280 CONTINUE - GO TO 410 - 290 CONTINUE -C -C Special code for 5 x 5 Householder. -C - V1 = V( 1 ) - T1 = TAU*V1 - V2 = V( 2 ) - T2 = TAU*V2 - V3 = V( 3 ) - T3 = TAU*V3 - V4 = V( 4 ) - T4 = TAU*V4 - DO 300 J = 1, M - SUM = C( J, 1 ) + V1*C( J, 2 ) + V2*C( J, 3 ) + - $ V3*C( J, 4 ) + V4*C( J, 5 ) - C( J, 1 ) = C( J, 1 ) - SUM*TAU - C( J, 2 ) = C( J, 2 ) - SUM*T1 - C( J, 3 ) = C( J, 3 ) - SUM*T2 - C( J, 4 ) = C( J, 4 ) - SUM*T3 - C( J, 5 ) = C( J, 5 ) - SUM*T4 - 300 CONTINUE - GO TO 410 - 310 CONTINUE -C -C Special code for 6 x 6 Householder. -C - V1 = V( 1 ) - T1 = TAU*V1 - V2 = V( 2 ) - T2 = TAU*V2 - V3 = V( 3 ) - T3 = TAU*V3 - V4 = V( 4 ) - T4 = TAU*V4 - V5 = V( 5 ) - T5 = TAU*V5 - DO 320 J = 1, M - SUM = C( J, 1 ) + V1*C( J, 2 ) + V2*C( J, 3 ) + - $ V3*C( J, 4 ) + V4*C( J, 5 ) + V5*C( J, 6 ) - C( J, 1 ) = C( J, 1 ) - SUM*TAU - C( J, 2 ) = C( J, 2 ) - SUM*T1 - C( J, 3 ) = C( J, 3 ) - SUM*T2 - C( J, 4 ) = C( J, 4 ) - SUM*T3 - C( J, 5 ) = C( J, 5 ) - SUM*T4 - C( J, 6 ) = C( J, 6 ) - SUM*T5 - 320 CONTINUE - GO TO 410 - 330 CONTINUE -C -C Special code for 7 x 7 Householder. -C - V1 = V( 1 ) - T1 = TAU*V1 - V2 = V( 2 ) - T2 = TAU*V2 - V3 = V( 3 ) - T3 = TAU*V3 - V4 = V( 4 ) - T4 = TAU*V4 - V5 = V( 5 ) - T5 = TAU*V5 - V6 = V( 6 ) - T6 = TAU*V6 - DO 340 J = 1, M - SUM = C( J, 1 ) + V1*C( J, 2 ) + V2*C( J, 3 ) + - $ V3*C( J, 4 ) + V4*C( J, 5 ) + V5*C( J, 6 ) + - $ V6*C( J, 7 ) - C( J, 1 ) = C( J, 1 ) - SUM*TAU - C( J, 2 ) = C( J, 2 ) - SUM*T1 - C( J, 3 ) = C( J, 3 ) - SUM*T2 - C( J, 4 ) = C( J, 4 ) - SUM*T3 - C( J, 5 ) = C( J, 5 ) - SUM*T4 - C( J, 6 ) = C( J, 6 ) - SUM*T5 - C( J, 7 ) = C( J, 7 ) - SUM*T6 - 340 CONTINUE - GO TO 410 - 350 CONTINUE -C -C Special code for 8 x 8 Householder. -C - V1 = V( 1 ) - T1 = TAU*V1 - V2 = V( 2 ) - T2 = TAU*V2 - V3 = V( 3 ) - T3 = TAU*V3 - V4 = V( 4 ) - T4 = TAU*V4 - V5 = V( 5 ) - T5 = TAU*V5 - V6 = V( 6 ) - T6 = TAU*V6 - V7 = V( 7 ) - T7 = TAU*V7 - DO 360 J = 1, M - SUM = C( J, 1 ) + V1*C( J, 2 ) + V2*C( J, 3 ) + - $ V3*C( J, 4 ) + V4*C( J, 5 ) + V5*C( J, 6 ) + - $ V6*C( J, 7 ) + V7*C( J, 8 ) - C( J, 1 ) = C( J, 1 ) - SUM*TAU - C( J, 2 ) = C( J, 2 ) - SUM*T1 - C( J, 3 ) = C( J, 3 ) - SUM*T2 - C( J, 4 ) = C( J, 4 ) - SUM*T3 - C( J, 5 ) = C( J, 5 ) - SUM*T4 - C( J, 6 ) = C( J, 6 ) - SUM*T5 - C( J, 7 ) = C( J, 7 ) - SUM*T6 - C( J, 8 ) = C( J, 8 ) - SUM*T7 - 360 CONTINUE - GO TO 410 - 370 CONTINUE -C -C Special code for 9 x 9 Householder. -C - V1 = V( 1 ) - T1 = TAU*V1 - V2 = V( 2 ) - T2 = TAU*V2 - V3 = V( 3 ) - T3 = TAU*V3 - V4 = V( 4 ) - T4 = TAU*V4 - V5 = V( 5 ) - T5 = TAU*V5 - V6 = V( 6 ) - T6 = TAU*V6 - V7 = V( 7 ) - T7 = TAU*V7 - V8 = V( 8 ) - T8 = TAU*V8 - DO 380 J = 1, M - SUM = C( J, 1 ) + V1*C( J, 2 ) + V2*C( J, 3 ) + - $ V3*C( J, 4 ) + V4*C( J, 5 ) + V5*C( J, 6 ) + - $ V6*C( J, 7 ) + V7*C( J, 8 ) + V8*C( J, 9 ) - C( J, 1 ) = C( J, 1 ) - SUM*TAU - C( J, 2 ) = C( J, 2 ) - SUM*T1 - C( J, 3 ) = C( J, 3 ) - SUM*T2 - C( J, 4 ) = C( J, 4 ) - SUM*T3 - C( J, 5 ) = C( J, 5 ) - SUM*T4 - C( J, 6 ) = C( J, 6 ) - SUM*T5 - C( J, 7 ) = C( J, 7 ) - SUM*T6 - C( J, 8 ) = C( J, 8 ) - SUM*T7 - C( J, 9 ) = C( J, 9 ) - SUM*T8 - 380 CONTINUE - GO TO 410 - 390 CONTINUE -C -C Special code for 10 x 10 Householder. -C - V1 = V( 1 ) - T1 = TAU*V1 - V2 = V( 2 ) - T2 = TAU*V2 - V3 = V( 3 ) - T3 = TAU*V3 - V4 = V( 4 ) - T4 = TAU*V4 - V5 = V( 5 ) - T5 = TAU*V5 - V6 = V( 6 ) - T6 = TAU*V6 - V7 = V( 7 ) - T7 = TAU*V7 - V8 = V( 8 ) - T8 = TAU*V8 - V9 = V( 9 ) - T9 = TAU*V9 - DO 400 J = 1, M - SUM = C( J, 1 ) + V1*C( J, 2 ) + V2*C( J, 3 ) + - $ V3*C( J, 4 ) + V4*C( J, 5 ) + V5*C( J, 6 ) + - $ V6*C( J, 7 ) + V7*C( J, 8 ) + V8*C( J, 9 ) + - $ V9*C( J, 10 ) - C( J, 1 ) = C( J, 1 ) - SUM*TAU - C( J, 2 ) = C( J, 2 ) - SUM*T1 - C( J, 3 ) = C( J, 3 ) - SUM*T2 - C( J, 4 ) = C( J, 4 ) - SUM*T3 - C( J, 5 ) = C( J, 5 ) - SUM*T4 - C( J, 6 ) = C( J, 6 ) - SUM*T5 - C( J, 7 ) = C( J, 7 ) - SUM*T6 - C( J, 8 ) = C( J, 8 ) - SUM*T7 - C( J, 9 ) = C( J, 9 ) - SUM*T8 - C( J, 10 ) = C( J, 10 ) - SUM*T9 - 400 CONTINUE - GO TO 410 - END IF - 410 CONTINUE - RETURN -C -C *** Last line of MB04PY *** - END diff --git a/mex/sources/libslicot/MB04QB.f b/mex/sources/libslicot/MB04QB.f deleted file mode 100644 index 6cb9e6777..000000000 --- a/mex/sources/libslicot/MB04QB.f +++ /dev/null @@ -1,454 +0,0 @@ - SUBROUTINE MB04QB( TRANC, TRAND, TRANQ, STOREV, STOREW, M, N, K, - $ V, LDV, W, LDW, C, LDC, D, LDD, CS, TAU, DWORK, - $ LDWORK, INFO ) -C -C SLICOT RELEASE 5.0. -C -C Copyright (c) 2002-2009 NICONET e.V. -C -C This program is free software: you can redistribute it and/or -C modify it under the terms of the GNU General Public License as -C published by the Free Software Foundation, either version 2 of -C the License, or (at your option) any later version. -C -C This program is distributed in the hope that it will be useful, -C but WITHOUT ANY WARRANTY; without even the implied warranty of -C MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the -C GNU General Public License for more details. -C -C You should have received a copy of the GNU General Public License -C along with this program. If not, see -C . -C -C PURPOSE -C -C To overwrite general real m-by-n matrices C and D, or their -C transposes, with -C -C [ op(C) ] -C Q * [ ] if TRANQ = 'N', or -C [ op(D) ] -C -C T [ op(C) ] -C Q * [ ] if TRANQ = 'T', -C [ op(D) ] -C -C where Q is defined as the product of symplectic reflectors and -C Givens rotators, -C -C Q = diag( H(1),H(1) ) G(1) diag( F(1),F(1) ) -C diag( H(2),H(2) ) G(2) diag( F(2),F(2) ) -C .... -C diag( H(k),H(k) ) G(k) diag( F(k),F(k) ). -C -C Blocked version. -C -C ARGUMENTS -C -C Mode Parameters -C -C TRANC CHARACTER*1 -C Specifies the form of op( C ) as follows: -C = 'N': op( C ) = C; -C = 'T': op( C ) = C'; -C = 'C': op( C ) = C'. -C -C TRAND CHARACTER*1 -C Specifies the form of op( D ) as follows: -C = 'N': op( D ) = D; -C = 'T': op( D ) = D'; -C = 'C': op( D ) = D'. -C -C TRANQ CHARACTER*1 -C = 'N': apply Q; -C = 'T': apply Q'. -C -C STOREV CHARACTER*1 -C Specifies how the vectors which define the concatenated -C Householder reflectors contained in V are stored: -C = 'C': columnwise; -C = 'R': rowwise. -C -C STOREW CHARACTER*1 -C Specifies how the vectors which define the concatenated -C Householder reflectors contained in W are stored: -C = 'C': columnwise; -C = 'R': rowwise. -C -C Input/Output Parameters -C -C M (input) INTEGER -C The number of rows of the matrices op(C) and op(D). -C M >= 0. -C -C N (input) INTEGER -C The number of columns of the matrices op(C) and op(D). -C N >= 0. -C -C K (input) INTEGER -C The number of elementary reflectors whose product defines -C the matrix Q. M >= K >= 0. -C -C V (input) DOUBLE PRECISION array, dimension -C (LDV,K) if STOREV = 'C', -C (LDV,M) if STOREV = 'R' -C On entry with STOREV = 'C', the leading M-by-K part of -C this array must contain in its columns the vectors which -C define the elementary reflectors F(i). -C On entry with STOREV = 'R', the leading K-by-M part of -C this array must contain in its rows the vectors which -C define the elementary reflectors F(i). -C -C LDV INTEGER -C The leading dimension of the array V. -C LDV >= MAX(1,M), if STOREV = 'C'; -C LDV >= MAX(1,K), if STOREV = 'R'. -C -C W (input) DOUBLE PRECISION array, dimension -C (LDW,K) if STOREW = 'C', -C (LDW,M) if STOREW = 'R' -C On entry with STOREW = 'C', the leading M-by-K part of -C this array must contain in its columns the vectors which -C define the elementary reflectors H(i). -C On entry with STOREW = 'R', the leading K-by-M part of -C this array must contain in its rows the vectors which -C define the elementary reflectors H(i). -C -C LDW INTEGER -C The leading dimension of the array W. -C LDW >= MAX(1,M), if STOREW = 'C'; -C LDW >= MAX(1,K), if STOREW = 'R'. -C -C C (input/output) DOUBLE PRECISION array, dimension -C (LDC,N) if TRANC = 'N', -C (LDC,M) if TRANC = 'T' or TRANC = 'C' -C On entry with TRANC = 'N', the leading M-by-N part of -C this array must contain the matrix C. -C On entry with TRANC = 'C' or TRANC = 'T', the leading -C N-by-M part of this array must contain the transpose of -C the matrix C. -C On exit with TRANC = 'N', the leading M-by-N part of -C this array contains the updated matrix C. -C On exit with TRANC = 'C' or TRANC = 'T', the leading -C N-by-M part of this array contains the transpose of the -C updated matrix C. -C -C LDC INTEGER -C The leading dimension of the array C. -C LDC >= MAX(1,M), if TRANC = 'N'; -C LDC >= MAX(1,N), if TRANC = 'T' or TRANC = 'C'. -C -C D (input/output) DOUBLE PRECISION array, dimension -C (LDD,N) if TRAND = 'N', -C (LDD,M) if TRAND = 'T' or TRAND = 'C' -C On entry with TRAND = 'N', the leading M-by-N part of -C this array must contain the matrix D. -C On entry with TRAND = 'C' or TRAND = 'T', the leading -C N-by-M part of this array must contain the transpose of -C the matrix D. -C On exit with TRAND = 'N', the leading M-by-N part of -C this array contains the updated matrix D. -C On exit with TRAND = 'C' or TRAND = 'T', the leading -C N-by-M part of this array contains the transpose of the -C updated matrix D. -C -C LDD INTEGER -C The leading dimension of the array D. -C LDD >= MAX(1,M), if TRAND = 'N'; -C LDD >= MAX(1,N), if TRAND = 'T' or TRAND = 'C'. -C -C CS (input) DOUBLE PRECISION array, dimension (2*K) -C On entry, the first 2*K elements of this array must -C contain the cosines and sines of the symplectic Givens -C rotators G(i). -C -C TAU (input) DOUBLE PRECISION array, dimension (K) -C On entry, the first K elements of this array must -C contain the scalar factors of the elementary reflectors -C F(i). -C -C Workspace -C -C DWORK DOUBLE PRECISION array, dimension (LDWORK) -C On exit, if INFO = 0, DWORK(1) returns the optimal -C value of LDWORK. -C On exit, if INFO = -20, DWORK(1) returns the minimum -C value of LDWORK. -C -C LDWORK INTEGER -C The length of the array DWORK. LDWORK >= MAX(1,N). -C -C Error Indicator -C -C INFO INTEGER -C = 0: successful exit; -C < 0: if INFO = -i, the i-th argument had an illegal -C value. -C -C REFERENCES -C -C [1] Kressner, D. -C Block algorithms for orthogonal symplectic factorizations. -C BIT, 43 (4), pp. 775-790, 2003. -C -C CONTRIBUTORS -C -C D. Kressner, Technical Univ. Berlin, Germany, and -C P. Benner, Technical Univ. Chemnitz, Germany, December 2003. -C -C REVISIONS -C -C V. Sima, June 2008 (SLICOT version of the HAPACK routine DOSMSB). -C -C KEYWORDS -C -C Elementary matrix operations, orthogonal symplectic matrix. -C -C ****************************************************************** -C -C .. Parameters .. - DOUBLE PRECISION ONE - PARAMETER ( ONE = 1.0D+0 ) -C .. Scalar Arguments .. - CHARACTER STOREV, STOREW, TRANC, TRAND, TRANQ - INTEGER INFO, K, LDC, LDD, LDV, LDW, LDWORK, M, N -C .. Array Arguments .. - DOUBLE PRECISION C(LDC,*), CS(*), D(LDD,*), DWORK(*), TAU(*), - $ V(LDV,*), W(LDW,*) -C .. Local Scalars .. - LOGICAL LCOLV, LCOLW, LTRC, LTRD, LTRQ - INTEGER I, IB, IC, ID, IERR, JC, JD, KI, KK, NB, NBMIN, - $ NX, PDRS, PDT, PDW, WRKOPT -C .. External Functions .. - INTEGER UE01MD - LOGICAL LSAME - EXTERNAL LSAME, UE01MD -C .. External Subroutines .. - EXTERNAL MB04QC, MB04QF, MB04QU, XERBLA -C .. Intrinsic Functions .. - INTRINSIC DBLE, INT, MAX, MIN, SQRT -C -C .. Executable Statements .. -C -C Decode the scalar input parameters. -C - INFO = 0 - LCOLV = LSAME( STOREV, 'C' ) - LCOLW = LSAME( STOREW, 'C' ) - LTRC = LSAME( TRANC, 'T' ) .OR. LSAME( TRANC, 'C' ) - LTRD = LSAME( TRAND, 'T' ) .OR. LSAME( TRAND, 'C' ) - LTRQ = LSAME( TRANQ, 'T' ) -C -C Check the scalar input parameters. -C - IF ( .NOT.( LTRC .OR. LSAME( TRANC, 'N' ) ) ) THEN - INFO = -1 - ELSE IF ( .NOT.( LTRD .OR. LSAME( TRAND, 'N' ) ) ) THEN - INFO = -2 - ELSE IF ( .NOT.( LTRQ .OR. LSAME( TRANQ, 'N' ) ) ) THEN - INFO = -3 - ELSE IF ( .NOT.( LCOLV .OR. LSAME( STOREV, 'R' ) ) ) THEN - INFO = -4 - ELSE IF ( .NOT.( LCOLW .OR. LSAME( STOREW, 'R' ) ) ) THEN - INFO = -5 - ELSE IF ( M.LT.0 ) THEN - INFO = -6 - ELSE IF ( N.LT.0 ) THEN - INFO = -7 - ELSE IF ( K.LT.0 .OR. K.GT.M ) THEN - INFO = -8 - ELSE IF ( ( LCOLV .AND. LDV.LT.MAX( 1, M ) ) .OR. - $ ( .NOT.LCOLV .AND. LDV.LT.MAX( 1, K ) ) ) THEN - INFO = -10 - ELSE IF ( ( LCOLW .AND. LDW.LT.MAX( 1, M ) ) .OR. - $ ( .NOT.LCOLW .AND. LDW.LT.MAX( 1, K ) ) ) THEN - INFO = -12 - ELSE IF ( ( LTRC .AND. LDC.LT.MAX( 1, N ) ) .OR. - $ ( .NOT.LTRC .AND. LDC.LT.MAX( 1, M ) ) ) THEN - INFO = -14 - ELSE IF ( ( LTRD .AND. LDD.LT.MAX( 1, N ) ) .OR. - $ ( .NOT.LTRD .AND. LDD.LT.MAX( 1, M ) ) ) THEN - INFO = -16 - ELSE IF ( LDWORK.LT.MAX( 1, N ) ) THEN - DWORK(1) = DBLE( MAX( 1, N ) ) - INFO = -20 - END IF -C -C Return if there were illegal values. -C - IF ( INFO.NE.0 ) THEN - CALL XERBLA( 'MB04QB', -INFO ) - RETURN - END IF -C -C Quick return if possible. -C - IF ( MIN( K, M, N ).EQ.0 ) THEN - DWORK(1) = ONE - RETURN - END IF -C - NBMIN = 2 - NX = 0 - WRKOPT = N - NB = UE01MD( 1, 'MB04QB', TRANC // TRAND // TRANQ, M, N, K ) - IF ( NB.GT.1 .AND. NB.LT.K ) THEN -C -C Determine when to cross over from blocked to unblocked code. -C - NX = MAX( 0, UE01MD( 3, 'MB04QB', TRANC // TRAND // TRANQ, M, - $ N, K ) ) - IF ( NX.LT.K ) THEN -C -C Determine if workspace is large enough for blocked code. -C - WRKOPT = MAX( WRKOPT, 9*N*NB + 15*NB*NB ) - IF ( LDWORK.LT.WRKOPT ) THEN -C -C Not enough workspace to use optimal NB: reduce NB and -C determine the minimum value of NB. -C - NB = INT( ( SQRT( DBLE( 81*N*N + 60*LDWORK ) ) - $ - DBLE( 9*N ) ) / 30.0D0 ) - NBMIN = MAX( 2, UE01MD( 2, 'MB04QB', TRANC // TRAND // - $ TRANQ, M, N, K ) ) - END IF - END IF - END IF -C - PDRS = 1 - PDT = PDRS + 6*NB*NB - PDW = PDT + 9*NB*NB - IC = 1 - JC = 1 - ID = 1 - JD = 1 -C - IF ( LTRQ ) THEN -C -C Use blocked code initially. -C - IF ( NB.GE.NBMIN .AND. NB.LT.K .AND. NX.LT.K ) THEN - DO 10 I = 1, K - NX, NB - IB = MIN( K-I+1, NB ) -C -C Form the triangular factors of the symplectic block -C reflector SH. -C - CALL MB04QF( 'Forward', STOREV, STOREW, M-I+1, IB, - $ V(I,I), LDV, W(I,I), LDW, CS(2*I-1), TAU(I), - $ DWORK(PDRS), NB, DWORK(PDT), NB, - $ DWORK(PDW) ) -C -C Apply SH' to [ op(C)(i:m,:); op(D)(i:m,:) ] from the -C left. -C - IF ( LTRC ) THEN - JC = I - ELSE - IC = I - END IF - IF ( LTRD ) THEN - JD = I - ELSE - ID = I - END IF - CALL MB04QC( 'No Structure', TRANC, TRAND, TRANQ, - $ 'Forward', STOREV, STOREW, M-I+1, N, IB, - $ V(I,I), LDV, W(I,I), LDW, DWORK(PDRS), NB, - $ DWORK(PDT), NB, C(IC,JC), LDC, D(ID,JD), - $ LDD, DWORK(PDW) ) - 10 CONTINUE - ELSE - I = 1 - END IF -C -C Use unblocked code to update last or only block. -C - IF ( I.LE.K ) THEN - IF ( LTRC ) THEN - JC = I - ELSE - IC = I - END IF - IF ( LTRD ) THEN - JD = I - ELSE - ID = I - END IF - CALL MB04QU( TRANC, TRAND, TRANQ, STOREV, STOREW, M-I+1, N, - $ K-I+1, V(I,I), LDV, W(I,I), LDW, C(IC,JC), LDC, - $ D(ID,JD), LDD, CS(2*I-1), TAU(I), DWORK, - $ LDWORK, IERR ) - END IF - ELSE - IF ( NB.GE.NBMIN .AND. NB.LT.K .AND. NX.LT.K ) THEN -C -C Use blocked code after the last block. -C The first kk columns are handled by the block method. -C - KI = ( ( K-NX-1 ) / NB )*NB - KK = MIN( K, KI+NB ) - ELSE - KK = 0 - END IF -C -C Use unblocked code for the last or only block. -C - IF ( KK.LT.K ) THEN - IF ( LTRC ) THEN - JC = KK + 1 - ELSE - IC = KK + 1 - END IF - IF ( LTRD ) THEN - JD = KK + 1 - ELSE - ID = KK + 1 - END IF - CALL MB04QU( TRANC, TRAND, TRANQ, STOREV, STOREW, M-KK, N, - $ K-KK, V(KK+1,KK+1), LDV, W(KK+1,KK+1), LDW, - $ C(IC,JC), LDC, D(ID,JD), LDD, CS(2*KK+1), - $ TAU(KK+1), DWORK, LDWORK, IERR ) - END IF -C -C Blocked code. -C - IF ( KK.GT.0 ) THEN - DO 20 I = KI + 1, 1, -NB - IB = MIN( NB, K-I+1 ) -C -C Form the triangular factors of the symplectic block -C reflector SH. -C - CALL MB04QF( 'Forward', STOREV, STOREW, M-I+1, IB, - $ V(I,I), LDV, W(I,I), LDW, CS(2*I-1), TAU(I), - $ DWORK(PDRS), NB, DWORK(PDT), NB, - $ DWORK(PDW) ) -C -C Apply SH to [ op(C)(i:m,:); op(D)(i:m,:) ] from -C the left. -C - IF ( LTRC ) THEN - JC = I - ELSE - IC = I - END IF - IF ( LTRD ) THEN - JD = I - ELSE - ID = I - END IF - CALL MB04QC( 'No Structure', TRANC, TRAND, TRANQ, - $ 'Forward', STOREV, STOREW, M-I+1, N, IB, - $ V(I,I), LDV, W(I,I), LDW, DWORK(PDRS), NB, - $ DWORK(PDT), NB, C(IC,JC), LDC, D(ID,JD), - $ LDD, DWORK(PDW) ) - 20 CONTINUE - END IF - END IF - DWORK(1) = DBLE( WRKOPT ) -C - RETURN -C *** Last line of MB04QB *** - END diff --git a/mex/sources/libslicot/MB04QC.f b/mex/sources/libslicot/MB04QC.f deleted file mode 100644 index 44d6a9ebd..000000000 --- a/mex/sources/libslicot/MB04QC.f +++ /dev/null @@ -1,1223 +0,0 @@ - SUBROUTINE MB04QC( STRUCT, TRANA, TRANB, TRANQ, DIRECT, STOREV, - $ STOREW, M, N, K, V, LDV, W, LDW, RS, LDRS, T, - $ LDT, A, LDA, B, LDB, DWORK ) -C -C SLICOT RELEASE 5.0. -C -C Copyright (c) 2002-2009 NICONET e.V. -C -C This program is free software: you can redistribute it and/or -C modify it under the terms of the GNU General Public License as -C published by the Free Software Foundation, either version 2 of -C the License, or (at your option) any later version. -C -C This program is distributed in the hope that it will be useful, -C but WITHOUT ANY WARRANTY; without even the implied warranty of -C MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the -C GNU General Public License for more details. -C -C You should have received a copy of the GNU General Public License -C along with this program. If not, see -C . -C -C PURPOSE -C -C To apply the orthogonal symplectic block reflector -C -C [ I+V*T*V' V*R*S*V' ] -C Q = [ ] -C [ -V*R*S*V' I+V*T*V' ] -C -C or its transpose to a real 2m-by-n matrix [ op(A); op(B) ] from -C the left. -C The k-by-k upper triangular blocks of the matrices -C -C [ S1 ] [ T11 T12 T13 ] -C R = [ R1 R2 R3 ], S = [ S2 ], T = [ T21 T22 T23 ], -C [ S3 ] [ T31 T32 T33 ] -C -C with R2 unit and S1, R3, T21, T31, T32 strictly upper triangular, -C are stored rowwise in the arrays RS and T, respectively. -C -C ARGUMENTS -C -C Mode Parameters -C -C STRUCT CHARACTER*1 -C Specifies the structure of the first blocks of A and B: -C = 'Z': the leading K-by-N submatrices of op(A) and op(B) -C are (implicitly) assumed to be zero; -C = 'N'; no structure to mention. -C -C TRANA CHARACTER*1 -C Specifies the form of op( A ) as follows: -C = 'N': op( A ) = A; -C = 'T': op( A ) = A'; -C = 'C': op( A ) = A'. -C -C TRANB CHARACTER*1 -C Specifies the form of op( B ) as follows: -C = 'N': op( B ) = B; -C = 'T': op( B ) = B'; -C = 'C': op( B ) = B'. -C -C DIRECT CHARACTER*1 -C This is a dummy argument, which is reserved for future -C extensions of this subroutine. Not referenced. -C -C TRANQ CHARACTER*1 -C = 'N': apply Q; -C = 'T': apply Q'. -C -C STOREV CHARACTER*1 -C Specifies how the vectors which define the concatenated -C Householder reflectors contained in V are stored: -C = 'C': columnwise; -C = 'R': rowwise. -C -C STOREW CHARACTER*1 -C Specifies how the vectors which define the concatenated -C Householder reflectors contained in W are stored: -C = 'C': columnwise; -C = 'R': rowwise. -C -C Input/Output Parameters -C -C M (input) INTEGER -C The number of rows of the matrices op(A) and op(B). -C M >= 0. -C -C N (input) INTEGER -C The number of columns of the matrices op(A) and op(B). -C N >= 0. -C -C K (input) INTEGER -C The order of the triangular matrices defining R, S and T. -C M >= K >= 0. -C -C V (input) DOUBLE PRECISION array, dimension -C (LDV,K) if STOREV = 'C', -C (LDV,M) if STOREV = 'R' -C On entry with STOREV = 'C', the leading M-by-K part of -C this array must contain in its columns the vectors which -C define the elementary reflector used to form parts of Q. -C On entry with STOREV = 'R', the leading K-by-M part of -C this array must contain in its rows the vectors which -C define the elementary reflector used to form parts of Q. -C -C LDV INTEGER -C The leading dimension of the array V. -C LDV >= MAX(1,M), if STOREV = 'C'; -C LDV >= MAX(1,K), if STOREV = 'R'. -C -C W (input) DOUBLE PRECISION array, dimension -C (LDW,K) if STOREW = 'C', -C (LDW,M) if STOREW = 'R' -C On entry with STOREW = 'C', the leading M-by-K part of -C this array must contain in its columns the vectors which -C define the elementary reflector used to form parts of Q. -C On entry with STOREW = 'R', the leading K-by-M part of -C this array must contain in its rows the vectors which -C define the elementary reflector used to form parts of Q. -C -C LDW INTEGER -C The leading dimension of the array W. -C LDW >= MAX(1,M), if STOREW = 'C'; -C LDW >= MAX(1,K), if STOREW = 'R'. -C -C RS (input) DOUBLE PRECISION array, dimension (K,6*K) -C On entry, the leading K-by-6*K part of this array must -C contain the upper triangular matrices defining the factors -C R and S of the symplectic block reflector Q. The -C (strictly) lower portions of this array are not -C referenced. -C -C LDRS INTEGER -C The leading dimension of the array RS. LDRS >= MAX(1,K). -C -C T (input) DOUBLE PRECISION array, dimension (K,9*K) -C On entry, the leading K-by-9*K part of this array must -C contain the upper triangular matrices defining the factor -C T of the symplectic block reflector Q. The (strictly) -C lower portions of this array are not referenced. -C -C LDT INTEGER -C The leading dimension of the array T. LDT >= MAX(1,K). -C -C A (input/output) DOUBLE PRECISION array, dimension -C (LDA,N) if TRANA = 'N', -C (LDA,M) if TRANA = 'C' or TRANA = 'T' -C On entry with TRANA = 'N', the leading M-by-N part of this -C array must contain the matrix A. -C On entry with TRANA = 'T' or TRANA = 'C', the leading -C N-by-M part of this array must contain the matrix A. -C -C LDA INTEGER -C The leading dimension of the array A. -C LDA >= MAX(1,M), if TRANA = 'N'; -C LDA >= MAX(1,N), if TRANA = 'C' or TRANA = 'T'. -C -C B (input/output) DOUBLE PRECISION array, dimension -C (LDB,N) if TRANB = 'N', -C (LDB,M) if TRANB = 'C' or TRANB = 'T' -C On entry with TRANB = 'N', the leading M-by-N part of this -C array must contain the matrix B. -C On entry with TRANB = 'T' or TRANB = 'C', the leading -C N-by-M part of this array must contain the matrix B. -C -C LDB INTEGER -C The leading dimension of the array B. -C LDB >= MAX(1,M), if TRANB = 'N'; -C LDB >= MAX(1,N), if TRANB = 'C' or TRANB = 'T'. -C -C Workspace -C -C DWORK DOUBLE PRECISION array, dimension (LDWORK), where -C LDWORK >= 8*N*K, if STRUCT = 'Z', -C LDWORK >= 9*N*K, if STRUCT = 'N'. -C -C REFERENCES -C -C [1] Kressner, D. -C Block algorithms for orthogonal symplectic factorizations. -C BIT, 43 (4), pp. 775-790, 2003. -C -C NUMERICAL ASPECTS -C -C The algorithm requires 16*( M - K )*N + ( 26*K - 4 )*K*N floating -C point operations if STRUCT = 'Z' and additional ( 12*K + 2 )*K*N -C floating point operations if STRUCT = 'N'. -C -C CONTRIBUTORS -C -C D. Kressner, Technical Univ. Berlin, Germany, and -C P. Benner, Technical Univ. Chemnitz, Germany, December 2003. -C -C REVISIONS -C -C V. Sima, June 2008 (SLICOT version of the HAPACK routine DLAESB). -C -C KEYWORDS -C -C Elementary matrix operations, orthogonal symplectic matrix. -C -C ****************************************************************** -C -C .. Parameters .. - DOUBLE PRECISION ZERO, ONE - PARAMETER ( ZERO = 0.0D0, ONE = 1.0D0 ) -C .. Scalar Arguments .. - CHARACTER DIRECT, STOREV, STOREW, STRUCT, TRANA, TRANB, - $ TRANQ - INTEGER K, LDA, LDB, LDRS, LDT, LDV, LDW, M, N -C .. Array Arguments .. - DOUBLE PRECISION A(LDA,*), B(LDB,*), DWORK(*), RS(LDRS,*), - $ T(LDT,*), V(LDV,*), W(LDW,*) -C .. Local Scalars .. - LOGICAL LA1B1, LCOLV, LCOLW, LTRA, LTRB, LTRQ - INTEGER I, ITEMP, PDW1, PDW2, PDW3, PDW4, PDW5, PDW6, - $ PDW7, PDW8, PDW9, PR1, PR2, PR3, PS1, PS2, PS3, - $ PT11, PT12, PT13, PT21, PT22, PT23, PT31, PT32, - $ PT33 - DOUBLE PRECISION FACT -C .. External Functions .. - LOGICAL LSAME - EXTERNAL LSAME -C .. External Subroutines .. - EXTERNAL DAXPY, DCOPY, DGEMM, DLASET, DTRMM -C -C .. Executable Statements .. -C -C Quick return if possible. -C - IF ( M.LE.0 .OR. N.LE.0 ) - $ RETURN - LA1B1 = LSAME( STRUCT, 'N' ) - LCOLV = LSAME( STOREV, 'C' ) - LCOLW = LSAME( STOREW, 'C' ) - LTRA = LSAME( TRANA, 'T' ) .OR. LSAME( TRANA, 'C' ) - LTRB = LSAME( TRANB, 'T' ) .OR. LSAME( TRANB, 'C' ) - LTRQ = LSAME( TRANQ, 'T' ) .OR. LSAME( TRANQ, 'C' ) -C - PR1 = 1 - PR2 = PR1 + K - PR3 = PR2 + K - PS1 = PR3 + K - PS2 = PS1 + K - PS3 = PS2 + K - PT11 = 1 - PT12 = PT11 + K - PT13 = PT12 + K - PT21 = PT13 + K - PT22 = PT21 + K - PT23 = PT22 + K - PT31 = PT23 + K - PT32 = PT31 + K - PT33 = PT32 + K - PDW1 = 1 - PDW2 = PDW1 + N*K - PDW3 = PDW2 + N*K - PDW4 = PDW3 + N*K - PDW5 = PDW4 + N*K - PDW6 = PDW5 + N*K - PDW7 = PDW6 + N*K - PDW8 = PDW7 + N*K - PDW9 = PDW8 + N*K -C -C Update the matrix A. -C - IF ( LA1B1 ) THEN -C -C NZ1) DW7 := A1' -C - IF ( LTRA ) THEN - DO 10 I = 1, K - CALL DCOPY( N, A(1,I), 1, DWORK(PDW7+(I-1)*N), 1 ) - 10 CONTINUE - ELSE - DO 20 I = 1, N - CALL DCOPY( K, A(1,I), 1, DWORK(PDW7+I-1), N ) - 20 CONTINUE - END IF -C -C NZ2) DW1 := DW7*W1 -C - CALL DCOPY( N*K, DWORK(PDW7), 1, DWORK(PDW1), 1 ) - IF ( LCOLW ) THEN - CALL DTRMM( 'Right', 'Lower', 'No transpose', 'Unit', N, - $ K, ONE, W, LDW, DWORK(PDW1), N ) - ELSE - CALL DTRMM( 'Right', 'Upper', 'Transpose', 'Unit', N, - $ K, ONE, W, LDW, DWORK(PDW1), N ) - END IF -C -C NZ3) DW2 := DW7*V1 -C - CALL DCOPY( N*K, DWORK(PDW7), 1, DWORK(PDW2), 1 ) - IF ( LCOLV ) THEN - CALL DTRMM( 'Right', 'Lower', 'No transpose', 'Unit', N, - $ K, ONE, V, LDV, DWORK(PDW2), N ) - ELSE - CALL DTRMM( 'Right', 'Upper', 'Transpose', 'Unit', N, - $ K, ONE, V, LDV, DWORK(PDW2), N ) - END IF - FACT = ONE - ELSE - FACT = ZERO - END IF -C -C 1) DW1 := A2'*W2 -C - IF ( M.GT.K ) THEN - IF ( LTRA.AND.LCOLW ) THEN - CALL DGEMM( 'No Transpose', 'No Transpose', N, K, M-K, ONE, - $ A(1,K+1), LDA, W(K+1,1), LDW, FACT, DWORK(PDW1), - $ N ) - ELSE IF ( LTRA ) THEN - CALL DGEMM( 'No Transpose', 'Transpose', N, K, M-K, ONE, - $ A(1,K+1), LDA, W(1,K+1), LDW, FACT, DWORK(PDW1), - $ N ) - ELSE IF ( LCOLW ) THEN - CALL DGEMM( 'Transpose', 'No Transpose', N, K, M-K, ONE, - $ A(K+1,1), LDA, W(K+1,1), LDW, FACT, DWORK(PDW1), - $ N ) - ELSE - CALL DGEMM( 'Transpose', 'Transpose', N, K, M-K, ONE, - $ A(K+1,1), LDA, W(1,K+1), LDW, FACT, DWORK(PDW1), - $ N ) - END IF - ELSE IF ( .NOT.LA1B1 ) THEN - CALL DLASET( 'All', N, K, ZERO, ZERO, DWORK(PDW1), N ) - END IF -C -C 2) DW2 := A2'*V2 -C - IF ( M.GT.K ) THEN - IF ( LTRA.AND.LCOLV ) THEN - CALL DGEMM( 'No Transpose', 'No Transpose', N, K, M-K, ONE, - $ A(1,K+1), LDA, V(K+1,1), LDV, FACT, DWORK(PDW2), - $ N ) - ELSE IF ( LTRA ) THEN - CALL DGEMM( 'No Transpose', 'Transpose', N, K, M-K, ONE, - $ A(1,K+1), LDA, V(1,K+1), LDV, FACT, DWORK(PDW2), - $ N ) - ELSE IF ( LCOLV ) THEN - CALL DGEMM( 'Transpose', 'No Transpose', N, K, M-K, ONE, - $ A(K+1,1), LDA, V(K+1,1), LDV, FACT, DWORK(PDW2), - $ N ) - ELSE - CALL DGEMM( 'Transpose', 'Transpose', N, K, M-K, ONE, - $ A(K+1,1), LDA, V(1,K+1), LDV, FACT, DWORK(PDW2), - $ N ) - END IF - ELSE IF ( .NOT.LA1B1 ) THEN - CALL DLASET( 'All', N, K, ZERO, ZERO, DWORK(PDW2), N ) - END IF -C - IF ( LTRQ ) THEN -C -C 3) DW3 := DW1*T11 -C - CALL DCOPY( N*K, DWORK(PDW1), 1, DWORK(PDW3), 1 ) - CALL DTRMM( 'Right', 'Upper', 'No Transpose', 'Non-Unit', N, K, - $ ONE, T(1,PT11), LDT, DWORK(PDW3), N ) -C -C 4) DW4 := DW2*T31 -C - CALL DCOPY( N*(K-1), DWORK(PDW2), 1, DWORK(PDW4), 1 ) - CALL DTRMM( 'Right', 'Upper', 'No Transpose', 'Non-Unit', N, - $ K-1, ONE, T(1,PT31+1), LDT, DWORK(PDW4), N ) -C -C 5) DW3 := DW3 + DW4 -C - CALL DAXPY( N*(K-1), ONE, DWORK(PDW4), 1, DWORK(PDW3+N), 1 ) -C - IF ( LA1B1 ) THEN -C -C NZ4) DW8 := DW7*T21 -C - CALL DCOPY( N*(K-1), DWORK(PDW7), 1, DWORK(PDW8), 1 ) - CALL DTRMM( 'Right', 'Upper', 'No Transpose', 'Non-Unit', N, - $ K-1, ONE, T(1,PT21+1), LDT, DWORK(PDW8), N ) -C -C NZ5) DW3 := DW3 + DW8 -C - CALL DAXPY( N*(K-1), ONE, DWORK(PDW8), 1, DWORK(PDW3+N), 1 ) - END IF -C -C 6) DW4 := DW1*T12 -C - CALL DCOPY( N*K, DWORK(PDW1), 1, DWORK(PDW4), 1 ) - CALL DTRMM( 'Right', 'Upper', 'No Transpose', 'Non-Unit', N, - $ K, ONE, T(1,PT12), LDT, DWORK(PDW4), N ) -C -C 7) DW5 := DW2*T32 -C - CALL DCOPY( N*(K-1), DWORK(PDW2), 1, DWORK(PDW5), 1 ) - CALL DTRMM( 'Right', 'Upper', 'No Transpose', 'Non-Unit', N, - $ K-1, ONE, T(1,PT32+1), LDT, DWORK(PDW5), N ) -C -C 8) DW4 := DW4 + DW5 -C - CALL DAXPY( N*(K-1), ONE, DWORK(PDW5), 1, DWORK(PDW4+N), 1 ) -C - IF ( LA1B1 ) THEN -C -C NZ6) DW8 := DW7*T22 -C - CALL DCOPY( N*K, DWORK(PDW7), 1, DWORK(PDW8), 1 ) - CALL DTRMM( 'Right', 'Upper', 'No Transpose', 'Non-Unit', N, - $ K, ONE, T(1,PT22), LDT, DWORK(PDW8), N ) -C -C NZ7) DW4 := DW4 + DW8 -C - CALL DAXPY( N*K, ONE, DWORK(PDW8), 1, DWORK(PDW4), 1 ) - END IF -C -C 9) DW5 := DW2*T33 -C - CALL DCOPY( N*K, DWORK(PDW2), 1, DWORK(PDW5), 1 ) - CALL DTRMM( 'Right', 'Upper', 'No Transpose', 'Non-Unit', N, K, - $ ONE, T(1,PT33), LDT, DWORK(PDW5), N ) -C -C 10) DW6 := DW1*T13 -C - CALL DCOPY( N*K, DWORK(PDW1), 1, DWORK(PDW6), 1 ) - CALL DTRMM( 'Right', 'Upper', 'No Transpose', 'Non-Unit', N, - $ K, ONE, T(1,PT13), LDT, DWORK(PDW6), N ) -C -C 11) DW5 := DW5 + DW6 -C - CALL DAXPY( N*K, ONE, DWORK(PDW6), 1, DWORK(PDW5), 1 ) -C - IF ( LA1B1 ) THEN -C -C NZ8) DW8 := DW7*T23 -C - CALL DCOPY( N*K, DWORK(PDW7), 1, DWORK(PDW8), 1 ) - CALL DTRMM( 'Right', 'Upper', 'No Transpose', 'Non-Unit', N, - $ K, ONE, T(1,PT23), LDT, DWORK(PDW8), N ) -C -C NZ9) DW5 := DW5 + DW8 -C - CALL DAXPY( N*K, ONE, DWORK(PDW8), 1, DWORK(PDW5), 1 ) - END IF -C -C 12) DW1 := DW1*R1 -C - CALL DTRMM( 'Right', 'Upper', 'No Transpose', 'Non-Unit', N, K, - $ ONE, RS(1,PR1), LDRS, DWORK(PDW1), N ) -C -C 13) DW2 := DW2*R3 -C - CALL DTRMM( 'Right', 'Upper', 'No Transpose', 'Non-Unit', N, - $ K-1, ONE, RS(1,PR3+1), LDRS, DWORK(PDW2), N ) -C -C 14) DW1 := DW1 + DW2 -C - CALL DAXPY( N*(K-1), ONE, DWORK(PDW2), 1, DWORK(PDW1+N), 1 ) -C - IF ( LA1B1 ) THEN -C -C NZ10) DW7 := DW7*R2 -C - CALL DTRMM( 'Right', 'Upper', 'No Transpose', 'Unit', N, K, - $ ONE, RS(1,PR2), LDRS, DWORK(PDW7), N ) -C -C NZ11) DW1 := DW1 + DW7 -C - CALL DAXPY( N*K, ONE, DWORK(PDW7), 1, DWORK(PDW1), 1 ) - END IF -C -C Swap Pointers PDW1 <-> PDW2 -C - ITEMP = PDW2 - PDW2 = PDW1 - PDW1 = ITEMP - ELSE -C -C 3) DW3 := DW1*T11' -C - CALL DCOPY( N*K, DWORK(PDW1), 1, DWORK(PDW3), 1 ) - CALL DTRMM( 'Right', 'Upper', 'Transpose', 'Non-Unit', N, K, - $ ONE, T(1,PT11), LDT, DWORK(PDW3), N ) -C -C 4) DW4 := DW2*T13' -C - CALL DCOPY( N*K, DWORK(PDW2), 1, DWORK(PDW4), 1 ) - CALL DTRMM( 'Right', 'Upper', 'Transpose', 'Non-Unit', N, K, - $ ONE, T(1,PT13), LDT, DWORK(PDW4), N ) -C -C 5) DW3 := DW3 + DW4 -C - CALL DAXPY( N*K, ONE, DWORK(PDW4), 1, DWORK(PDW3), 1 ) -C - IF ( LA1B1 ) THEN -C -C NZ4) DW8 := DW7*T12' -C - CALL DCOPY( N*K, DWORK(PDW7), 1, DWORK(PDW8), 1 ) - CALL DTRMM( 'Right', 'Upper', 'Transpose', 'Non-Unit', N, K, - $ ONE, T(1,PT12), LDT, DWORK(PDW8), N ) -C -C NZ5) DW3 := DW3 + DW8 -C - CALL DAXPY( N*K, ONE, DWORK(PDW8), 1, DWORK(PDW3), 1 ) - END IF -C -C 6) DW4 := DW2*T23' -C - CALL DCOPY( N*K, DWORK(PDW2), 1, DWORK(PDW4), 1 ) - CALL DTRMM( 'Right', 'Upper', 'Transpose', 'Non-Unit', N, K, - $ ONE, T(1,PT23), LDT, DWORK(PDW4), N ) -C -C 7) DW5 := DW1*T21' -C - CALL DCOPY( N*(K-1), DWORK(PDW1+N), 1, DWORK(PDW5), 1 ) - CALL DTRMM( 'Right', 'Upper', 'Transpose', 'Non-Unit', N, K-1, - $ ONE, T(1,PT21+1), LDT, DWORK(PDW5), N ) -C -C 8) DW4 := DW4 + DW5 -C - CALL DAXPY( N*(K-1), ONE, DWORK(PDW5), 1, DWORK(PDW4), 1 ) -C - IF ( LA1B1 ) THEN -C -C NZ6) DW8 := DW7*T22' -C - CALL DCOPY( N*K, DWORK(PDW7), 1, DWORK(PDW8), 1 ) - CALL DTRMM( 'Right', 'Upper', 'Transpose', 'Non-Unit', N, K, - $ ONE, T(1,PT22), LDT, DWORK(PDW8), N ) -C -C NZ7) DW4 := DW4 + DW8 -C - CALL DAXPY( N*K, ONE, DWORK(PDW8), 1, DWORK(PDW4), 1 ) - END IF -C -C 9) DW5 := DW2*T33' -C - CALL DCOPY( N*K, DWORK(PDW2), 1, DWORK(PDW5), 1 ) - CALL DTRMM( 'Right', 'Upper', 'Transpose', 'Non-Unit', N, K, - $ ONE, T(1,PT33), LDT, DWORK(PDW5), N ) -C -C 10) DW6 := DW1*T31' -C - CALL DCOPY( N*(K-1), DWORK(PDW1+N), 1, DWORK(PDW6), 1 ) - CALL DTRMM( 'Right', 'Upper', 'Transpose', 'Non-Unit', N, K-1, - $ ONE, T(1,PT31+1), LDT, DWORK(PDW6), N ) -C -C 11) DW5 := DW5 + DW6 -C - CALL DAXPY( N*(K-1), ONE, DWORK(PDW6), 1, DWORK(PDW5), 1 ) -C - IF ( LA1B1 ) THEN -C -C NZ8) DW8 := DW7*T32' -C - CALL DCOPY( N*(K-1), DWORK(PDW7+N), 1, DWORK(PDW8), 1 ) - CALL DTRMM( 'Right', 'Upper', 'Transpose', 'Non-Unit', N, - $ K-1, ONE, T(1,PT32+1), LDT, DWORK(PDW8), N ) -C -C NZ9) DW5 := DW5 + DW8 -C - CALL DAXPY( N*(K-1), ONE, DWORK(PDW8), 1, DWORK(PDW5), 1 ) - END IF -C -C 12) DW1 := DW1*S1' -C - CALL DTRMM( 'Right', 'Upper', 'Transpose', 'Non-Unit', N, K-1, - $ ONE, RS(1,PS1+1), LDRS, DWORK(PDW1+N), N ) -C -C 13) DW2 := DW2*S3' -C - CALL DTRMM( 'Right', 'Upper', 'Transpose', 'Non-Unit', N, K, - $ ONE, RS(1,PS3), LDRS, DWORK(PDW2), N ) -C -C 14) DW2 := DW1 + DW2 -C - CALL DAXPY( N*(K-1), ONE, DWORK(PDW1+N), 1, DWORK(PDW2), 1 ) -C - IF ( LA1B1 ) THEN -C -C NZ10) DW7 := DW7*S2' -C - CALL DTRMM( 'Right', 'Upper', 'Transpose', 'Non-Unit', N, K, - $ ONE, RS(1,PS2), LDRS, DWORK(PDW7), N ) -C -C NZ11) DW2 := DW2 + DW7 -C - CALL DAXPY( N*K, ONE, DWORK(PDW7), 1, DWORK(PDW2), 1 ) - END IF - END IF -C - IF ( LA1B1 ) THEN -C -C NZ12) DW9 := B1' -C - IF ( LTRB ) THEN - DO 30 I = 1, K - CALL DCOPY( N, B(1,I), 1, DWORK(PDW9+(I-1)*N), 1 ) - 30 CONTINUE - ELSE - DO 40 I = 1, N - CALL DCOPY( K, B(1,I), 1, DWORK(PDW9+I-1), N ) - 40 CONTINUE - END IF -C -C NZ13) DW1 := DW9*W1 -C - CALL DCOPY( N*K, DWORK(PDW9), 1, DWORK(PDW1), 1 ) - IF ( LCOLW ) THEN - CALL DTRMM( 'Right', 'Lower', 'No transpose', 'Unit', N, - $ K, ONE, W, LDW, DWORK(PDW1), N ) - ELSE - CALL DTRMM( 'Right', 'Upper', 'Transpose', 'Unit', N, - $ K, ONE, W, LDW, DWORK(PDW1), N ) - END IF -C -C NZ14) DW6 := DW9*V1 -C - CALL DCOPY( N*K, DWORK(PDW9), 1, DWORK(PDW6), 1 ) - IF ( LCOLV ) THEN - CALL DTRMM( 'Right', 'Lower', 'No transpose', 'Unit', N, - $ K, ONE, V, LDV, DWORK(PDW6), N ) - ELSE - CALL DTRMM( 'Right', 'Upper', 'Transpose', 'Unit', N, - $ K, ONE, V, LDV, DWORK(PDW6), N ) - END IF - END IF -C -C 15) DW1 := B2'*W2 -C - IF ( M.GT.K ) THEN - IF ( LTRB.AND.LCOLW ) THEN - CALL DGEMM( 'No Transpose', 'No Transpose', N, K, M-K, ONE, - $ B(1,K+1), LDB, W(K+1,1), LDW, FACT, DWORK(PDW1), - $ N ) - ELSE IF ( LTRB ) THEN -C -C Critical Position -C - CALL DGEMM( 'No Transpose', 'Transpose', N, K, M-K, ONE, - $ B(1,K+1), LDB, W(1,K+1), LDW, FACT, DWORK(PDW1), - $ N ) - ELSE IF ( LCOLW ) THEN - CALL DGEMM( 'Transpose', 'No Transpose', N, K, M-K, ONE, - $ B(K+1,1), LDB, W(K+1,1), LDW, FACT, DWORK(PDW1), - $ N ) - ELSE - CALL DGEMM( 'Transpose', 'Transpose', N, K, M-K, ONE, - $ B(K+1,1), LDB, W(1,K+1), LDW, FACT, DWORK(PDW1), - $ N ) - END IF - ELSE IF ( .NOT.LA1B1 ) THEN - CALL DLASET( 'All', N, K, ZERO, ZERO, DWORK(PDW1), N ) - END IF -C -C 16) DW6 := B2'*V2 -C - IF ( M.GT.K ) THEN - IF ( LTRB.AND.LCOLV ) THEN - CALL DGEMM( 'No Transpose', 'No Transpose', N, K, M-K, ONE, - $ B(1,K+1), LDB, V(K+1,1), LDV, FACT, DWORK(PDW6), - $ N ) - ELSE IF ( LTRB ) THEN - CALL DGEMM( 'No Transpose', 'Transpose', N, K, M-K, ONE, - $ B(1,K+1), LDB, V(1,K+1), LDV, FACT, DWORK(PDW6), - $ N ) - ELSE IF ( LCOLV ) THEN - CALL DGEMM( 'Transpose', 'No Transpose', N, K, M-K, ONE, - $ B(K+1,1), LDB, V(K+1,1), LDV, FACT, DWORK(PDW6), - $ N ) - ELSE - CALL DGEMM( 'Transpose', 'Transpose', N, K, M-K, ONE, - $ B(K+1,1), LDB, V(1,K+1), LDV, FACT, DWORK(PDW6), - $ N ) - END IF - ELSE IF ( .NOT.LA1B1 ) THEN - CALL DLASET( 'All', N, K, ZERO, ZERO, DWORK(PDW6), N ) - END IF -C - IF ( LTRQ ) THEN -C -C 17) DW7 := DW1*R1 -C - CALL DCOPY( N*K, DWORK(PDW1), 1, DWORK(PDW7), 1 ) - CALL DTRMM( 'Right', 'Upper', 'No Transpose', 'Non-Unit', N, K, - $ ONE, RS(1,PR1), LDRS, DWORK(PDW7), N ) -C -C 18) DW8 := DW6*R3 -C - CALL DCOPY( N*(K-1), DWORK(PDW6), 1, DWORK(PDW8), 1 ) - CALL DTRMM( 'Right', 'Upper', 'No Transpose', 'Non-Unit', N, - $ K-1, ONE, RS(1,PR3+1), LDRS, DWORK(PDW8), N ) -C -C 19) DW7 := DW7 + DW8 -C - CALL DAXPY( N*(K-1), ONE, DWORK(PDW8), 1, DWORK(PDW7+N), 1 ) -C - IF ( LA1B1 ) THEN -C -C NZ15) DW8 := DW9*R2 -C - CALL DCOPY( N*K, DWORK(PDW9), 1, DWORK(PDW8), 1 ) - CALL DTRMM( 'Right', 'Upper', 'No Transpose', 'Unit', N, K, - $ ONE, RS(1,PR2), LDRS, DWORK(PDW8), N ) -C -C NZ16) DW7 := DW7 + DW8 -C - CALL DAXPY( N*K, ONE, DWORK(PDW8), 1, DWORK(PDW7), 1 ) - END IF -C -C 20) DW8 := DW7*S1 -C - CALL DCOPY( N*(K-1), DWORK(PDW7), 1, DWORK(PDW8), 1 ) - CALL DTRMM( 'Right', 'Upper', 'No Transpose', 'Non-Unit', N, - $ K-1, ONE, RS(1,PS1+1), LDRS, DWORK(PDW8), N ) -C -C 21) DW3 := DW3 - DW8 -C - CALL DAXPY( N*(K-1), -ONE, DWORK(PDW8), 1, DWORK(PDW3+N), 1 ) -C -C 22) DW8 := DW7*S3 -C - CALL DCOPY( N*K, DWORK(PDW7), 1, DWORK(PDW8), 1 ) - CALL DTRMM( 'Right', 'Upper', 'No Transpose', 'Non-Unit', N, - $ K, ONE, RS(1,PS3), LDRS, DWORK(PDW8), N ) -C -C 23) DW5 := DW5 - DW8 -C - CALL DAXPY( N*K, -ONE, DWORK(PDW8), 1, DWORK(PDW5), 1 ) -C -C 24) DW7 := DW7*S2 -C - CALL DTRMM( 'Right', 'Upper', 'No Transpose', 'Non-Unit', N, K, - $ -ONE, RS(1,PS2), LDRS, DWORK(PDW7), N ) - ELSE -C -C 17) DW7 := DW6*S3' -C - CALL DCOPY( N*K, DWORK(PDW6), 1, DWORK(PDW7), 1 ) - CALL DTRMM( 'Right', 'Upper', 'Transpose', 'Non-Unit', N, K, - $ ONE, RS(1,PS3), LDRS, DWORK(PDW7), N ) -C -C 18) DW8 := DW1*S1' -C - CALL DCOPY( N*(K-1), DWORK(PDW1+N), 1, DWORK(PDW8), 1 ) - CALL DTRMM( 'Right', 'Upper', 'Transpose', 'Non-Unit', N, K-1, - $ ONE, RS(1,PS1+1), LDRS, DWORK(PDW8), N ) -C -C 19) DW7 := DW7 + DW8 -C - CALL DAXPY( N*(K-1), ONE, DWORK(PDW8), 1, DWORK(PDW7), 1 ) -C - IF ( LA1B1 ) THEN -C -C NZ15) DW8 := DW9*S2' -C - CALL DCOPY( N*K, DWORK(PDW9), 1, DWORK(PDW8), 1 ) - CALL DTRMM( 'Right', 'Upper', 'Transpose', 'Non-Unit', N, K, - $ ONE, RS(1,PS2), LDRS, DWORK(PDW8), N ) -C -C NZ16) DW7 := DW7 + DW8 -C - CALL DAXPY( N*K, ONE, DWORK(PDW8), 1, DWORK(PDW7), 1 ) - END IF -C -C 20) DW8 := DW7*R1' -C - CALL DCOPY( N*K, DWORK(PDW7), 1, DWORK(PDW8), 1 ) - CALL DTRMM( 'Right', 'Upper', 'Transpose', 'Non-Unit', N, K, - $ ONE, RS(1,PR1), LDRS, DWORK(PDW8), N ) -C -C 21) DW3 := DW3 + DW8 -C - CALL DAXPY( N*K, ONE, DWORK(PDW8), 1, DWORK(PDW3), 1 ) -C -C 22) DW8 := DW7*R3' -C - CALL DCOPY( N*(K-1), DWORK(PDW7+N), 1, DWORK(PDW8), 1 ) - CALL DTRMM( 'Right', 'Upper', 'Transpose', 'Non-Unit', N, K-1, - $ ONE, RS(1,PR3+1), LDRS, DWORK(PDW8), N ) -C -C 23) DW5 := DW5 + DW8 -C - CALL DAXPY( N*(K-1), ONE, DWORK(PDW8), 1, DWORK(PDW5), 1 ) -C -C 24) DW7 := DW7*R2' -C - CALL DTRMM( 'Right', 'Upper', 'Transpose', 'Unit', N, K, - $ ONE, RS(1,PR2), LDRS, DWORK(PDW7), N ) - END IF -C -C 25) A2 := A2 + W2*DW3' -C - IF ( M.GT.K ) THEN - IF ( LTRA.AND.LCOLW ) THEN - CALL DGEMM( 'No Transpose', 'Transpose', N, M-K, K, ONE, - $ DWORK(PDW3), N, W(K+1,1), LDW, ONE, A(1,K+1), - $ LDA ) - ELSE IF ( LTRA ) THEN - CALL DGEMM( 'No Transpose', 'No Transpose', N, M-K, K, ONE, - $ DWORK(PDW3), N, W(1,K+1), LDW, ONE, A(1,K+1), - $ LDA ) - ELSE IF ( LCOLW ) THEN - CALL DGEMM( 'No Transpose', 'Transpose', M-K, N, K, ONE, - $ W(K+1,1), LDW, DWORK(PDW3), N, ONE, A(K+1,1), - $ LDA ) - ELSE - CALL DGEMM( 'Transpose', 'Transpose', M-K, N, K, ONE, - $ W(1,K+1), LDW, DWORK(PDW3), N, ONE, A(K+1,1), - $ LDA ) - END IF - END IF -C -C 26) A2 := A2 + V2*DW5' -C - IF ( M.GT.K ) THEN - IF ( LTRA.AND.LCOLV ) THEN - CALL DGEMM( 'No Transpose', 'Transpose', N, M-K, K, ONE, - $ DWORK(PDW5), N, V(K+1,1), LDV, ONE, A(1,K+1), - $ LDA ) - ELSE IF ( LTRA ) THEN - CALL DGEMM( 'No Transpose', 'No Transpose', N, M-K, K, ONE, - $ DWORK(PDW5), N, V(1,K+1), LDV, ONE, A(1,K+1), - $ LDA ) - ELSE IF ( LCOLV ) THEN - CALL DGEMM( 'No Transpose', 'Transpose', M-K, N, K, ONE, - $ V(K+1,1), LDV, DWORK(PDW5), N, ONE, A(K+1,1), - $ LDA ) - ELSE - CALL DGEMM( 'Transpose', 'Transpose', M-K, N, K, ONE, - $ V(1,K+1), LDV, DWORK(PDW5), N, ONE, A(K+1,1), - $ LDA ) - END IF - END IF -C -C 27) DW4 := DW4 + DW7 -C - CALL DAXPY( N*K, ONE, DWORK(PDW7), 1, DWORK(PDW4), 1 ) -C -C 28) DW3 := DW3*W1' -C - IF ( LCOLW ) THEN - CALL DTRMM( 'Right', 'Lower', 'Transpose', 'Unit', N, K, ONE, - $ W, LDW, DWORK(PDW3), N ) - ELSE - CALL DTRMM( 'Right', 'Upper', 'No Transpose', 'Unit', N, K, - $ ONE, W, LDW, DWORK(PDW3), N ) - END IF -C -C 29) DW4 := DW4 + DW3 -C - CALL DAXPY( N*K, ONE, DWORK(PDW3), 1, DWORK(PDW4), 1 ) -C -C 30) DW5 := DW5*V1' -C - IF ( LCOLV ) THEN - CALL DTRMM( 'Right', 'Lower', 'Transpose', 'Unit', N, K, ONE, - $ V, LDV, DWORK(PDW5), N ) - ELSE - CALL DTRMM( 'Right', 'Upper', 'No Transpose', 'Unit', N, K, - $ ONE, V, LDV, DWORK(PDW5), N ) - END IF -C -C 31) DW4 := DW4 + DW5 -C - CALL DAXPY( N*K, ONE, DWORK(PDW5), 1, DWORK(PDW4), 1 ) -C -C 32) A1 := A1 + DW4' -C - IF ( LA1B1 ) THEN - IF ( LTRA ) THEN - DO 50 I = 1, K - CALL DAXPY( N, ONE, DWORK(PDW4+(I-1)*N), 1, A(1,I), 1 ) - 50 CONTINUE - ELSE - DO 60 I = 1, N - CALL DAXPY( K, ONE, DWORK(PDW4+I-1), N, A(1,I), 1 ) - 60 CONTINUE - END IF - ELSE - IF ( LTRA ) THEN - DO 70 I = 1, K - CALL DCOPY( N, DWORK(PDW4+(I-1)*N), 1, A(1,I), 1 ) - 70 CONTINUE - ELSE - DO 80 I = 1, N - CALL DCOPY( K, DWORK(PDW4+I-1), N, A(1,I), 1 ) - 80 CONTINUE - END IF - END IF -C -C Update the matrix B. -C - IF ( LTRQ ) THEN -C -C 33) DW3 := DW1*T11 -C - CALL DCOPY( N*K, DWORK(PDW1), 1, DWORK(PDW3), 1 ) - CALL DTRMM( 'Right', 'Upper', 'No Transpose', 'Non-Unit', N, K, - $ ONE, T(1,PT11), LDT, DWORK(PDW3), N ) -C -C 34) DW4 := DW6*T31 -C - CALL DCOPY( N*(K-1), DWORK(PDW6), 1, DWORK(PDW4), 1 ) - CALL DTRMM( 'Right', 'Upper', 'No Transpose', 'Non-Unit', N, - $ K-1, ONE, T(1,PT31+1), LDT, DWORK(PDW4), N ) -C -C 35) DW3 := DW3 + DW4 -C - CALL DAXPY( N*(K-1), ONE, DWORK(PDW4), 1, DWORK(PDW3+N), 1 ) -C - IF ( LA1B1 ) THEN -C -C NZ17) DW8 := DW9*T21 -C - CALL DCOPY( N*(K-1), DWORK(PDW9), 1, DWORK(PDW8), 1 ) - CALL DTRMM( 'Right', 'Upper', 'No Transpose', 'Non-Unit', N, - $ K-1, ONE, T(1,PT21+1), LDT, DWORK(PDW8), N ) -C -C NZ18) DW3 := DW3 + DW8 -C - CALL DAXPY( N*(K-1), ONE, DWORK(PDW8), 1, DWORK(PDW3+N), 1 ) - END IF -C -C 36) DW4 := DW2*S1 -C - CALL DCOPY( N*(K-1), DWORK(PDW2), 1, DWORK(PDW4), 1 ) - CALL DTRMM( 'Right', 'Upper', 'No Transpose', 'Non-Unit', N, - $ K-1, ONE, RS(1,PS1+1), LDRS, DWORK(PDW4), N ) -C -C 37) DW3 := DW3 + DW4 -C - CALL DAXPY( N*(K-1), ONE, DWORK(PDW4), 1, DWORK(PDW3+N), 1 ) -C -C 38) DW4 := DW1*T12 -C - CALL DCOPY( N*K, DWORK(PDW1), 1, DWORK(PDW4), 1 ) - CALL DTRMM( 'Right', 'Upper', 'No Transpose', 'Non-Unit', N, K, - $ ONE, T(1,PT12), LDT, DWORK(PDW4), N ) -C -C 38) DW5 := DW6*T32 -C - CALL DCOPY( N*(K-1), DWORK(PDW6), 1, DWORK(PDW5), 1 ) - CALL DTRMM( 'Right', 'Upper', 'No Transpose', 'Non-Unit', N, - $ K-1, ONE, T(1,PT32+1), LDT, DWORK(PDW5), N ) -C -C 40) DW4 := DW4 + DW5 -C - CALL DAXPY( N*(K-1), ONE, DWORK(PDW5), 1, DWORK(PDW4+N), 1 ) -C - IF ( LA1B1 ) THEN -C -C NZ19) DW8 := DW9*T22 -C - CALL DCOPY( N*K, DWORK(PDW9), 1, DWORK(PDW8), 1 ) - CALL DTRMM( 'Right', 'Upper', 'No Transpose', 'Non-Unit', N, - $ K, ONE, T(1,PT22), LDT, DWORK(PDW8), N ) -C -C NZ20) DW4 := DW4 + DW8 -C - CALL DAXPY( N*K, ONE, DWORK(PDW8), 1, DWORK(PDW4), 1 ) - END IF -C -C 41) DW5 := DW2*S2 -C - CALL DCOPY( N*K, DWORK(PDW2), 1, DWORK(PDW5), 1 ) - CALL DTRMM( 'Right', 'Upper', 'No Transpose', 'Non-Unit', N, K, - $ ONE, RS(1,PS2), LDRS, DWORK(PDW5), N ) -C -C 42) DW4 := DW4 + DW5 -C - CALL DAXPY( N*K, ONE, DWORK(PDW5), 1, DWORK(PDW4), 1 ) -C -C 43) DW6 := DW6*T33 -C - CALL DTRMM( 'Right', 'Upper', 'No Transpose', 'Non-Unit', N, K, - $ ONE, T(1,PT33), LDT, DWORK(PDW6), N ) -C -C 44) DW1 := DW1*T13 -C - CALL DTRMM( 'Right', 'Upper', 'No Transpose', 'Non-Unit', N, K, - $ ONE, T(1,PT13), LDT, DWORK(PDW1), N ) -C -C 45) DW6 := DW6 + DW1 -C - CALL DAXPY( N*K, ONE, DWORK(PDW1), 1, DWORK(PDW6), 1 ) -C - IF ( LA1B1 ) THEN -C -C NZ19) DW9 := DW9*T23 -C - CALL DTRMM( 'Right', 'Upper', 'No Transpose', 'Non-Unit', N, - $ K, ONE, T(1,PT23), LDT, DWORK(PDW9), N ) -C -C NZ20) DW6 := DW6 + DW9 -C - CALL DAXPY( N*K, ONE, DWORK(PDW9), 1, DWORK(PDW6), 1 ) - END IF -C -C 46) DW2 := DW2*S3 -C - CALL DTRMM( 'Right', 'Upper', 'No Transpose', 'Non-Unit', N, K, - $ ONE, RS(1,PS3), LDRS, DWORK(PDW2), N ) -C -C 45) DW6 := DW6 + DW2 -C - CALL DAXPY( N*K, ONE, DWORK(PDW2), 1, DWORK(PDW6), 1 ) - ELSE -C -C 33) DW3 := DW1*T11' -C - CALL DCOPY( N*K, DWORK(PDW1), 1, DWORK(PDW3), 1 ) - CALL DTRMM( 'Right', 'Upper', 'Transpose', 'Non-Unit', N, K, - $ ONE, T(1,PT11), LDT, DWORK(PDW3), N ) -C -C 34) DW4 := DW6*T13' -C - CALL DCOPY( N*K, DWORK(PDW6), 1, DWORK(PDW4), 1 ) - CALL DTRMM( 'Right', 'Upper', 'Transpose', 'Non-Unit', N, K, - $ ONE, T(1,PT13), LDT, DWORK(PDW4), N ) -C -C 35) DW3 := DW3 + DW4 -C - CALL DAXPY( N*K, ONE, DWORK(PDW4), 1, DWORK(PDW3), 1 ) -C - IF ( LA1B1 ) THEN -C -C NZ17) DW8 := DW9*T12' -C - CALL DCOPY( N*K, DWORK(PDW9), 1, DWORK(PDW8), 1 ) - CALL DTRMM( 'Right', 'Upper', 'Transpose', 'Non-Unit', N, K, - $ ONE, T(1,PT12), LDT, DWORK(PDW8), N ) -C -C NZ18) DW3 := DW3 + DW8 -C - CALL DAXPY( N*K, ONE, DWORK(PDW8), 1, DWORK(PDW3), 1 ) - END IF -C -C 36) DW4 := DW2*R1' -C - CALL DCOPY( N*K, DWORK(PDW2), 1, DWORK(PDW4), 1 ) - CALL DTRMM( 'Right', 'Upper', 'Transpose', 'Non-Unit', N, K, - $ ONE, RS(1,PR1), LDRS, DWORK(PDW4), N ) -C -C 37) DW3 := DW3 - DW4 -C - CALL DAXPY( N*K, -ONE, DWORK(PDW4), 1, DWORK(PDW3), 1 ) -C -C 38) DW4 := DW6*T23' -C - CALL DCOPY( N*K, DWORK(PDW6), 1, DWORK(PDW4), 1 ) - CALL DTRMM( 'Right', 'Upper', 'Transpose', 'Non-Unit', N, K, - $ ONE, T(1,PT23), LDT, DWORK(PDW4), N ) -C -C 39) DW5 := DW1*T21' -C - CALL DCOPY( N*(K-1), DWORK(PDW1+N), 1, DWORK(PDW5), 1 ) - CALL DTRMM( 'Right', 'Upper', 'Transpose', 'Non-Unit', N, K-1, - $ ONE, T(1,PT21+1), LDT, DWORK(PDW5), N ) -C -C 40) DW4 := DW4 + DW5 -C - CALL DAXPY( N*(K-1), ONE, DWORK(PDW5), 1, DWORK(PDW4), 1 ) -C - IF ( LA1B1 ) THEN -C -C NZ19) DW8 := DW9*T22' -C - CALL DCOPY( N*K, DWORK(PDW9), 1, DWORK(PDW8), 1 ) - CALL DTRMM( 'Right', 'Upper', 'Transpose', 'Non-Unit', N, K, - $ ONE, T(1,PT22), LDT, DWORK(PDW8), N ) -C -C NZ20) DW4 := DW4 + DW8 -C - CALL DAXPY( N*K, ONE, DWORK(PDW8), 1, DWORK(PDW4), 1 ) - END IF -C -C 41) DW5 := DW2*R2' -C - CALL DCOPY( N*K, DWORK(PDW2), 1, DWORK(PDW5), 1 ) - CALL DTRMM( 'Right', 'Upper', 'Transpose', 'Unit', N, K, - $ ONE, RS(1,PR2), LDRS, DWORK(PDW5), N ) -C -C 42) DW4 := DW4 - DW5 -C - CALL DAXPY( N*K, -ONE, DWORK(PDW5), 1, DWORK(PDW4), 1 ) -C -C 43) DW6 := DW6*T33' -C - CALL DTRMM( 'Right', 'Upper', 'Transpose', 'Non-Unit', N, K, - $ ONE, T(1,PT33), LDT, DWORK(PDW6), N ) -C -C 44) DW1 := DW1*T31' -C - CALL DTRMM( 'Right', 'Upper', 'Transpose', 'Non-Unit', N, K-1, - $ ONE, T(1,PT31+1), LDT, DWORK(PDW1+N), N ) -C -C 45) DW6 := DW6 + DW1 -C - CALL DAXPY( N*(K-1), ONE, DWORK(PDW1+N), 1, DWORK(PDW6), 1 ) -C - IF ( LA1B1 ) THEN -C -C NZ19) DW9 := DW9*T32' -C - CALL DTRMM( 'Right', 'Upper', 'Transpose', 'Non-Unit', N, - $ K-1, ONE, T(1,PT32+1), LDT, DWORK(PDW9+N), N ) -C -C NZ20) DW6 := DW6 + DW9 -C - CALL DAXPY( N*(K-1), ONE, DWORK(PDW9+N), 1, DWORK(PDW6), 1 ) - END IF -C -C 46) DW2 := DW2*R3' -C - CALL DTRMM( 'Right', 'Upper', 'Transpose', 'Non-Unit', N, K-1, - $ ONE, RS(1,PR3+1), LDRS, DWORK(PDW2+N), N ) -C -C 45) DW6 := DW6 - DW2 -C - CALL DAXPY( N*(K-1), -ONE, DWORK(PDW2+N), 1, DWORK(PDW6), 1 ) - END IF -C -C 46) B2 := B2 + W2*DW3' -C - IF ( M.GT.K ) THEN - IF ( LTRB.AND.LCOLW ) THEN - CALL DGEMM( 'No Transpose', 'Transpose', N, M-K, K, ONE, - $ DWORK(PDW3), N, W(K+1,1), LDW, ONE, B(1,K+1), - $ LDB ) - ELSE IF ( LTRB ) THEN - CALL DGEMM( 'No Transpose', 'No Transpose', N, M-K, K, ONE, - $ DWORK(PDW3), N, W(1,K+1), LDW, ONE, B(1,K+1), - $ LDB ) - ELSE IF ( LCOLW ) THEN - CALL DGEMM( 'No Transpose', 'Transpose', M-K, N, K, ONE, - $ W(K+1,1), LDW, DWORK(PDW3), N, ONE, B(K+1,1), - $ LDB ) - ELSE - CALL DGEMM( 'Transpose', 'Transpose', M-K, N, K, ONE, - $ W(1,K+1), LDW, DWORK(PDW3), N, ONE, B(K+1,1), - $ LDB ) - END IF - END IF -C -C 47) B2 := B2 + V2*DW6' -C - IF ( M.GT.K ) THEN - IF ( LTRB.AND.LCOLV ) THEN - CALL DGEMM( 'No Transpose', 'Transpose', N, M-K, K, ONE, - $ DWORK(PDW6), N, V(K+1,1), LDV, ONE, B(1,K+1), - $ LDB ) - ELSE IF ( LTRB ) THEN - CALL DGEMM( 'No Transpose', 'No Transpose', N, M-K, K, ONE, - $ DWORK(PDW6), N, V(1,K+1), LDV, ONE, B(1,K+1), - $ LDB ) - ELSE IF ( LCOLV ) THEN - CALL DGEMM( 'No Transpose', 'Transpose', M-K, N, K, ONE, - $ V(K+1,1), LDV, DWORK(PDW6), N, ONE, B(K+1,1), - $ LDB ) - ELSE - CALL DGEMM( 'Transpose', 'Transpose', M-K, N, K, ONE, - $ V(1,K+1), LDV, DWORK(PDW6), N, ONE, B(K+1,1), - $ LDB ) - END IF - END IF -C -C 48) DW3 := DW3*W1' -C - IF ( LCOLW ) THEN - CALL DTRMM( 'Right', 'Lower', 'Transpose', 'Unit', N, K, ONE, - $ W, LDW, DWORK(PDW3), N ) - ELSE - CALL DTRMM( 'Right', 'Upper', 'No Transpose', 'Unit', N, K, - $ ONE, W, LDW, DWORK(PDW3), N ) - END IF -C -C 49) DW4 := DW4 + DW3 -C - CALL DAXPY( N*K, ONE, DWORK(PDW3), 1, DWORK(PDW4), 1 ) -C -C 50) DW6 := DW6*V1' -C - IF ( LCOLV ) THEN - CALL DTRMM( 'Right', 'Lower', 'Transpose', 'Unit', N, K, ONE, - $ V, LDV, DWORK(PDW6), N ) - ELSE - CALL DTRMM( 'Right', 'Upper', 'No Transpose', 'Unit', N, K, - $ ONE, V, LDV, DWORK(PDW6), N ) - END IF -C -C 51) DW4 := DW4 + DW6 -C - CALL DAXPY( N*K, ONE, DWORK(PDW6), 1, DWORK(PDW4), 1 ) -C -C 52) B1 := B1 + DW4' -C - IF ( LA1B1 ) THEN - IF ( LTRB ) THEN - DO 90 I = 1, K - CALL DAXPY( N, ONE, DWORK(PDW4+(I-1)*N), 1, B(1,I), 1 ) - 90 CONTINUE - ELSE - DO 100 I = 1, N - CALL DAXPY( K, ONE, DWORK(PDW4+I-1), N, B(1,I), 1 ) - 100 CONTINUE - END IF - ELSE - IF ( LTRB ) THEN - DO 110 I = 1, K - CALL DCOPY( N, DWORK(PDW4+(I-1)*N), 1, B(1,I), 1 ) - 110 CONTINUE - ELSE - DO 120 I = 1, N - CALL DCOPY( K, DWORK(PDW4+I-1), N, B(1,I), 1 ) - 120 CONTINUE - END IF - END IF -C - RETURN -C *** Last line of MB04QC *** - END diff --git a/mex/sources/libslicot/MB04QF.f b/mex/sources/libslicot/MB04QF.f deleted file mode 100644 index f2be26ce0..000000000 --- a/mex/sources/libslicot/MB04QF.f +++ /dev/null @@ -1,532 +0,0 @@ - SUBROUTINE MB04QF( DIRECT, STOREV, STOREW, N, K, V, LDV, W, LDW, - $ CS, TAU, RS, LDRS, T, LDT, DWORK ) -C -C SLICOT RELEASE 5.0. -C -C Copyright (c) 2002-2009 NICONET e.V. -C -C This program is free software: you can redistribute it and/or -C modify it under the terms of the GNU General Public License as -C published by the Free Software Foundation, either version 2 of -C the License, or (at your option) any later version. -C -C This program is distributed in the hope that it will be useful, -C but WITHOUT ANY WARRANTY; without even the implied warranty of -C MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the -C GNU General Public License for more details. -C -C You should have received a copy of the GNU General Public License -C along with this program. If not, see -C . -C -C PURPOSE -C -C To form the triangular block factors R, S and T of a symplectic -C block reflector SH, which is defined as a product of 2k -C concatenated Householder reflectors and k Givens rotators, -C -C SH = diag( H(1),H(1) ) G(1) diag( F(1),F(1) ) -C diag( H(2),H(2) ) G(2) diag( F(2),F(2) ) -C .... -C diag( H(k),H(k) ) G(k) diag( F(k),F(k) ). -C -C The upper triangular blocks of the matrices -C -C [ S1 ] [ T11 T12 T13 ] -C R = [ R1 R2 R3 ], S = [ S2 ], T = [ T21 T22 T23 ], -C [ S3 ] [ T31 T32 T33 ] -C -C with R2 unit and S1, R3, T21, T31, T32 strictly upper triangular, -C are stored rowwise in the arrays RS and T, respectively. -C -C ARGUMENTS -C -C Mode Parameters -C -C DIRECT CHARACTER*1 -C This is a dummy argument, which is reserved for future -C extensions of this subroutine. Not referenced. -C -C STOREV CHARACTER*1 -C Specifies how the vectors which define the concatenated -C Householder F(i) reflectors are stored: -C = 'C': columnwise; -C = 'R': rowwise. -C -C STOREW CHARACTER*1 -C Specifies how the vectors which define the concatenated -C Householder H(i) reflectors are stored: -C = 'C': columnwise; -C = 'R': rowwise. -C -C Input/Output Parameters -C -C N (input) INTEGER -C The order of the Householder reflectors F(i) and H(i). -C N >= 0. -C -C K (input) INTEGER -C The number of Givens rotators. K >= 1. -C -C V (input) DOUBLE PRECISION array, dimension -C (LDV,K) if STOREV = 'C', -C (LDV,N) if STOREV = 'R' -C On entry with STOREV = 'C', the leading N-by-K part of -C this array must contain in its i-th column the vector -C which defines the elementary reflector F(i). -C On entry with STOREV = 'R', the leading K-by-N part of -C this array must contain in its i-th row the vector -C which defines the elementary reflector F(i). -C -C LDV INTEGER -C The leading dimension of the array V. -C LDV >= MAX(1,N), if STOREV = 'C'; -C LDV >= K, if STOREV = 'R'. -C -C W (input) DOUBLE PRECISION array, dimension -C (LDW,K) if STOREW = 'C', -C (LDW,N) if STOREW = 'R' -C On entry with STOREW = 'C', the leading N-by-K part of -C this array must contain in its i-th column the vector -C which defines the elementary reflector H(i). -C On entry with STOREV = 'R', the leading K-by-N part of -C this array must contain in its i-th row the vector -C which defines the elementary reflector H(i). -C -C LDW INTEGER -C The leading dimension of the array W. -C LDW >= MAX(1,N), if STOREW = 'C'; -C LDW >= K, if STOREW = 'R'. -C -C CS (input) DOUBLE PRECISION array, dimension (2*K) -C On entry, the first 2*K elements of this array must -C contain the cosines and sines of the symplectic Givens -C rotators G(i). -C -C TAU (input) DOUBLE PRECISION array, dimension (K) -C On entry, the first K elements of this array must -C contain the scalar factors of the elementary reflectors -C F(i). -C -C RS (output) DOUBLE PRECISION array, dimension (K,6*K) -C On exit, the leading K-by-6*K part of this array contains -C the upper triangular matrices defining the factors R and -C S of the symplectic block reflector SH. The (strictly) -C lower portions of this array are not used. -C -C LDRS INTEGER -C The leading dimension of the array RS. LDRS >= K. -C -C T (output) DOUBLE PRECISION array, dimension (K,9*K) -C On exit, the leading K-by-9*K part of this array contains -C the upper triangular matrices defining the factor T of the -C symplectic block reflector SH. The (strictly) lower -C portions of this array are not used. -C -C LDT INTEGER -C The leading dimension of the array T. LDT >= K. -C -C Workspace -C -C DWORK DOUBLE PRECISION array, dimension (3*K) -C -C REFERENCES -C -C [1] Kressner, D. -C Block algorithms for orthogonal symplectic factorizations. -C BIT, 43 (4), pp. 775-790, 2003. -C -C NUMERICAL ASPECTS -C -C The algorithm requires ( 4*K - 2 )*K*N + 19/3*K*K*K + 1/2*K*K -C + 43/6*K - 4 floating point operations. -C -C CONTRIBUTORS -C -C D. Kressner, Technical Univ. Berlin, Germany, and -C P. Benner, Technical Univ. Chemnitz, Germany, December 2003. -C -C REVISIONS -C -C V. Sima, June 2008 (SLICOT version of the HAPACK routine DLAEST). -C -C KEYWORDS -C -C Elementary matrix operations, orthogonal symplectic matrix. -C -C ****************************************************************** -C -C .. Parameters .. - DOUBLE PRECISION ZERO, ONE - PARAMETER ( ZERO = 0.0D0, ONE = 1.0D0 ) -C .. Scalar Arguments .. - CHARACTER DIRECT, STOREV, STOREW - INTEGER K, LDRS, LDT, LDV, LDW, N -C .. Array Arguments .. - DOUBLE PRECISION CS(*), DWORK(*), RS(LDRS,*), T(LDT,*), - $ TAU(*), V(LDV,*), W(LDW,*) -C .. Local Scalars .. - LOGICAL LCOLV, LCOLW - INTEGER I, J, K2, PR1, PR2, PR3, PS1, PS2, PS3, PT11, - $ PT12, PT13, PT21, PT22, PT23, PT31, PT32, PT33 - DOUBLE PRECISION CM1, TAUI, VII, WII -C .. External Functions .. - LOGICAL LSAME - EXTERNAL LSAME -C .. External Subroutines .. - EXTERNAL DAXPY, DCOPY, DGEMV, DSCAL, DTRMV -C -C .. Executable Statements .. -C -C Quick return if possible. -C - IF ( N.EQ.0 ) - $ RETURN -C - LCOLV = LSAME( STOREV, 'C' ) - LCOLW = LSAME( STOREW, 'C' ) -C - K2 = K + K - PR1 = 0 - PR2 = PR1 + K - PR3 = PR2 + K - PS1 = PR3 + K - PS2 = PS1 + K - PS3 = PS2 + K -C - PT11 = 0 - PT12 = PT11 + K - PT13 = PT12 + K - PT21 = PT13 + K - PT22 = PT21 + K - PT23 = PT22 + K - PT31 = PT23 + K - PT32 = PT31 + K - PT33 = PT32 + K -C - DO 90 I = 1, K - TAUI = TAU(I) - VII = V(I,I) - V(I,I) = ONE - WII = W(I,I) - W(I,I) = ONE - IF ( WII.EQ.ZERO ) THEN - DO 10 J = 1, I - T(J,PT11+I) = ZERO - 10 CONTINUE - DO 20 J = 1, I-1 - T(J,PT21+I) = ZERO - 20 CONTINUE - DO 30 J = 1, I-1 - T(J,PT31+I) = ZERO - 30 CONTINUE - DO 40 J = 1, I-1 - RS(J,PS1+I) = ZERO - 40 CONTINUE - ELSE -C -C Treat first Householder reflection. -C - IF ( LCOLV.AND.LCOLW ) THEN -C -C Compute t1 = -wii * W(i:n,1:i-1)' * W(i:n,i). -C - CALL DGEMV( 'Transpose', N-I+1, I-1, -WII, W(I,1), LDW, - $ W(I,I), 1, ZERO, DWORK, 1 ) -C -C Compute t2 = -wii * V(i:n,1:i-1)' * W(i:n,i). -C - CALL DGEMV( 'Transpose', N-I+1, I-1, -WII, V(I,1), LDV, - $ W(I,I), 1, ZERO, DWORK(K+1), 1 ) - ELSE IF ( LCOLV ) THEN -C -C Compute t1 = -wii * W(1:i-1,i:n) * W(i,i:n)'. -C - CALL DGEMV( 'No Transpose', I-1, N-I+1, -WII, W(1,I), - $ LDW, W(I,I), LDW, ZERO, DWORK, 1 ) -C -C Compute t2 = -wii * V(i:n,1:i-1)' * W(i,i:n)'. -C - CALL DGEMV( 'Transpose', N-I+1, I-1, -WII, V(I,1), LDV, - $ W(I,I), LDW, ZERO, DWORK(K+1), 1 ) - ELSE IF ( LCOLW ) THEN -C -C Compute t1 = -wii * W(i:n,1:i-1)' * W(i:n,i). -C - CALL DGEMV( 'Transpose', N-I+1, I-1, -WII, W(I,1), LDW, - $ W(I,I), 1, ZERO, DWORK, 1 ) -C -C Compute t2 = -wii * V(1:i-1,i:n) * W(i:n,i). -C - CALL DGEMV( 'No Transpose', I-1, N-I+1, -WII, V(1,I), - $ LDV, W(I,I), 1, ZERO, DWORK(K+1), 1 ) - ELSE -C -C Compute t1 = -wii * W(1:i-1,i:n) * W(i,i:n)'. -C - CALL DGEMV( 'No Transpose', I-1, N-I+1, -WII, W(1,I), - $ LDW, W(I,I), LDW, ZERO, DWORK, 1 ) -C -C Compute t2 = -wii * V(1:i-1,i:n) * W(i,i:n)'. -C - CALL DGEMV( 'No Transpose', I-1, N-I+1, -WII, V(1,I), - $ LDV, W(I,I), LDW, ZERO, DWORK(K+1), 1 ) - END IF -C -C T11(1:i-1,i) := T11(1:i-1,1:i-1)*t1 + T13(1:i-1,1:i-1)*t2 -C - CALL DCOPY( I-1, DWORK, 1, T(1,PT11+I), 1 ) - CALL DTRMV( 'Upper', 'No transpose', 'Non-unit', I-1, - $ T(1,PT11+1), LDT, T(1,PT11+I), 1 ) - CALL DCOPY( I-1, DWORK(K+1), 1, T(1,PT13+I), 1 ) - CALL DTRMV( 'Upper', 'No transpose', 'Non-unit', I-1, - $ T(1,PT13+1), LDT, T(1,PT13+I), 1 ) - CALL DAXPY( I-1, ONE, T(1,PT13+I), 1, T(1,PT11+I), 1 ) - T(I,PT11+I) = -WII -C - IF ( I.GT.1 ) THEN -C -C T21(1:i-1,i) := T21(1:i-1,1:i-1)*t1 + T23(1:i-1,1:i-1)*t2 -C - CALL DCOPY( I-2, DWORK(2), 1, T(1,PT21+I), 1 ) - CALL DTRMV( 'Upper', 'No transpose', 'Non-unit', I-2, - $ T(1,PT21+2), LDT, T(1,PT21+I), 1 ) - T(I-1, PT21+I) = ZERO - CALL DCOPY( I-1, DWORK(K+1), 1, T(1,PT23+I), 1 ) - CALL DTRMV( 'Upper', 'No transpose', 'Non-unit', I-1, - $ T(1,PT23+1), LDT, T(1,PT23+I), 1 ) - CALL DAXPY( I-1, ONE, T(1,PT23+I), 1, T(1,PT21+I), 1 ) -C -C T31(1:i-1,i) := T31(1:i-1,1:i-1)*t1 + T33(1:i-1,1:i-1)*t2 -C - CALL DCOPY( I-2, DWORK(2), 1, T(1,PT31+I), 1 ) - CALL DTRMV( 'Upper', 'No transpose', 'Non-unit', I-2, - $ T(1,PT31+2), LDT, T(1,PT31+I), 1 ) - T(I-1, PT31+I) = ZERO - CALL DCOPY( I-1, DWORK(K+1), 1, T(1,PT33+I), 1 ) - CALL DTRMV( 'Upper', 'No transpose', 'Non-unit', I-1, - $ T(1,PT33+1), LDT, T(1,PT33+I), 1 ) - CALL DAXPY( I-1, ONE, T(1,PT33+I), 1, T(1,PT31+I), 1 ) -C -C S1(1:i-1,i) := S1(1:i-1,1:i-1)*t1 + S3(1:i-1,1:i-1)*t2 -C - CALL DCOPY( I-2, DWORK(2), 1, RS(1,PS1+I), 1 ) - CALL DTRMV( 'Upper', 'No transpose', 'Non-unit', I-2, - $ RS(1,PS1+2), LDRS, RS(1,PS1+I), 1 ) - RS(I-1, PS1+I) = ZERO - CALL DCOPY( I-1, DWORK(K+1), 1, RS(1,PS3+I), 1 ) - CALL DTRMV( 'Upper', 'No transpose', 'Non-unit', I-1, - $ RS(1,PS3+1), LDRS, RS(1,PS3+I), 1 ) - CALL DAXPY( I-1, ONE, RS(1,PS3+I), 1, RS(1,PS1+I), 1 ) - END IF - END IF -C -C Treat Givens rotation. -C - CM1 = CS(2*I-1) - ONE - IF ( LCOLW ) THEN - CALL DCOPY( I, W(I,1), LDW, DWORK, 1 ) - ELSE - CALL DCOPY( I, W(1,I), 1, DWORK, 1 ) - END IF - IF ( LCOLV ) THEN - CALL DCOPY( I-1, V(I,1), LDV, DWORK(K+1), 1 ) - ELSE - CALL DCOPY( I-1, V(1,I), 1, DWORK(K+1), 1 ) - END IF -C -C R1(1:i,i) = T11(1:i,1:i) * dwork(1:i) -C + [ T13(1:i-1,1:i-1) * dwork(k+1:k+i-1); 0 ] -C - CALL DCOPY( I, DWORK, 1, RS(1,PR1+I), 1 ) - CALL DTRMV( 'Upper', 'No transpose', 'Non-unit', I, - $ T(1,PT11+1), LDT, RS(1,PR1+I), 1 ) - CALL DCOPY( I-1, DWORK(K+1), 1, T(1,PT13+I), 1 ) - CALL DTRMV( 'Upper', 'No transpose', 'Non-unit', I-1, - $ T(1,PT13+1), LDT, T(1,PT13+I), 1 ) - CALL DAXPY( I-1, ONE, T(1,PT13+I), 1, RS(1,PR1+I), 1 ) -C -C R2(1:i-1,i) = T21(1:i-1,2:i) * W(i,2:i) -C + T23(1:i-1,1:i-1) * V(i,1:i-1) -C - CALL DCOPY( I-1, DWORK(2), 1, RS(1,PR2+I), 1 ) - CALL DTRMV( 'Upper', 'No transpose', 'Non-unit', I-1, - $ T(1,PT21+2), LDT, RS(1,PR2+I), 1 ) - CALL DCOPY( I-1, DWORK(K+1), 1, T(1,PT23+I), 1 ) - CALL DTRMV( 'Upper', 'No transpose', 'Non-unit', I-1, - $ T(1,PT23+1), LDT, T(1,PT23+I), 1 ) - CALL DAXPY( I-1, ONE, T(1,PT23+I), 1, RS(1,PR2+I), 1 ) -C -C R3(1:i-1,i) = T31(1:i-1,2:i) * dwork(2:i) -C + T33(1:i-1,1:i-1) * dwork(k+1:k+i-1) -C - CALL DCOPY( I-1, DWORK(2), 1, RS(1,PR3+I), 1 ) - CALL DTRMV( 'Upper', 'No transpose', 'Non-unit', I-1, - $ T(1,PT31+2), LDT, RS(1,PR3+I), 1 ) - CALL DCOPY( I-1, DWORK(K+1), 1, T(1,PT33+I), 1 ) - CALL DTRMV( 'Upper', 'No transpose', 'Non-unit', I-1, - $ T(1,PT33+1), LDT, T(1,PT33+I), 1 ) - CALL DAXPY( I-1, ONE, T(1,PT33+I), 1, RS(1,PR3+I), 1 ) -C -C S2(1:i-1,i) = S1(1:i-1,2:i) * dwork(2:i) -C + S3(1:i-1,1:i-1) * dwork(k+1:k+i-1) -C - CALL DCOPY( I-1, DWORK(2), 1, RS(1,PS2+I), 1 ) - CALL DTRMV( 'Upper', 'No transpose', 'Non-unit', I-1, - $ RS(1,PS1+2), LDRS, RS(1,PS2+I), 1 ) - CALL DTRMV( 'Upper', 'No transpose', 'Non-unit', I-1, - $ RS(1,PS3+1), LDRS, DWORK(K+1), 1 ) - CALL DAXPY( I-1, ONE, DWORK(K+1), 1, RS(1,PS2+I), 1 ) - RS(I,PS2+I) = -CS(2*I) -C -C T12(1:i,i) = [ R1(1:i-1,1:i-1)*S2(1:i-1,i); 0 ] -C + (c-1) * R1(1:i,i) -C - CALL DCOPY( I-1, RS(1,PS2+I), 1, T(1,PT12+I), 1 ) - CALL DSCAL( I-1, CM1, RS(1,PS2+I), 1) - CALL DSCAL( I-1, CS(2*I), T(1,PT12+I), 1 ) - CALL DCOPY( I-1, T(1,PT12+I), 1, T(1,PT22+I), 1 ) - CALL DTRMV( 'Upper', 'No transpose', 'Non-unit', I-1, - $ RS(1,PR1+1), LDRS, T(1,PT12+I), 1 ) - T(I,PT12+I) = ZERO - CALL DAXPY( I, CM1, RS(1,PR1+I), 1, T(1,PT12+I), 1 ) -C -C T22(1:i-1,i) = R2(1:i-1,1:i-1)*S2(1:i-1,i) + (c-1)*R2(1:i-1,i) -C - IF (I.GT.1) - $ CALL DCOPY( I-2, T(2,PT22+I), 1, T(1,PT32+I), 1 ) - CALL DTRMV( 'Upper', 'No transpose', 'Unit diagonal', I-1, - $ RS(1,PR2+1), LDRS, T(1,PT22+I), 1 ) - CALL DAXPY( I-1, CM1, RS(1,PR2+I), 1, T(1,PT22+I), 1 ) - T(I,PT22+I) = CM1 -C -C T32(1:i-1,i) = R3(1:i-1,1:i-1)*S2(1:i-1,i) + (c-1)*R3(1:i-1,i) -C - IF ( I.GT.1 ) THEN - CALL DTRMV( 'Upper', 'No transpose', 'Non-Unit', I-2, - $ RS(1,PR3+2), LDRS, T(1,PT32+I), 1 ) - T(I-1,PT32+I) = ZERO - CALL DAXPY( I-1, CM1, RS(1,PR3+I), 1, T(1,PT32+I), 1 ) - END IF -C - IF ( TAUI.EQ.ZERO ) THEN - DO 50 J = 1, I - T(J,PT13+I) = ZERO - 50 CONTINUE - DO 60 J = 1, I - T(J,PT23+I) = ZERO - 60 CONTINUE - DO 70 J = 1, I - T(J,PT33+I) = ZERO - 70 CONTINUE - DO 80 J = 1, I - RS(J,PS3+I) = ZERO - 80 CONTINUE - ELSE -C -C Treat second Householder reflection. -C - IF ( LCOLV.AND.LCOLW ) THEN -C -C Compute t1 = -tau(i) * W(i:n,1:i)' * V(i:n,i). -C - CALL DGEMV( 'Transpose', N-I+1, I, -TAUI, W(I,1), - $ LDW, V(I,I), 1, ZERO, DWORK, 1 ) -C -C Compute t2 = -tau(i) * V(i:n,1:i-1)' * V(i:n,i). -C - CALL DGEMV( 'Transpose', N-I+1, I-1, -TAUI, V(I,1), - $ LDV, V(I,I), 1, ZERO, DWORK(K2+1), 1 ) - ELSE IF ( LCOLV ) THEN -C -C Compute t1 = -tau(i) * W(1:i,i:n) * V(i:n,i). -C - CALL DGEMV( 'No Transpose', I, N-I+1, -TAUI, W(1,I), - $ LDW, V(I,I), 1, ZERO, DWORK, 1 ) -C -C Compute t2 = -tau(i) * V(i:n,1:i-1)' * V(i:n,i). -C - CALL DGEMV( 'Transpose', N-I+1, I-1, -TAUI, V(I,1), - $ LDV, V(I,I), 1, ZERO, DWORK(K2+1), 1 ) - ELSE IF ( LCOLW ) THEN -C -C Compute t1 = -tau(i) * W(i:n,1:i)' * V(i,i:n)'. -C - CALL DGEMV( 'Transpose', N-I+1, I, -TAUI, W(I,1), - $ LDW, V(I,I), LDV, ZERO, DWORK, 1 ) -C -C Compute t2 = -tau(i) * V(1:i-1,i:n) * V(i,i:n)'. -C - CALL DGEMV( 'No Transpose', I-1, N-I+1, -TAUI, V(1,I), - $ LDV, V(I,I), LDV, ZERO, DWORK(K2+1), 1 ) - ELSE -C -C Compute t1 = -tau(i) * W(1:i,i:n) * V(i,i:n)'. -C - CALL DGEMV( 'No Transpose', I, N-I+1, -TAUI, W(1,I), - $ LDW, V(I,I), LDV, ZERO, DWORK, 1 ) -C -C Compute t2 = -tau(i) * V(1:i-1,i:n) * V(i,i:n)'. -C - CALL DGEMV( 'No Transpose', I-1, N-I+1, -TAUI, V(1,I), - $ LDV, V(I,I), LDV, ZERO, DWORK(K2+1), 1 ) - END IF -C -C T13(1:i,i) := T11(1:i,1:i)*t1 - tau(i)*T12(1:i,i) -C + [T13(1:i-1,1:i-1)*t2;0] -C - CALL DCOPY( I-1, DWORK(K2+1), 1, T(1,PT13+I), 1 ) - CALL DTRMV( 'Upper', 'No transpose', 'Non-unit', I-1, - $ T(1,PT13+1), LDT, T(1,PT13+I), 1 ) - T(I,PT13+I) = ZERO - CALL DCOPY( I, DWORK, 1, DWORK(K+1), 1 ) - CALL DTRMV( 'Upper', 'No transpose', 'Non-unit', I, - $ T(1,PT11+1), LDT, DWORK(K+1), 1 ) - CALL DAXPY( I, ONE, DWORK(K+1), 1, T(1,PT13+I), 1 ) - CALL DAXPY( I, -TAUI, T(1,PT12+I), 1, T(1,PT13+I), 1 ) -C -C T23(1:i,i) := T21(1:i,1:i)*t1 - tau(i)*T22(1:i,i) -C + [T23(1:i-1,1:i-1)*t2;0] -C - CALL DCOPY( I-1, DWORK(K2+1), 1, T(1,PT23+I), 1 ) - CALL DTRMV( 'Upper', 'No transpose', 'Non-unit', I-1, - $ T(1,PT23+1), LDT, T(1,PT23+I), 1 ) - T(I,PT23+I) = ZERO - CALL DCOPY( I-1, DWORK(2), 1, DWORK(K+1), 1 ) - CALL DTRMV( 'Upper', 'No transpose', 'Non-unit', I-1, - $ T(1,PT21+2), LDT, DWORK(K+1), 1 ) - CALL DAXPY( I-1, ONE, DWORK(K+1), 1, T(1,PT23+I), 1 ) - CALL DAXPY( I, -TAUI, T(1,PT22+I), 1, T(1,PT23+I), 1 ) -C -C T33(1:i,i) := T31(1:i,1:i)*t1 - tau(i)*T32(1:i,i) -C + [T33(1:i-1,1:i-1)*t2;0] -C - CALL DCOPY( I-1, DWORK(K2+1), 1, T(1,PT33+I), 1 ) - CALL DTRMV( 'Upper', 'No transpose', 'Non-unit', I-1, - $ T(1,PT33+1), LDT, T(1,PT33+I), 1 ) - CALL DCOPY( I-1, DWORK(2), 1, DWORK(K+1), 1 ) - CALL DTRMV( 'Upper', 'No transpose', 'Non-unit', I-1, - $ T(1,PT31+2), LDT, DWORK(K+1), 1 ) - CALL DAXPY( I-1, ONE, DWORK(K+1), 1, T(1,PT33+I), 1 ) - CALL DAXPY( I-1, -TAUI, T(1,PT32+I), 1, T(1,PT33+I), 1 ) - T(I,PT33+I) = -TAUI -C -C S3(1:i,i) := S1(1:i,1:i)*t1 - tau(i)*S2(1:i,i) -C + [S3(1:i-1,1:i-1)*t2;0] -C - CALL DCOPY( I-1, DWORK(K2+1), 1, RS(1,PS3+I), 1 ) - CALL DTRMV( 'Upper', 'No transpose', 'Non-unit', I-1, - $ RS(1,PS3+1), LDRS, RS(1,PS3+I), 1 ) - CALL DTRMV( 'Upper', 'No transpose', 'Non-unit', I-1, - $ RS(1,PS1+2), LDRS, DWORK(2), 1 ) - CALL DAXPY( I-1, ONE, DWORK(2), 1, RS(1,PS3+I), 1 ) - RS(I,PS3+I) = ZERO - CALL DAXPY( I, -TAUI, RS(1,PS2+I), 1, RS(1,PS3+I), 1 ) - END IF - W(I,I) = WII - V(I,I) = VII - 90 CONTINUE -C - RETURN -C *** Last line of MB04QF *** - END diff --git a/mex/sources/libslicot/MB04QU.f b/mex/sources/libslicot/MB04QU.f deleted file mode 100644 index 6ae814da0..000000000 --- a/mex/sources/libslicot/MB04QU.f +++ /dev/null @@ -1,472 +0,0 @@ - SUBROUTINE MB04QU( TRANC, TRAND, TRANQ, STOREV, STOREW, M, N, K, - $ V, LDV, W, LDW, C, LDC, D, LDD, CS, TAU, DWORK, - $ LDWORK, INFO ) -C -C SLICOT RELEASE 5.0. -C -C Copyright (c) 2002-2009 NICONET e.V. -C -C This program is free software: you can redistribute it and/or -C modify it under the terms of the GNU General Public License as -C published by the Free Software Foundation, either version 2 of -C the License, or (at your option) any later version. -C -C This program is distributed in the hope that it will be useful, -C but WITHOUT ANY WARRANTY; without even the implied warranty of -C MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the -C GNU General Public License for more details. -C -C You should have received a copy of the GNU General Public License -C along with this program. If not, see -C . -C -C PURPOSE -C -C To overwrite general real m-by-n matrices C and D, or their -C transposes, with -C -C [ op(C) ] -C Q * [ ] if TRANQ = 'N', or -C [ op(D) ] -C -C T [ op(C) ] -C Q * [ ] if TRANQ = 'T', -C [ op(D) ] -C -C where Q is defined as the product of symplectic reflectors and -C Givens rotators, -C -C Q = diag( H(1),H(1) ) G(1) diag( F(1),F(1) ) -C diag( H(2),H(2) ) G(2) diag( F(2),F(2) ) -C .... -C diag( H(k),H(k) ) G(k) diag( F(k),F(k) ). -C -C Unblocked version. -C -C ARGUMENTS -C -C Mode Parameters -C -C TRANC CHARACTER*1 -C Specifies the form of op( C ) as follows: -C = 'N': op( C ) = C; -C = 'T': op( C ) = C'; -C = 'C': op( C ) = C'. -C -C STOREV CHARACTER*1 -C Specifies how the vectors which define the concatenated -C Householder reflectors contained in V are stored: -C = 'C': columnwise; -C = 'R': rowwise. -C -C STOREW CHARACTER*1 -C Specifies how the vectors which define the concatenated -C Householder reflectors contained in W are stored: -C = 'C': columnwise; -C = 'R': rowwise. -C -C TRAND CHARACTER*1 -C Specifies the form of op( D ) as follows: -C = 'N': op( D ) = D; -C = 'T': op( D ) = D'; -C = 'C': op( D ) = D'. -C -C TRANQ CHARACTER*1 -C = 'N': apply Q; -C = 'T': apply Q'. -C -C Input/Output Parameters -C -C M (input) INTEGER -C The number of rows of the matrices op(C) and op(D). -C M >= 0. -C -C N (input) INTEGER -C The number of columns of the matrices op(C) and op(D). -C N >= 0. -C -C K (input) INTEGER -C The number of elementary reflectors whose product defines -C the matrix Q. M >= K >= 0. -C -C V (input) DOUBLE PRECISION array, dimension -C (LDV,K) if STOREV = 'C', -C (LDV,M) if STOREV = 'R' -C On entry with STOREV = 'C', the leading M-by-K part of -C this array must contain in its columns the vectors which -C define the elementary reflectors F(i). -C On entry with STOREV = 'R', the leading K-by-M part of -C this array must contain in its rows the vectors which -C define the elementary reflectors F(i). -C -C LDV INTEGER -C The leading dimension of the array V. -C LDV >= MAX(1,M), if STOREV = 'C'; -C LDV >= MAX(1,K), if STOREV = 'R'. -C -C W (input) DOUBLE PRECISION array, dimension -C (LDW,K) if STOREW = 'C', -C (LDW,M) if STOREW = 'R' -C On entry with STOREW = 'C', the leading M-by-K part of -C this array must contain in its columns the vectors which -C define the elementary reflectors H(i). -C On entry with STOREW = 'R', the leading K-by-M part of -C this array must contain in its rows the vectors which -C define the elementary reflectors H(i). -C -C LDW INTEGER -C The leading dimension of the array W. -C LDW >= MAX(1,M), if STOREW = 'C'; -C LDW >= MAX(1,K), if STOREW = 'R'. -C -C C (input/output) DOUBLE PRECISION array, dimension -C (LDC,N) if TRANC = 'N', -C (LDC,M) if TRANC = 'T' or TRANC = 'C' -C On entry with TRANC = 'N', the leading M-by-N part of -C this array must contain the matrix C. -C On entry with TRANC = 'C' or TRANC = 'T', the leading -C N-by-M part of this array must contain the transpose of -C the matrix C. -C On exit with TRANC = 'N', the leading M-by-N part of -C this array contains the updated matrix C. -C On exit with TRANC = 'C' or TRANC = 'T', the leading -C N-by-M part of this array contains the transpose of the -C updated matrix C. -C -C LDC INTEGER -C The leading dimension of the array C. -C LDC >= MAX(1,M), if TRANC = 'N'; -C LDC >= MAX(1,N), if TRANC = 'T' or TRANC = 'C'. -C -C D (input/output) DOUBLE PRECISION array, dimension -C (LDD,N) if TRAND = 'N', -C (LDD,M) if TRAND = 'T' or TRAND = 'C' -C On entry with TRAND = 'N', the leading M-by-N part of -C this array must contain the matrix D. -C On entry with TRAND = 'C' or TRAND = 'T', the leading -C N-by-M part of this array must contain the transpose of -C the matrix D. -C On exit with TRAND = 'N', the leading M-by-N part of -C this array contains the updated matrix D. -C On exit with TRAND = 'C' or TRAND = 'T', the leading -C N-by-M part of this array contains the transpose of the -C updated matrix D. -C -C LDD INTEGER -C The leading dimension of the array D. -C LDD >= MAX(1,M), if TRAND = 'N'; -C LDD >= MAX(1,N), if TRAND = 'T' or TRAND = 'C'. -C -C CS (input) DOUBLE PRECISION array, dimension (2*K) -C On entry, the first 2*K elements of this array must -C contain the cosines and sines of the symplectic Givens -C rotators G(i). -C -C TAU (input) DOUBLE PRECISION array, dimension (K) -C On entry, the first K elements of this array must -C contain the scalar factors of the elementary reflectors -C F(i). -C -C Workspace -C -C DWORK DOUBLE PRECISION array, dimension (LDWORK) -C On exit, if INFO = 0, DWORK(1) returns the optimal -C value of LDWORK. -C On exit, if INFO = -20, DWORK(1) returns the minimum -C value of LDWORK. -C -C LDWORK INTEGER -C The length of the array DWORK. LDWORK >= MAX(1,N). -C -C Error Indicator -C -C INFO INTEGER -C = 0: successful exit; -C < 0: if INFO = -i, the i-th argument had an illegal -C value. -C -C CONTRIBUTORS -C -C D. Kressner, Technical Univ. Berlin, Germany, and -C P. Benner, Technical Univ. Chemnitz, Germany, December 2003. -C -C REVISIONS -C -C V. Sima, June 2008 (SLICOT version of the HAPACK routine DOSMSQ). -C -C KEYWORDS -C -C Elementary matrix operations, orthogonal symplectic matrix. -C -C ****************************************************************** -C -C .. Parameters .. - DOUBLE PRECISION ONE - PARAMETER ( ONE = 1.0D+0 ) -C .. Scalar Arguments .. - CHARACTER STOREV, STOREW, TRANC, TRAND, TRANQ - INTEGER INFO, K, LDC, LDD, LDV, LDW, LDWORK, M, N -C .. Array Arguments .. - DOUBLE PRECISION CS(*), DWORK(*), C(LDC,*), D(LDD,*), V(LDV,*), - $ W(LDW,*), TAU(*) -C .. Local Scalars .. - LOGICAL LCOLV, LCOLW, LTRC, LTRD, LTRQ - INTEGER I - DOUBLE PRECISION NU -C .. External Functions .. - LOGICAL LSAME - EXTERNAL LSAME -C .. External Subroutines .. - EXTERNAL DLARF, DROT, XERBLA -C .. Intrinsic Functions .. - INTRINSIC DBLE, MAX, MIN -C -C .. Executable Statements .. -C -C Decode the scalar input parameters. -C - INFO = 0 - LCOLV = LSAME( STOREV, 'C' ) - LCOLW = LSAME( STOREW, 'C' ) - LTRC = LSAME( TRANC, 'T' ) .OR. LSAME( TRANC, 'C' ) - LTRD = LSAME( TRAND, 'T' ) .OR. LSAME( TRAND, 'C' ) - LTRQ = LSAME( TRANQ, 'T' ) -C -C Check the scalar input parameters. -C - IF ( .NOT.( LTRC.OR.LSAME( TRANC, 'N' ) ) ) THEN - INFO = -1 - ELSE IF ( .NOT.( LTRD .OR. LSAME( TRAND, 'N' ) ) ) THEN - INFO = -2 - ELSE IF ( .NOT.( LTRQ .OR. LSAME( TRANQ, 'N' ) ) ) THEN - INFO = -3 - ELSE IF ( .NOT.( LCOLV.OR. LSAME( STOREV, 'R' ) ) ) THEN - INFO = -4 - ELSE IF ( .NOT.( LCOLW.OR. LSAME( STOREW, 'R' ) ) ) THEN - INFO = -5 - ELSE IF ( M.LT.0 ) THEN - INFO = -6 - ELSE IF ( N.LT.0 ) THEN - INFO = -7 - ELSE IF ( K.LT.0 .OR. K.GT.M ) THEN - INFO = -8 - ELSE IF ( ( LCOLV.AND.LDV.LT.MAX( 1, M ) ) .OR. - $ ( .NOT.LCOLV.AND.LDV.LT.MAX( 1, K ) ) ) THEN - INFO = -10 - ELSE IF ( ( LCOLW.AND.LDW.LT.MAX( 1, M ) ) .OR. - $ ( .NOT.LCOLW.AND.LDW.LT.MAX( 1, K ) ) ) THEN - INFO = -12 - ELSE IF ( ( LTRC.AND.LDC.LT.MAX( 1, N ) ) .OR. - $ ( .NOT.LTRC.AND.LDC.LT.MAX( 1, M ) ) ) THEN - INFO = -14 - ELSE IF ( ( LTRD.AND.LDD.LT.MAX( 1, N ) ) .OR. - $ ( .NOT.LTRD.AND.LDD.LT.MAX( 1, M ) ) ) THEN - INFO = -16 - ELSE IF ( LDWORK.LT.MAX( 1, N ) ) THEN - DWORK(1) = DBLE( MAX( 1, N ) ) - INFO = -20 - END IF -C -C Return if there were illegal values. -C - IF ( INFO.NE.0 ) THEN - CALL XERBLA( 'MB04QU', -INFO ) - RETURN - END IF -C -C Quick return if possible. -C - IF( MIN( K, M, N ).EQ.0 ) THEN - DWORK(1) = ONE - RETURN - END IF -C - IF ( LTRQ ) THEN - DO 10 I = 1, K -C -C Apply H(I) to C(I:M,:) and D(I:M,:) from the left. -C - NU = W(I,I) - W(I,I) = ONE - IF ( LCOLW ) THEN - IF ( LTRC ) THEN - CALL DLARF( 'Right', N, M-I+1, W(I,I), 1, NU, C(1,I), - $ LDC, DWORK ) - ELSE - CALL DLARF( 'Left', M-I+1, N, W(I,I), 1, NU, C(I,1), - $ LDC, DWORK ) - END IF - IF ( LTRD ) THEN - CALL DLARF( 'Right', N, M-I+1, W(I,I), 1, NU, D(1,I), - $ LDD, DWORK ) - ELSE - CALL DLARF( 'Left', M-I+1, N, W(I,I), 1, NU, D(I,1), - $ LDD, DWORK ) - END IF - ELSE - IF ( LTRC ) THEN - CALL DLARF( 'Right', N, M-I+1, W(I,I), LDW, NU, - $ C(1,I), LDC, DWORK ) - ELSE - CALL DLARF( 'Left', M-I+1, N, W(I,I), LDW, NU, C(I,1), - $ LDC, DWORK ) - END IF - IF ( LTRD ) THEN - CALL DLARF( 'Right', N, M-I+1, W(I,I), LDW, NU, - $ D(1,I), LDD, DWORK ) - ELSE - CALL DLARF( 'Left', M-I+1, N, W(I,I), LDW, NU, D(I,1), - $ LDD, DWORK ) - END IF - END IF - W(I,I) = NU -C -C Apply G(i) to C(I,:) and D(I,:) from the left. -C - IF ( LTRC.AND.LTRD ) THEN - CALL DROT( N, C(1,I), 1, D(1,I), 1, CS(2*I-1), CS(2*I) ) - ELSE IF ( LTRC ) THEN - CALL DROT( N, C(1,I), 1, D(I,1), LDD, CS(2*I-1), - $ CS(2*I) ) - ELSE IF ( LTRD ) THEN - CALL DROT( N, C(I,1), LDC, D(1,I), 1, CS(2*I-1), - $ CS(2*I) ) - ELSE - CALL DROT( N, C(I,1), LDC, D(I,1), LDD, CS(2*I-1), - $ CS(2*I) ) - END IF -C -C Apply F(I) to C(I:M,:) and D(I:M,:) from the left. -C - NU = V(I,I) - V(I,I) = ONE - IF ( LCOLV ) THEN - IF ( LTRC ) THEN - CALL DLARF( 'Right', N, M-I+1, V(I,I), 1, TAU(I), - $ C(1,I), LDC, DWORK ) - ELSE - CALL DLARF( 'Left', M-I+1, N, V(I,I), 1, TAU(I), - $ C(I,1), LDC, DWORK ) - END IF - IF ( LTRD ) THEN - CALL DLARF( 'Right', N, M-I+1, V(I,I), 1, TAU(I), - $ D(1,I), LDD, DWORK ) - ELSE - CALL DLARF( 'Left', M-I+1, N, V(I,I), 1, TAU(I), - $ D(I,1), LDD, DWORK ) - END IF - ELSE - IF ( LTRC ) THEN - CALL DLARF( 'Right', N, M-I+1, V(I,I), LDV, TAU(I), - $ C(1,I), LDC, DWORK ) - ELSE - CALL DLARF( 'Left', M-I+1, N, V(I,I), LDV, TAU(I), - $ C(I,1), LDC, DWORK ) - END IF - IF ( LTRD ) THEN - CALL DLARF( 'Right', N, M-I+1, V(I,I), LDV, TAU(I), - $ D(1,I), LDD, DWORK ) - ELSE - CALL DLARF( 'Left', M-I+1, N, V(I,I), LDV, TAU(I), - $ D(I,1), LDD, DWORK ) - END IF - END IF - V(I,I) = NU - 10 CONTINUE - ELSE - DO 20 I = K, 1, -1 -C -C Apply F(I) to C(I:M,:) and D(I:M,:) from the left. -C - NU = V(I,I) - V(I,I) = ONE - IF ( LCOLV ) THEN - IF ( LTRC ) THEN - CALL DLARF( 'Right', N, M-I+1, V(I,I), 1, TAU(I), - $ C(1,I), LDC, DWORK ) - ELSE - CALL DLARF( 'Left', M-I+1, N, V(I,I), 1, TAU(I), - $ C(I,1), LDC, DWORK ) - END IF - IF ( LTRD ) THEN - CALL DLARF( 'Right', N, M-I+1, V(I,I), 1, TAU(I), - $ D(1,I), LDD, DWORK ) - ELSE - CALL DLARF( 'Left', M-I+1, N, V(I,I), 1, TAU(I), - $ D(I,1), LDD, DWORK ) - END IF - ELSE - IF ( LTRC ) THEN - CALL DLARF( 'Right', N, M-I+1, V(I,I), LDV, TAU(I), - $ C(1,I), LDC, DWORK ) - ELSE - CALL DLARF( 'Left', M-I+1, N, V(I,I), LDV, TAU(I), - $ C(I,1), LDC, DWORK ) - END IF - IF ( LTRD ) THEN - CALL DLARF( 'Right', N, M-I+1, V(I,I), LDV, TAU(I), - $ D(1,I), LDD, DWORK ) - ELSE - CALL DLARF( 'Left', M-I+1, N, V(I,I), LDV, TAU(I), - $ D(I,1), LDD, DWORK ) - END IF - END IF - V(I,I) = NU -C -C Apply G(i) to C(I,:) and D(I,:) from the left. -C - IF ( LTRC.AND.LTRD ) THEN - CALL DROT( N, C(1,I), 1, D(1,I), 1, CS(2*I-1), -CS(2*I) ) - ELSE IF ( LTRC ) THEN - CALL DROT( N, C(1,I), 1, D(I,1), LDD, CS(2*I-1), - $ -CS(2*I) ) - ELSE IF ( LTRD ) THEN - CALL DROT( N, C(I,1), LDC, D(1,I), 1, CS(2*I-1), - $ -CS(2*I) ) - ELSE - CALL DROT( N, C(I,1), LDC, D(I,1), LDD, CS(2*I-1), - $ -CS(2*I) ) - END IF -C -C Apply H(I) to C(I:M,:) and D(I:M,:) from the left. -C - NU = W(I,I) - W(I,I) = ONE - IF ( LCOLW ) THEN - IF ( LTRC ) THEN - CALL DLARF( 'Right', N, M-I+1, W(I,I), 1, NU, C(1,I), - $ LDC, DWORK ) - ELSE - CALL DLARF( 'Left', M-I+1, N, W(I,I), 1, NU, C(I,1), - $ LDC, DWORK ) - END IF - IF ( LTRD ) THEN - CALL DLARF( 'Right', N, M-I+1, W(I,I), 1, NU, D(1,I), - $ LDD, DWORK ) - ELSE - CALL DLARF( 'Left', M-I+1, N, W(I,I), 1, NU, D(I,1), - $ LDD, DWORK ) - END IF - ELSE - IF ( LTRC ) THEN - CALL DLARF( 'Right', N, M-I+1, W(I,I), LDW, NU, - $ C(1,I), LDC, DWORK ) - ELSE - CALL DLARF( 'Left', M-I+1, N, W(I,I), LDW, NU, C(I,1), - $ LDC, DWORK ) - END IF - IF ( LTRD ) THEN - CALL DLARF( 'Right', N, M-I+1, W(I,I), LDW, NU, - $ D(1,I), LDD, DWORK ) - ELSE - CALL DLARF( 'Left', M-I+1, N, W(I,I), LDW, NU, D(I,1), - $ LDD, DWORK ) - END IF - END IF - W(I,I) = NU - 20 CONTINUE - END IF -C - DWORK(1) = DBLE( MAX( 1, N ) ) -C *** Last line of MB04QU *** - END diff --git a/mex/sources/libslicot/MB04TB.f b/mex/sources/libslicot/MB04TB.f deleted file mode 100644 index 3d5ad6614..000000000 --- a/mex/sources/libslicot/MB04TB.f +++ /dev/null @@ -1,677 +0,0 @@ - SUBROUTINE MB04TB( TRANA, TRANB, N, ILO, A, LDA, B, LDB, G, LDG, - $ Q, LDQ, CSL, CSR, TAUL, TAUR, DWORK, LDWORK, - $ INFO ) -C -C SLICOT RELEASE 5.0. -C -C Copyright (c) 2002-2009 NICONET e.V. -C -C This program is free software: you can redistribute it and/or -C modify it under the terms of the GNU General Public License as -C published by the Free Software Foundation, either version 2 of -C the License, or (at your option) any later version. -C -C This program is distributed in the hope that it will be useful, -C but WITHOUT ANY WARRANTY; without even the implied warranty of -C MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the -C GNU General Public License for more details. -C -C You should have received a copy of the GNU General Public License -C along with this program. If not, see -C . -C -C PURPOSE -C -C To compute a symplectic URV (SURV) decomposition of a real -C 2N-by-2N matrix H, -C -C [ op(A) G ] [ op(R11) R12 ] -C H = [ ] = U R V' = U * [ ] * V' , -C [ Q op(B) ] [ 0 op(R22) ] -C -C where A, B, G, Q, R12 are real N-by-N matrices, op(R11) is a real -C N-by-N upper triangular matrix, op(R22) is a real N-by-N lower -C Hessenberg matrix and U, V are 2N-by-2N orthogonal symplectic -C matrices. Blocked version. -C -C ARGUMENTS -C -C Mode Parameters -C -C TRANA CHARACTER*1 -C Specifies the form of op( A ) as follows: -C = 'N': op( A ) = A; -C = 'T': op( A ) = A'; -C = 'C': op( A ) = A'. -C -C TRANB CHARACTER*1 -C Specifies the form of op( B ) as follows: -C = 'N': op( B ) = B; -C = 'T': op( B ) = B'; -C = 'C': op( B ) = B'. -C -C Input/Output Parameters -C -C N (input) INTEGER -C The order of the matrix A. N >= 0. -C -C ILO (input) INTEGER -C It is assumed that op(A) is already upper triangular, -C op(B) is lower triangular and Q is zero in rows and -C columns 1:ILO-1. ILO is normally set by a previous call -C to MB04DD; otherwise it should be set to 1. -C 1 <= ILO <= N, if N > 0; ILO=1, if N=0. -C -C A (input/output) DOUBLE PRECISION array, dimension (LDA,N) -C On entry, the leading N-by-N part of this array must -C contain the matrix A. -C On exit, the leading N-by-N part of this array contains -C the triangular matrix R11, and in the zero part -C information about the elementary reflectors used to -C compute the SURV decomposition. -C -C LDA INTEGER -C The leading dimension of the array A. LDA >= MAX(1,N). -C -C B (input/output) DOUBLE PRECISION array, dimension (LDB,N) -C On entry, the leading N-by-N part of this array must -C contain the matrix B. -C On exit, the leading N-by-N part of this array contains -C the Hessenberg matrix R22, and in the zero part -C information about the elementary reflectors used to -C compute the SURV decomposition. -C -C LDB INTEGER -C The leading dimension of the array B. LDB >= MAX(1,N). -C -C G (input/output) DOUBLE PRECISION array, dimension (LDG,N) -C On entry, the leading N-by-N part of this array must -C contain the matrix G. -C On exit, the leading N-by-N part of this array contains -C the matrix R12. -C -C LDG INTEGER -C The leading dimension of the array G. LDG >= MAX(1,N). -C -C Q (input/output) DOUBLE PRECISION array, dimension (LDQ,N) -C On entry, the leading N-by-N part of this array must -C contain the matrix Q. -C On exit, the leading N-by-N part of this array contains -C information about the elementary reflectors used to -C compute the SURV decomposition. -C -C LDQ INTEGER -C The leading dimension of the array Q. LDQ >= MAX(1,N). -C -C CSL (output) DOUBLE PRECISION array, dimension (2N) -C On exit, the first 2N elements of this array contain the -C cosines and sines of the symplectic Givens rotations -C applied from the left-hand side used to compute the SURV -C decomposition. -C -C CSR (output) DOUBLE PRECISION array, dimension (2N-2) -C On exit, the first 2N-2 elements of this array contain the -C cosines and sines of the symplectic Givens rotations -C applied from the right-hand side used to compute the SURV -C decomposition. -C -C TAUL (output) DOUBLE PRECISION array, dimension (N) -C On exit, the first N elements of this array contain the -C scalar factors of some of the elementary reflectors -C applied form the left-hand side. -C -C TAUR (output) DOUBLE PRECISION array, dimension (N-1) -C On exit, the first N-1 elements of this array contain the -C scalar factors of some of the elementary reflectors -C applied form the right-hand side. -C -C Workspace -C -C DWORK DOUBLE PRECISION array, dimension (LDWORK) -C On exit, if INFO = 0, DWORK(1) returns the optimal -C value of LDWORK, (16*N + 5)*NB, where NB is the optimal -C block size determined by the function UE01MD. -C On exit, if INFO = -16, DWORK(1) returns the minimum -C value of LDWORK. -C -C LDWORK INTEGER -C The length of the array DWORK. LDWORK >= MAX(1,N). -C -C Error Indicator -C -C INFO INTEGER -C = 0: successful exit; -C < 0: if INFO = -i, the i-th argument had an illegal -C value. -C -C METHOD -C -C The matrices U and V are represented as products of symplectic -C reflectors and Givens rotators -C -C U = diag( HU(1),HU(1) ) GU(1) diag( FU(1),FU(1) ) -C diag( HU(2),HU(2) ) GU(2) diag( FU(2),FU(2) ) -C .... -C diag( HU(n),HU(n) ) GU(n) diag( FU(n),FU(n) ), -C -C V = diag( HV(1),HV(1) ) GV(1) diag( FV(1),FV(1) ) -C diag( HV(2),HV(2) ) GV(2) diag( FV(2),FV(2) ) -C .... -C diag( HV(n-1),HV(n-1) ) GV(n-1) diag( FV(n-1),FV(n-1) ). -C -C Each HU(i) has the form -C -C HU(i) = I - tau * v * v' -C -C where tau is a real scalar, and v is a real vector with -C v(1:i-1) = 0 and v(i) = 1; v(i+1:n) is stored on exit in -C Q(i+1:n,i), and tau in Q(i,i). -C -C Each FU(i) has the form -C -C FU(i) = I - nu * w * w' -C -C where nu is a real scalar, and w is a real vector with -C w(1:i-1) = 0 and w(i) = 1; w(i+1:n) is stored on exit in -C A(i+1:n,i), if op(A) = 'N', and in A(i,i+1:n), otherwise. The -C scalar nu is stored in TAUL(i). -C -C Each GU(i) is a Givens rotator acting on rows i and n+i, -C where the cosine is stored in CSL(2*i-1) and the sine in -C CSL(2*i). -C -C Each HV(i) has the form -C -C HV(i) = I - tau * v * v' -C -C where tau is a real scalar, and v is a real vector with -C v(1:i) = 0 and v(i+1) = 1; v(i+2:n) is stored on exit in -C Q(i,i+2:n), and tau in Q(i,i+1). -C -C Each FV(i) has the form -C -C FV(i) = I - nu * w * w' -C -C where nu is a real scalar, and w is a real vector with -C w(1:i) = 0 and w(i+1) = 1; w(i+2:n) is stored on exit in -C B(i,i+2:n), if op(B) = 'N', and in B(i+2:n,i), otherwise. -C The scalar nu is stored in TAUR(i). -C -C Each GV(i) is a Givens rotator acting on columns i+1 and n+i+1, -C where the cosine is stored in CSR(2*i-1) and the sine in -C CSR(2*i). -C -C NUMERICAL ASPECTS -C -C The algorithm requires 80/3*N**3 + ( 64*NB + 77 )*N**2 + -C ( -16*NB + 48 )*NB*N + O(N) floating point operations, where -C NB is the used block size, and is numerically backward stable. -C -C REFERENCES -C -C [1] Benner, P., Mehrmann, V., and Xu, H. -C A numerically stable, structure preserving method for -C computing the eigenvalues of real Hamiltonian or symplectic -C pencils. Numer. Math., Vol 78 (3), pp. 329-358, 1998. -C -C [2] Kressner, D. -C Block algorithms for orthogonal symplectic factorizations. -C BIT, 43 (4), pp. 775-790, 2003. -C -C CONTRIBUTORS -C -C D. Kressner, Technical Univ. Berlin, Germany, and -C P. Benner, Technical Univ. Chemnitz, Germany, December 2003. -C -C REVISIONS -C -C V. Sima, June 2008 (SLICOT version of the HAPACK routine DGESUB). -C -C KEYWORDS -C -C Elementary matrix operations, Matrix decompositions, Hamiltonian -C matrix -C -C ****************************************************************** -C -C .. Parameters .. - DOUBLE PRECISION ZERO, ONE - PARAMETER ( ZERO = 0.0D0, ONE = 1.0D0 ) -C .. Scalar Arguments .. - CHARACTER TRANA, TRANB - INTEGER ILO, INFO, LDA, LDB, LDG, LDQ, LDWORK, N -C .. Array Arguments .. - DOUBLE PRECISION A(LDA,*), B(LDB,*), CSL(*), CSR(*), DWORK(*), - $ G(LDG,*), Q(LDQ,*), TAUL(*), TAUR(*) -C .. Local Scalars .. - LOGICAL LTRA, LTRB - INTEGER I, IB, IERR, NB, NBMIN, NH, NIB, NNB, NX, PDW, - $ PXA, PXB, PXG, PXQ, PYA, PYB, PYG, PYQ, WRKOPT -C .. External Functions .. - LOGICAL LSAME - INTEGER UE01MD - EXTERNAL LSAME, UE01MD -C .. External Subroutines .. - EXTERNAL DGEMM, MB03XU, MB04TS, XERBLA -C .. Intrinsic Functions .. - INTRINSIC DBLE, MAX, MIN -C -C .. Executable Statements .. -C -C Check the scalar input parameters. -C - INFO = 0 - LTRA = LSAME( TRANA, 'T' ) .OR. LSAME( TRANA, 'C' ) - LTRB = LSAME( TRANB, 'T' ) .OR. LSAME( TRANB, 'C' ) - IF ( .NOT.LTRA .AND. .NOT.LSAME( TRANA, 'N' ) ) THEN - INFO = -1 - ELSE IF ( .NOT.LTRB .AND. .NOT.LSAME( TRANB, 'N' ) ) THEN - INFO = -2 - ELSE IF ( N.LT.0 ) THEN - INFO = -3 - ELSE IF ( ILO.LT.1 .OR. ILO.GT.MAX( 1, N ) ) THEN - INFO = -4 - ELSE IF ( LDA.LT.MAX( 1, N ) ) THEN - INFO = -6 - ELSE IF ( LDB.LT.MAX( 1, N ) ) THEN - INFO = -8 - ELSE IF ( LDG.LT.MAX( 1, N ) ) THEN - INFO = -10 - ELSE IF ( LDQ.LT.MAX( 1, N ) ) THEN - INFO = -12 - ELSE IF ( LDWORK.LT.MAX( 1, N ) ) THEN - DWORK(1) = DBLE( MAX( 1, N ) ) - INFO = -18 - END IF -C -C Return if there were illegal values. -C - IF ( INFO.NE.0 ) THEN - CALL XERBLA( 'MB04TB', -INFO ) - RETURN - END IF -C -C Set elements 1:ILO-1 of CSL, CSR, TAUL and TAUR to their default -C values. -C - DO 10 I = 1, ILO - 1 - CSL(2*I-1) = ONE - CSL(2*I) = ZERO - CSR(2*I-1) = ONE - CSR(2*I) = ZERO - TAUL(I) = ZERO - TAUR(I) = ZERO - 10 CONTINUE -C -C Quick return if possible. -C - NH = N - ILO + 1 - IF ( NH.EQ.0 ) THEN - DWORK(1) = ONE - RETURN - END IF -C -C Determine the block size. -C - NB = UE01MD( 1, 'MB04TB', TRANA // TRANB, N, ILO, -1 ) - NBMIN = 2 - WRKOPT = N - IF ( NB.GT.1 .AND. NB.LT.NH ) THEN -C -C Determine when to cross over from blocked to unblocked code. -C - NX = MAX( NB, UE01MD( 3, 'MB04TB', TRANA // TRANB, N, ILO, -1 ) - $ ) - IF ( NX.LT.NH ) THEN -C -C Check whether workspace is large enough for blocked code. -C - WRKOPT = 16*N*NB + 5*NB - IF ( LDWORK.LT.WRKOPT ) THEN -C -C Not enough workspace available. Determine minimum value -C of NB, and reduce NB. -C - NBMIN = MAX( 2, UE01MD( 2, 'MB04TB', TRANA // TRANB, N, - $ ILO, -1 ) ) - NB = LDWORK / ( 16*N + 5 ) - END IF - END IF - END IF -C - NNB = N*NB - PYB = 1 - PYQ = PYB + 2*NNB - PYA = PYQ + 2*NNB - PYG = PYA + 2*NNB - PXQ = PYG + 2*NNB - PXA = PXQ + 2*NNB - PXG = PXA + 2*NNB - PXB = PXG + 2*NNB - PDW = PXB + 2*NNB -C - IF ( NB.LT.NBMIN .OR. NB.GE.NH ) THEN -C -C Use unblocked code. -C - I = ILO -C - ELSE IF ( LTRA .AND. LTRB ) THEN - DO 20 I = ILO, N-NX-1, NB - IB = MIN( NB, N-I ) - NIB = N*IB -C -C Reduce rows and columns i:i+nb-1 to symplectic URV form and -C return the matrices XA, XB, XG, XQ, YA, YB, YG and YQ which -C are needed to update the unreduced parts of the matrices. -C - CALL MB03XU( LTRA, LTRB, N-I+1, I-1, IB, A(I,1), LDA, - $ B(1,I), LDB, G, LDG, Q(I,I), LDQ, DWORK(PXA), - $ N, DWORK(PXB), N, DWORK(PXG), N, DWORK(PXQ), N, - $ DWORK(PYA), N, DWORK(PYB), N, DWORK(PYG), N, - $ DWORK(PYQ), N, CSL(2*I-1), CSR(2*I-1), TAUL(I), - $ TAUR(I), DWORK(PDW) ) -C -C Update the submatrix A(i+1+ib:n,1:n). -C - CALL DGEMM( 'No transpose', 'Transpose', N-I-IB, N-I-IB+1, - $ IB, ONE, DWORK(PXA+NB+1), N, Q(I+IB,I), LDQ, - $ ONE, A(I+IB+1,I+IB), LDA ) - CALL DGEMM( 'No transpose', 'No transpose', N-I-IB, - $ N-I-IB+1, IB, ONE, DWORK(PXA+NIB+NB+1), N, - $ A(I,I+IB), LDA, ONE, A(I+IB+1,I+IB), LDA ) - CALL DGEMM( 'Transpose', 'Transpose', N-I-IB, N, IB, - $ ONE, Q(I,I+IB+1), LDQ, DWORK(PYA), N, ONE, - $ A(I+IB+1,1), LDA ) - CALL DGEMM( 'No transpose', 'Transpose', N-I-IB, N, IB, - $ ONE, B(I+IB+1,I), LDB, DWORK(PYA+NIB), N, ONE, - $ A(I+IB+1,1), LDA ) -C -C Update the submatrix Q(i+ib:n,i+1+ib:n). -C - CALL DGEMM( 'No transpose', 'Transpose', N-I-IB+1, N-I-IB, - $ IB, ONE, Q(I+IB,I), LDQ, DWORK(PXQ+NB+1), N, - $ ONE, Q(I+IB,I+IB+1), LDQ ) - CALL DGEMM( 'Transpose', 'Transpose', N-I-IB+1, N-I-IB, - $ IB, ONE, A(I,I+IB), LDA, DWORK(PXQ+NIB+NB+1), N, - $ ONE, Q(I+IB,I+IB+1), LDQ ) - CALL DGEMM( 'No transpose', 'No transpose', N-I-IB+1, - $ N-I-IB, IB, ONE, DWORK(PYQ+NB), N, - $ Q(I,I+IB+1), LDQ, ONE, Q(I+IB,I+IB+1), LDQ ) - CALL DGEMM( 'No transpose', 'Transpose', N-I-IB+1, - $ N-I-IB, IB, ONE, DWORK(PYQ+NIB+NB), N, - $ B(I+IB+1,I), LDB, ONE, Q(I+IB,I+IB+1), LDQ ) -C -C Update the matrix G. -C - CALL DGEMM( 'No transpose', 'Transpose', N-I-IB+1, N, IB, - $ ONE, Q(I+IB,I), LDQ, DWORK(PXG), N, ONE, - $ G(I+IB,1), LDG ) - CALL DGEMM( 'Transpose', 'Transpose', N-I-IB+1, N, IB, - $ ONE, A(I,I+IB), LDA, DWORK(PXG+NIB), N, ONE, - $ G(I+IB,1), LDG ) - CALL DGEMM( 'No transpose', 'No transpose', N, N-I-IB, IB, - $ ONE, DWORK(PYG), N, Q(I,I+IB+1), LDQ, ONE, - $ G(1,I+IB+1), LDG ) - CALL DGEMM( 'No transpose', 'Transpose', N, N-I-IB, IB, - $ ONE, DWORK(PYG+NIB), N, B(I+IB+1,I), LDB, ONE, - $ G(1,I+IB+1), LDG ) -C -C Update the submatrix B(1:n,i+ib:n). -C - CALL DGEMM( 'No transpose', 'Transpose', N, N-I-IB+1, - $ IB, ONE, DWORK(PXB), N, Q(I+IB,I), LDQ, - $ ONE, B(1,I+IB), LDB ) - CALL DGEMM( 'No transpose', 'No transpose', N, N-I-IB+1, IB, - $ ONE, DWORK(PXB+NIB), N, A(I,I+IB), LDA, ONE, - $ B(1,I+IB), LDB ) - CALL DGEMM( 'Transpose', 'Transpose', N-I-IB, N-I-IB+1, - $ IB, ONE, Q(I,I+IB+1), LDQ, DWORK(PYB+NB), N, - $ ONE, B(I+IB+1,I+IB), LDB ) - CALL DGEMM( 'No transpose', 'Transpose', N-I-IB, N-I-IB+1, - $ IB, ONE, B(I+IB+1,I), LDB, DWORK(PYB+NIB+NB), N, - $ ONE, B(I+IB+1,I+IB), LDB ) - 20 CONTINUE -C - ELSE IF ( LTRA ) THEN - DO 30 I = ILO, N-NX-1, NB - IB = MIN( NB, N-I ) - NIB = N*IB -C -C Reduce rows and columns i:i+nb-1 to symplectic URV form and -C return the matrices XA, XB, XG, XQ, YA, YB, YG and YQ which -C are needed to update the unreduced parts of the matrices. -C - CALL MB03XU( LTRA, LTRB, N-I+1, I-1, IB, A(I,1), LDA, - $ B(I,1), LDB, G, LDG, Q(I,I), LDQ, DWORK(PXA), - $ N, DWORK(PXB), N, DWORK(PXG), N, DWORK(PXQ), N, - $ DWORK(PYA), N, DWORK(PYB), N, DWORK(PYG), N, - $ DWORK(PYQ), N, CSL(2*I-1), CSR(2*I-1), TAUL(I), - $ TAUR(I), DWORK(PDW) ) -C -C Update the submatrix A(i+1+ib:n,1:n). -C - CALL DGEMM( 'No transpose', 'Transpose', N-I-IB, N-I-IB+1, - $ IB, ONE, DWORK(PXA+NB+1), N, Q(I+IB,I), LDQ, - $ ONE, A(I+IB+1,I+IB), LDA ) - CALL DGEMM( 'No transpose', 'No transpose', N-I-IB, - $ N-I-IB+1, IB, ONE, DWORK(PXA+NIB+NB+1), N, - $ A(I,I+IB), LDA, ONE, A(I+IB+1,I+IB), LDA ) - CALL DGEMM( 'Transpose', 'Transpose', N-I-IB, N, IB, - $ ONE, Q(I,I+IB+1), LDQ, DWORK(PYA), N, ONE, - $ A(I+IB+1,1), LDA ) - CALL DGEMM( 'Transpose', 'Transpose', N-I-IB, N, IB, - $ ONE, B(I,I+IB+1), LDB, DWORK(PYA+NIB), N, ONE, - $ A(I+IB+1,1), LDA ) -C -C Update the submatrix Q(i+ib:n,i+1+ib:n). -C - CALL DGEMM( 'No transpose', 'Transpose', N-I-IB+1, N-I-IB, - $ IB, ONE, Q(I+IB,I), LDQ, DWORK(PXQ+NB+1), N, - $ ONE, Q(I+IB,I+IB+1), LDQ ) - CALL DGEMM( 'Transpose', 'Transpose', N-I-IB+1, N-I-IB, - $ IB, ONE, A(I,I+IB), LDA, DWORK(PXQ+NIB+NB+1), N, - $ ONE, Q(I+IB,I+IB+1), LDQ ) - CALL DGEMM( 'No transpose', 'No transpose', N-I-IB+1, - $ N-I-IB, IB, ONE, DWORK(PYQ+NB), N, - $ Q(I,I+IB+1), LDQ, ONE, Q(I+IB,I+IB+1), LDQ ) - CALL DGEMM( 'No transpose', 'No transpose', N-I-IB+1, - $ N-I-IB, IB, ONE, DWORK(PYQ+NIB+NB), N, - $ B(I,I+IB+1), LDB, ONE, Q(I+IB,I+IB+1), LDQ ) -C -C Update the matrix G. -C - CALL DGEMM( 'No transpose', 'Transpose', N-I-IB+1, N, IB, - $ ONE, Q(I+IB,I), LDQ, DWORK(PXG), N, ONE, - $ G(I+IB,1), LDG ) - CALL DGEMM( 'Transpose', 'Transpose', N-I-IB+1, N, IB, - $ ONE, A(I,I+IB), LDA, DWORK(PXG+NIB), N, ONE, - $ G(I+IB,1), LDG ) - CALL DGEMM( 'No transpose', 'No transpose', N, N-I-IB, IB, - $ ONE, DWORK(PYG), N, Q(I,I+IB+1), LDQ, ONE, - $ G(1,I+IB+1), LDG ) - CALL DGEMM( 'No transpose', 'No transpose', N, N-I-IB, IB, - $ ONE, DWORK(PYG+NIB), N, B(I,I+IB+1), LDB, ONE, - $ G(1,I+IB+1), LDG ) -C -C Update the submatrix B(i+ib:n,1:n). -C - CALL DGEMM( 'No transpose', 'Transpose', N-I-IB+1, N, - $ IB, ONE, Q(I+IB,I), LDQ, DWORK(PXB), N, - $ ONE, B(I+IB,1), LDB ) - CALL DGEMM( 'Transpose', 'Transpose', N-I-IB+1, N, IB, - $ ONE, A(I,I+IB), LDA, DWORK(PXB+NIB), N, ONE, - $ B(I+IB,1), LDB ) - CALL DGEMM( 'No transpose', 'No transpose', N-I-IB+1, - $ N-I-IB, IB, ONE, DWORK(PYB+NB), N, Q(I,I+IB+1), - $ LDQ, ONE, B(I+IB,I+IB+1), LDB ) - CALL DGEMM( 'No transpose', 'No transpose', N-I-IB+1, - $ N-I-IB, IB, ONE, DWORK(PYB+NIB+NB), N, - $ B(I,I+IB+1), LDB, ONE, B(I+IB,I+IB+1), LDB ) - 30 CONTINUE -C - ELSE IF ( LTRB ) THEN - DO 40 I = ILO, N-NX-1, NB - IB = MIN( NB, N-I ) - NIB = N*IB -C -C Reduce rows and columns i:i+nb-1 to symplectic URV form and -C return the matrices XA, XB, XG, XQ, YA, YB, YG and YQ which -C are needed to update the unreduced parts of the matrices. -C - CALL MB03XU( LTRA, LTRB, N-I+1, I-1, IB, A(1,I), LDA, - $ B(1,I), LDB, G, LDG, Q(I,I), LDQ, DWORK(PXA), - $ N, DWORK(PXB), N, DWORK(PXG), N, DWORK(PXQ), N, - $ DWORK(PYA), N, DWORK(PYB), N, DWORK(PYG), N, - $ DWORK(PYQ), N, CSL(2*I-1), CSR(2*I-1), TAUL(I), - $ TAUR(I), DWORK(PDW) ) -C -C Update the submatrix A(1:n,i+1+ib:n). -C - CALL DGEMM( 'No transpose', 'Transpose', N-I-IB+1, N-I-IB, - $ IB, ONE, Q(I+IB,I), LDQ, DWORK(PXA+NB+1), N, - $ ONE, A(I+IB,I+IB+1), LDA ) - CALL DGEMM( 'No transpose', 'Transpose', N-I-IB+1, N-I-IB, - $ IB, ONE, A(I+IB,I), LDA, DWORK(PXA+NIB+NB+1), N, - $ ONE, A(I+IB,I+IB+1), LDA ) - CALL DGEMM( 'No transpose', 'No transpose', N, N-I-IB, IB, - $ ONE, DWORK(PYA), N, Q(I,I+IB+1), LDQ, ONE, - $ A(1,I+IB+1), LDA ) - CALL DGEMM( 'No transpose', 'Transpose', N, N-I-IB, IB, - $ ONE, DWORK(PYA+NIB), N, B(I+IB+1,I), LDB, ONE, - $ A(1,I+IB+1), LDA ) -C -C Update the submatrix Q(i+ib:n,i+1+ib:n). -C - CALL DGEMM( 'No transpose', 'Transpose', N-I-IB+1, N-I-IB, - $ IB, ONE, Q(I+IB,I), LDQ, DWORK(PXQ+NB+1), N, - $ ONE, Q(I+IB,I+IB+1), LDQ ) - CALL DGEMM( 'No transpose', 'Transpose', N-I-IB+1, N-I-IB, - $ IB, ONE, A(I+IB,I), LDA, DWORK(PXQ+NIB+NB+1), N, - $ ONE, Q(I+IB,I+IB+1), LDQ ) - CALL DGEMM( 'No transpose', 'No transpose', N-I-IB+1, - $ N-I-IB, IB, ONE, DWORK(PYQ+NB), N, - $ Q(I,I+IB+1), LDQ, ONE, Q(I+IB,I+IB+1), LDQ ) - CALL DGEMM( 'No Transpose', 'Transpose', N-I-IB+1, - $ N-I-IB, IB, ONE, DWORK(PYQ+NIB+NB), N, - $ B(I+IB+1,I), LDB, ONE, Q(I+IB,I+IB+1), LDQ ) -C -C Update the matrix G. -C - CALL DGEMM( 'No transpose', 'Transpose', N-I-IB+1, N, IB, - $ ONE, Q(I+IB,I), LDQ, DWORK(PXG), N, ONE, - $ G(I+IB,1), LDG ) - CALL DGEMM( 'No transpose', 'Transpose', N-I-IB+1, N, IB, - $ ONE, A(I+IB,I), LDA, DWORK(PXG+NIB), N, ONE, - $ G(I+IB,1), LDG ) - CALL DGEMM( 'No transpose', 'No transpose', N, N-I-IB, IB, - $ ONE, DWORK(PYG), N, Q(I,I+IB+1), LDQ, ONE, - $ G(1,I+IB+1), LDG ) - CALL DGEMM( 'No transpose', 'Transpose', N, N-I-IB, IB, - $ ONE, DWORK(PYG+NIB), N, B(I+IB+1,I), LDB, ONE, - $ G(1,I+IB+1), LDG ) -C -C Update the submatrix B(1:n,i+ib:n). -C - CALL DGEMM( 'No transpose', 'Transpose', N, N-I-IB+1, - $ IB, ONE, DWORK(PXB), N, Q(I+IB,I), LDQ, - $ ONE, B(1,I+IB), LDB ) - CALL DGEMM( 'No transpose', 'Transpose', N, N-I-IB+1, IB, - $ ONE, DWORK(PXB+NIB), N, A(I+IB,I), LDA, ONE, - $ B(1,I+IB), LDB ) - CALL DGEMM( 'Transpose', 'Transpose', N-I-IB, N-I-IB+1, - $ IB, ONE, Q(I,I+IB+1), LDQ, DWORK(PYB+NB), N, - $ ONE, B(I+IB+1,I+IB), LDB ) - CALL DGEMM( 'No transpose', 'Transpose', N-I-IB, N-I-IB+1, - $ IB, ONE, B(I+IB+1,I), LDB, DWORK(PYB+NIB+NB), N, - $ ONE, B(I+IB+1,I+IB), LDB ) - 40 CONTINUE -C - ELSE - DO 50 I = ILO, N-NX-1, NB - IB = MIN( NB, N-I ) - NIB = N*IB -C -C Reduce rows and columns i:i+nb-1 to symplectic URV form and -C return the matrices XA, XB, XG, XQ, YA, YB, YG and YQ which -C are needed to update the unreduced parts of the matrices. -C - CALL MB03XU( LTRA, LTRB, N-I+1, I-1, IB, A(1,I), LDA, - $ B(I,1), LDB, G, LDG, Q(I,I), LDQ, DWORK(PXA), - $ N, DWORK(PXB), N, DWORK(PXG), N, DWORK(PXQ), N, - $ DWORK(PYA), N, DWORK(PYB), N, DWORK(PYG), N, - $ DWORK(PYQ), N, CSL(2*I-1), CSR(2*I-1), TAUL(I), - $ TAUR(I), DWORK(PDW) ) -C -C Update the submatrix A(1:n,i+1+ib:n). -C - CALL DGEMM( 'No transpose', 'Transpose', N-I-IB+1, N-I-IB, - $ IB, ONE, Q(I+IB,I), LDQ, DWORK(PXA+NB+1), N, - $ ONE, A(I+IB,I+IB+1), LDA ) - CALL DGEMM( 'No transpose', 'Transpose', N-I-IB+1, N-I-IB, - $ IB, ONE, A(I+IB,I), LDA, DWORK(PXA+NIB+NB+1), N, - $ ONE, A(I+IB,I+IB+1), LDA ) - CALL DGEMM( 'No transpose', 'No transpose', N, N-I-IB, IB, - $ ONE, DWORK(PYA), N, Q(I,I+IB+1), LDQ, ONE, - $ A(1,I+IB+1), LDA ) - CALL DGEMM( 'No transpose', 'No transpose', N, N-I-IB, IB, - $ ONE, DWORK(PYA+NIB), N, B(I,I+IB+1), LDB, ONE, - $ A(1,I+IB+1), LDA ) -C -C Update the submatrix Q(i+ib:n,i+1+ib:n). -C - CALL DGEMM( 'No transpose', 'Transpose', N-I-IB+1, N-I-IB, - $ IB, ONE, Q(I+IB,I), LDQ, DWORK(PXQ+NB+1), N, - $ ONE, Q(I+IB,I+IB+1), LDQ ) - CALL DGEMM( 'No transpose', 'Transpose', N-I-IB+1, N-I-IB, - $ IB, ONE, A(I+IB,I), LDA, DWORK(PXQ+NIB+NB+1), N, - $ ONE, Q(I+IB,I+IB+1), LDQ ) - CALL DGEMM( 'No transpose', 'No transpose', N-I-IB+1, - $ N-I-IB, IB, ONE, DWORK(PYQ+NB), N, - $ Q(I,I+IB+1), LDQ, ONE, Q(I+IB,I+IB+1), LDQ ) - CALL DGEMM( 'No transpose', 'No transpose', N-I-IB+1, - $ N-I-IB, IB, ONE, DWORK(PYQ+NIB+NB), N, - $ B(I,I+IB+1), LDB, ONE, Q(I+IB,I+IB+1), LDQ ) -C -C Update the matrix G. -C - CALL DGEMM( 'No transpose', 'Transpose', N-I-IB+1, N, IB, - $ ONE, Q(I+IB,I), LDQ, DWORK(PXG), N, ONE, - $ G(I+IB,1), LDG ) - CALL DGEMM( 'No transpose', 'Transpose', N-I-IB+1, N, IB, - $ ONE, A(I+IB,I), LDA, DWORK(PXG+NIB), N, ONE, - $ G(I+IB,1), LDG ) - CALL DGEMM( 'No transpose', 'No transpose', N, N-I-IB, IB, - $ ONE, DWORK(PYG), N, Q(I,I+IB+1), LDQ, ONE, - $ G(1,I+IB+1), LDG ) - CALL DGEMM( 'No transpose', 'No transpose', N, N-I-IB, IB, - $ ONE, DWORK(PYG+NIB), N, B(I,I+IB+1), LDB, ONE, - $ G(1,I+IB+1), LDG ) -C -C Update the submatrix B(i+ib:n,1:n). -C - CALL DGEMM( 'No transpose', 'Transpose', N-I-IB+1, N, - $ IB, ONE, Q(I+IB,I), LDQ, DWORK(PXB), N, - $ ONE, B(I+IB,1), LDB ) - CALL DGEMM( 'No transpose', 'Transpose', N-I-IB+1, N, IB, - $ ONE, A(I+IB,I), LDA, DWORK(PXB+NIB), N, ONE, - $ B(I+IB,1), LDB ) - CALL DGEMM( 'No transpose', 'No transpose', N-I-IB+1, - $ N-I-IB, IB, ONE, DWORK(PYB+NB), N, Q(I,I+IB+1), - $ LDQ, ONE, B(I+IB,I+IB+1), LDB ) - CALL DGEMM( 'No transpose', 'No transpose', N-I-IB+1, - $ N-I-IB, IB, ONE, DWORK(PYB+NIB+NB), N, - $ B(I,I+IB+1), LDB, ONE, B(I+IB,I+IB+1), LDB ) - 50 CONTINUE - END IF -C -C Unblocked code to reduce the rest of the matrices. -C - CALL MB04TS( TRANA, TRANB, N, I, A, LDA, B, LDB, G, LDG, Q, LDQ, - $ CSL, CSR, TAUL, TAUR, DWORK, LDWORK, IERR ) -C - DWORK(1) = DBLE( WRKOPT ) -C - RETURN -C *** Last line of MB04TB *** - END diff --git a/mex/sources/libslicot/MB04TS.f b/mex/sources/libslicot/MB04TS.f deleted file mode 100644 index 66f085f5f..000000000 --- a/mex/sources/libslicot/MB04TS.f +++ /dev/null @@ -1,519 +0,0 @@ - SUBROUTINE MB04TS( TRANA, TRANB, N, ILO, A, LDA, B, LDB, G, LDG, - $ Q, LDQ, CSL, CSR, TAUL, TAUR, DWORK, LDWORK, - $ INFO ) -C -C SLICOT RELEASE 5.0. -C -C Copyright (c) 2002-2009 NICONET e.V. -C -C This program is free software: you can redistribute it and/or -C modify it under the terms of the GNU General Public License as -C published by the Free Software Foundation, either version 2 of -C the License, or (at your option) any later version. -C -C This program is distributed in the hope that it will be useful, -C but WITHOUT ANY WARRANTY; without even the implied warranty of -C MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the -C GNU General Public License for more details. -C -C You should have received a copy of the GNU General Public License -C along with this program. If not, see -C . -C -C PURPOSE -C -C To compute a symplectic URV (SURV) decomposition of a real -C 2N-by-2N matrix H: -C -C [ op(A) G ] T [ op(R11) R12 ] T -C H = [ ] = U R V = U * [ ] * V , -C [ Q op(B) ] [ 0 op(R22) ] -C -C where A, B, G, Q, R12 are real N-by-N matrices, op(R11) is a real -C N-by-N upper triangular matrix, op(R22) is a real N-by-N lower -C Hessenberg matrix and U, V are 2N-by-2N orthogonal symplectic -C matrices. Unblocked version. -C -C ARGUMENTS -C -C Mode Parameters -C -C TRANA CHARACTER*1 -C Specifies the form of op( A ) as follows: -C = 'N': op( A ) = A; -C = 'T': op( A ) = A'; -C = 'C': op( A ) = A'. -C -C TRANB CHARACTER*1 -C Specifies the form of op( B ) as follows: -C = 'N': op( B ) = B; -C = 'T': op( B ) = B'; -C = 'C': op( B ) = B'. -C -C Input/Output Parameters -C -C N (input) INTEGER -C The order of the matrix A. N >= 0. -C -C ILO (input) INTEGER -C It is assumed that op(A) is already upper triangular, -C op(B) is lower triangular and Q is zero in rows and -C columns 1:ILO-1. ILO is normally set by a previous call -C to MB04DD; otherwise it should be set to 1. -C 1 <= ILO <= N, if N > 0; ILO=1, if N=0. -C -C A (input/output) DOUBLE PRECISION array, dimension (LDA,N) -C On entry, the leading N-by-N part of this array must -C contain the matrix A. -C On exit, the leading N-by-N part of this array contains -C the triangular matrix R11, and in the zero part -C information about the elementary reflectors used to -C compute the SURV decomposition. -C -C LDA INTEGER -C The leading dimension of the array A. LDA >= MAX(1,N). -C -C B (input/output) DOUBLE PRECISION array, dimension (LDB,N) -C On entry, the leading N-by-N part of this array must -C contain the matrix B. -C On exit, the leading N-by-N part of this array contains -C the Hessenberg matrix R22, and in the zero part -C information about the elementary reflectors used to -C compute the SURV decomposition. -C -C LDB INTEGER -C The leading dimension of the array B. LDB >= MAX(1,N). -C -C G (input/output) DOUBLE PRECISION array, dimension (LDG,N) -C On entry, the leading N-by-N part of this array must -C contain the matrix G. -C On exit, the leading N-by-N part of this array contains -C the matrix R12. -C -C LDG INTEGER -C The leading dimension of the array G. LDG >= MAX(1,N). -C -C Q (input/output) DOUBLE PRECISION array, dimension (LDQ,N) -C On entry, the leading N-by-N part of this array must -C contain the matrix Q. -C On exit, the leading N-by-N part of this array contains -C information about the elementary reflectors used to -C compute the SURV decomposition. -C -C LDQ INTEGER -C The leading dimension of the array Q. LDG >= MAX(1,N). -C -C CSL (output) DOUBLE PRECISION array, dimension (2N) -C On exit, the first 2N elements of this array contain the -C cosines and sines of the symplectic Givens rotations -C applied from the left-hand side used to compute the SURV -C decomposition. -C -C CSR (output) DOUBLE PRECISION array, dimension (2N-2) -C On exit, the first 2N-2 elements of this array contain the -C cosines and sines of the symplectic Givens rotations -C applied from the right-hand side used to compute the SURV -C decomposition. -C -C TAUL (output) DOUBLE PRECISION array, dimension (N) -C On exit, the first N elements of this array contain the -C scalar factors of some of the elementary reflectors -C applied from the left-hand side. -C -C TAUR (output) DOUBLE PRECISION array, dimension (N-1) -C On exit, the first N-1 elements of this array contain the -C scalar factors of some of the elementary reflectors -C applied from the right-hand side. -C -C Workspace -C -C DWORK DOUBLE PRECISION array, dimension (LDWORK) -C On exit, if INFO = 0, DWORK(1) returns the optimal -C value of LDWORK. -C On exit, if INFO = -16, DWORK(1) returns the minimum -C value of LDWORK. -C -C LDWORK INTEGER -C The length of the array DWORK. LDWORK >= MAX(1,N). -C -C Error Indicator -C -C INFO INTEGER -C = 0: successful exit; -C < 0: if INFO = -i, the i-th argument had an illegal -C value. -C -C METHOD -C -C The matrices U and V are represented as products of symplectic -C reflectors and Givens rotators -C -C U = diag( HU(1),HU(1) ) GU(1) diag( FU(1),FU(1) ) -C diag( HU(2),HU(2) ) GU(2) diag( FU(2),FU(2) ) -C .... -C diag( HU(n),HU(n) ) GU(n) diag( FU(n),FU(n) ), -C -C V = diag( HV(1),HV(1) ) GV(1) diag( FV(1),FV(1) ) -C diag( HV(2),HV(2) ) GV(2) diag( FV(2),FV(2) ) -C .... -C diag( HV(n-1),HV(n-1) ) GV(n-1) diag( FV(n-1),FV(n-1) ). -C -C Each HU(i) has the form -C -C HU(i) = I - tau * v * v' -C -C where tau is a real scalar, and v is a real vector with -C v(1:i-1) = 0 and v(i) = 1; v(i+1:n) is stored on exit in -C Q(i+1:n,i), and tau in Q(i,i). -C -C Each FU(i) has the form -C -C FU(i) = I - nu * w * w' -C -C where nu is a real scalar, and w is a real vector with -C w(1:i-1) = 0 and w(i) = 1; w(i+1:n) is stored on exit in -C A(i+1:n,i), if op(A) = 'N', and in A(i,i+1:n), otherwise. The -C scalar nu is stored in TAUL(i). -C -C Each GU(i) is a Givens rotator acting on rows i and n+i, -C where the cosine is stored in CSL(2*i-1) and the sine in -C CSL(2*i). -C -C Each HV(i) has the form -C -C HV(i) = I - tau * v * v' -C -C where tau is a real scalar, and v is a real vector with -C v(1:i) = 0 and v(i+1) = 1; v(i+2:n) is stored on exit in -C Q(i,i+2:n), and tau in Q(i,i+1). -C -C Each FV(i) has the form -C -C FV(i) = I - nu * w * w' -C -C where nu is a real scalar, and w is a real vector with -C w(1:i) = 0 and w(i+1) = 1; w(i+2:n) is stored on exit in -C B(i,i+2:n), if op(B) = 'N', and in B(i+2:n,i), otherwise. -C The scalar nu is stored in TAUR(i). -C -C Each GV(i) is a Givens rotator acting on columns i+1 and n+i+1, -C where the cosine is stored in CSR(2*i-1) and the sine in -C CSR(2*i). -C -C NUMERICAL ASPECTS -C -C The algorithm requires 80/3 N**3 + 20 N**2 + O(N) floating point -C operations and is numerically backward stable. -C -C REFERENCES -C -C [1] Benner, P., Mehrmann, V., and Xu, H. -C A numerically stable, structure preserving method for -C computing the eigenvalues of real Hamiltonian or symplectic -C pencils. Numer. Math., Vol 78 (3), pp. 329-358, 1998. -C -C CONTRIBUTORS -C -C D. Kressner, Technical Univ. Berlin, Germany, and -C P. Benner, Technical Univ. Chemnitz, Germany, December 2003. -C -C REVISIONS -C -C V. Sima, June 2008 (SLICOT version of the HAPACK routine DGESUV). -C -C KEYWORDS -C -C Elementary matrix operations, Matrix decompositions, Hamiltonian -C matrix -C -C ****************************************************************** -C -C .. Parameters .. - DOUBLE PRECISION ZERO, ONE - PARAMETER ( ZERO = 0.0D0, ONE = 1.0D0 ) -C .. Scalar Arguments .. - CHARACTER TRANA, TRANB - INTEGER ILO, INFO, LDA, LDB, LDG, LDQ, LDWORK, N -C .. Array Arguments .. - DOUBLE PRECISION A(LDA,*), B(LDB,*), CSL(*), CSR(*), DWORK(*), - $ G(LDG,*), Q(LDQ,*), TAUL(*), TAUR(*) -C .. Local Scalars .. - LOGICAL LTRA, LTRB - INTEGER I - DOUBLE PRECISION ALPHA, C, NU, S, TEMP -C .. External Functions .. - LOGICAL LSAME - EXTERNAL LSAME -C .. External Subroutines .. - EXTERNAL DLARF, DLARFG, DLARTG, DROT, XERBLA -C .. Intrinsic Functions .. - INTRINSIC DBLE, MAX -C -C .. Executable Statements .. -C -C Check the scalar input parameters. -C - INFO = 0 - LTRA = LSAME( TRANA, 'T' ) .OR. LSAME( TRANA, 'C' ) - LTRB = LSAME( TRANB, 'T' ) .OR. LSAME( TRANB, 'C' ) - IF ( .NOT.LTRA .AND. .NOT.LSAME( TRANA, 'N' ) ) THEN - INFO = -1 - ELSE IF ( .NOT.LTRB .AND. .NOT.LSAME( TRANB, 'N' ) ) THEN - INFO = -2 - ELSE IF ( N.LT.0 ) THEN - INFO = -3 - ELSE IF ( ILO.LT.1 .OR. ILO.GT.MAX( 1, N ) ) THEN - INFO = -4 - ELSE IF ( LDA.LT.MAX( 1, N ) ) THEN - INFO = -6 - ELSE IF ( LDB.LT.MAX( 1, N ) ) THEN - INFO = -8 - ELSE IF ( LDG.LT.MAX( 1, N ) ) THEN - INFO = -10 - ELSE IF ( LDQ.LT.MAX( 1, N ) ) THEN - INFO = -12 - ELSE IF ( LDWORK.LT.MAX( 1, N ) ) THEN - DWORK(1) = DBLE( MAX( 1, N ) ) - INFO = -18 - END IF -C -C Return if there were illegal values. -C - IF ( INFO.NE.0 ) THEN - CALL XERBLA( 'MB04TS', -INFO ) - RETURN - END IF -C -C Quick return if possible. -C - IF ( N.EQ.0 ) THEN - DWORK(1) = ONE - RETURN - END IF -C - DO 10 I = ILO, N - ALPHA = Q(I,I) - IF ( I.LT.N ) THEN -C -C Generate elementary reflector HU(i) to annihilate Q(i+1:n,i) -C - CALL DLARFG( N-I+1, ALPHA, Q(I+1,I), 1, NU ) -C -C Apply HU(i) from the left. -C - Q(I,I) = ONE - CALL DLARF( 'Left', N-I+1, N-I, Q(I,I), 1, NU, Q(I,I+1), - $ LDQ, DWORK ) - IF ( LTRA ) THEN - CALL DLARF( 'Right', N-I+1, N-I+1, Q(I,I), 1, NU, A(I,I), - $ LDA, DWORK ) - ELSE - CALL DLARF( 'Left', N-I+1, N-I+1, Q(I,I), 1, NU, A(I,I), - $ LDA, DWORK ) - END IF - IF ( LTRB ) THEN - CALL DLARF( 'Right', N, N-I+1, Q(I,I), 1, NU, B(1,I), - $ LDB, DWORK ) - ELSE - CALL DLARF( 'Left', N-I+1, N, Q(I,I), 1, NU, B(I,1), LDB, - $ DWORK ) - END IF - CALL DLARF( 'Left', N-I+1, N, Q(I,I), 1, NU, G(I,1), LDG, - $ DWORK ) - Q(I,I) = NU - ELSE - Q(I,I) = ZERO - END IF -C -C Generate symplectic Givens rotator GU(i) to annihilate Q(i,i). -C - TEMP = A(I,I) - CALL DLARTG( TEMP, ALPHA, C, S, A(I,I) ) -C -C Apply G(i) from the left. -C - IF ( LTRA ) THEN - CALL DROT( N-I, A(I+1,I), 1, Q(I,I+1), LDQ, C, S ) - ELSE - CALL DROT( N-I, A(I,I+1), LDA, Q(I,I+1), LDQ, C, S ) - END IF - IF ( LTRB ) THEN - CALL DROT( N, G(I,1), LDG, B(1,I), 1, C, S ) - ELSE - CALL DROT( N, G(I,1), LDG, B(I,1), LDB, C, S ) - END IF - CSL(2*I-1) = C - CSL(2*I) = S -C - IF ( I.LT.N ) THEN - IF ( LTRA ) THEN -C -C Generate elementary reflector FU(i) to annihilate -C A(i,i+1:n). -C - CALL DLARFG( N-I+1, A(I,I), A(I,I+1), LDA, TAUL(I) ) -C -C Apply FU(i) from the left. -C - TEMP = A(I,I) - A(I,I) = ONE - CALL DLARF( 'Right', N-I, N-I+1, A(I,I), LDA, TAUL(I), - $ A(I+1,I), LDA, DWORK ) - CALL DLARF( 'Left', N-I+1, N-I, A(I,I), LDA, TAUL(I), - $ Q(I,I+1), LDQ, DWORK ) - IF ( LTRB ) THEN - CALL DLARF( 'Right', N, N-I+1, A(I,I), LDA, TAUL(I), - $ B(1,I), LDB, DWORK ) - ELSE - CALL DLARF( 'Left', N-I+1, N, A(I,I), LDA, TAUL(I), - $ B(I,1), LDB, DWORK ) - END IF - CALL DLARF( 'Left', N-I+1, N, A(I,I), LDA, TAUL(I), - $ G(I,1), LDG, DWORK ) - A(I,I) = TEMP - ELSE -C -C Generate elementary reflector FU(i) to annihilate -C A(i+1:n,i). -C - CALL DLARFG( N-I+1, A(I,I), A(I+1,I), 1, TAUL(I) ) -C -C Apply FU(i) from the left. -C - TEMP = A(I,I) - A(I,I) = ONE - CALL DLARF( 'Left', N-I+1, N-I, A(I,I), 1, TAUL(I), - $ A(I,I+1), LDA, DWORK ) - CALL DLARF( 'Left', N-I+1, N-I, A(I,I), 1, TAUL(I), - $ Q(I,I+1), LDQ, DWORK ) - IF ( LTRB ) THEN - CALL DLARF( 'Right', N, N-I+1, A(I,I), 1, TAUL(I), - $ B(1,I), LDB, DWORK ) - ELSE - CALL DLARF( 'Left', N-I+1, N, A(I,I), 1, TAUL(I), - $ B(I,1), LDB, DWORK ) - END IF - CALL DLARF( 'Left', N-I+1, N, A(I,I), 1, TAUL(I), G(I,1), - $ LDG, DWORK ) - A(I,I) = TEMP - END IF - ELSE - TAUL(I) = ZERO - END IF - IF ( I.LT.N ) - $ ALPHA = Q(I,I+1) - IF ( I.LT.N-1 ) THEN -C -C Generate elementary reflector HV(i) to annihilate Q(i,i+2:n) -C - CALL DLARFG( N-I, ALPHA, Q(I,I+2), LDQ, NU ) -C -C Apply HV(i) from the right. -C - Q(I,I+1) = ONE - CALL DLARF( 'Right', N-I, N-I, Q(I,I+1), LDQ, NU, - $ Q(I+1,I+1), LDQ, DWORK ) - IF ( LTRA ) THEN - CALL DLARF( 'Left', N-I, N, Q(I,I+1), LDQ, NU, - $ A(I+1,1), LDA, DWORK ) - ELSE - CALL DLARF( 'Right', N, N-I, Q(I,I+1), LDQ, NU, - $ A(1,I+1), LDA, DWORK ) - END IF - IF ( LTRB ) THEN - CALL DLARF( 'Left', N-I, N-I+1, Q(I,I+1), LDQ, NU, - $ B(I+1,I), LDB, DWORK ) - ELSE - CALL DLARF( 'Right', N-I+1, N-I, Q(I,I+1), LDQ, NU, - $ B(I,I+1), LDB, DWORK ) - END IF - CALL DLARF( 'Right', N, N-I, Q(I,I+1), LDQ, NU, - $ G(1,I+1), LDG, DWORK ) - Q(I,I+1) = NU - ELSE IF ( I.LT.N ) THEN - Q(I,I+1) = ZERO - END IF - IF ( I.LT.N ) THEN -C -C Generate symplectic Givens rotator GV(i) to annihilate -C Q(i,i+1). -C - IF ( LTRB ) THEN - TEMP = B(I+1,I) - CALL DLARTG( TEMP, ALPHA, C, S, B(I+1,I) ) - S = -S - CALL DROT( N-I, Q(I+1,I+1), 1, B(I+1,I+1), LDB, C, S ) - ELSE - TEMP = B(I,I+1) - CALL DLARTG( TEMP, ALPHA, C, S, B(I,I+1) ) - S = -S - CALL DROT( N-I, Q(I+1,I+1), 1, B(I+1,I+1), 1, C, S ) - END IF - IF ( LTRA ) THEN - CALL DROT( N, A(I+1,1), LDA, G(1,I+1), 1, C, S ) - ELSE - CALL DROT( N, A(1,I+1), 1, G(1,I+1), 1, C, S ) - END IF - CSR(2*I-1) = C - CSR(2*I) = S - END IF - IF ( I.LT.N-1 ) THEN - IF ( LTRB ) THEN -C -C Generate elementary reflector FV(i) to annihilate -C B(i+2:n,i). -C - CALL DLARFG( N-I, B(I+1,I), B(I+2,I), 1, TAUR(I) ) -C -C Apply FV(i) from the right. -C - TEMP = B(I+1,I) - B(I+1,I) = ONE - CALL DLARF( 'Left', N-I, N-I, B(I+1,I), 1, TAUR(I), - $ B(I+1,I+1), LDB, DWORK ) - CALL DLARF( 'Right', N-I, N-I, B(I+1,I), 1, TAUR(I), - $ Q(I+1,I+1), LDQ, DWORK ) - IF ( LTRA ) THEN - CALL DLARF( 'Left', N-I, N, B(I+1,I), 1, - $ TAUR(I), A(I+1,1), LDA, DWORK ) - ELSE - CALL DLARF( 'Right', N, N-I, B(I+1,I), 1, - $ TAUR(I), A(1,I+1), LDA, DWORK ) - END IF - CALL DLARF( 'Right', N, N-I, B(I+1,I), 1, TAUR(I), - $ G(1,I+1), LDG, DWORK ) - B(I+1,I) = TEMP - ELSE -C -C Generate elementary reflector FV(i) to annihilate -C B(i,i+2:n). -C - CALL DLARFG( N-I, B(I,I+1), B(I,I+2), LDB, TAUR(I) ) -C -C Apply FV(i) from the right. -C - TEMP = B(I,I+1) - B(I,I+1) = ONE - CALL DLARF( 'Right', N-I, N-I, B(I,I+1), LDB, TAUR(I), - $ B(I+1,I+1), LDB, DWORK ) - CALL DLARF( 'Right', N-I, N-I, B(I,I+1), LDB, TAUR(I), - $ Q(I+1,I+1), LDQ, DWORK ) - IF ( LTRA ) THEN - CALL DLARF( 'Left', N-I, N, B(I,I+1), LDB, TAUR(I), - $ A(I+1,1), LDA, DWORK ) - ELSE - CALL DLARF( 'Right', N, N-I, B(I,I+1), LDB, - $ TAUR(I), A(1,I+1), LDA, DWORK ) - END IF - CALL DLARF( 'Right', N, N-I, B(I,I+1), LDB, TAUR(I), - $ G(1,I+1), LDG, DWORK ) - B(I,I+1) = TEMP - END IF - ELSE IF ( I.LT.N ) THEN - TAUR(I) = ZERO - END IF - 10 CONTINUE - DWORK(1) = DBLE( MAX( 1, N ) ) - RETURN -C *** Last line of MB04TS *** - END diff --git a/mex/sources/libslicot/MB04TT.f b/mex/sources/libslicot/MB04TT.f deleted file mode 100644 index 7d8e207f9..000000000 --- a/mex/sources/libslicot/MB04TT.f +++ /dev/null @@ -1,413 +0,0 @@ - SUBROUTINE MB04TT( UPDATQ, UPDATZ, M, N, IFIRA, IFICA, NCA, A, - $ LDA, E, LDE, Q, LDQ, Z, LDZ, ISTAIR, RANK, TOL, - $ IWORK ) -C -C SLICOT RELEASE 5.0. -C -C Copyright (c) 2002-2009 NICONET e.V. -C -C This program is free software: you can redistribute it and/or -C modify it under the terms of the GNU General Public License as -C published by the Free Software Foundation, either version 2 of -C the License, or (at your option) any later version. -C -C This program is distributed in the hope that it will be useful, -C but WITHOUT ANY WARRANTY; without even the implied warranty of -C MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the -C GNU General Public License for more details. -C -C You should have received a copy of the GNU General Public License -C along with this program. If not, see -C . -C -C PURPOSE -C -C Let A and E be M-by-N matrices with E in column echelon form. -C Let AA and EE be the following submatrices of A and E: -C AA := A(IFIRA : M ; IFICA : N) -C EE := E(IFIRA : M ; IFICA : N). -C Let Aj and Ej be the following submatrices of AA and EE: -C Aj := A(IFIRA : M ; IFICA : IFICA + NCA - 1) and -C Ej := E(IFIRA : M ; IFICA + NCA : N). -C -C To transform (AA,EE) such that Aj is row compressed while keeping -C matrix Ej in column echelon form (which may be different from the -C form on entry). -C In fact the routine performs the j-th step of Algorithm 3.2.1 in -C [1]. Furthermore, it determines the rank RANK of the submatrix Ej, -C which is equal to the number of corner points in submatrix Ej. -C -C ARGUMENTS -C -C Mode Parameters -C -C UPDATQ LOGICAL -C Indicates whether the user wishes to accumulate in a -C matrix Q the orthogonal row transformations, as follows: -C = .FALSE.: Do not form Q; -C = .TRUE.: The given matrix Q is updated by the orthogonal -C row transformations used in the reduction. -C -C UPDATZ LOGICAL -C Indicates whether the user wishes to accumulate in a -C matrix Z the orthogonal column transformations, as -C follows: -C = .FALSE.: Do not form Z; -C = .TRUE.: The given matrix Z is updated by the orthogonal -C column transformations used in the reduction. -C -C Input/Output Parameters -C -C M (input) INTEGER -C M is the number of rows of the matrices A, E and Q. -C M >= 0. -C -C N (input) INTEGER -C N is the number of columns of the matrices A, E and Z. -C N >= 0. -C -C IFIRA (input) INTEGER -C IFIRA is the first row index of the submatrices Aj and Ej -C in the matrices A and E, respectively. -C -C IFICA (input) INTEGER -C IFICA and IFICA + NCA are the first column indices of the -C submatrices Aj and Ej in the matrices A and E, -C respectively. -C -C NCA (input) INTEGER -C NCA is the number of columns of the submatrix Aj in A. -C -C A (input/output) DOUBLE PRECISION array, dimension (LDA,N) -C On entry, A(IFIRA : M ; IFICA : IFICA + NCA - 1) contains -C the matrix Aj. -C On exit, it contains the matrix A with AA that has been -C row compressed while keeping EE in column echelon form. -C -C LDA INTEGER -C The leading dimension of array A. LDA >= MAX(1,M). -C -C E (input/output) DOUBLE PRECISION array, dimension (LDE,N) -C On entry, E(IFIRA : M ; IFICA + NCA : N) contains the -C matrix Ej which is in column echelon form. -C On exit, it contains the transformed matrix EE which is -C kept in column echelon form. -C -C LDE INTEGER -C The leading dimension of array E. LDE >= MAX(1,M). -C -C Q (input/output) DOUBLE PRECISION array, dimension (LDQ,*) -C On entry, if UPDATQ = .TRUE., then the leading M-by-M -C part of this array must contain a given matrix Q (e.g. -C from a previous call to another SLICOT routine), and on -C exit, the leading M-by-M part of this array contains the -C product of the input matrix Q and the row transformation -C matrix that has transformed the rows of the matrices A -C and E. -C If UPDATQ = .FALSE., the array Q is not referenced and -C can be supplied as a dummy array (i.e. set parameter -C LDQ = 1 and declare this array to be Q(1,1) in the calling -C program). -C -C LDQ INTEGER -C The leading dimension of array Q. If UPDATQ = .TRUE., -C LDQ >= MAX(1,M); if UPDATQ = .FALSE., LDQ >= 1. -C -C Z (input/output) DOUBLE PRECISION array, dimension (LDZ,*) -C On entry, if UPDATZ = .TRUE., then the leading N-by-N -C part of this array must contain a given matrix Z (e.g. -C from a previous call to another SLICOT routine), and on -C exit, the leading N-by-N part of this array contains the -C product of the input matrix Z and the column -C transformation matrix that has transformed the columns of -C the matrices A and E. -C If UPDATZ = .FALSE., the array Z is not referenced and -C can be supplied as a dummy array (i.e. set parameter -C LDZ = 1 and declare this array to be Z(1,1) in the calling -C program). -C -C LDZ INTEGER -C The leading dimension of array Z. If UPDATZ = .TRUE., -C LDZ >= MAX(1,N); if UPDATZ = .FALSE., LDZ >= 1. -C -C ISTAIR (input/output) INTEGER array, dimension (M) -C On entry, ISTAIR contains information on the column -C echelon form of the input matrix E as follows: -C ISTAIR(i) = +j: the boundary element E(i,j) is a corner -C point; -C -j: the boundary element E(i,j) is not a -C corner point (where i=1,...,M). -C On exit, ISTAIR contains the same information for the -C transformed matrix E. -C -C RANK (output) INTEGER -C Numerical rank of the submatrix Aj in A (based on TOL). -C -C Tolerances -C -C TOL DOUBLE PRECISION -C The tolerance used when considering matrix elements -C to be zero. -C -C Workspace -C -C IWORK INTEGER array, dimension (N) -C -C REFERENCES -C -C [1] Beelen, Th. -C New Algorithms for Computing the Kronecker structure of a -C Pencil with Applications to Systems and Control Theory. -C Ph.D.Thesis, Eindhoven University of Technology, -C The Netherlands, 1987. -C -C NUMERICAL ASPECTS -C 3 -C The algorithm requires 0(N ) operations and is backward stable. -C -C CONTRIBUTOR -C -C Release 3.0: V. Sima, Katholieke Univ. Leuven, Belgium, Mar. 1997. -C Supersedes Release 2.0 routine MB04FZ by Th.G.J. Beelen, -C Philips Glass Eindhoven, Holland. -C -C REVISIONS -C -C June 13, 1997, V. Sima. -C November 24, 1997, A. Varga: array starting point A(KK,LL) -C correctly set when calling DLASET. -C -C KEYWORDS -C -C Echelon form, orthogonal transformation. -C -C ****************************************************************** -C -C .. Parameters .. - DOUBLE PRECISION ZERO - PARAMETER ( ZERO = 0.0D0 ) -C .. Scalar Arguments .. - LOGICAL UPDATQ, UPDATZ - INTEGER IFICA, IFIRA, LDA, LDE, LDQ, LDZ, M, N, NCA, - $ RANK - DOUBLE PRECISION TOL -C .. Array Arguments .. - INTEGER ISTAIR(*), IWORK(*) - DOUBLE PRECISION A(LDA,*), E(LDE,*), Q(LDQ,*), Z(LDZ,*) -C .. Local Scalars .. - LOGICAL LZERO - INTEGER I, IFICA1, IFIRA1, II, IP, IST1, IST2, ISTPVT, - $ ITYPE, JC1, JC2, JPVT, K, KK, L, LL, LSAV, MJ, - $ MK1, MXRANK, NJ - DOUBLE PRECISION BMX, BMXNRM, EIJPVT, SC, SS -C .. External Functions .. - INTEGER IDAMAX - EXTERNAL IDAMAX -C .. External Subroutines .. - EXTERNAL DLAPMT, DLASET, DROT, DROTG, DSWAP -C .. Intrinsic Functions .. - INTRINSIC ABS, MIN -C .. Executable Statements .. -C - RANK = 0 - IF ( M.LE.0 .OR. N.LE.0 ) - $ RETURN -C -C Initialisation. -C -C NJ = number of columns in submatrix Aj, -C MJ = number of rows in submatrices Aj and Ej. -C - NJ = NCA - MJ = M + 1 - IFIRA - IFIRA1 = IFIRA - 1 - IFICA1 = IFICA - 1 -C - DO 20 I = 1, NJ - IWORK(I) = I - 20 CONTINUE -C - K = 1 - LZERO = .FALSE. - RANK = MIN( NJ, MJ ) - MXRANK = RANK -C -C WHILE ( K <= MXRANK ) and ( LZERO = FALSE ) DO - 40 IF ( ( K.LE.MXRANK ) .AND. ( .NOT.LZERO ) ) THEN -C -C Determine column in Aj with largest max-norm. -C - BMXNRM = ZERO - LSAV = K - KK = IFIRA1 + K -C - DO 60 L = K, NJ -C -C IDAMAX call gives the relative index in column L of Aj where -C max element is found. -C Note: the first element in column L is in row K of -C matrix Aj. -C - LL = IFICA1 + L - BMX = ABS( A(IDAMAX( MJ-K+1, A(KK,LL), 1 )+KK-1,LL) ) - IF ( BMX.GT.BMXNRM ) THEN - BMXNRM = BMX - LSAV = L - END IF - 60 CONTINUE -C - LL = IFICA1 + K - IF ( BMXNRM.LT.TOL ) THEN -C -C Set submatrix of Aj to zero. -C - CALL DLASET( 'Full', MJ-K+1, NJ-K+1, ZERO, ZERO, A(KK,LL), - $ LDA ) - LZERO = .TRUE. - RANK = K - 1 - ELSE -C -C Check whether columns have to be interchanged. -C - IF ( LSAV.NE.K ) THEN -C -C Interchange the columns in A which correspond to the -C columns lsav and k in Aj. Store the permutation in IWORK. -C - CALL DSWAP( M, A(1,LL), 1, A(1,IFICA1+LSAV), 1 ) - IP = IWORK(LSAV) - IWORK(LSAV) = IWORK(K) - IWORK(K) = IP - END IF -C - K = K + 1 - MK1 = N - LL + 1 -C - DO 80 I = MJ, K, -1 -C -C II = absolute row number in A corresponding to row i in -C Aj. -C - II = IFIRA1 + I -C -C Construct Givens transformation to annihilate Aj(i,k). -C Apply the row transformation to whole matrix A -C (NOT only to Aj). -C Update row transformation matrix Q, if needed. -C - CALL DROTG( A(II-1,LL), A(II,LL), SC, SS ) - CALL DROT( MK1-1, A(II-1,LL+1), LDA, A(II,LL+1), LDA, SC, - $ SS ) - A(II,LL) = ZERO - IF ( UPDATQ ) - $ CALL DROT( M, Q(1,II-1), 1, Q(1,II), 1, SC, SS ) -C -C Determine boundary type of matrix E at rows II-1 and II. -C - IST1 = ISTAIR(II-1) - IST2 = ISTAIR(II) - IF ( ( IST1*IST2 ).GT.0 ) THEN - IF ( IST1.GT.0 ) THEN -C -C boundary form = (* x) -C (0 *) -C - ITYPE = 1 - ELSE -C -C boundary form = (x x) -C (x x) -C - ITYPE = 3 - END IF - ELSE - IF ( IST1.LT.0 ) THEN -C -C boundary form = (x x) -C (* x) -C - ITYPE = 2 - ELSE -C -C boundary form = (* x) -C (0 x) -C - ITYPE = 4 - END IF - END IF -C -C Apply row transformation also to matrix E. -C -C JC1 = absolute number of the column in E in which stair -C element of row i-1 of Ej is present. -C JC2 = absolute number of the column in E in which stair -C element of row i of Ej is present. -C -C Note: JC1 < JC2 if ITYPE = 1. -C JC1 = JC2 if ITYPE = 2, 3 or 4. -C - JC1 = ABS( IST1 ) - JC2 = ABS( IST2 ) - JPVT = MIN( JC1, JC2 ) -C - CALL DROT( N-JPVT+1, E(II-1,JPVT), LDE, E(II,JPVT), LDE, - $ SC, SS ) - EIJPVT = E(II,JPVT) -C - IF ( ITYPE.EQ.1 ) THEN -C -C Construct column Givens transformation to annihilate -C E(ii,jpvt). -C Apply column Givens transformation to matrix E -C (NOT only to Ej). -C - CALL DROTG( E(II,JPVT+1), E(II,JPVT), SC, SS ) - CALL DROT( II-1, E(1,JPVT+1), 1, E(1,JPVT), 1, SC, - $ SS ) - E(II,JPVT) = ZERO -C -C Apply this transformation also to matrix A -C (NOT only to Aj). -C Update column transformation matrix Z, if needed. -C - CALL DROT( M, A(1,JPVT+1), 1, A(1,JPVT), 1, SC, SS ) - IF ( UPDATZ ) CALL DROT( N, Z(1,JPVT+1), 1, Z(1,JPVT), - $ 1, SC, SS ) -C - ELSE IF ( ITYPE.EQ.2 ) THEN - IF ( ABS( EIJPVT ).LT.TOL ) THEN -C -C (x x) (* x) -C Boundary form has been changed from (* x) to (0 x). -C - ISTPVT = ISTAIR(II) - ISTAIR(II-1) = ISTPVT - ISTAIR(II) = -(ISTPVT+1 ) - E(II,JPVT) = ZERO - END IF -C - ELSE IF ( ITYPE.EQ.4 ) THEN - IF ( ABS( EIJPVT ).GE.TOL ) THEN -C -C (* x) (x x) -C Boundary form has been changed from (0 x) to (* x). -C - ISTPVT = ISTAIR(II-1) - ISTAIR(II-1) = -ISTPVT - ISTAIR(II) = ISTPVT - END IF - END IF - 80 CONTINUE -C - END IF - GO TO 40 - END IF -C END WHILE 40 -C -C Permute columns of Aj to original order. -C - CALL DLAPMT( .FALSE., IFIRA1+RANK, NJ, A(1,IFICA), LDA, IWORK ) -C - RETURN -C *** Last line of MB04TT *** - END diff --git a/mex/sources/libslicot/MB04TU.f b/mex/sources/libslicot/MB04TU.f deleted file mode 100644 index 74e81bfe1..000000000 --- a/mex/sources/libslicot/MB04TU.f +++ /dev/null @@ -1,96 +0,0 @@ - SUBROUTINE MB04TU( N, X, INCX, Y, INCY, C, S ) -C -C SLICOT RELEASE 5.0. -C -C Copyright (c) 2002-2009 NICONET e.V. -C -C This program is free software: you can redistribute it and/or -C modify it under the terms of the GNU General Public License as -C published by the Free Software Foundation, either version 2 of -C the License, or (at your option) any later version. -C -C This program is distributed in the hope that it will be useful, -C but WITHOUT ANY WARRANTY; without even the implied warranty of -C MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the -C GNU General Public License for more details. -C -C You should have received a copy of the GNU General Public License -C along with this program. If not, see -C . -C -C PURPOSE -C -C To perform the Givens transformation, defined by C (cos) and S -C (sin), and interchange the vectors involved, i.e. -C -C |X(i)| | 0 1 | | C S | |X(i)| -C | | := | | x | | x | |, i = 1,...N. -C |Y(i)| | 1 0 | |-S C | |Y(i)| -C -C REMARK. This routine is a modification of DROT from BLAS. -C This routine is called only by the SLICOT routines MB04TX -C and MB04VX. -C -C NUMERICAL ASPECTS -C -C The algorithm is backward stable. -C -C CONTRIBUTOR -C -C Release 3.0: V. Sima, Katholieke Univ. Leuven, Belgium, Apr. 1997. -C Supersedes Release 2.0 routine MB04FU by Th.G.J. Beelen, -C Philips Glass Eindhoven, Holland. -C -C REVISIONS -C -C January 26, 1998. -C -C KEYWORDS -C -C Othogonal transformation. -C -C ****************************************************************** -C -C .. Scalar Arguments .. - INTEGER INCX, INCY, N - DOUBLE PRECISION C, S -C .. Array Arguments .. - DOUBLE PRECISION X(*), Y(*) -C .. Local Scalars .. - DOUBLE PRECISION DTEMP - INTEGER I, IX, IY -C .. Executable Statements .. -C - IF ( N.LE.0 ) RETURN - IF ( ( INCX.NE.1 ) .OR. ( INCY.NE.1 ) ) THEN -C -C Code for unequal increments or equal increments not equal to 1. -C - IX = 1 - IY = 1 - IF ( INCX.LT.0 ) IX = (-N+1)*INCX + 1 - IF ( INCY.LT.0 ) IY = (-N+1)*INCY + 1 -C - DO 20 I = 1, N - DTEMP = C*Y(IY) - S*X(IX) - Y(IY) = C*X(IX) + S*Y(IY) - X(IX) = DTEMP - IX = IX + INCX - IY = IY + INCY - 20 CONTINUE -C - ELSE -C -C Code for both increments equal to 1. -C - DO 40 I = 1, N - DTEMP = C*Y(I) - S*X(I) - Y(I) = C*X(I) + S*Y(I) - X(I) = DTEMP - 40 CONTINUE -C - END IF -C - RETURN -C *** Last line of MB04TU *** - END diff --git a/mex/sources/libslicot/MB04TV.f b/mex/sources/libslicot/MB04TV.f deleted file mode 100644 index c3fa37f2d..000000000 --- a/mex/sources/libslicot/MB04TV.f +++ /dev/null @@ -1,171 +0,0 @@ - SUBROUTINE MB04TV( UPDATZ, N, NRA, NCA, IFIRA, IFICA, A, LDA, E, - $ LDE, Z, LDZ ) -C -C SLICOT RELEASE 5.0. -C -C Copyright (c) 2002-2009 NICONET e.V. -C -C This program is free software: you can redistribute it and/or -C modify it under the terms of the GNU General Public License as -C published by the Free Software Foundation, either version 2 of -C the License, or (at your option) any later version. -C -C This program is distributed in the hope that it will be useful, -C but WITHOUT ANY WARRANTY; without even the implied warranty of -C MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the -C GNU General Public License for more details. -C -C You should have received a copy of the GNU General Public License -C along with this program. If not, see -C . -C -C PURPOSE -C -C To reduce a submatrix A(k) of A to upper triangular form by column -C Givens rotations only. -C Here A(k) = A(IFIRA:ma,IFICA:na) where ma = IFIRA - 1 + NRA, -C na = IFICA - 1 + NCA. -C Matrix A(k) is assumed to have full row rank on entry. Hence, no -C pivoting is done during the reduction process. See Algorithm 2.3.1 -C and Remark 2.3.4 in [1]. -C The constructed column transformations are also applied to matrix -C E(k) = E(1:IFIRA-1,IFICA:na). -C Note that in E columns are transformed with the same column -C indices as in A, but with row indices different from those in A. -C -C ARGUMENTS -C -C Mode Parameters -C -C UPDATZ LOGICAL -C Indicates whether the user wishes to accumulate in a -C matrix Z the orthogonal column transformations, as -C follows: -C = .FALSE.: Do not form Z; -C = .TRUE.: The given matrix Z is updated by the orthogonal -C column transformations used in the reduction. -C -C Input/Output Parameters -C -C N (input) INTEGER -C Number of columns of A and E. N >= 0. -C -C NRA (input) INTEGER -C Number of rows in A to be transformed. 0 <= NRA <= LDA. -C -C NCA (input) INTEGER -C Number of columns in A to be transformed. 0 <= NCA <= N. -C -C IFIRA (input) INTEGER -C Index of the first row in A to be transformed. -C -C IFICA (input) INTEGER -C Index of the first column in A to be transformed. -C -C A (input/output) DOUBLE PRECISION array, dimension (LDA,N) -C On entry, the elements of A(IFIRA:ma,IFICA:na) must -C contain the submatrix A(k) of full row rank to be reduced -C to upper triangular form. -C On exit, it contains the transformed matrix A. -C -C LDA INTEGER -C The leading dimension of array A. LDA >= MAX(1,NRA). -C -C E (input/output) DOUBLE PRECISION array, dimension (LDE,N) -C On entry, the elements of E(1:IFIRA-1,IFICA:na) must -C contain the submatrix E(k). -C On exit, it contains the transformed matrix E. -C -C LDE INTEGER -C The leading dimension of array E. LDE >= MAX(1,IFIRA-1). -C -C Z (input/output) DOUBLE PRECISION array, dimension (LDZ,*) -C On entry, if UPDATZ = .TRUE., then the leading N-by-N -C part of this array must contain a given matrix Z (e.g. -C from a previous call to another SLICOT routine), and on -C exit, the leading N-by-N part of this array contains the -C product of the input matrix Z and the column -C transformation matrix that has transformed the columns of -C the matrices A and E. -C If UPDATZ = .FALSE., the array Z is not referenced and -C can be supplied as a dummy array (i.e. set parameter -C LDZ = 1 and declare this array to be Z(1,1) in the calling -C program). -C -C LDZ INTEGER -C The leading dimension of array Z. If UPDATZ = .TRUE., -C LDZ >= MAX(1,N); if UPDATZ = .FALSE., LDZ >= 1. -C -C REFERENCES -C -C [1] Beelen, Th. -C New Algorithms for Computing the Kronecker structure of a -C Pencil with Applications to Systems and Control Theory. -C Ph.D.Thesis, Eindhoven University of Technology, -C The Netherlands, 1987. -C -C NUMERICAL ASPECTS -C -C The algorithm is backward stable. -C -C CONTRIBUTOR -C -C Release 3.0: V. Sima, Katholieke Univ. Leuven, Belgium, Apr. 1997. -C Supersedes Release 2.0 routine MB04FV by Th.G.J. Beelen, -C Philips Glass Eindhoven, Holland. -C -C REVISIONS -C -C - -C -C KEYWORDS -C -C Generalized eigenvalue problem, orthogonal transformation, -C staircase form. -C -C ****************************************************************** -C -C .. Parameters .. - DOUBLE PRECISION ZERO - PARAMETER ( ZERO = 0.0D0 ) -C .. Scalar Arguments .. - LOGICAL UPDATZ - INTEGER IFICA, IFIRA, LDA, LDE, LDZ, N, NCA, NRA -C .. Array Arguments .. - DOUBLE PRECISION A(LDA,*), E(LDE,*), Z(LDZ,*) -C .. Local Scalars .. - INTEGER I, IFIRA1, J, JPVT - DOUBLE PRECISION SC, SS -C .. External Subroutines .. - EXTERNAL DROT, DROTG -C .. Executable Statements .. -C - IF ( N.LE.0 .OR. NRA.LE.0 .OR. NCA.LE.0 ) - $ RETURN - IFIRA1 = IFIRA - 1 - JPVT = IFICA + NCA -C - DO 40 I = IFIRA1 + NRA, IFIRA, -1 - JPVT = JPVT - 1 -C - DO 20 J = JPVT - 1, IFICA, -1 -C -C Determine the Givens transformation on columns j and jpvt -C to annihilate A(i,j). Apply the transformation to these -C columns from rows 1 up to i. -C Apply the transformation also to the E-matrix (from rows 1 -C up to ifira1). -C Update column transformation matrix Z, if needed. -C - CALL DROTG( A(I,JPVT), A(I,J), SC, SS ) - CALL DROT( I-1, A(1,JPVT), 1, A(1,J), 1, SC, SS ) - A(I,J) = ZERO - CALL DROT( IFIRA1, E(1,JPVT), 1, E(1,J), 1, SC, SS ) - IF( UPDATZ ) CALL DROT( N, Z(1,JPVT), 1, Z(1,J), 1, SC, SS ) - 20 CONTINUE -C - 40 CONTINUE -C - RETURN -C *** Last line of MB04TV *** - END diff --git a/mex/sources/libslicot/MB04TW.f b/mex/sources/libslicot/MB04TW.f deleted file mode 100644 index 81854d9f2..000000000 --- a/mex/sources/libslicot/MB04TW.f +++ /dev/null @@ -1,180 +0,0 @@ - SUBROUTINE MB04TW( UPDATQ, M, N, NRE, NCE, IFIRE, IFICE, IFICA, A, - $ LDA, E, LDE, Q, LDQ ) -C -C SLICOT RELEASE 5.0. -C -C Copyright (c) 2002-2009 NICONET e.V. -C -C This program is free software: you can redistribute it and/or -C modify it under the terms of the GNU General Public License as -C published by the Free Software Foundation, either version 2 of -C the License, or (at your option) any later version. -C -C This program is distributed in the hope that it will be useful, -C but WITHOUT ANY WARRANTY; without even the implied warranty of -C MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the -C GNU General Public License for more details. -C -C You should have received a copy of the GNU General Public License -C along with this program. If not, see -C . -C -C PURPOSE -C -C To reduce a submatrix E(k) of E to upper triangular form by row -C Givens rotations only. -C Here E(k) = E(IFIRE:me,IFICE:ne), where me = IFIRE - 1 + NRE, -C ne = IFICE - 1 + NCE. -C Matrix E(k) is assumed to have full column rank on entry. Hence, -C no pivoting is done during the reduction process. See Algorithm -C 2.3.1 and Remark 2.3.4 in [1]. -C The constructed row transformations are also applied to matrix -C A(k) = A(IFIRE:me,IFICA:N). -C Note that in A(k) rows are transformed with the same row indices -C as in E but with column indices different from those in E. -C -C ARGUMENTS -C -C Mode Parameters -C -C UPDATQ LOGICAL -C Indicates whether the user wishes to accumulate in a -C matrix Q the orthogonal row transformations, as follows: -C = .FALSE.: Do not form Q; -C = .TRUE.: The given matrix Q is updated by the orthogonal -C row transformations used in the reduction. -C -C Input/Output Parameters -C -C M (input) INTEGER -C Number of rows of A and E. M >= 0. -C -C N (input) INTEGER -C Number of columns of A and E. N >= 0. -C -C NRE (input) INTEGER -C Number of rows in E to be transformed. 0 <= NRE <= M. -C -C NCE (input) INTEGER -C Number of columns in E to be transformed. 0 <= NCE <= N. -C -C IFIRE (input) INTEGER -C Index of first row in E to be transformed. -C -C IFICE (input) INTEGER -C Index of first column in E to be transformed. -C -C IFICA (input) INTEGER -C Index of first column in A to be transformed. -C -C A (input/output) DOUBLE PRECISION array, dimension (LDA,N) -C On entry, this array contains the submatrix A(k). -C On exit, it contains the transformed matrix A(k). -C -C LDA INTEGER -C The leading dimension of array A. LDA >= MAX(1,M). -C -C E (input/output) DOUBLE PRECISION array, dimension (LDE,N) -C On entry, this array contains the submatrix E(k) of full -C column rank to be reduced to upper triangular form. -C On exit, it contains the transformed matrix E. -C -C LDE INTEGER -C The leading dimension of array E. LDE >= MAX(1,M). -C -C Q (input/output) DOUBLE PRECISION array, dimension (LDQ,*) -C On entry, if UPDATQ = .TRUE., then the leading M-by-M -C part of this array must contain a given matrix Q (e.g. -C from a previous call to another SLICOT routine), and on -C exit, the leading M-by-M part of this array contains the -C product of the input matrix Q and the row transformation -C matrix that has transformed the rows of the matrices A -C and E. -C If UPDATQ = .FALSE., the array Q is not referenced and -C can be supplied as a dummy array (i.e. set parameter -C LDQ = 1 and declare this array to be Q(1,1) in the calling -C program). -C -C LDQ INTEGER -C The leading dimension of array Q. If UPDATQ = .TRUE., -C LDQ >= MAX(1,M); if UPDATQ = .FALSE., LDQ >= 1. -C -C REFERENCES -C -C [1] Beelen, Th. -C New Algorithms for Computing the Kronecker structure of a -C Pencil with Applications to Systems and Control Theory. -C Ph.D.Thesis, Eindhoven University of Technology, -C The Netherlands, 1987. -C -C NUMERICAL ASPECTS -C -C The algorithm is backward stable. -C -C CONTRIBUTOR -C -C Release 3.0: V. Sima, Katholieke Univ. Leuven, Belgium, Apr. 1997. -C Supersedes Release 2.0 routine MB04FW by Th.G.J. Beelen, -C Philips Glass Eindhoven, Holland. -C -C REVISIONS -C -C June 13, 1997. V. Sima. -C December 30, 1997. A. Varga: Corrected column range to apply -C transformations on the matrix E. -C -C KEYWORDS -C -C Generalized eigenvalue problem, orthogonal transformation, -C staircase form. -C -C ****************************************************************** -C -C .. Parameters .. - DOUBLE PRECISION ZERO - PARAMETER ( ZERO = 0.0D0 ) -C .. Scalar Arguments .. - LOGICAL UPDATQ - INTEGER IFICA, IFICE, IFIRE, LDA, LDE, LDQ, M, N, NCE, - $ NRE -C .. Array Arguments .. - DOUBLE PRECISION A(LDA,*), E(LDE,*), Q(LDQ,*) -C .. Local Scalars .. - INTEGER I, IPVT, J - DOUBLE PRECISION SC, SS -C .. External Subroutines .. - EXTERNAL DROT, DROTG -C .. Executable Statements .. -C - IF ( M.LE.0 .OR. N.LE.0 .OR. NRE.LE.0 .OR. NCE.LE.0 ) - $ RETURN -C - IPVT = IFIRE - 1 -C - DO 40 J = IFICE, IFICE + NCE - 1 - IPVT = IPVT + 1 -C - DO 20 I = IPVT + 1, IFIRE + NRE - 1 -C -C Determine the Givens transformation on rows i and ipvt -C to annihilate E(i,j). -C Apply the transformation to these rows (in whole E-matrix) -C from columns j up to n . -C Apply the transformations also to the A-matrix -C (from columns ifica up to n). -C Update the row transformation matrix Q, if needed. -C - CALL DROTG( E(IPVT,J), E(I,J), SC, SS ) - CALL DROT( N-J, E(IPVT,J+1), LDE, E(I,J+1), LDE, SC, SS ) - E(I,J) = ZERO - CALL DROT( N-IFICA+1, A(IPVT,IFICA), LDA, A(I,IFICA), LDA, - $ SC, SS ) - IF( UPDATQ ) - $ CALL DROT( M, Q(1,IPVT), 1, Q(1,I), 1, SC, SS ) - 20 CONTINUE -C - 40 CONTINUE -C - RETURN -C *** Last line of MB04TW *** - END diff --git a/mex/sources/libslicot/MB04TX.f b/mex/sources/libslicot/MB04TX.f deleted file mode 100644 index ff4c37128..000000000 --- a/mex/sources/libslicot/MB04TX.f +++ /dev/null @@ -1,394 +0,0 @@ - SUBROUTINE MB04TX( UPDATQ, UPDATZ, M, N, NBLCKS, INUK, IMUK, A, - $ LDA, E, LDE, Q, LDQ, Z, LDZ, MNEI ) -C -C SLICOT RELEASE 5.0. -C -C Copyright (c) 2002-2009 NICONET e.V. -C -C This program is free software: you can redistribute it and/or -C modify it under the terms of the GNU General Public License as -C published by the Free Software Foundation, either version 2 of -C the License, or (at your option) any later version. -C -C This program is distributed in the hope that it will be useful, -C but WITHOUT ANY WARRANTY; without even the implied warranty of -C MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the -C GNU General Public License for more details. -C -C You should have received a copy of the GNU General Public License -C along with this program. If not, see -C . -C -C PURPOSE -C -C To separate the pencils s*E(eps)-A(eps) and s*E(inf)-A(inf) in -C s*E(eps,inf)-A(eps,inf) using Algorithm 3.3.3 in [1]. -C -C On entry, it is assumed that the M-by-N matrices A and E have -C been obtained after applying the Algorithms 3.2.1 and 3.3.1 to -C the pencil s*E - A as described in [1], i.e. -C -C | s*E(eps,inf)-A(eps,inf) | X | -C Q'(s*E - A)Z = |-------------------------|-------------| -C | 0 | s*E(r)-A(r) | -C -C Here the pencil s*E(eps,inf)-A(eps,inf) is in staircase form. -C This pencil contains all Kronecker column indices and infinite -C elementary divisors of the pencil s*E - A. -C The pencil s*E(r)-A(r) contains all Kronecker row indices and -C finite elementary divisors of s*E - A. -C Furthermore, the submatrices having full row and column rank in -C the pencil s*E(eps,inf)-A(eps,inf) are assumed to be -C triangularized. -C -C On exit, the result then is -C -C Q'(s*E - A)Z = -C -C | s*E(eps)-A(eps) | X | X | -C |-----------------|-----------------|-------------| -C | 0 | s*E(inf)-A(inf) | X | -C |===================================|=============| -C | | | -C | 0 | s*E(r)-A(r) | -C -C Note that the pencil s*E(r)-A(r) is not reduced further. -C -C ARGUMENTS -C -C Mode Parameters -C -C UPDATQ LOGICAL -C Indicates whether the user wishes to accumulate in a -C matrix Q the orthogonal row transformations, as follows: -C = .FALSE.: Do not form Q; -C = .TRUE.: The given matrix Q is updated by the orthogonal -C row transformations used in the reduction. -C -C UPDATZ LOGICAL -C Indicates whether the user wishes to accumulate in a -C matrix Z the orthogonal column transformations, as -C follows: -C = .FALSE.: Do not form Z; -C = .TRUE.: The given matrix Z is updated by the orthogonal -C column transformations used in the reduction. -C -C Input/Output Parameters -C -C M (input) INTEGER -C Number of rows of A and E. M >= 0. -C -C N (input) INTEGER -C Number of columns of A and E. N >= 0. -C -C NBLCKS (input/output) INTEGER -C On entry, the number of submatrices having full row rank -C (possibly zero) in A(eps,inf). -C On exit, the input value has been reduced by one, if the -C last submatrix is a 0-by-0 (empty) matrix. -C -C INUK (input/output) INTEGER array, dimension (NBLCKS) -C On entry, this array contains the row dimensions nu(k), -C (k=1, 2, ..., NBLCKS) of the submatrices having full row -C rank in the pencil s*E(eps,inf)-A(eps,inf). -C On exit, this array contains the row dimensions nu(k), -C (k=1, 2, ..., NBLCKS) of the submatrices having full row -C rank in the pencil s*E(eps)-A(eps). -C -C IMUK (input/output) INTEGER array, dimension (NBLCKS) -C On entry, this array contains the column dimensions mu(k), -C (k=1, 2, ..., NBLCKS) of the submatrices having full -C column rank in the pencil s*E(eps,inf)-A(eps,inf). -C On exit, this array contains the column dimensions mu(k), -C (k=1, 2, ..., NBLCKS) of the submatrices having full -C column rank in the pencil s*E(eps)-A(eps). -C -C A (input/output) DOUBLE PRECISION array, dimension (LDA,N) -C On entry, this array contains the matrix A to be reduced. -C On exit, it contains the transformed matrix A. -C -C LDA INTEGER -C The leading dimension of array A. LDA >= MAX(1,M). -C -C E (input/output) DOUBLE PRECISION array, dimension (LDE,N) -C On entry, this array contains the matrix E to be reduced. -C On exit, it contains the transformed matrix E. -C -C LDE INTEGER -C The leading dimension of array E. LDE >= MAX(1,M). -C -C Q (input/output) DOUBLE PRECISION array, dimension (LDQ,*) -C On entry, if UPDATQ = .TRUE., then the leading M-by-M -C part of this array must contain a given matrix Q (e.g. -C from a previous call to another SLICOT routine), and on -C exit, the leading M-by-M part of this array contains the -C product of the input matrix Q and the row transformation -C matrix that has transformed the rows of the matrices A -C and E. -C If UPDATQ = .FALSE., the array Q is not referenced and -C can be supplied as a dummy array (i.e. set parameter -C LDQ = 1 and declare this array to be Q(1,1) in the calling -C program). -C -C LDQ INTEGER -C The leading dimension of array Q. If UPDATQ = .TRUE., -C LDQ >= MAX(1,M); if UPDATQ = .FALSE., LDQ >= 1. -C -C Z (input/output) DOUBLE PRECISION array, dimension (LDZ,*) -C On entry, if UPDATZ = .TRUE., then the leading N-by-N -C part of this array must contain a given matrix Z (e.g. -C from a previous call to another SLICOT routine), and on -C exit, the leading N-by-N part of this array contains the -C product of the input matrix Z and the column -C transformation matrix that has transformed the columns of -C the matrices A and E. -C If UPDATZ = .FALSE., the array Z is not referenced and -C can be supplied as a dummy array (i.e. set parameter -C LDZ = 1 and declare this array to be Z(1,1) in the calling -C program). -C -C LDZ INTEGER -C The leading dimension of array Z. If UPDATZ = .TRUE., -C LDZ >= MAX(1,N); if UPDATZ = .FALSE., LDZ >= 1. -C -C MNEI (output) INTEGER array, dimension (4) -C MNEI(1) = MEPS = row dimension of s*E(eps)-A(eps), -C MNEI(2) = NEPS = column dimension of s*E(eps)-A(eps), -C MNEI(3) = MINF = row dimension of s*E(inf)-A(inf), -C MNEI(4) = NINF = column dimension of s*E(inf)-A(inf). -C -C REFERENCES -C -C [1] Beelen, Th. -C New Algorithms for Computing the Kronecker structure of a -C Pencil with Applications to Systems and Control Theory. -C Ph.D.Thesis, Eindhoven University of Technology, -C The Netherlands, 1987. -C -C NUMERICAL ASPECTS -C -C The algorithm is backward stable. -C -C CONTRIBUTOR -C -C Release 3.0: V. Sima, Katholieke Univ. Leuven, Belgium, Apr. 1997. -C Supersedes Release 2.0 routine MB04FX by Th.G.J. Beelen, -C Philips Glass Eindhoven, Holland. -C -C REVISIONS -C -C June 13, 1997, V. Sima. -C November 24, 1997, A. Varga: initialization of MNEI to 0, instead -C of ZERO. -C -C KEYWORDS -C -C Generalized eigenvalue problem, Kronecker indices, orthogonal -C transformation, staircase form. -C -C ****************************************************************** -C -C .. Parameters .. - DOUBLE PRECISION ZERO - PARAMETER ( ZERO = 0.0D0 ) -C .. Scalar Arguments .. - LOGICAL UPDATQ, UPDATZ - INTEGER LDA, LDE, LDQ, LDZ, M, N, NBLCKS -C .. Array Arguments .. - INTEGER IMUK(*), INUK(*), MNEI(4) - DOUBLE PRECISION A(LDA,*), E(LDE,*), Q(LDQ,*), Z(LDZ,*) -C .. Local Scalars .. - INTEGER CA, CE, CJA, CJE, IP, ISMUK, ISNUK, K, MEPS, - $ MINF, MUK, MUKP1, MUP, MUP1, NEPS, NINF, NUK, - $ NUP, RA, RJE, SK1P1, TK1P1, TP1 - DOUBLE PRECISION SC, SS -C .. External Subroutines .. - EXTERNAL DROTG, MB04TU -C .. Executable Statements .. -C - MNEI(1) = 0 - MNEI(2) = 0 - MNEI(3) = 0 - MNEI(4) = 0 - IF ( M.LE.0 .OR. N.LE.0 ) - $ RETURN -C -C Initialisation. -C - ISMUK = 0 - ISNUK = 0 -C - DO 20 K = 1, NBLCKS - ISMUK = ISMUK + IMUK(K) - ISNUK = ISNUK + INUK(K) - 20 CONTINUE -C -C MEPS, NEPS are the dimensions of the pencil s*E(eps)-A(eps). -C MEPS = Sum(k=1,...,nblcks) NU(k), -C NEPS = Sum(k=1,...,nblcks) MU(k). -C MINF, NINF are the dimensions of the pencil s*E(inf)-A(inf). -C - MEPS = ISNUK - NEPS = ISMUK - MINF = 0 - NINF = 0 -C -C MUKP1 = mu(k+1). N.B. It is assumed that mu(NBLCKS + 1) = 0. -C - MUKP1 = 0 -C - DO 120 K = NBLCKS, 1, -1 - NUK = INUK(K) - MUK = IMUK(K) -C -C Reduce submatrix E(k,k+1) to square matrix. -C NOTE that always NU(k) >= MU(k+1) >= 0. -C -C WHILE ( NU(k) > MU(k+1) ) DO - 40 IF ( NUK.GT.MUKP1 ) THEN -C -C sk1p1 = sum(i=k+1,...,p-1) NU(i) -C tk1p1 = sum(i=k+1,...,p-1) MU(i) -C ismuk = sum(i=1,...,k) MU(i) -C tp1 = sum(i=1,...,p-1) MU(i) = ismuk + tk1p1. -C - SK1P1 = 0 - TK1P1 = 0 -C - DO 100 IP = K + 1, NBLCKS -C -C Annihilate the elements originally present in the last -C row of E(k,p+1) and A(k,p). -C Start annihilating the first MU(p) - MU(p+1) elements by -C applying column Givens rotations plus interchanging -C elements. -C Use original bottom diagonal element of A(k,k) as pivot. -C Start position of pivot in A = (ra,ca). -C - TP1 = ISMUK + TK1P1 - RA = ISNUK + SK1P1 - CA = TP1 -C - MUP = IMUK(IP) - NUP = INUK(IP) - MUP1 = NUP -C - DO 60 CJA = CA, CA + MUP - NUP - 1 -C -C CJA = current column index of pivot in A. -C - CALL DROTG( A(RA,CJA), A(RA,CJA+1), SC, SS ) -C -C Apply transformations to A- and E-matrix. -C Interchange columns simultaneously. -C Update column transformation matrix Z, if needed. -C - CALL MB04TU( RA-1, A(1,CJA), 1, A(1,CJA+1), 1, SC, - $ SS ) - A(RA,CJA+1) = A(RA,CJA) - A(RA,CJA) = ZERO - CALL MB04TU( RA, E(1,CJA), 1, E(1,CJA+1), 1, SC, SS ) - IF( UPDATZ ) CALL MB04TU( N, Z(1,CJA), 1, Z(1,CJA+1), - $ 1, SC, SS ) - 60 CONTINUE -C -C Annihilate the remaining elements originally present in -C the last row of E(k,p+1) and A(k,p) by alternatingly -C applying row and column rotations plus interchanging -C elements. -C Use diagonal elements of E(p,p+1) and original bottom -C diagonal element of A(k,k) as pivots, respectively. -C (re,ce) and (ra,ca) are the starting positions of the -C pivots in E and A. -C - CE = TP1 + MUP - CA = CE - MUP1 - 1 -C - DO 80 RJE = RA + 1, RA + MUP1 -C -C (RJE,CJE) = current position pivot in E. -C - CJE = CE + 1 - CJA = CA + 1 -C -C Determine the row transformations. -C Apply these transformations to E- and A-matrix. -C Interchange the rows simultaneously. -C Update row transformation matrix Q, if needed. -C - CALL DROTG( E(RJE,CJE), E(RJE-1,CJE), SC, SS ) - CALL MB04TU( N-CJE, E(RJE,CJE+1), LDE, E(RJE-1,CJE+1), - $ LDE, SC, SS ) - E(RJE-1,CJE) = E(RJE,CJE) - E(RJE,CJE) = ZERO - CALL MB04TU( N-CJA+1, A(RJE,CJA), LDA, A(RJE-1,CJA), - $ LDA, SC, SS ) - IF( UPDATQ ) CALL MB04TU( M, Q(1,RJE), 1, - $ Q(1,RJE-1), 1, SC, SS ) -C -C Determine the column transformations. -C Apply these transformations to A- and E-matrix. -C Interchange the columns simultaneously. -C Update column transformation matrix Z, if needed. -C - CALL DROTG( A(RJE,CJA), A(RJE,CJA+1), SC, SS ) - CALL MB04TU( RJE-1, A(1,CJA), 1, A(1,CJA+1), 1, SC, - $ SS ) - A(RJE,CJA+1) = A(RJE,CJA) - A(RJE,CJA) = ZERO - CALL MB04TU( RJE, E(1,CJA), 1, E(1,CJA+1), 1, SC, SS ) - IF( UPDATZ ) CALL MB04TU( N, Z(1,CJA), 1, Z(1,CJA+1), - $ 1, SC, SS ) - 80 CONTINUE -C - SK1P1 = SK1P1 + NUP - TK1P1 = TK1P1 + MUP -C - 100 CONTINUE -C -C Reduce A=A(eps,inf) and E=E(eps,inf) by ignoring their last -C row and right most column. The row and column ignored -C belong to the pencil s*E(inf)-A(inf). -C Redefine blocks in new A and E. -C - MUK = MUK - 1 - NUK = NUK - 1 - ISMUK = ISMUK - 1 - ISNUK = ISNUK - 1 - MEPS = MEPS - 1 - NEPS = NEPS - 1 - MINF = MINF + 1 - NINF = NINF + 1 -C - GO TO 40 - END IF -C END WHILE 40 -C - IMUK(K) = MUK - INUK(K) = NUK -C -C Now submatrix E(k,k+1) is square. -C -C Consider next submatrix (k:=k-1). -C - ISNUK = ISNUK - NUK - ISMUK = ISMUK - MUK - MUKP1 = MUK - 120 CONTINUE -C -C If mu(NBLCKS) = 0, then the last submatrix counted in NBLCKS is -C a 0-by-0 (empty) matrix. This "matrix" must be removed. -C - IF ( IMUK(NBLCKS).EQ.0 ) NBLCKS = NBLCKS - 1 -C -C Store dimensions of the pencils s*E(eps)-A(eps) and -C s*E(inf)-A(inf) in array MNEI. -C - MNEI(1) = MEPS - MNEI(2) = NEPS - MNEI(3) = MINF - MNEI(4) = NINF -C - RETURN -C *** Last line of MB04TX *** - END diff --git a/mex/sources/libslicot/MB04TY.f b/mex/sources/libslicot/MB04TY.f deleted file mode 100644 index 1a146092f..000000000 --- a/mex/sources/libslicot/MB04TY.f +++ /dev/null @@ -1,241 +0,0 @@ - SUBROUTINE MB04TY( UPDATQ, UPDATZ, M, N, NBLCKS, INUK, IMUK, A, - $ LDA, E, LDE, Q, LDQ, Z, LDZ, INFO ) -C -C SLICOT RELEASE 5.0. -C -C Copyright (c) 2002-2009 NICONET e.V. -C -C This program is free software: you can redistribute it and/or -C modify it under the terms of the GNU General Public License as -C published by the Free Software Foundation, either version 2 of -C the License, or (at your option) any later version. -C -C This program is distributed in the hope that it will be useful, -C but WITHOUT ANY WARRANTY; without even the implied warranty of -C MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the -C GNU General Public License for more details. -C -C You should have received a copy of the GNU General Public License -C along with this program. If not, see -C . -C -C PURPOSE -C -C To perform the triangularization of the submatrices having full -C row and column rank in the pencil s*E(eps,inf)-A(eps,inf) below -C -C | s*E(eps,inf)-A(eps,inf) | X | -C s*E - A = |-------------------------|-------------| , -C | 0 | s*E(r)-A(r) | -C -C using Algorithm 3.3.1 in [1]. -C On entry, it is assumed that the M-by-N matrices A and E have -C been transformed to generalized Schur form by unitary -C transformations (see Algorithm 3.2.1 in [1]), and that the pencil -C s*E(eps,inf)-A(eps,inf) is in staircase form. -C This pencil contains all Kronecker column indices and infinite -C elementary divisors of the pencil s*E - A. -C The pencil s*E(r)-A(r) contains all Kronecker row indices and -C finite elementary divisors of s*E - A. -C -C ARGUMENTS -C -C Mode Parameters -C -C UPDATQ LOGICAL -C Indicates whether the user wishes to accumulate in a -C matrix Q the orthogonal row transformations, as follows: -C = .FALSE.: Do not form Q; -C = .TRUE.: The given matrix Q is updated by the orthogonal -C row transformations used in the reduction. -C -C UPDATZ LOGICAL -C Indicates whether the user wishes to accumulate in a -C matrix Z the orthogonal column transformations, as -C follows: -C = .FALSE.: Do not form Z; -C = .TRUE.: The given matrix Z is updated by the orthogonal -C column transformations used in the reduction. -C -C Input/Output Parameters -C -C M (input) INTEGER -C Number of rows in A and E. M >= 0. -C -C N (input) INTEGER -C Number of columns in A and E. N >= 0. -C -C NBLCKS (input) INTEGER -C Number of submatrices having full row rank (possibly zero) -C in A(eps,inf). -C -C INUK (input) INTEGER array, dimension (NBLCKS) -C The row dimensions nu(k) (k=1, 2, ..., NBLCKS) of the -C submatrices having full row rank in the pencil -C s*E(eps,inf)-A(eps,inf). -C -C IMUK (input) INTEGER array, dimension (NBLCKS) -C The column dimensions mu(k) (k=1, 2, ..., NBLCKS) of the -C submatrices having full column rank in the pencil. -C -C A (input/output) DOUBLE PRECISION array, dimension (LDA,N) -C On entry, this array contains the matrix A to be reduced. -C On exit, it contains the transformed matrix A. -C -C LDA INTEGER -C The leading dimension of array A. LDA >= MAX(1,M). -C -C E (input/output) DOUBLE PRECISION array, dimension (LDE,N) -C On entry, this array contains the matrix E to be reduced. -C On exit, it contains the transformed matrix E. -C -C LDE INTEGER -C The leading dimension of array E. LDE >= MAX(1,M). -C -C Q (input/output) DOUBLE PRECISION array, dimension (LDQ,*) -C On entry, if UPDATQ = .TRUE., then the leading M-by-M -C part of this array must contain a given matrix Q (e.g. -C from a previous call to another SLICOT routine), and on -C exit, the leading M-by-M part of this array contains the -C product of the input matrix Q and the row transformation -C matrix that has transformed the rows of the matrices A -C and E. -C If UPDATQ = .FALSE., the array Q is not referenced and -C can be supplied as a dummy array (i.e. set parameter -C LDQ = 1 and declare this array to be Q(1,1) in the calling -C program). -C -C LDQ INTEGER -C The leading dimension of array Q. If UPDATQ = .TRUE., -C LDQ >= MAX(1,M); if UPDATQ = .FALSE., LDQ >= 1. -C -C Z (input/output) DOUBLE PRECISION array, dimension (LDZ,*) -C On entry, if UPDATZ = .TRUE., then the leading N-by-N -C part of this array must contain a given matrix Z (e.g. -C from a previous call to another SLICOT routine), and on -C exit, the leading N-by-N part of this array contains the -C product of the input matrix Z and the column -C transformation matrix that has transformed the columns of -C the matrices A and E. -C If UPDATZ = .FALSE., the array Z is not referenced and -C can be supplied as a dummy array (i.e. set parameter -C LDZ = 1 and declare this array to be Z(1,1) in the calling -C program). -C -C LDZ INTEGER -C The leading dimension of array Z. If UPDATZ = .TRUE., -C LDZ >= MAX(1,N); if UPDATZ = .FALSE., LDZ >= 1. -C -C Error Indicator -C -C INFO INTEGER -C = 0: successful exit; -C = 1: if incorrect dimensions of a full column rank -C submatrix; -C = 2: if incorrect dimensions of a full row rank -C submatrix. -C -C REFERENCES -C -C [1] Beelen, Th. -C New Algorithms for Computing the Kronecker structure of a -C Pencil with Applications to Systems and Control Theory. -C Ph.D.Thesis, Eindhoven University of Technology, -C The Netherlands, 1987. -C -C NUMERICAL ASPECTS -C -C The algorithm is backward stable. -C -C CONTRIBUTOR -C -C Release 3.0: V. Sima, Katholieke Univ. Leuven, Belgium, Apr. 1997. -C Supersedes Release 2.0 routine MB04FY by Th.G.J. Beelen, -C Philips Glass Eindhoven, Holland. -C -C REVISIONS -C -C - -C -C KEYWORDS -C -C Generalized eigenvalue problem, orthogonal transformation, -C staircase form. -C -C ****************************************************************** -C -C .. Scalar Arguments .. - LOGICAL UPDATQ, UPDATZ - INTEGER INFO, LDA, LDE, LDQ, LDZ, M, N, NBLCKS -C .. Array Arguments .. - INTEGER IMUK(*), INUK(*) - DOUBLE PRECISION A(LDA,*), E(LDE,*), Q(LDQ,*), Z(LDZ,*) -C .. Local Scalars .. - INTEGER IFICA, IFICE, IFIRE, ISMUK, ISNUK1, K, MUK, - $ MUKP1, NUK -C .. External Subroutines .. - EXTERNAL MB04TV, MB04TW -C .. Executable Statements .. -C - INFO = 0 - IF ( M.LE.0 .OR. N.LE.0 ) - $ RETURN -C -C ISMUK = sum(i=1,...,k) MU(i), -C ISNUK1 = sum(i=1,...,k-1) NU(i). -C - ISMUK = 0 - ISNUK1 = 0 -C - DO 20 K = 1, NBLCKS - ISMUK = ISMUK + IMUK(K) - ISNUK1 = ISNUK1 + INUK(K) - 20 CONTINUE -C -C Note: ISNUK1 has not yet the correct value. -C - MUKP1 = 0 -C - DO 40 K = NBLCKS, 1, -1 - MUK = IMUK(K) - NUK = INUK(K) - ISNUK1 = ISNUK1 - NUK -C -C Determine left upper absolute co-ordinates of E(k) in E-matrix -C and of A(k) in A-matrix. -C - IFIRE = 1 + ISNUK1 - IFICE = 1 + ISMUK - IFICA = IFICE - MUK -C -C Reduce E(k) to upper triangular form using Givens -C transformations on rows only. Apply the same transformations -C to the rows of A(k). -C - IF ( MUKP1.GT.NUK ) THEN - INFO = 1 - RETURN - END IF -C - CALL MB04TW( UPDATQ, M, N, NUK, MUKP1, IFIRE, IFICE, IFICA, A, - $ LDA, E, LDE, Q, LDQ ) -C -C Reduce A(k) to upper triangular form using Givens -C transformations on columns only. Apply the same transformations -C to the columns in the E-matrix. -C - IF ( NUK.GT.MUK ) THEN - INFO = 2 - RETURN - END IF -C - CALL MB04TV( UPDATZ, N, NUK, MUK, IFIRE, IFICA, A, LDA, E, LDE, - $ Z, LDZ ) -C - ISMUK = ISMUK - MUK - MUKP1 = MUK - 40 CONTINUE -C - RETURN -C *** Last line of MB04TY *** - END diff --git a/mex/sources/libslicot/MB04UD.f b/mex/sources/libslicot/MB04UD.f deleted file mode 100644 index a5e2ba347..000000000 --- a/mex/sources/libslicot/MB04UD.f +++ /dev/null @@ -1,375 +0,0 @@ - SUBROUTINE MB04UD( JOBQ, JOBZ, M, N, A, LDA, E, LDE, Q, LDQ, - $ Z, LDZ, RANKE, ISTAIR, TOL, DWORK, INFO ) -C -C SLICOT RELEASE 5.0. -C -C Copyright (c) 2002-2009 NICONET e.V. -C -C This program is free software: you can redistribute it and/or -C modify it under the terms of the GNU General Public License as -C published by the Free Software Foundation, either version 2 of -C the License, or (at your option) any later version. -C -C This program is distributed in the hope that it will be useful, -C but WITHOUT ANY WARRANTY; without even the implied warranty of -C MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the -C GNU General Public License for more details. -C -C You should have received a copy of the GNU General Public License -C along with this program. If not, see -C . -C -C PURPOSE -C -C To compute orthogonal transformations Q and Z such that the -C transformed pencil Q'(sE-A)Z has the E matrix in column echelon -C form, where E and A are M-by-N matrices. -C -C ARGUMENTS -C -C Mode Parameters -C -C JOBQ CHARACTER*1 -C Indicates whether the user wishes to accumulate in a -C matrix Q the unitary row permutations, as follows: -C = 'N': Do not form Q; -C = 'I': Q is initialized to the unit matrix and the -C unitary row permutation matrix Q is returned; -C = 'U': The given matrix Q is updated by the unitary -C row permutations used in the reduction. -C -C JOBZ CHARACTER*1 -C Indicates whether the user wishes to accumulate in a -C matrix Z the unitary column transformations, as follows: -C = 'N': Do not form Z; -C = 'I': Z is initialized to the unit matrix and the -C unitary transformation matrix Z is returned; -C = 'U': The given matrix Z is updated by the unitary -C transformations used in the reduction. -C -C Input/Output Parameters -C -C M (input) INTEGER -C The number of rows in the matrices A, E and the order of -C the matrix Q. M >= 0. -C -C N (input) INTEGER -C The number of columns in the matrices A, E and the order -C of the matrix Z. N >= 0. -C -C A (input/output) DOUBLE PRECISION array, dimension (LDA,N) -C On entry, the leading M-by-N part of this array must -C contain the A matrix of the pencil sE-A. -C On exit, the leading M-by-N part of this array contains -C the unitary transformed matrix Q' * A * Z. -C -C LDA INTEGER -C The leading dimension of array A. LDA >= MAX(1,M). -C -C E (input/output) DOUBLE PRECISION array, dimension (LDE,N) -C On entry, the leading M-by-N part of this array must -C contain the E matrix of the pencil sE-A, to be reduced to -C column echelon form. -C On exit, the leading M-by-N part of this array contains -C the unitary transformed matrix Q' * E * Z, which is in -C column echelon form. -C -C LDE INTEGER -C The leading dimension of array E. LDE >= MAX(1,M). -C -C Q (input/output) DOUBLE PRECISION array, dimension (LDQ,*) -C On entry, if JOBQ = 'U', then the leading M-by-M part of -C this array must contain a given matrix Q (e.g. from a -C previous call to another SLICOT routine), and on exit, the -C leading M-by-M part of this array contains the product of -C the input matrix Q and the row permutation matrix used to -C transform the rows of matrix E. -C On exit, if JOBQ = 'I', then the leading M-by-M part of -C this array contains the matrix of accumulated unitary -C row transformations performed. -C If JOBQ = 'N', the array Q is not referenced and can be -C supplied as a dummy array (i.e. set parameter LDQ = 1 and -C declare this array to be Q(1,1) in the calling program). -C -C LDQ INTEGER -C The leading dimension of array Q. If JOBQ = 'U' or -C JOBQ = 'I', LDQ >= MAX(1,M); if JOBQ = 'N', LDQ >= 1. -C -C Z (input/output) DOUBLE PRECISION array, dimension (LDZ,*) -C On entry, if JOBZ = 'U', then the leading N-by-N part of -C this array must contain a given matrix Z (e.g. from a -C previous call to another SLICOT routine), and on exit, the -C leading N-by-N part of this array contains the product of -C the input matrix Z and the column transformation matrix -C used to transform the columns of matrix E. -C On exit, if JOBZ = 'I', then the leading N-by-N part of -C this array contains the matrix of accumulated unitary -C column transformations performed. -C If JOBZ = 'N', the array Z is not referenced and can be -C supplied as a dummy array (i.e. set parameter LDZ = 1 and -C declare this array to be Z(1,1) in the calling program). -C -C LDZ INTEGER -C The leading dimension of array Z. If JOBZ = 'U' or -C JOBZ = 'I', LDZ >= MAX(1,N); if JOBZ = 'N', LDZ >= 1. -C -C RANKE (output) INTEGER -C The computed rank of the unitary transformed matrix E. -C -C ISTAIR (output) INTEGER array, dimension (M) -C This array contains information on the column echelon form -C of the unitary transformed matrix E. Specifically, -C ISTAIR(i) = +j if the first non-zero element E(i,j) -C is a corner point and -j otherwise, for i = 1,2,...,M. -C -C Tolerances -C -C TOL DOUBLE PRECISION -C A tolerance below which matrix elements are considered -C to be zero. If the user sets TOL to be less than (or -C equal to) zero then the tolerance is taken as -C EPS * MAX(ABS(E(I,J))), where EPS is the machine -C precision (see LAPACK Library routine DLAMCH), -C I = 1,2,...,M and J = 1,2,...,N. -C -C Workspace -C -C DWORK DOUBLE PRECISION array, dimension MAX(M,N) -C -C Error Indicator -C -C INFO INTEGER -C = 0: successful exit; -C < 0: if INFO = -i, the i-th argument had an illegal -C value. -C -C METHOD -C -C Given an M-by-N matrix pencil sE-A with E not necessarily regular, -C the routine computes a unitary transformed pencil Q'(sE-A)Z such -C that the matrix Q' * E * Z is in column echelon form (trapezoidal -C form). Further details can be found in [1]. -C -C [An M-by-N matrix E with rank(E) = r is said to be in column -C echelon form if the following conditions are satisfied: -C (a) the first (N - r) columns contain only zero elements; and -C (b) if E(i(k),k) is the last nonzero element in column k for -C k = N-r+1,...,N, i.e. E(i(k),k) <> 0 and E(j,k) = 0 for -C j > i(k), then 1 <= i(N-r+1) < i(N-r+2) < ... < i(N) <= M.] -C -C REFERENCES -C -C [1] Beelen, Th. and Van Dooren, P. -C An improved algorithm for the computation of Kronecker's -C canonical form of a singular pencil. -C Linear Algebra and Applications, 105, pp. 9-65, 1988. -C -C NUMERICAL ASPECTS -C -C It is shown in [1] that the algorithm is numerically backward -C stable. The operations count is proportional to (MAX(M,N))**3. -C -C CONTRIBUTOR -C -C Release 3.0: V. Sima, Katholieke Univ. Leuven, Belgium, Jan. 1998. -C Based on Release 3.0 routine MB04SD modified by A. Varga, -C German Aerospace Research Establishment, Oberpfaffenhofen, -C Germany, Dec. 1997, to transform also the matrix A. -C -C REVISIONS -C -C A. Varga, DLR Oberpfaffenhofen, June 2005. -C -C KEYWORDS -C -C Echelon form, orthogonal transformation, staircase form. -C -C ****************************************************************** -C -C .. Parameters .. - DOUBLE PRECISION ZERO, ONE - PARAMETER ( ZERO = 0.0D0, ONE = 1.0D0 ) -C .. Scalar Arguments .. - CHARACTER JOBQ, JOBZ - INTEGER INFO, LDA, LDE, LDQ, LDZ, M, N, RANKE - DOUBLE PRECISION TOL -C .. Array Arguments .. - INTEGER ISTAIR(*) - DOUBLE PRECISION A(LDA,*), DWORK(*), E(LDE,*), Q(LDQ,*), Z(LDZ,*) -C .. Local Scalars .. - LOGICAL LJOBQI, LJOBZI, LZERO, UPDATQ, UPDATZ - INTEGER I, K, KM1, L, LK, MNK, NR1 - DOUBLE PRECISION EMX, EMXNRM, TAU, TOLER -C .. External Functions .. - LOGICAL LSAME - INTEGER IDAMAX - DOUBLE PRECISION DLAMCH, DLANGE - EXTERNAL DLAMCH, DLANGE, IDAMAX, LSAME -C .. External Subroutines .. - EXTERNAL DLARF, DLARFG, DLASET, DSWAP, XERBLA -C .. Intrinsic Functions .. - INTRINSIC ABS, MAX, MIN -C .. Executable Statements .. -C - INFO = 0 - LJOBQI = LSAME( JOBQ, 'I' ) - UPDATQ = LJOBQI.OR.LSAME( JOBQ, 'U' ) - LJOBZI = LSAME( JOBZ, 'I' ) - UPDATZ = LJOBZI.OR.LSAME( JOBZ, 'U' ) -C -C Test the input scalar arguments. -C - IF( .NOT.UPDATQ .AND. .NOT.LSAME( JOBQ, 'N' ) ) THEN - INFO = -1 - ELSE IF( .NOT.UPDATZ .AND. .NOT.LSAME( JOBZ, 'N' ) ) THEN - INFO = -2 - ELSE IF( M.LT.0 ) THEN - INFO = -3 - ELSE IF( N.LT.0 ) THEN - INFO = -4 - ELSE IF( LDA.LT.MAX( 1, M ) ) THEN - INFO = -6 - ELSE IF( LDE.LT.MAX( 1, M ) ) THEN - INFO = -8 - ELSE IF( .NOT.UPDATQ .AND. LDQ.LT.1 .OR. - $ UPDATQ .AND. LDQ.LT.MAX( 1, M ) ) THEN - INFO = -10 - ELSE IF( .NOT.UPDATZ .AND. LDZ.LT.1 .OR. - $ UPDATZ .AND. LDZ.LT.MAX( 1, N ) ) THEN - INFO = -12 - END IF -C - IF ( INFO.NE.0 ) THEN -C -C Error return. -C - CALL XERBLA( 'MB04UD', -INFO ) - RETURN - END IF -C -C Initialize Q and Z to the identity matrices, if needed. -C - IF ( LJOBQI ) - $ CALL DLASET( 'Full', M, M, ZERO, ONE, Q, LDQ ) - IF ( LJOBZI ) - $ CALL DLASET( 'Full', N, N, ZERO, ONE, Z, LDZ ) -C -C Quick return if possible. -C - RANKE = MIN( M, N ) -C - IF ( RANKE.EQ.0 ) - $ RETURN -C - TOLER = TOL - IF ( TOLER.LE.ZERO ) - $ TOLER = DLAMCH( 'Epsilon' )*DLANGE( 'M', M, N, E, LDE, DWORK ) -C - K = N - LZERO = .FALSE. -C -C WHILE ( ( K > 0 ) AND ( NOT a zero submatrix encountered ) ) DO - 20 IF ( ( K.GT.0 ) .AND. ( .NOT. LZERO ) ) THEN -C -C Intermediate form of E -C -C <--k--><--n-k-> -C l=1 |x....x| | -C | | | -C | Ek | X | -C | | | -C l=m-n+k |x....x| | -C ---------------- -C | |x ... x| } -C | O | x x x| } -C | | x x| } n-k -C | | x| } -C -C where submatrix Ek = E[1:m-n+k;1:k]. -C -C Determine row LK in submatrix Ek with largest max-norm -C (starting with row m-n+k). -C - MNK = M - N + K - EMXNRM = ZERO - LK = MNK -C - DO 40 L = MNK, 1, -1 - EMX = ABS( E(L,IDAMAX( K, E(L,1), LDE )) ) - IF ( EMX.GT.EMXNRM ) THEN - EMXNRM = EMX - LK = L - END IF - 40 CONTINUE -C - IF ( EMXNRM.LE.TOLER ) THEN -C -C Set submatrix Ek to zero. -C - CALL DLASET( 'Full', MNK, K, ZERO, ZERO, E, LDE ) - LZERO = .TRUE. - RANKE = N - K - ELSE -C -C Submatrix Ek is not considered to be identically zero. -C Check whether rows have to be interchanged. -C - IF ( LK.NE.MNK ) THEN -C -C Interchange rows lk and m-n+k in whole A- and E-matrix -C and update the row transformation matrix Q, if needed. -C (For Q, the number of elements involved is m.) -C - CALL DSWAP( N, E(LK,1), LDE, E(MNK,1), LDE ) - CALL DSWAP( N, A(LK,1), LDA, A(MNK,1), LDA ) - IF( UPDATQ ) CALL DSWAP( M, Q(1,LK), 1, Q(1,MNK), 1 ) - END IF -C - KM1 = K - 1 -C -C Determine a Householder transformation to annihilate -C E(m-n+k,1:k-1) using E(m-n+k,k) as pivot. -C Apply the transformation to the columns of A and Ek -C (number of elements involved is m for A and m-n+k for Ek). -C Update the column transformation matrix Z, if needed -C (number of elements involved is n). -C - CALL DLARFG( K, E(MNK,K), E(MNK,1), LDE, TAU ) - EMX = E(MNK,K) - E(MNK,K) = ONE - CALL DLARF( 'Right', MNK-1, K, E(MNK,1), LDE, TAU, E, LDE, - $ DWORK ) - CALL DLARF( 'Right', M, K, E(MNK,1), LDE, TAU, A, LDA, - $ DWORK ) - IF( UPDATZ ) CALL DLARF( 'Right', N, K, E(MNK,1), LDE, TAU, - $ Z, LDZ, DWORK ) - E(MNK,K) = EMX - CALL DLASET( 'Full', 1, KM1, ZERO, ZERO, E(MNK,1), LDE ) -C - K = KM1 - END IF - GO TO 20 - END IF -C END WHILE 20 -C -C Initialise administration staircase form, i.e. -C ISTAIR(i) = j if E(i,j) is a nonzero corner point -C = -j if E(i,j) is on the boundary but is no corner -C point. -C Thus, -C ISTAIR(m-k) = n-k for k=0,...,rank(E)-1 -C = -(n-rank(E)+1) for k=rank(E),...,m-1. -C - DO 60 I = 0, RANKE - 1 - ISTAIR(M-I) = N - I - 60 CONTINUE -C - NR1 = -(N - RANKE + 1) -C - DO 80 I = 1, M - RANKE - ISTAIR(I) = NR1 - 80 CONTINUE -C - RETURN -C *** Last line of MB04UD *** - END diff --git a/mex/sources/libslicot/MB04VD.f b/mex/sources/libslicot/MB04VD.f deleted file mode 100644 index e83817aad..000000000 --- a/mex/sources/libslicot/MB04VD.f +++ /dev/null @@ -1,540 +0,0 @@ - SUBROUTINE MB04VD( MODE, JOBQ, JOBZ, M, N, RANKE, A, LDA, E, LDE, - $ Q, LDQ, Z, LDZ, ISTAIR, NBLCKS, NBLCKI, IMUK, - $ INUK, IMUK0, MNEI, TOL, IWORK, INFO ) -C -C SLICOT RELEASE 5.0. -C -C Copyright (c) 2002-2009 NICONET e.V. -C -C This program is free software: you can redistribute it and/or -C modify it under the terms of the GNU General Public License as -C published by the Free Software Foundation, either version 2 of -C the License, or (at your option) any later version. -C -C This program is distributed in the hope that it will be useful, -C but WITHOUT ANY WARRANTY; without even the implied warranty of -C MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the -C GNU General Public License for more details. -C -C You should have received a copy of the GNU General Public License -C along with this program. If not, see -C . -C -C PURPOSE -C -C To compute orthogonal transformations Q and Z such that the -C transformed pencil Q'(sE-A)Z is in upper block triangular form, -C where E is an M-by-N matrix in column echelon form (see SLICOT -C Library routine MB04UD) and A is an M-by-N matrix. -C -C If MODE = 'B', then the matrices A and E are transformed into the -C following generalized Schur form by unitary transformations Q1 -C and Z1 : -C -C | sE(eps,inf)-A(eps,inf) | X | -C Q1'(sE-A)Z1 = |------------------------|------------|. (1) -C | O | sE(r)-A(r) | -C -C The pencil sE(eps,inf)-A(eps,inf) is in staircase form, and it -C contains all Kronecker column indices and infinite elementary -C divisors of the pencil sE-A. The pencil sE(r)-A(r) contains all -C Kronecker row indices and elementary divisors of sE-A. -C Note: X is a pencil. -C -C If MODE = 'T', then the submatrices having full row and column -C rank in the pencil sE(eps,inf)-A(eps,inf) in (1) are -C triangularized by applying unitary transformations Q2 and Z2 to -C Q1'*(sE-A)*Z1. -C -C If MODE = 'S', then the pencil sE(eps,inf)-A(eps,inf) in (1) is -C separated into sE(eps)-A(eps) and sE(inf)-A(inf) by applying -C unitary transformations Q3 and Z3 to Q2'*Q1'*(sE-A)*Z1*Z2. -C -C This gives -C -C | sE(eps)-A(eps) | X | X | -C |----------------|----------------|------------| -C | O | sE(inf)-A(inf) | X | -C Q'(sE-A)Z =|=================================|============| (2) -C | | | -C | O | sE(r)-A(r) | -C -C where Q = Q1*Q2*Q3 and Z = Z1*Z2*Z3. -C Note: the pencil sE(r)-A(r) is not reduced further. -C -C ARGUMENTS -C -C Mode Parameters -C -C MODE CHARACTER*1 -C Specifies the desired structure of the transformed -C pencil Q'(sE-A)Z to be computed as follows: -C = 'B': Basic reduction given by (1); -C = 'T': Further reduction of (1) to triangular form; -C = 'S': Further separation of sE(eps,inf)-A(eps,inf) -C in (1) into the two pencils in (2). -C -C JOBQ CHARACTER*1 -C Indicates whether the user wishes to accumulate in a -C matrix Q the orthogonal row transformations, as follows: -C = 'N': Do not form Q; -C = 'I': Q is initialized to the unit matrix and the -C orthogonal transformation matrix Q is returned; -C = 'U': The given matrix Q is updated by the orthogonal -C row transformations used in the reduction. -C -C JOBZ CHARACTER*1 -C Indicates whether the user wishes to accumulate in a -C matrix Z the orthogonal column transformations, as -C follows: -C = 'N': Do not form Z; -C = 'I': Z is initialized to the unit matrix and the -C orthogonal transformation matrix Z is returned; -C = 'U': The given matrix Z is updated by the orthogonal -C transformations used in the reduction. -C -C Input/Output Parameters -C -C M (input) INTEGER -C The number of rows in the matrices A, E and the order of -C the matrix Q. M >= 0. -C -C N (input) INTEGER -C The number of columns in the matrices A, E and the order -C of the matrix Z. N >= 0. -C -C RANKE (input) INTEGER -C The rank of the matrix E in column echelon form. -C RANKE >= 0. -C -C A (input/output) DOUBLE PRECISION array, dimension (LDA,N) -C On entry, the leading M-by-N part of this array must -C contain the matrix to be row compressed. -C On exit, the leading M-by-N part of this array contains -C the matrix that has been row compressed while keeping -C matrix E in column echelon form. -C -C LDA INTEGER -C The leading dimension of array A. LDA >= MAX(1,M). -C -C E (input/output) DOUBLE PRECISION array, dimension (LDE,N) -C On entry, the leading M-by-N part of this array must -C contain the matrix in column echelon form to be -C transformed equivalent to matrix A. -C On exit, the leading M-by-N part of this array contains -C the matrix that has been transformed equivalent to matrix -C A. -C -C LDE INTEGER -C The leading dimension of array E. LDE >= MAX(1,M). -C -C Q (input/output) DOUBLE PRECISION array, dimension (LDQ,*) -C On entry, if JOBQ = 'U', then the leading M-by-M part of -C this array must contain a given matrix Q (e.g. from a -C previous call to another SLICOT routine), and on exit, the -C leading M-by-M part of this array contains the product of -C the input matrix Q and the row transformation matrix used -C to transform the rows of matrices A and E. -C On exit, if JOBQ = 'I', then the leading M-by-M part of -C this array contains the matrix of accumulated orthogonal -C row transformations performed. -C If JOBQ = 'N', the array Q is not referenced and can be -C supplied as a dummy array (i.e. set parameter LDQ = 1 and -C declare this array to be Q(1,1) in the calling program). -C -C LDQ INTEGER -C The leading dimension of array Q. If JOBQ = 'U' or -C JOBQ = 'I', LDQ >= MAX(1,M); if JOBQ = 'N', LDQ >= 1. -C -C Z (input/output) DOUBLE PRECISION array, dimension (LDZ,*) -C On entry, if JOBZ = 'U', then the leading N-by-N part of -C this array must contain a given matrix Z (e.g. from a -C previous call to another SLICOT routine), and on exit, the -C leading N-by-N part of this array contains the product of -C the input matrix Z and the column transformation matrix -C used to transform the columns of matrices A and E. -C On exit, if JOBZ = 'I', then the leading N-by-N part of -C this array contains the matrix of accumulated orthogonal -C column transformations performed. -C If JOBZ = 'N', the array Z is not referenced and can be -C supplied as a dummy array (i.e. set parameter LDZ = 1 and -C declare this array to be Z(1,1) in the calling program). -C -C LDZ INTEGER -C The leading dimension of array Z. If JOBZ = 'U' or -C JOBZ = 'I', LDZ >= MAX(1,N); if JOBZ = 'N', LDZ >= 1. -C -C ISTAIR (input/output) INTEGER array, dimension (M) -C On entry, this array must contain information on the -C column echelon form of the unitary transformed matrix E. -C Specifically, ISTAIR(i) must be set to +j if the first -C non-zero element E(i,j) is a corner point and -j -C otherwise, for i = 1,2,...,M. -C On exit, this array contains no useful information. -C -C NBLCKS (output) INTEGER -C The number of submatrices having full row rank greater -C than or equal to 0 detected in matrix A in the pencil -C sE(x)-A(x), -C where x = eps,inf if MODE = 'B' or 'T', -C or x = eps if MODE = 'S'. -C -C NBLCKI (output) INTEGER -C If MODE = 'S', the number of diagonal submatrices in the -C pencil sE(inf)-A(inf). If MODE = 'B' or 'T' then -C NBLCKI = 0. -C -C IMUK (output) INTEGER array, dimension (MAX(N,M+1)) -C The leading NBLCKS elements of this array contain the -C column dimensions mu(1),...,mu(NBLCKS) of the submatrices -C having full column rank in the pencil sE(x)-A(x), -C where x = eps,inf if MODE = 'B' or 'T', -C or x = eps if MODE = 'S'. -C -C INUK (output) INTEGER array, dimension (MAX(N,M+1)) -C The leading NBLCKS elements of this array contain the -C row dimensions nu(1),...,nu(NBLCKS) of the submatrices -C having full row rank in the pencil sE(x)-A(x), -C where x = eps,inf if MODE = 'B' or 'T', -C or x = eps if MODE = 'S'. -C -C IMUK0 (output) INTEGER array, dimension (limuk0), -C where limuk0 = N if MODE = 'S' and 1, otherwise. -C If MODE = 'S', then the leading NBLCKI elements of this -C array contain the dimensions mu0(1),...,mu0(NBLCKI) -C of the square diagonal submatrices in the pencil -C sE(inf)-A(inf). -C Otherwise, IMUK0 is not referenced and can be supplied -C as a dummy array. -C -C MNEI (output) INTEGER array, dimension (3) -C If MODE = 'B' or 'T' then -C MNEI(1) contains the row dimension of -C sE(eps,inf)-A(eps,inf); -C MNEI(2) contains the column dimension of -C sE(eps,inf)-A(eps,inf); -C MNEI(3) = 0. -C If MODE = 'S', then -C MNEI(1) contains the row dimension of sE(eps)-A(eps); -C MNEI(2) contains the column dimension of sE(eps)-A(eps); -C MNEI(3) contains the order of the regular pencil -C sE(inf)-A(inf). -C -C Tolerances -C -C TOL DOUBLE PRECISION -C A tolerance below which matrix elements are considered -C to be zero. If the user sets TOL to be less than (or -C equal to) zero then the tolerance is taken as -C EPS * MAX( ABS(A(I,J)), ABS(E(I,J)) ), where EPS is the -C machine precision (see LAPACK Library routine DLAMCH), -C I = 1,2,...,M and J = 1,2,...,N. -C -C Workspace -C -C IWORK INTEGER array, dimension (N) -C -C Error Indicator -C -C INFO INTEGER -C = 0: successful exit; -C < 0: if INFO = -i, the i-th argument had an illegal -C value. -C > 0: if incorrect rank decisions were revealed during the -C triangularization phase. This failure is not likely -C to occur. The possible values are: -C = 1: if incorrect dimensions of a full column rank -C submatrix; -C = 2: if incorrect dimensions of a full row rank -C submatrix. -C -C METHOD -C -C Let sE - A be an arbitrary pencil. Prior to calling the routine, -C this pencil must be transformed into a pencil with E in column -C echelon form. This may be accomplished by calling the SLICOT -C Library routine MB04UD. Depending on the value of MODE, -C submatrices of A and E are then reduced to one of the forms -C described above. Further details can be found in [1]. -C -C REFERENCES -C -C [1] Beelen, Th. and Van Dooren, P. -C An improved algorithm for the computation of Kronecker's -C canonical form of a singular pencil. -C Linear Algebra and Applications, 105, pp. 9-65, 1988. -C -C NUMERICAL ASPECTS -C -C It is shown in [1] that the algorithm is numerically backward -C stable. The operations count is proportional to (MAX(M,N))**3. -C -C FURTHER COMMENTS -C -C The difference mu(k)-nu(k), for k = 1,2,...,NBLCKS, is the number -C of elementary Kronecker blocks of size k x (k+1). -C -C If MODE = 'B' or 'T' on entry, then the difference nu(k)-mu(k+1), -C for k = 1,2,...,NBLCKS, is the number of infinite elementary -C divisors of degree k (with mu(NBLCKS+1) = 0). -C -C If MODE = 'S' on entry, then the difference mu0(k)-mu0(k+1), -C for k = 1,2,...,NBLCKI, is the number of infinite elementary -C divisors of degree k (with mu0(NBLCKI+1) = 0). -C In the pencil sE(r)-A(r), the pencils sE(f)-A(f) and -C sE(eta)-A(eta) can be separated by pertransposing the pencil -C sE(r)-A(r) and calling the routine with MODE set to 'B'. The -C result has got to be pertransposed again. (For more details see -C [1]). -C -C CONTRIBUTOR -C -C Release 3.0: V. Sima, Katholieke Univ. Leuven, Belgium, Jan. 1998. -C Based on Release 3.0 routine MB04TD modified by A. Varga, -C German Aerospace Research Establishment, Oberpfaffenhofen, -C Germany, Nov. 1997, as follows: -C 1) NBLCKI is added; -C 2) the significance of IMUK0 and MNEI is changed; -C 3) INUK0 is removed. -C -C REVISIONS -C -C - -C -C KEYWORDS -C -C Generalized eigenvalue problem, orthogonal transformation, -C staircase form. -C -C ****************************************************************** -C -C .. Parameters .. - DOUBLE PRECISION ZERO, ONE - PARAMETER ( ZERO = 0.0D0, ONE = 1.0D0 ) -C .. Scalar Arguments .. - CHARACTER JOBQ, JOBZ, MODE - INTEGER INFO, LDA, LDE, LDQ, LDZ, M, N, NBLCKI, NBLCKS, - $ RANKE - DOUBLE PRECISION TOL -C .. Array Arguments .. - INTEGER IMUK(*), IMUK0(*), INUK(*), ISTAIR(*), IWORK(*), - $ MNEI(*) - DOUBLE PRECISION A(LDA,*), E(LDE,*), Q(LDQ,*), Z(LDZ,*) -C .. Local Scalars .. - LOGICAL FIRST, FIRSTI, LJOBQI, LJOBZI, LMODEB, LMODES, - $ LMODET, UPDATQ, UPDATZ - INTEGER I, IFICA, IFIRA, ISMUK, ISNUK, JK, K, NCA, NRA, - $ RANKA - DOUBLE PRECISION TOLER -C .. Local Arrays .. - DOUBLE PRECISION DWORK(1) -C .. External Functions .. - LOGICAL LSAME - DOUBLE PRECISION DLAMCH, DLANGE - EXTERNAL DLAMCH, DLANGE, LSAME -C .. External Subroutines .. - EXTERNAL DLASET, MB04TT, MB04TY, MB04VX, XERBLA -C .. Intrinsic Functions .. - INTRINSIC ABS, MAX -C .. Executable Statements .. -C - INFO = 0 - LMODEB = LSAME( MODE, 'B' ) - LMODET = LSAME( MODE, 'T' ) - LMODES = LSAME( MODE, 'S' ) - LJOBQI = LSAME( JOBQ, 'I' ) - UPDATQ = LJOBQI.OR.LSAME( JOBQ, 'U' ) - LJOBZI = LSAME( JOBZ, 'I' ) - UPDATZ = LJOBZI.OR.LSAME( JOBZ, 'U' ) -C -C Test the input scalar arguments. -C - IF( .NOT.LMODEB .AND. .NOT.LMODET .AND. .NOT.LMODES ) THEN - INFO = -1 - ELSE IF( .NOT.UPDATQ .AND. .NOT.LSAME( JOBQ, 'N' ) ) THEN - INFO = -2 - ELSE IF( .NOT.UPDATZ .AND. .NOT.LSAME( JOBZ, 'N' ) ) THEN - INFO = -3 - ELSE IF( M.LT.0 ) THEN - INFO = -4 - ELSE IF( N.LT.0 ) THEN - INFO = -5 - ELSE IF( RANKE.LT.0 ) THEN - INFO = -6 - ELSE IF( LDA.LT.MAX( 1, M ) ) THEN - INFO = -8 - ELSE IF( LDE.LT.MAX( 1, M ) ) THEN - INFO = -10 - ELSE IF( .NOT.UPDATQ .AND. LDQ.LT.1 .OR. - $ UPDATQ .AND. LDQ.LT.MAX( 1, M ) ) THEN - INFO = -12 - ELSE IF( .NOT.UPDATZ .AND. LDZ.LT.1 .OR. - $ UPDATZ .AND. LDZ.LT.MAX( 1, N ) ) THEN - INFO = -14 - END IF -C - IF ( INFO.NE.0 ) THEN -C -C Error return. -C - CALL XERBLA( 'MB04VD', -INFO ) - RETURN - END IF -C -C Initialize Q and Z to the identity matrices, if needed. -C - IF ( LJOBQI ) - $ CALL DLASET( 'Full', M, M, ZERO, ONE, Q, LDQ ) - IF ( LJOBZI ) - $ CALL DLASET( 'Full', N, N, ZERO, ONE, Z, LDZ ) -C -C Quick return if possible. -C - NBLCKS = 0 - NBLCKI = 0 -C - IF ( N.EQ.0 ) THEN - MNEI(1) = 0 - MNEI(2) = 0 - MNEI(3) = 0 - RETURN - END IF -C - IF ( M.EQ.0 ) THEN - NBLCKS = N - DO 10 I = 1, N - IMUK(I) = 1 - INUK(I) = 0 - 10 CONTINUE - MNEI(1) = 0 - MNEI(2) = N - MNEI(3) = 0 - RETURN - END IF -C - TOLER = TOL - IF ( TOLER.LE.ZERO ) - $ TOLER = DLAMCH( 'Epsilon' )* - $ MAX( DLANGE( 'M', M, N, A, LDA, DWORK ), - $ DLANGE( 'M', M, N, E, LDE, DWORK ) ) -C -C A(k) is the submatrix in A that will be row compressed. -C -C ISMUK = sum(i=1,..,k) MU(i), ISNUK = sum(i=1,...,k) NU(i), -C IFIRA, IFICA: first row and first column index of A(k) in A. -C NRA, NCA: number of rows and columns in A(k). -C - IFIRA = 1 - IFICA = 1 - NRA = M - NCA = N - RANKE - ISNUK = 0 - ISMUK = 0 - K = 0 -C -C Initialization of the arrays INUK and IMUK. -C - DO 20 I = 1, M + 1 - INUK(I) = -1 - 20 CONTINUE -C -C Note: it is necessary that array INUK has DIMENSION M+1 since it -C is possible that M = 1 and NBLCKS = 2. -C Example sE-A = (0 0 s -1). -C - DO 40 I = 1, N - IMUK(I) = -1 - 40 CONTINUE -C -C Compress the rows of A while keeping E in column echelon form. -C -C REPEAT -C - 60 K = K + 1 - CALL MB04TT( UPDATQ, UPDATZ, M, N, IFIRA, IFICA, NCA, A, LDA, - $ E, LDE, Q, LDQ, Z, LDZ, ISTAIR, RANKA, TOLER, - $ IWORK ) - IMUK(K) = NCA - ISMUK = ISMUK + NCA -C - INUK(K) = RANKA - ISNUK = ISNUK + RANKA - NBLCKS = NBLCKS + 1 -C -C If the rank of A(k) is nra then A has full row rank; -C JK = the first column index (in A) after the right most column -C of matrix A(k+1). (In case A(k+1) is empty, then JK = N+1.) -C - IFIRA = 1 + ISNUK - IFICA = 1 + ISMUK - IF ( IFIRA.GT.M ) THEN - JK = N + 1 - ELSE - JK = ABS( ISTAIR(IFIRA) ) - END IF - NRA = M - ISNUK - NCA = JK - 1 - ISMUK -C -C If NCA > 0 then there can be done some more row compression -C of matrix A while keeping matrix E in column echelon form. -C - IF ( NCA.GT.0 ) GO TO 60 -C UNTIL NCA <= 0 -C -C Matrix E(k+1) has full column rank since NCA = 0. -C Reduce A and E by ignoring all rows and columns corresponding -C to E(k+1). Ignoring these columns in E changes the ranks of the -C submatrices E(i), (i=1,...,k-1). -C - MNEI(1) = ISNUK - MNEI(2) = ISMUK - MNEI(3) = 0 -C - IF ( LMODEB ) - $ RETURN -C -C Triangularization of the submatrices in A and E. -C - CALL MB04TY( UPDATQ, UPDATZ, M, N, NBLCKS, INUK, IMUK, A, LDA, E, - $ LDE, Q, LDQ, Z, LDZ, INFO ) -C - IF ( INFO.GT.0 .OR. LMODET ) - $ RETURN -C -C Save the row dimensions of the diagonal submatrices in pencil -C sE(eps,inf)-A(eps,inf). -C - DO 80 I = 1, NBLCKS - IMUK0(I) = INUK(I) - 80 CONTINUE -C -C Reduction to square submatrices E(k)'s in E. -C - CALL MB04VX( UPDATQ, UPDATZ, M, N, NBLCKS, INUK, IMUK, A, LDA, E, - $ LDE, Q, LDQ, Z, LDZ, MNEI ) -C -C Determine the dimensions of the inf diagonal submatrices and -C update block numbers if necessary. -C - FIRST = .TRUE. - FIRSTI = .TRUE. - NBLCKI = NBLCKS - K = NBLCKS -C - DO 100 I = K, 1, -1 - IMUK0(I) = IMUK0(I) - INUK(I) - IF ( FIRSTI .AND. IMUK0(I).EQ.0 ) THEN - NBLCKI = NBLCKI - 1 - ELSE - FIRSTI = .FALSE. - END IF - IF ( FIRST .AND. IMUK(I).EQ.0 ) THEN - NBLCKS = NBLCKS - 1 - ELSE - FIRST = .FALSE. - END IF - 100 CONTINUE -C - RETURN -C *** Last line of MB04VD *** - END diff --git a/mex/sources/libslicot/MB04VX.f b/mex/sources/libslicot/MB04VX.f deleted file mode 100644 index 92cfab1cd..000000000 --- a/mex/sources/libslicot/MB04VX.f +++ /dev/null @@ -1,384 +0,0 @@ - SUBROUTINE MB04VX( UPDATQ, UPDATZ, M, N, NBLCKS, INUK, IMUK, A, - $ LDA, E, LDE, Q, LDQ, Z, LDZ, MNEI ) -C -C SLICOT RELEASE 5.0. -C -C Copyright (c) 2002-2009 NICONET e.V. -C -C This program is free software: you can redistribute it and/or -C modify it under the terms of the GNU General Public License as -C published by the Free Software Foundation, either version 2 of -C the License, or (at your option) any later version. -C -C This program is distributed in the hope that it will be useful, -C but WITHOUT ANY WARRANTY; without even the implied warranty of -C MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the -C GNU General Public License for more details. -C -C You should have received a copy of the GNU General Public License -C along with this program. If not, see -C . -C -C PURPOSE -C -C To separate the pencils s*E(eps)-A(eps) and s*E(inf)-A(inf) in -C s*E(eps,inf)-A(eps,inf) using Algorithm 3.3.3 in [1]. -C -C On entry, it is assumed that the M-by-N matrices A and E have -C been obtained after applying the Algorithms 3.2.1 and 3.3.1 to -C the pencil s*E - A as described in [1], i.e. -C -C | s*E(eps,inf)-A(eps,inf) | X | -C Q'(s*E - A)Z = |-------------------------|-------------| -C | 0 | s*E(r)-A(r) | -C -C Here the pencil s*E(eps,inf)-A(eps,inf) is in staircase form. -C This pencil contains all Kronecker column indices and infinite -C elementary divisors of the pencil s*E - A. -C The pencil s*E(r)-A(r) contains all Kronecker row indices and -C finite elementary divisors of s*E - A. -C Furthermore, the submatrices having full row and column rank in -C the pencil s*E(eps,inf)-A(eps,inf) are assumed to be -C triangularized. -C -C On exit, the result then is -C -C Q'(s*E - A)Z = -C -C | s*E(eps)-A(eps) | X | X | -C |-----------------|-----------------|-------------| -C | 0 | s*E(inf)-A(inf) | X | -C |===================================|=============| -C | | | -C | 0 | s*E(r)-A(r) | -C -C Note that the pencil s*E(r)-A(r) is not reduced further. -C -C ARGUMENTS -C -C Mode Parameters -C -C UPDATQ LOGICAL -C Indicates whether the user wishes to accumulate in a -C matrix Q the orthogonal row transformations, as follows: -C = .FALSE.: Do not form Q; -C = .TRUE.: The given matrix Q is updated by the orthogonal -C row transformations used in the reduction. -C -C UPDATZ LOGICAL -C Indicates whether the user wishes to accumulate in a -C matrix Z the orthogonal column transformations, as -C follows: -C = .FALSE.: Do not form Z; -C = .TRUE.: The given matrix Z is updated by the orthogonal -C column transformations used in the reduction. -C -C Input/Output Parameters -C -C M (input) INTEGER -C Number of rows of A and E. M >= 0. -C -C N (input) INTEGER -C Number of columns of A and E. N >= 0. -C -C NBLCKS (input) INTEGER -C The number of submatrices having full row rank (possibly -C zero) in A(eps,inf). -C -C INUK (input/output) INTEGER array, dimension (NBLCKS) -C On entry, this array contains the row dimensions nu(k), -C (k=1, 2, ..., NBLCKS) of the submatrices having full row -C rank in the pencil s*E(eps,inf)-A(eps,inf). -C On exit, this array contains the row dimensions nu(k), -C (k=1, 2, ..., NBLCKS) of the submatrices having full row -C rank in the pencil s*E(eps)-A(eps). -C -C IMUK (input/output) INTEGER array, dimension (NBLCKS) -C On entry, this array contains the column dimensions mu(k), -C (k=1, 2, ..., NBLCKS) of the submatrices having full -C column rank in the pencil s*E(eps,inf)-A(eps,inf). -C On exit, this array contains the column dimensions mu(k), -C (k=1, 2, ..., NBLCKS) of the submatrices having full -C column rank in the pencil s*E(eps)-A(eps). -C -C A (input/output) DOUBLE PRECISION array, dimension (LDA,N) -C On entry, this array contains the matrix A to be reduced. -C On exit, it contains the transformed matrix A. -C -C LDA INTEGER -C The leading dimension of array A. LDA >= MAX(1,M). -C -C E (input/output) DOUBLE PRECISION array, dimension (LDE,N) -C On entry, this array contains the matrix E to be reduced. -C On exit, it contains the transformed matrix E. -C -C LDE INTEGER -C The leading dimension of array E. LDE >= MAX(1,M). -C -C Q (input/output) DOUBLE PRECISION array, dimension (LDQ,*) -C On entry, if UPDATQ = .TRUE., then the leading M-by-M -C part of this array must contain a given matrix Q (e.g. -C from a previous call to another SLICOT routine), and on -C exit, the leading M-by-M part of this array contains the -C product of the input matrix Q and the row transformation -C matrix that has transformed the rows of the matrices A -C and E. -C If UPDATQ = .FALSE., the array Q is not referenced and -C can be supplied as a dummy array (i.e. set parameter -C LDQ = 1 and declare this array to be Q(1,1) in the calling -C program). -C -C LDQ INTEGER -C The leading dimension of array Q. If UPDATQ = .TRUE., -C LDQ >= MAX(1,M); if UPDATQ = .FALSE., LDQ >= 1. -C -C Z (input/output) DOUBLE PRECISION array, dimension (LDZ,*) -C On entry, if UPDATZ = .TRUE., then the leading N-by-N -C part of this array must contain a given matrix Z (e.g. -C from a previous call to another SLICOT routine), and on -C exit, the leading N-by-N part of this array contains the -C product of the input matrix Z and the column -C transformation matrix that has transformed the columns of -C the matrices A and E. -C If UPDATZ = .FALSE., the array Z is not referenced and -C can be supplied as a dummy array (i.e. set parameter -C LDZ = 1 and declare this array to be Z(1,1) in the calling -C program). -C -C LDZ INTEGER -C The leading dimension of array Z. If UPDATZ = .TRUE., -C LDZ >= MAX(1,N); if UPDATZ = .FALSE., LDZ >= 1. -C -C MNEI (output) INTEGER array, dimension (3) -C MNEI(1) = MEPS = row dimension of sE(eps)-A(eps); -C MNEI(2) = NEPS = column dimension of sE(eps)-A(eps); -C MNEI(3) = MINF = order of the regular pencil -C sE(inf)-A(inf). -C -C REFERENCES -C -C [1] Beelen, Th. -C New Algorithms for Computing the Kronecker structure of a -C Pencil with Applications to Systems and Control Theory. -C Ph.D.Thesis, Eindhoven University of Technology, -C The Netherlands, 1987. -C -C NUMERICAL ASPECTS -C -C The algorithm is backward stable. -C -C CONTRIBUTOR -C -C Release 3.0: V. Sima, Katholieke Univ. Leuven, Belgium, Jan. 1998. -C Based on Release 3.0 routine MB04TX modified by A. Varga, -C German Aerospace Research Establishment, Oberpfaffenhofen, -C Germany, Nov. 1997, as follows: -C 1) NBLCKS is only an input variable; -C 2) the significance of MNEI is changed. -C -C REVISIONS -C -C A. Varga, DLR Oberpfaffenhofen, March 2002. -C -C KEYWORDS -C -C Generalized eigenvalue problem, Kronecker indices, orthogonal -C transformation, staircase form. -C -C ****************************************************************** -C -C .. Parameters .. - DOUBLE PRECISION ZERO - PARAMETER ( ZERO = 0.0D0 ) -C .. Scalar Arguments .. - LOGICAL UPDATQ, UPDATZ - INTEGER LDA, LDE, LDQ, LDZ, M, N, NBLCKS -C .. Array Arguments .. - INTEGER IMUK(*), INUK(*), MNEI(3) - DOUBLE PRECISION A(LDA,*), E(LDE,*), Q(LDQ,*), Z(LDZ,*) -C .. Local Scalars .. - INTEGER CA, CJA, CJE, IP, ISMUK, ISNUK, K, MEPS, MINF, - $ MUK, MUKP1, MUP, MUP1, NEPS, NUK, NUP, RA, RJE, - $ SK1P1, TK1P1, TP1 - DOUBLE PRECISION SC, SS -C .. External Subroutines .. - EXTERNAL DROTG, MB04TU -C .. Executable Statements .. -C - MNEI(1) = 0 - MNEI(2) = 0 - MNEI(3) = 0 - IF ( M.LE.0 .OR. N.LE.0 ) - $ RETURN -C -C Initialisation. -C - ISMUK = 0 - ISNUK = 0 -C - DO 20 K = 1, NBLCKS - ISMUK = ISMUK + IMUK(K) - ISNUK = ISNUK + INUK(K) - 20 CONTINUE -C -C MEPS, NEPS are the dimensions of the pencil s*E(eps)-A(eps). -C MEPS = Sum(k=1,...,nblcks) NU(k), -C NEPS = Sum(k=1,...,nblcks) MU(k). -C MINF is the order of the regular pencil s*E(inf)-A(inf). -C - MEPS = ISNUK - NEPS = ISMUK - MINF = 0 -C -C MUKP1 = mu(k+1). N.B. It is assumed that mu(NBLCKS + 1) = 0. -C - MUKP1 = 0 -C - DO 120 K = NBLCKS, 1, -1 - NUK = INUK(K) - MUK = IMUK(K) -C -C Reduce submatrix E(k,k+1) to square matrix. -C NOTE that always NU(k) >= MU(k+1) >= 0. -C -C WHILE ( NU(k) > MU(k+1) ) DO - 40 IF ( NUK.GT.MUKP1 ) THEN -C -C sk1p1 = sum(i=k+1,...,p-1) NU(i) -C tk1p1 = sum(i=k+1,...,p-1) MU(i) -C ismuk = sum(i=1,...,k) MU(i) -C tp1 = sum(i=1,...,p-1) MU(i) = ismuk + tk1p1. -C - SK1P1 = 0 - TK1P1 = 0 -C - DO 100 IP = K + 1, NBLCKS -C -C Annihilate the elements originally present in the last -C row of E(k,p+1) and A(k,p). -C Start annihilating the first MU(p) - MU(p+1) elements by -C applying column Givens rotations plus interchanging -C elements. -C Use original bottom diagonal element of A(k,k) as pivot. -C Start position of pivot in A = (ra,ca). -C - TP1 = ISMUK + TK1P1 - RA = ISNUK + SK1P1 - CA = TP1 -C - MUP = IMUK(IP) - NUP = INUK(IP) - MUP1 = NUP -C - DO 60 CJA = CA, CA + MUP - NUP - 1 -C -C CJA = current column index of pivot in A. -C - CALL DROTG( A(RA,CJA), A(RA,CJA+1), SC, SS ) -C -C Apply transformations to A- and E-matrix. -C Interchange columns simultaneously. -C Update column transformation matrix Z, if needed. -C - CALL MB04TU( RA-1, A(1,CJA), 1, A(1,CJA+1), 1, SC, - $ SS ) - A(RA,CJA+1) = A(RA,CJA) - A(RA,CJA) = ZERO - CALL MB04TU( RA, E(1,CJA), 1, E(1,CJA+1), 1, SC, SS ) - IF( UPDATZ ) CALL MB04TU( N, Z(1,CJA), 1, Z(1,CJA+1), - $ 1, SC, SS ) - 60 CONTINUE -C -C Annihilate the remaining elements originally present in -C the last row of E(k,p+1) and A(k,p) by alternatingly -C applying row and column rotations plus interchanging -C elements. -C Use diagonal elements of E(p,p+1) and original bottom -C diagonal element of A(k,k) as pivots, respectively. -C (re,ce) and (ra,ca) are the starting positions of the -C pivots in E and A. -C - CJE = TP1 + MUP - CJA = CJE - MUP1 - 1 -C - DO 80 RJE = RA + 1, RA + MUP1 -C -C (RJE,CJE) = current position pivot in E. -C - CJE = CJE + 1 - CJA = CJA + 1 -C -C Determine the row transformations. -C Apply these transformations to E- and A-matrix. -C Interchange the rows simultaneously. -C Update row transformation matrix Q, if needed. -C - CALL DROTG( E(RJE,CJE), E(RJE-1,CJE), SC, SS ) - CALL MB04TU( N-CJE, E(RJE,CJE+1), LDE, E(RJE-1,CJE+1), - $ LDE, SC, SS ) - E(RJE-1,CJE) = E(RJE,CJE) - E(RJE,CJE) = ZERO - CALL MB04TU( N-CJA+1, A(RJE,CJA), LDA, A(RJE-1,CJA), - $ LDA, SC, SS ) - IF( UPDATQ ) CALL MB04TU( M, Q(1,RJE), 1, - $ Q(1,RJE-1), 1, SC, SS ) -C -C Determine the column transformations. -C Apply these transformations to A- and E-matrix. -C Interchange the columns simultaneously. -C Update column transformation matrix Z, if needed. -C - CALL DROTG( A(RJE,CJA), A(RJE,CJA+1), SC, SS ) - CALL MB04TU( RJE-1, A(1,CJA), 1, A(1,CJA+1), 1, SC, - $ SS ) - A(RJE,CJA+1) = A(RJE,CJA) - A(RJE,CJA) = ZERO - CALL MB04TU( RJE, E(1,CJA), 1, E(1,CJA+1), 1, SC, SS ) - IF( UPDATZ ) CALL MB04TU( N, Z(1,CJA), 1, Z(1,CJA+1), - $ 1, SC, SS ) - 80 CONTINUE -C - SK1P1 = SK1P1 + NUP - TK1P1 = TK1P1 + MUP -C - 100 CONTINUE -C -C Reduce A=A(eps,inf) and E=E(eps,inf) by ignoring their last -C row and right most column. The row and column ignored -C belong to the pencil s*E(inf)-A(inf). -C Redefine blocks in new A and E. -C - MUK = MUK - 1 - NUK = NUK - 1 - ISMUK = ISMUK - 1 - ISNUK = ISNUK - 1 - MEPS = MEPS - 1 - NEPS = NEPS - 1 - MINF = MINF + 1 -C - GO TO 40 - END IF -C END WHILE 40 -C - IMUK(K) = MUK - INUK(K) = NUK -C -C Now submatrix E(k,k+1) is square. -C -C Consider next submatrix (k:=k-1). -C - ISNUK = ISNUK - NUK - ISMUK = ISMUK - MUK - MUKP1 = MUK - 120 CONTINUE -C -C Store dimensions of the pencils s*E(eps)-A(eps) and -C s*E(inf)-A(inf) in array MNEI. -C - MNEI(1) = MEPS - MNEI(2) = NEPS - MNEI(3) = MINF -C - RETURN -C *** Last line of MB04VX *** - END diff --git a/mex/sources/libslicot/MB04WD.f b/mex/sources/libslicot/MB04WD.f deleted file mode 100644 index 9edbbf8c6..000000000 --- a/mex/sources/libslicot/MB04WD.f +++ /dev/null @@ -1,411 +0,0 @@ - SUBROUTINE MB04WD( TRANQ1, TRANQ2, M, N, K, Q1, LDQ1, Q2, LDQ2, - $ CS, TAU, DWORK, LDWORK, INFO ) -C -C SLICOT RELEASE 5.0. -C -C Copyright (c) 2002-2009 NICONET e.V. -C -C This program is free software: you can redistribute it and/or -C modify it under the terms of the GNU General Public License as -C published by the Free Software Foundation, either version 2 of -C the License, or (at your option) any later version. -C -C This program is distributed in the hope that it will be useful, -C but WITHOUT ANY WARRANTY; without even the implied warranty of -C MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the -C GNU General Public License for more details. -C -C You should have received a copy of the GNU General Public License -C along with this program. If not, see -C . -C -C PURPOSE -C -C To generate a matrix Q with orthogonal columns (spanning an -C isotropic subspace), which is defined as the first n columns -C of a product of symplectic reflectors and Givens rotators, -C -C Q = diag( H(1),H(1) ) G(1) diag( F(1),F(1) ) -C diag( H(2),H(2) ) G(2) diag( F(2),F(2) ) -C .... -C diag( H(k),H(k) ) G(k) diag( F(k),F(k) ). -C -C The matrix Q is returned in terms of its first 2*M rows -C -C [ op( Q1 ) op( Q2 ) ] -C Q = [ ]. -C [ -op( Q2 ) op( Q1 ) ] -C -C Blocked version of the SLICOT Library routine MB04WU. -C -C ARGUMENTS -C -C Mode Parameters -C -C TRANQ1 CHARACTER*1 -C Specifies the form of op( Q1 ) as follows: -C = 'N': op( Q1 ) = Q1; -C = 'T': op( Q1 ) = Q1'; -C = 'C': op( Q1 ) = Q1'. -C -C TRANQ2 CHARACTER*1 -C Specifies the form of op( Q2 ) as follows: -C = 'N': op( Q2 ) = Q2; -C = 'T': op( Q2 ) = Q2'; -C = 'C': op( Q2 ) = Q2'. -C -C Input/Output Parameters -C -C M (input) INTEGER -C The number of rows of the matrices Q1 and Q2. M >= 0. -C -C N (input) INTEGER -C The number of columns of the matrices Q1 and Q2. -C M >= N >= 0. -C -C K (input) INTEGER -C The number of symplectic Givens rotators whose product -C partly defines the matrix Q. N >= K >= 0. -C -C Q1 (input/output) DOUBLE PRECISION array, dimension -C (LDQ1,N) if TRANQ1 = 'N', -C (LDQ1,M) if TRANQ1 = 'T' or TRANQ1 = 'C' -C On entry with TRANQ1 = 'N', the leading M-by-K part of -C this array must contain in its i-th column the vector -C which defines the elementary reflector F(i). -C On entry with TRANQ1 = 'T' or TRANQ1 = 'C', the leading -C K-by-M part of this array must contain in its i-th row -C the vector which defines the elementary reflector F(i). -C On exit with TRANQ1 = 'N', the leading M-by-N part of this -C array contains the matrix Q1. -C On exit with TRANQ1 = 'T' or TRANQ1 = 'C', the leading -C N-by-M part of this array contains the matrix Q1'. -C -C LDQ1 INTEGER -C The leading dimension of the array Q1. -C LDQ1 >= MAX(1,M), if TRANQ1 = 'N'; -C LDQ1 >= MAX(1,N), if TRANQ1 = 'T' or TRANQ1 = 'C'. -C -C Q2 (input/output) DOUBLE PRECISION array, dimension -C (LDQ2,N) if TRANQ2 = 'N', -C (LDQ2,M) if TRANQ2 = 'T' or TRANQ2 = 'C' -C On entry with TRANQ2 = 'N', the leading M-by-K part of -C this array must contain in its i-th column the vector -C which defines the elementary reflector H(i) and, on the -C diagonal, the scalar factor of H(i). -C On entry with TRANQ2 = 'T' or TRANQ2 = 'C', the leading -C K-by-M part of this array must contain in its i-th row the -C vector which defines the elementary reflector H(i) and, on -C the diagonal, the scalar factor of H(i). -C On exit with TRANQ2 = 'N', the leading M-by-N part of this -C array contains the matrix Q2. -C On exit with TRANQ2 = 'T' or TRANQ2 = 'C', the leading -C N-by-M part of this array contains the matrix Q2'. -C -C LDQ2 INTEGER -C The leading dimension of the array Q2. -C LDQ2 >= MAX(1,M), if TRANQ2 = 'N'; -C LDQ2 >= MAX(1,N), if TRANQ2 = 'T' or TRANQ2 = 'C'. -C -C CS (input) DOUBLE PRECISION array, dimension (2*K) -C On entry, the first 2*K elements of this array must -C contain the cosines and sines of the symplectic Givens -C rotators G(i). -C -C TAU (input) DOUBLE PRECISION array, dimension (K) -C On entry, the first K elements of this array must -C contain the scalar factors of the elementary reflectors -C F(i). -C -C Workspace -C -C DWORK DOUBLE PRECISION array, dimension (LDWORK) -C On exit, if INFO = 0, DWORK(1) returns the optimal -C value of LDWORK, MAX(M+N,8*N*NB + 15*NB*NB), where NB is -C the optimal block size determined by the function UE01MD. -C On exit, if INFO = -13, DWORK(1) returns the minimum -C value of LDWORK. -C -C LDWORK INTEGER -C The length of the array DWORK. LDWORK >= MAX(1,M+N). -C -C Error Indicator -C -C INFO INTEGER -C = 0: successful exit; -C < 0: if INFO = -i, the i-th argument had an illegal -C value. -C -C REFERENCES -C -C [1] Kressner, D. -C Block algorithms for orthogonal symplectic factorizations. -C BIT, 43 (4), pp. 775-790, 2003. -C -C CONTRIBUTORS -C -C D. Kressner, Technical Univ. Berlin, Germany, and -C P. Benner, Technical Univ. Chemnitz, Germany, December 2003. -C -C REVISIONS -C -C V. Sima, June 2008 (SLICOT version of the HAPACK routine DOSGSB). -C -C KEYWORDS -C -C Elementary matrix operations, orthogonal symplectic matrix. -C -C ****************************************************************** -C -C .. Parameters .. - DOUBLE PRECISION ONE - PARAMETER ( ONE = 1.0D+0 ) -C .. Scalar Arguments .. - CHARACTER TRANQ1, TRANQ2 - INTEGER INFO, K, LDQ1, LDQ2, LDWORK, M, N -C .. Array Arguments .. - DOUBLE PRECISION CS(*), DWORK(*), Q1(LDQ1,*), Q2(LDQ2,*), TAU(*) -C .. Local Scalars .. - LOGICAL LTRQ1, LTRQ2 - INTEGER I, IB, IERR, KI, KK, NB, NBMIN, NX, PDRS, PDT, - $ PDW, WRKOPT -C .. External Functions .. - LOGICAL LSAME - INTEGER UE01MD - EXTERNAL LSAME, UE01MD -C .. External Subroutines .. - EXTERNAL MB04QC, MB04QF, MB04WU, XERBLA -C .. Intrinsic Functions .. - INTRINSIC DBLE, INT, MAX, MIN, SQRT -C -C .. Executable Statements .. -C -C Decode the scalar input parameters. -C - INFO = 0 - LTRQ1 = LSAME( TRANQ1, 'T' ) .OR. LSAME( TRANQ1,'C' ) - LTRQ2 = LSAME( TRANQ2, 'T' ) .OR. LSAME( TRANQ2,'C' ) - NB = UE01MD( 1, 'MB04WD', TRANQ1 // TRANQ2, M, N, K ) -C -C Check the scalar input parameters. -C - IF ( .NOT.( LTRQ1 .OR. LSAME( TRANQ1, 'N' ) ) ) THEN - INFO = -1 - ELSE IF ( .NOT.( LTRQ2 .OR. LSAME( TRANQ2, 'N' ) ) ) THEN - INFO = -2 - ELSE IF ( M.LT.0 ) THEN - INFO = -3 - ELSE IF ( N.LT.0 .OR. N.GT.M ) THEN - INFO = -4 - ELSE IF ( K.LT.0 .OR. K.GT.N ) THEN - INFO = -5 - ELSE IF ( ( LTRQ1 .AND. LDQ1.LT.MAX( 1, N ) ) .OR. - $ ( .NOT.LTRQ1 .AND. LDQ1.LT.MAX( 1, M ) ) ) THEN - INFO = -7 - ELSE IF ( ( LTRQ2 .AND. LDQ2.LT.MAX( 1, N ) ) .OR. - $ ( .NOT.LTRQ2 .AND. LDQ2.LT.MAX( 1, M ) ) ) THEN - INFO = -9 - ELSE IF ( LDWORK.LT.MAX( 1, M + N ) ) THEN - DWORK(1) = DBLE( MAX( 1, M + N ) ) - INFO = -13 - END IF -C -C Return if there were illegal values. -C - IF ( INFO.NE.0 ) THEN - CALL XERBLA( 'MB04WD', -INFO ) - RETURN - END IF -C -C Quick return if possible. -C - IF( N.EQ.0 ) THEN - DWORK(1) = ONE - RETURN - END IF -C - NBMIN = 2 - NX = 0 - WRKOPT = M + N - IF( NB.GT.1 .AND. NB.LT.K ) THEN -C -C Determine when to cross over from blocked to unblocked code. -C - NX = MAX( 0, UE01MD( 3, 'MB04WD', TRANQ1 // TRANQ2, M, N, K ) ) - IF ( NX.LT.K ) THEN -C -C Determine if workspace is large enough for blocked code. -C - WRKOPT = MAX( WRKOPT, 8*N*NB + 15*NB*NB ) - IF( LDWORK.LT.WRKOPT ) THEN -C -C Not enough workspace to use optimal NB: reduce NB and -C determine the minimum value of NB. -C - NB = INT( ( SQRT( DBLE( 16*N*N + 15*LDWORK ) ) - $ - DBLE( 4*N ) ) / 15.0D0 ) - NBMIN = MAX( 2, UE01MD( 2, 'MB04WD', TRANQ1 // TRANQ2, M, - $ N, K ) ) - END IF - END IF - END IF -C - IF ( NB.GE.NBMIN .AND. NB.LT.K .AND. NX.LT.K ) THEN -C -C Use blocked code after the last block. -C The first kk columns are handled by the block method. -C - KI = ( ( K-NX-1 ) / NB )*NB - KK = MIN( K, KI+NB ) - ELSE - KK = 0 - END IF -C -C Use unblocked code for the last or only block. -C - IF ( KK.LT.N ) - $ CALL MB04WU( TRANQ1, TRANQ2, M-KK, N-KK, K-KK, Q1(KK+1,KK+1), - $ LDQ1, Q2(KK+1,KK+1), LDQ2, CS(2*KK+1), TAU(KK+1), - $ DWORK, LDWORK, IERR ) -C -C Blocked code. -C - IF ( KK.GT.0 ) THEN - PDRS = 1 - PDT = PDRS + 6*NB*NB - PDW = PDT + 9*NB*NB - IF ( LTRQ1.AND.LTRQ2 ) THEN - DO 10 I = KI + 1, 1, -NB - IB = MIN( NB, K-I+1 ) - IF ( I+IB.LE.N ) THEN -C -C Form the triangular factors of the symplectic block -C reflector SH. -C - CALL MB04QF( 'Forward', 'Rowwise', 'Rowwise', M-I+1, - $ IB, Q1(I,I), LDQ1, Q2(I,I), LDQ2, - $ CS(2*I-1), TAU(I), DWORK(PDRS), NB, - $ DWORK(PDT), NB, DWORK(PDW) ) -C -C Apply SH to Q1(i+ib:n,i:m) and Q2(i+ib:n,i:m) from -C the right. -C - CALL MB04QC( 'Zero Structure', 'Transpose', - $ 'Transpose', 'No Transpose', 'Forward', - $ 'Rowwise', 'Rowwise', M-I+1, N-I-IB+1, - $ IB, Q1(I,I), LDQ1, Q2(I,I), LDQ2, - $ DWORK(PDRS), NB, DWORK(PDT), NB, - $ Q2(I+IB,I), LDQ2, Q1(I+IB,I), LDQ1, - $ DWORK(PDW) ) - END IF -C -C Apply SH to columns i:m of the current block. -C - CALL MB04WU( 'Transpose', 'Transpose', M-I+1, IB, IB, - $ Q1(I,I), LDQ1, Q2(I,I), LDQ2, CS(2*I-1), - $ TAU(I), DWORK, LDWORK, IERR ) - 10 CONTINUE -C - ELSE IF ( LTRQ1 ) THEN - DO 20 I = KI + 1, 1, -NB - IB = MIN( NB, K-I+1 ) - IF ( I+IB.LE.N ) THEN -C -C Form the triangular factors of the symplectic block -C reflector SH. -C - CALL MB04QF( 'Forward', 'Rowwise', 'Columnwise', - $ M-I+1, IB, Q1(I,I), LDQ1, Q2(I,I), LDQ2, - $ CS(2*I-1), TAU(I), DWORK(PDRS), NB, - $ DWORK(PDT), NB, DWORK(PDW) ) -C -C Apply SH to Q1(i+ib:n,i:m) from the right and to -C Q2(i:m,i+ib:n) from the left. -C - CALL MB04QC( 'Zero Structure', 'No Transpose', - $ 'Transpose', 'No Transpose', - $ 'Forward', 'Rowwise', 'Columnwise', - $ M-I+1, N-I-IB+1, IB, Q1(I,I), LDQ1, - $ Q2(I,I), LDQ2, DWORK(PDRS), NB, - $ DWORK(PDT), NB, Q2(I,I+IB), LDQ2, - $ Q1(I+IB,I), LDQ1, DWORK(PDW) ) - END IF -C -C Apply SH to columns/rows i:m of the current block. -C - CALL MB04WU( 'Transpose', 'No Transpose', M-I+1, IB, IB, - $ Q1(I,I), LDQ1, Q2(I,I), LDQ2, CS(2*I-1), - $ TAU(I), DWORK, LDWORK, IERR ) - 20 CONTINUE -C - ELSE IF ( LTRQ2 ) THEN - DO 30 I = KI + 1, 1, -NB - IB = MIN( NB, K-I+1 ) - IF ( I+IB.LE.N ) THEN -C -C Form the triangular factors of the symplectic block -C reflector SH. -C - CALL MB04QF( 'Forward', 'Columnwise', 'Rowwise', - $ M-I+1, IB, Q1(I,I), LDQ1, Q2(I,I), LDQ2, - $ CS(2*I-1), TAU(I), DWORK(PDRS), NB, - $ DWORK(PDT), NB, DWORK(PDW) ) -C -C Apply SH to Q1(i:m,i+ib:n) from the left and to -C Q2(i+ib:n,i:m) from the right. -C - CALL MB04QC( 'Zero Structure', 'Transpose', - $ 'No Transpose', 'No Transpose', 'Forward', - $ 'Columnwise', 'Rowwise', M-I+1, N-I-IB+1, - $ IB, Q1(I,I), LDQ1, Q2(I,I), LDQ2, - $ DWORK(PDRS), NB, DWORK(PDT), NB, - $ Q2(I+IB,I), LDQ2, Q1(I,I+IB), LDQ1, - $ DWORK(PDW) ) - END IF -C -C Apply SH to columns/rows i:m of the current block. -C - CALL MB04WU( 'No Transpose', 'Transpose', M-I+1, IB, IB, - $ Q1(I,I), LDQ1, Q2(I,I), LDQ2, CS(2*I-1), - $ TAU(I), DWORK, LDWORK, IERR ) - 30 CONTINUE -C - ELSE - DO 40 I = KI + 1, 1, -NB - IB = MIN( NB, K-I+1 ) - IF ( I+IB.LE.N ) THEN -C -C Form the triangular factors of the symplectic block -C reflector SH. -C - CALL MB04QF( 'Forward', 'Columnwise', 'Columnwise', - $ M-I+1, IB, Q1(I,I), LDQ1, Q2(I,I), LDQ2, - $ CS(2*I-1), TAU(I), DWORK(PDRS), NB, - $ DWORK(PDT), NB, DWORK(PDW) ) -C -C Apply SH to Q1(i:m,i+ib:n) and Q2(i:m,i+ib:n) from -C the left. -C - CALL MB04QC( 'Zero Structure', 'No Transpose', - $ 'No Transpose', 'No Transpose', - $ 'Forward', 'Columnwise', 'Columnwise', - $ M-I+1, N-I-IB+1, IB, Q1(I,I), LDQ1, - $ Q2(I,I), LDQ2, DWORK(PDRS), NB, - $ DWORK(PDT), NB, Q2(I,I+IB), LDQ2, - $ Q1(I,I+IB), LDQ1, DWORK(PDW) ) - END IF -C -C Apply SH to rows i:m of the current block. -C - CALL MB04WU( 'No Transpose', 'No Transpose', M-I+1, IB, - $ IB, Q1(I,I), LDQ1, Q2(I,I), LDQ2, CS(2*I-1), - $ TAU(I), DWORK, LDWORK, IERR ) - 40 CONTINUE - END IF - END IF -C - DWORK(1) = DBLE( WRKOPT ) -C - RETURN -C *** Last line of MB04WD *** - END diff --git a/mex/sources/libslicot/MB04WP.f b/mex/sources/libslicot/MB04WP.f deleted file mode 100644 index 2af3306c6..000000000 --- a/mex/sources/libslicot/MB04WP.f +++ /dev/null @@ -1,211 +0,0 @@ - SUBROUTINE MB04WP( N, ILO, U1, LDU1, U2, LDU2, CS, TAU, DWORK, - $ LDWORK, INFO ) -C -C SLICOT RELEASE 5.0. -C -C Copyright (c) 2002-2009 NICONET e.V. -C -C This program is free software: you can redistribute it and/or -C modify it under the terms of the GNU General Public License as -C published by the Free Software Foundation, either version 2 of -C the License, or (at your option) any later version. -C -C This program is distributed in the hope that it will be useful, -C but WITHOUT ANY WARRANTY; without even the implied warranty of -C MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the -C GNU General Public License for more details. -C -C You should have received a copy of the GNU General Public License -C along with this program. If not, see -C . -C -C PURPOSE -C -C To generate an orthogonal symplectic matrix U, which is defined as -C a product of symplectic reflectors and Givens rotators -C -C U = diag( H(1),H(1) ) G(1) diag( F(1),F(1) ) -C diag( H(2),H(2) ) G(2) diag( F(2),F(2) ) -C .... -C diag( H(n-1),H(n-1) ) G(n-1) diag( F(n-1),F(n-1) ). -C -C as returned by MB04PU. The matrix U is returned in terms of its -C first N rows -C -C [ U1 U2 ] -C U = [ ]. -C [ -U2 U1 ] -C -C ARGUMENTS -C -C Input/Output Parameters -C -C N (input) INTEGER -C The order of the matrices U1 and U2. N >= 0. -C -C ILO (input) INTEGER -C ILO must have the same value as in the previous call of -C MB04PU. U is equal to the unit matrix except in the -C submatrix -C U([ilo+1:n n+ilo+1:2*n], [ilo+1:n n+ilo+1:2*n]). -C 1 <= ILO <= N, if N > 0; ILO = 1, if N = 0. -C -C U1 (input/output) DOUBLE PRECISION array, dimension (LDU1,N) -C On entry, the leading N-by-N part of this array must -C contain in its i-th column the vector which defines the -C elementary reflector F(i). -C On exit, the leading N-by-N part of this array contains -C the matrix U1. -C -C LDU1 INTEGER -C The leading dimension of the array U1. LDU1 >= MAX(1,N). -C -C U2 (input/output) DOUBLE PRECISION array, dimension (LDU2,N) -C On entry, the leading N-by-N part of this array must -C contain in its i-th column the vector which defines the -C elementary reflector H(i) and, on the subdiagonal, the -C scalar factor of H(i). -C On exit, the leading N-by-N part of this array contains -C the matrix U2. -C -C LDU2 INTEGER -C The leading dimension of the array U2. LDU2 >= MAX(1,N). -C -C CS (input) DOUBLE PRECISION array, dimension (2N-2) -C On entry, the first 2N-2 elements of this array must -C contain the cosines and sines of the symplectic Givens -C rotators G(i). -C -C TAU (input) DOUBLE PRECISION array, dimension (N-1) -C On entry, the first N-1 elements of this array must -C contain the scalar factors of the elementary reflectors -C F(i). -C -C Workspace -C -C DWORK DOUBLE PRECISION array, dimension (LDWORK) -C On exit, if INFO = 0, DWORK(1) returns the optimal -C value of LDWORK. -C On exit, if INFO = -10, DWORK(1) returns the minimum -C value of LDWORK. -C -C LDWORK INTEGER -C The length of the array DWORK. LDWORK >= MAX(1,2*(N-ILO)). -C For optimum performance LDWORK should be larger. (See -C SLICOT Library routine MB04WD). -C -C Error Indicator -C -C INFO INTEGER -C = 0: successful exit; -C < 0: if INFO = -i, the i-th argument had an illegal -C value. -C -C NUMERICAL ASPECTS -C -C The algorithm requires O(N**3) floating point operations and is -C strongly backward stable. -C -C REFERENCES -C -C [1] C. F. VAN LOAN: -C A symplectic method for approximating all the eigenvalues of -C a Hamiltonian matrix. -C Linear Algebra and its Applications, 61, pp. 233-251, 1984. -C -C [2] D. KRESSNER: -C Block algorithms for orthogonal symplectic factorizations. -C BIT, 43 (4), pp. 775-790, 2003. -C -C CONTRIBUTORS -C -C D. Kressner (Technical Univ. Berlin, Germany) and -C P. Benner (Technical Univ. Chemnitz, Germany), December 2003. -C -C REVISIONS -C -C V. Sima, Nov. 2008 (SLICOT version of the HAPACK routine DOSGPV). -C -C KEYWORDS -C -C Elementary matrix operations, orthogonal symplectic matrix. -C -C ****************************************************************** -C -C .. Parameters .. - DOUBLE PRECISION ZERO, ONE - PARAMETER ( ZERO = 0.0D+0, ONE = 1.0D+0 ) -C .. Scalar Arguments .. - INTEGER ILO, INFO, LDU1, LDU2, LDWORK, N -C .. Array Arguments .. - DOUBLE PRECISION CS(*), DWORK(*), U1(LDU1,*), U2(LDU2,*), TAU(*) -C .. Local Scalars .. - INTEGER I, IERR, J, NH -C .. External Subroutines .. - EXTERNAL DLASET, MB04WD, XERBLA -C .. Intrinsic Functions .. - INTRINSIC DBLE, MAX -C -C .. Executable Statements .. -C -C Check the scalar input parameters. -C - INFO = 0 - IF ( N.LT.0 ) THEN - INFO = -1 - ELSE IF ( ILO.LT.1 .OR. ILO.GT.MAX( 1, N ) ) THEN - INFO = -2 - ELSE IF ( LDU1.LT.MAX( 1, N ) ) THEN - INFO = -4 - ELSE IF ( LDU2.LT.MAX( 1, N ) ) THEN - INFO = -6 - ELSE IF ( LDWORK.LT.MAX( 1, 2*( N - ILO ) ) ) THEN - DWORK(1) = DBLE( MAX( 1, 2*( N - ILO ) ) ) - INFO = -10 - END IF -C -C Return if there were illegal values. -C - IF ( INFO.NE.0 ) THEN - CALL XERBLA( 'MB04WP', -INFO ) - RETURN - END IF -C -C Quick return if possible. -C - IF( N.EQ.0 ) THEN - DWORK(1) = ONE - RETURN - END IF -C -C Shift the vectors which define the elementary reflectors one -C column to the right, and set the first ilo rows and columns to -C those of the unit matrix. -C - DO 30 J = N, ILO + 1, -1 - DO 10 I = 1, J-1 - U1(I,J) = ZERO - 10 CONTINUE - DO 20 I = J+1, N - U1(I,J) = U1(I,J-1) - 20 CONTINUE - 30 CONTINUE - CALL DLASET( 'All', N, ILO, ZERO, ONE, U1, LDU1 ) - DO 60 J = N, ILO + 1, -1 - DO 40 I = 1, J-1 - U2(I,J) = ZERO - 40 CONTINUE - DO 50 I = J, N - U2(I,J) = U2(I,J-1) - 50 CONTINUE - 60 CONTINUE - CALL DLASET( 'All', N, ILO, ZERO, ZERO, U2, LDU2 ) - NH = N - ILO - IF ( NH.GT.0 ) THEN - CALL MB04WD( 'No Transpose', 'No Transpose', NH, NH, NH, - $ U1(ILO+1,ILO+1), LDU1, U2(ILO+1,ILO+1), LDU2, - $ CS(ILO), TAU(ILO), DWORK, LDWORK, IERR ) - END IF - RETURN -C *** Last line of MB04WP *** - END diff --git a/mex/sources/libslicot/MB04WR.f b/mex/sources/libslicot/MB04WR.f deleted file mode 100644 index 42c1f461b..000000000 --- a/mex/sources/libslicot/MB04WR.f +++ /dev/null @@ -1,340 +0,0 @@ - SUBROUTINE MB04WR( JOB, TRANS, N, ILO, Q1, LDQ1, Q2, LDQ2, CS, - $ TAU, DWORK, LDWORK, INFO ) -C -C SLICOT RELEASE 5.0. -C -C Copyright (c) 2002-2009 NICONET e.V. -C -C This program is free software: you can redistribute it and/or -C modify it under the terms of the GNU General Public License as -C published by the Free Software Foundation, either version 2 of -C the License, or (at your option) any later version. -C -C This program is distributed in the hope that it will be useful, -C but WITHOUT ANY WARRANTY; without even the implied warranty of -C MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the -C GNU General Public License for more details. -C -C You should have received a copy of the GNU General Public License -C along with this program. If not, see -C . -C -C PURPOSE -C -C To generate orthogonal symplectic matrices U or V, defined as -C products of symplectic reflectors and Givens rotators -C -C U = diag( HU(1),HU(1) ) GU(1) diag( FU(1),FU(1) ) -C diag( HU(2),HU(2) ) GU(2) diag( FU(2),FU(2) ) -C .... -C diag( HU(n),HU(n) ) GU(n) diag( FU(n),FU(n) ), -C -C V = diag( HV(1),HV(1) ) GV(1) diag( FV(1),FV(1) ) -C diag( HV(2),HV(2) ) GV(2) diag( FV(2),FV(2) ) -C .... -C diag( HV(n-1),HV(n-1) ) GV(n-1) diag( FV(n-1),FV(n-1) ), -C -C as returned by the SLICOT Library routines MB04TS or MB04TB. The -C matrices U and V are returned in terms of their first N/2 rows: -C -C [ U1 U2 ] [ V1 V2 ] -C U = [ ], V = [ ]. -C [ -U2 U1 ] [ -V2 V1 ] -C -C ARGUMENTS -C -C Input/Output Parameters -C -C JOB CHARACTER*1 -C Specifies whether the matrix U or the matrix V is -C required: -C = 'U': generate U; -C = 'V': generate V. -C -C TRANS CHARACTER*1 -C If JOB = 'U' then TRANS must have the same value as -C the argument TRANA in the previous call of MB04TS or -C MB04TB. -C If JOB = 'V' then TRANS must have the same value as -C the argument TRANB in the previous call of MB04TS or -C MB04TB. -C -C N (input) INTEGER -C The order of the matrices Q1 and Q2. N >= 0. -C -C ILO (input) INTEGER -C ILO must have the same value as in the previous call of -C MB04TS or MB04TB. U and V are equal to the unit matrix -C except in the submatrices -C U([ilo:n n+ilo:2*n], [ilo:n n+ilo:2*n]) and -C V([ilo+1:n n+ilo+1:2*n], [ilo+1:n n+ilo+1:2*n]), -C respectively. -C 1 <= ILO <= N, if N > 0; ILO = 1, if N = 0. -C -C Q1 (input/output) DOUBLE PRECISION array, dimension (LDQ1,N) -C On entry, if JOB = 'U' and TRANS = 'N' then the -C leading N-by-N part of this array must contain in its i-th -C column the vector which defines the elementary reflector -C FU(i). -C If JOB = 'U' and TRANS = 'T' or TRANS = 'C' then the -C leading N-by-N part of this array must contain in its i-th -C row the vector which defines the elementary reflector -C FU(i). -C If JOB = 'V' and TRANS = 'N' then the leading N-by-N -C part of this array must contain in its i-th row the vector -C which defines the elementary reflector FV(i). -C If JOB = 'V' and TRANS = 'T' or TRANS = 'C' then the -C leading N-by-N part of this array must contain in its i-th -C column the vector which defines the elementary reflector -C FV(i). -C On exit, if JOB = 'U' and TRANS = 'N' then the leading -C N-by-N part of this array contains the matrix U1. -C If JOB = 'U' and TRANS = 'T' or TRANS = 'C' then the -C leading N-by-N part of this array contains the matrix -C U1**T. -C If JOB = 'V' and TRANS = 'N' then the leading N-by-N -C part of this array contains the matrix V1**T. -C If JOB = 'V' and TRANS = 'T' or TRANS = 'C' then the -C leading N-by-N part of this array contains the matrix V1. -C -C LDQ1 INTEGER -C The leading dimension of the array Q1. LDQ1 >= MAX(1,N). -C -C Q2 (input/output) DOUBLE PRECISION array, dimension (LDQ2,N) -C On entry, if JOB = 'U' then the leading N-by-N part of -C this array must contain in its i-th column the vector -C which defines the elementary reflector HU(i). -C If JOB = 'V' then the leading N-by-N part of this array -C must contain in its i-th row the vector which defines the -C elementary reflector HV(i). -C On exit, if JOB = 'U' then the leading N-by-N part of -C this array contains the matrix U2. -C If JOB = 'V' then the leading N-by-N part of this array -C contains the matrix V2**T. -C -C LDQ2 INTEGER -C The leading dimension of the array Q2. LDQ2 >= MAX(1,N). -C -C CS (input) DOUBLE PRECISION array, dimension (2N) -C On entry, if JOB = 'U' then the first 2N elements of -C this array must contain the cosines and sines of the -C symplectic Givens rotators GU(i). -C If JOB = 'V' then the first 2N-2 elements of this array -C must contain the cosines and sines of the symplectic -C Givens rotators GV(i). -C -C TAU (input) DOUBLE PRECISION array, dimension (N) -C On entry, if JOB = 'U' then the first N elements of -C this array must contain the scalar factors of the -C elementary reflectors FU(i). -C If JOB = 'V' then the first N-1 elements of this array -C must contain the scalar factors of the elementary -C reflectors FV(i). -C -C Workspace -C -C DWORK DOUBLE PRECISION array, dimension (LDWORK) -C On exit, if INFO = 0, DWORK(1) returns the optimal -C value of LDWORK. -C On exit, if INFO = -12, DWORK(1) returns the minimum -C value of LDWORK. -C -C LDWORK INTEGER -C The length of the array DWORK. -C LDWORK >= MAX(1,2*(N-ILO+1)). -C -C Error Indicator -C -C INFO INTEGER -C = 0: successful exit; -C < 0: if INFO = -i, the i-th argument had an illegal -C value. -C -C REFERENCES -C -C [1] Benner, P., Mehrmann, V., and Xu, H. -C A numerically stable, structure preserving method for -C computing the eigenvalues of real Hamiltonian or symplectic -C pencils. Numer. Math., Vol 78 (3), pp. 329-358, 1998. -C -C [2] Kressner, D. -C Block algorithms for orthogonal symplectic factorizations. -C BIT, 43 (4), pp. 775-790, 2003. -C -C CONTRIBUTORS -C -C D. Kressner, Technical Univ. Berlin, Germany, and -C P. Benner, Technical Univ. Chemnitz, Germany, December 2003. -C -C REVISIONS -C -C V. Sima, June 2008 (SLICOT version of the HAPACK routine DOSGSU). -C -C KEYWORDS -C -C Elementary matrix operations, Hamiltonian matrix, orthogonal -C symplectic matrix. -C -C ****************************************************************** -C -C .. Parameters .. - DOUBLE PRECISION ZERO, ONE - PARAMETER ( ZERO = 0.0D+0, ONE = 1.0D+0 ) -C .. Scalar Arguments .. - CHARACTER JOB, TRANS - INTEGER ILO, INFO, LDQ1, LDQ2, LDWORK, N -C .. Array Arguments .. - DOUBLE PRECISION CS(*), DWORK(*), Q1(LDQ1,*), Q2(LDQ2,*), TAU(*) -C .. Local Scalars .. - LOGICAL COMPU, LTRAN - INTEGER I, IERR, J, NH -C .. External Functions .. - LOGICAL LSAME - EXTERNAL LSAME -C .. External Subroutines .. - EXTERNAL DLASET, MB04WD, XERBLA -C .. Intrinsic Functions .. - INTRINSIC DBLE, MAX -C -C .. Executable Statements .. -C -C Check the scalar input parameters. -C - INFO = 0 - LTRAN = LSAME( TRANS, 'T' ) .OR. LSAME( TRANS, 'C' ) - COMPU = LSAME( JOB, 'U' ) - IF ( .NOT.COMPU .AND. .NOT.LSAME( JOB, 'V' ) ) THEN - INFO = -1 - ELSE IF ( .NOT.LTRAN .AND. .NOT.LSAME( TRANS, 'N' ) ) THEN - INFO = -2 - ELSE IF ( N.LT.0 ) THEN - INFO = -3 - ELSE IF ( ILO.LT.1 .OR. ILO.GT.MAX( 1, N ) ) THEN - INFO = -4 - ELSE IF ( LDQ1.LT.MAX( 1, N ) ) THEN - INFO = -6 - ELSE IF ( LDQ2.LT.MAX( 1, N ) ) THEN - INFO = -8 - ELSE IF ( LDWORK.LT.MAX( 1, 2*( N-ILO+1 ) ) ) THEN - DWORK(1) = DBLE( MAX( 1, 2*( N-ILO+1 ) ) ) - INFO = -12 - END IF -C -C Return if there were illegal values. -C - IF ( INFO.NE.0 ) THEN - CALL XERBLA( 'MB04WR', -INFO ) - RETURN - END IF -C -C Quick return if possible. -C - IF( N.EQ.0 ) THEN - DWORK(1) = ONE - RETURN - END IF -C - IF ( COMPU ) THEN - CALL DLASET( 'All', N, ILO-1, ZERO, ONE, Q1, LDQ1 ) - CALL DLASET( 'All', ILO-1, N-ILO+1, ZERO, ZERO, Q1(1,ILO), - $ LDQ1 ) - CALL DLASET( 'All', N, ILO-1, ZERO, ZERO, Q2, LDQ2 ) - CALL DLASET( 'All', ILO-1, N-ILO+1, ZERO, ZERO, Q2(1,ILO), - $ LDQ2 ) - NH = N - ILO + 1 - END IF - IF ( COMPU .AND. .NOT.LTRAN ) THEN -C -C Generate U1 and U2. -C - IF ( NH.GT.0 ) THEN - CALL MB04WD( 'No Transpose', 'No Transpose', NH, NH, NH, - $ Q1(ILO,ILO), LDQ1, Q2(ILO,ILO), LDQ2, CS(ILO), - $ TAU(ILO), DWORK, LDWORK, IERR ) - END IF - ELSE IF ( COMPU.AND.LTRAN ) THEN -C -C Generate U1**T and U2. -C - IF ( NH.GT.0 ) THEN - CALL MB04WD( 'Transpose', 'No Transpose', NH, NH, NH, - $ Q1(ILO,ILO), LDQ1, Q2(ILO,ILO), LDQ2, CS(ILO), - $ TAU(ILO), DWORK, LDWORK, IERR ) - END IF - ELSE IF ( .NOT.COMPU .AND. .NOT.LTRAN ) THEN -C -C Generate V1**T and V2**T. -C -C Shift the vectors which define the elementary reflectors one -C column to the bottom, and set the first ilo rows and -C columns to those of the unit matrix. -C - DO 40 I = 1, N - DO 10 J = N, MAX( I, ILO )+1, -1 - Q1(J,I) = ZERO - 10 CONTINUE - DO 20 J = MAX( I, ILO ), ILO+1, -1 - Q1(J,I) = Q1(J-1,I) - 20 CONTINUE - DO 30 J = ILO, 1, -1 - Q1(J,I) = ZERO - 30 CONTINUE - IF ( I.LE.ILO ) Q1(I,I) = ONE - 40 CONTINUE - DO 80 I = 1, N - DO 50 J = N, MAX( I, ILO )+1, -1 - Q2(J,I) = ZERO - 50 CONTINUE - DO 60 J = MAX( I, ILO ), ILO+1, -1 - Q2(J,I) = Q2(J-1,I) - 60 CONTINUE - DO 70 J = ILO, 1, -1 - Q2(J,I) = ZERO - 70 CONTINUE - 80 CONTINUE -C - NH = N - ILO - IF ( NH.GT.0 ) THEN - CALL MB04WD( 'Transpose', 'Transpose', NH, NH, NH, - $ Q1(ILO+1,ILO+1), LDQ1, Q2(ILO+1,ILO+1), LDQ2, - $ CS(ILO), TAU(ILO), DWORK, LDWORK, IERR ) - END IF - ELSE IF ( .NOT.COMPU .AND. LTRAN ) THEN -C -C Generate V1 and V2**T. -C -C Shift the vectors which define the elementary reflectors one -C column to the right/bottom, and set the first ilo rows and -C columns to those of the unit matrix. -C - DO 110 J = N, ILO + 1, -1 - DO 90 I = 1, J-1 - Q1(I,J) = ZERO - 90 CONTINUE - DO 100 I = J+1, N - Q1(I,J) = Q1(I,J-1) - 100 CONTINUE - 110 CONTINUE - CALL DLASET( 'All', N, ILO, ZERO, ONE, Q1, LDQ1 ) - DO 150 I = 1, N - DO 120 J = N, MAX( I, ILO )+1, -1 - Q2(J,I) = ZERO - 120 CONTINUE - DO 130 J = MAX( I, ILO ), ILO+1, -1 - Q2(J,I) = Q2(J-1,I) - 130 CONTINUE - DO 140 J = ILO, 1, -1 - Q2(J,I) = ZERO - 140 CONTINUE - 150 CONTINUE - NH = N - ILO -C - IF ( NH.GT.0 ) THEN - CALL MB04WD( 'No Transpose', 'Transpose', NH, NH, NH, - $ Q1(ILO+1,ILO+1), LDQ1, Q2(ILO+1,ILO+1), LDQ2, - $ CS(ILO), TAU(ILO), DWORK, LDWORK, IERR ) - END IF - END IF - RETURN -C *** Last line of MB04WR *** - END diff --git a/mex/sources/libslicot/MB04WU.f b/mex/sources/libslicot/MB04WU.f deleted file mode 100644 index 1e177810b..000000000 --- a/mex/sources/libslicot/MB04WU.f +++ /dev/null @@ -1,402 +0,0 @@ - SUBROUTINE MB04WU( TRANQ1, TRANQ2, M, N, K, Q1, LDQ1, Q2, LDQ2, - $ CS, TAU, DWORK, LDWORK, INFO ) -C -C SLICOT RELEASE 5.0. -C -C Copyright (c) 2002-2009 NICONET e.V. -C -C This program is free software: you can redistribute it and/or -C modify it under the terms of the GNU General Public License as -C published by the Free Software Foundation, either version 2 of -C the License, or (at your option) any later version. -C -C This program is distributed in the hope that it will be useful, -C but WITHOUT ANY WARRANTY; without even the implied warranty of -C MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the -C GNU General Public License for more details. -C -C You should have received a copy of the GNU General Public License -C along with this program. If not, see -C . -C -C PURPOSE -C -C To generate a matrix Q with orthogonal columns (spanning an -C isotropic subspace), which is defined as the first n columns -C of a product of symplectic reflectors and Givens rotators, -C -C Q = diag( H(1),H(1) ) G(1) diag( F(1),F(1) ) -C diag( H(2),H(2) ) G(2) diag( F(2),F(2) ) -C .... -C diag( H(k),H(k) ) G(k) diag( F(k),F(k) ). -C -C The matrix Q is returned in terms of its first 2*M rows -C -C [ op( Q1 ) op( Q2 ) ] -C Q = [ ]. -C [ -op( Q2 ) op( Q1 ) ] -C -C ARGUMENTS -C -C Mode Parameters -C -C TRANQ1 CHARACTER*1 -C Specifies the form of op( Q1 ) as follows: -C = 'N': op( Q1 ) = Q1; -C = 'T': op( Q1 ) = Q1'; -C = 'C': op( Q1 ) = Q1'. -C -C TRANQ2 CHARACTER*1 -C Specifies the form of op( Q2 ) as follows: -C = 'N': op( Q2 ) = Q2; -C = 'T': op( Q2 ) = Q2'; -C = 'C': op( Q2 ) = Q2'. -C -C Input/Output Parameters -C -C M (input) INTEGER -C The number of rows of the matrices Q1 and Q2. M >= 0. -C -C N (input) INTEGER -C The number of columns of the matrices Q1 and Q2. -C M >= N >= 0. -C -C K (input) INTEGER -C The number of symplectic Givens rotators whose product -C partly defines the matrix Q. N >= K >= 0. -C -C Q1 (input/output) DOUBLE PRECISION array, dimension -C (LDQ1,N) if TRANQ1 = 'N', -C (LDQ1,M) if TRANQ1 = 'T' or TRANQ1 = 'C' -C On entry with TRANQ1 = 'N', the leading M-by-K part of -C this array must contain in its i-th column the vector -C which defines the elementary reflector F(i). -C On entry with TRANQ1 = 'T' or TRANQ1 = 'C', the leading -C K-by-M part of this array must contain in its i-th row -C the vector which defines the elementary reflector F(i). -C On exit with TRANQ1 = 'N', the leading M-by-N part of this -C array contains the matrix Q1. -C On exit with TRANQ1 = 'T' or TRANQ1 = 'C', the leading -C N-by-M part of this array contains the matrix Q1'. -C -C LDQ1 INTEGER -C The leading dimension of the array Q1. -C LDQ1 >= MAX(1,M), if TRANQ1 = 'N'; -C LDQ1 >= MAX(1,N), if TRANQ1 = 'T' or TRANQ1 = 'C'. -C -C Q2 (input/output) DOUBLE PRECISION array, dimension -C (LDQ2,N) if TRANQ2 = 'N', -C (LDQ2,M) if TRANQ2 = 'T' or TRANQ2 = 'C' -C On entry with TRANQ2 = 'N', the leading M-by-K part of -C this array must contain in its i-th column the vector -C which defines the elementary reflector H(i) and, on the -C diagonal, the scalar factor of H(i). -C On entry with TRANQ2 = 'T' or TRANQ2 = 'C', the leading -C K-by-M part of this array must contain in its i-th row the -C vector which defines the elementary reflector H(i) and, on -C the diagonal, the scalar factor of H(i). -C On exit with TRANQ2 = 'N', the leading M-by-N part of this -C array contains the matrix Q2. -C On exit with TRANQ2 = 'T' or TRANQ2 = 'C', the leading -C N-by-M part of this array contains the matrix Q2'. -C -C LDQ2 INTEGER -C The leading dimension of the array Q2. -C LDQ2 >= MAX(1,M), if TRANQ2 = 'N'; -C LDQ2 >= MAX(1,N), if TRANQ2 = 'T' or TRANQ2 = 'C'. -C -C CS (input) DOUBLE PRECISION array, dimension (2*K) -C On entry, the first 2*K elements of this array must -C contain the cosines and sines of the symplectic Givens -C rotators G(i). -C -C TAU (input) DOUBLE PRECISION array, dimension (K) -C On entry, the first K elements of this array must -C contain the scalar factors of the elementary reflectors -C F(i). -C -C Workspace -C -C DWORK DOUBLE PRECISION array, dimension (LDWORK) -C On exit, if INFO = 0, DWORK(1) returns the optimal -C value of LDWORK. -C On exit, if INFO = -13, DWORK(1) returns the minimum -C value of LDWORK. -C -C LDWORK INTEGER -C The length of the array DWORK. LDWORK >= MAX(1,M+N). -C -C Error Indicator -C -C INFO INTEGER -C = 0: successful exit; -C < 0: if INFO = -i, the i-th argument had an illegal -C value. -C -C REFERENCES -C -C [1] Bunse-Gerstner, A. -C Matrix factorizations for symplectic QR-like methods. -C Linear Algebra Appl., 83, pp. 49-77, 1986. -C -C CONTRIBUTORS -C -C D. Kressner, Technical Univ. Berlin, Germany, and -C P. Benner, Technical Univ. Chemnitz, Germany, December 2003. -C -C REVISIONS -C -C V. Sima, June 2008 (SLICOT version of the HAPACK routine DOSGSQ). -C -C KEYWORDS -C -C Elementary matrix operations, orthogonal symplectic matrix. -C -C ****************************************************************** -C -C .. Parameters .. - DOUBLE PRECISION ZERO, ONE - PARAMETER ( ZERO = 0.0D+0, ONE = 1.0D+0 ) -C .. Scalar Arguments .. - CHARACTER TRANQ1, TRANQ2 - INTEGER INFO, K, LDQ1, LDQ2, LDWORK, M, N -C .. Array Arguments .. - DOUBLE PRECISION CS(*), DWORK(*), Q1(LDQ1,*), Q2(LDQ2,*), TAU(*) -C .. Local Scalars .. - LOGICAL LTRQ1, LTRQ2 - INTEGER I, J - DOUBLE PRECISION NU -C .. External Functions .. - LOGICAL LSAME - EXTERNAL LSAME -C .. External Subroutines .. - EXTERNAL DCOPY, DLARF, DLASET, DROT, DSCAL, XERBLA -C .. Intrinsic Functions .. - INTRINSIC DBLE, MAX -C -C .. Executable Statements .. -C -C Decode the scalar input parameters. -C - INFO = 0 - LTRQ1 = LSAME( TRANQ1,'T' ) .OR. LSAME( TRANQ1,'C' ) - LTRQ2 = LSAME( TRANQ2,'T' ) .OR. LSAME( TRANQ2,'C' ) -C -C Check the scalar input parameters. -C - IF ( .NOT.( LTRQ1 .OR. LSAME( TRANQ1, 'N' ) ) ) THEN - INFO = -1 - ELSE IF ( .NOT.( LTRQ2 .OR. LSAME( TRANQ2, 'N' ) ) ) THEN - INFO = -2 - ELSE IF ( M.LT.0 ) THEN - INFO = -3 - ELSE IF ( N.LT.0 .OR. N.GT.M ) THEN - INFO = -4 - ELSE IF ( K.LT.0 .OR. K.GT.N ) THEN - INFO = -5 - ELSE IF ( ( LTRQ1 .AND. LDQ1.LT.MAX( 1, N ) ) .OR. - $ ( .NOT.LTRQ1 .AND. LDQ1.LT.MAX( 1, M ) ) ) THEN - INFO = -7 - ELSE IF ( ( LTRQ2 .AND. LDQ2.LT.MAX( 1, N ) ) .OR. - $ ( .NOT.LTRQ2 .AND. LDQ2.LT.MAX( 1, M ) ) ) THEN - INFO = -9 - ELSE IF ( LDWORK.LT.MAX( 1,M + N ) ) THEN - DWORK(1) = DBLE( MAX( 1,M + N ) ) - INFO = -13 - END IF -C -C Return if there were illegal values. -C - IF ( INFO.NE.0 ) THEN - CALL XERBLA( 'MB04WU', -INFO ) - RETURN - END IF -C -C Quick return if possible. -C - IF( N.EQ.0 ) THEN - DWORK(1) = ONE - RETURN - END IF -C -C Initialize columns K+1:N to columns of the unit matrix. -C - DO 20 J = K + 1, N - DO 10 I = 1, M - Q1(I,J) = ZERO - 10 CONTINUE - Q1(J,J) = ONE - 20 CONTINUE - CALL DLASET( 'All', M, N-K, ZERO, ZERO, Q2(1,K+1), LDQ2 ) -C - IF ( LTRQ1.AND.LTRQ2 ) THEN - DO 50 I = K, 1, -1 -C -C Apply F(I) to Q1(I+1:N,I:M) and Q2(I+1:N,I:M) from the -C right. -C - CALL DCOPY( M-I+1, Q2(I,I), LDQ2, DWORK, 1 ) - IF ( I.LT.N ) THEN - Q1(I,I) = ONE - CALL DLARF( 'Right', N-I, M-I+1, Q1(I,I), LDQ1, TAU(I), - $ Q1(I+1,I), LDQ1, DWORK(M+1) ) - CALL DLARF( 'Right', N-I, M-I+1, Q1(I,I), LDQ1, TAU(I), - $ Q2(I+1,I), LDQ2, DWORK(M+1) ) - END IF - IF ( I.LT.M ) - $ CALL DSCAL( M-I, -TAU(I), Q1(I,I+1), LDQ1 ) - Q1(I,I) = ONE - TAU(I) -C -C Set Q1(I,1:I-1) and Q2(I,1:M) to zero. -C - DO 30 J = 1, I - 1 - Q1(I,J) = ZERO - 30 CONTINUE - DO 40 J = 1, M - Q2(I,J) = ZERO - 40 CONTINUE -C -C Apply G(I) to Q1(I:N,I) and Q2(I:N,I) from the right. -C - CALL DROT( N-I+1, Q1(I,I), 1, Q2(I,I), 1, CS(2*I-1), - $ CS(2*I) ) -C -C Apply H(I) to Q1(I:N,I:M) and Q2(I:N,I:M) from the right. -C - NU = DWORK(1) - DWORK(1) = ONE - CALL DLARF( 'Right', N-I+1, M-I+1, DWORK, 1, NU, Q1(I,I), - $ LDQ1, DWORK(M+1) ) - CALL DLARF( 'Right', N-I+1, M-I+1, DWORK, 1, NU, Q2(I,I), - $ LDQ2, DWORK(M+1) ) - 50 CONTINUE - ELSE IF ( LTRQ1 ) THEN - DO 80 I = K, 1, -1 -C -C Apply F(I) to Q1(I+1:N,I:M) from the right and to -C Q2(I:M,I+1:N) from the left. -C - CALL DCOPY( M-I+1, Q2(I,I), 1, DWORK, 1 ) - IF ( I.LT.N ) THEN - Q1(I,I) = ONE - CALL DLARF( 'Right', N-I, M-I+1, Q1(I,I), LDQ1, TAU(I), - $ Q1(I+1,I), LDQ1, DWORK(M+1) ) - CALL DLARF( 'Left', M-I+1, N-I, Q1(I,I), LDQ1, TAU(I), - $ Q2(I,I+1), LDQ2, DWORK(M+1) ) - END IF - IF ( I.LT.M ) - $ CALL DSCAL( M-I, -TAU(I), Q1(I,I+1), LDQ1 ) - Q1(I,I) = ONE - TAU(I) -C -C Set Q1(I,1:I-1) and Q2(1:M,I) to zero. -C - DO 60 J = 1, I - 1 - Q1(I,J) = ZERO - 60 CONTINUE - DO 70 J = 1, M - Q2(J,I) = ZERO - 70 CONTINUE -C -C Apply G(I) to Q1(I:N,I) from the right and to Q2(I,I:N) -C from the left. -C - CALL DROT( N-I+1, Q1(I,I), 1, Q2(I,I), LDQ2, CS(2*I-1), - $ CS(2*I) ) -C -C Apply H(I) to Q1(I:N,I:M) from the right and to Q2(I:M,I:N) -C from the left. -C - NU = DWORK(1) - DWORK(1) = ONE - CALL DLARF( 'Right', N-I+1, M-I+1, DWORK, 1, NU, Q1(I,I), - $ LDQ1, DWORK(M+1) ) - CALL DLARF( 'Left', M-I+1, N-I+1, DWORK, 1, NU, Q2(I,I), - $ LDQ2, DWORK(M+1) ) - 80 CONTINUE - ELSE IF ( LTRQ2 ) THEN - DO 110 I = K, 1, -1 -C -C Apply F(I) to Q1(I:M,I+1:N) from the left and to -C Q2(I+1:N,I:M) from the right. -C - CALL DCOPY( M-I+1, Q2(I,I), LDQ2, DWORK, 1 ) - IF ( I.LT.N ) THEN - Q1(I,I) = ONE - CALL DLARF( 'Left', M-I+1, N-I, Q1(I,I), 1, TAU(I), - $ Q1(I,I+1), LDQ1, DWORK(M+1) ) - CALL DLARF( 'Right', N-I, M-I+1, Q1(I,I), 1, TAU(I), - $ Q2(I+1,I), LDQ2, DWORK(M+1) ) - END IF - IF ( I.LT.M ) - $ CALL DSCAL( M-I, -TAU(I), Q1(I+1,I), 1 ) - Q1(I,I) = ONE - TAU(I) -C -C Set Q1(1:I-1,I) and Q2(I,1:M) to zero. -C - DO 90 J = 1, I - 1 - Q1(J,I) = ZERO - 90 CONTINUE - DO 100 J = 1, M - Q2(I,J) = ZERO - 100 CONTINUE -C -C Apply G(I) to Q1(I,I:N) from the left and to Q2(I:N,I) -C from the right. -C - CALL DROT( N-I+1, Q1(I,I), LDQ1, Q2(I,I), 1, CS(2*I-1), - $ CS(2*I) ) -C -C Apply H(I) to Q1(I:M,I:N) from the left and to Q2(I:N,I:M) -C from the left. -C - NU = DWORK(1) - DWORK(1) = ONE - CALL DLARF( 'Left', M-I+1, N-I+1, DWORK, 1, NU, Q1(I,I), - $ LDQ1, DWORK(M+1) ) - CALL DLARF( 'Right', N-I+1, M-I+1, DWORK, 1, NU, Q2(I,I), - $ LDQ2, DWORK(M+1) ) - 110 CONTINUE - ELSE - DO 140 I = K, 1, -1 -C -C Apply F(I) to Q1(I:M,I+1:N) and Q2(I:M,I+1:N) from the left. -C - CALL DCOPY( M-I+1, Q2(I,I), 1, DWORK, 1 ) - IF ( I.LT.N ) THEN - Q1(I,I) = ONE - CALL DLARF( 'Left', M-I+1, N-I, Q1(I,I), 1, TAU(I), - $ Q1(I,I+1), LDQ1, DWORK(M+1) ) - CALL DLARF( 'Left', M-I+1, N-I, Q1(I,I), 1, TAU(I), - $ Q2(I,I+1), LDQ2, DWORK(M+1) ) - END IF - IF ( I.LT.M ) - $ CALL DSCAL( M-I, -TAU(I), Q1(I+1,I), 1 ) - Q1(I,I) = ONE - TAU(I) -C -C Set Q1(1:I-1,I) and Q2(1:M,I) to zero. -C - DO 120 J = 1, I - 1 - Q1(J,I) = ZERO - 120 CONTINUE - DO 130 J = 1, M - Q2(J,I) = ZERO - 130 CONTINUE -C -C Apply G(I) to Q1(I,I:N) and Q2(I,I:N) from the left. -C - CALL DROT( N-I+1, Q1(I,I), LDQ1, Q2(I,I), LDQ2, CS(2*I-1), - $ CS(2*I) ) -C -C Apply H(I) to Q1(I:M,I:N) and Q2(I:M,I:N) from the left. -C - NU = DWORK(1) - DWORK(1) = ONE - CALL DLARF( 'Left', M-I+1, N-I+1, DWORK, 1, NU, Q1(I,I), - $ LDQ1, DWORK(M+1) ) - CALL DLARF( 'Left', M-I+1, N-I+1, DWORK, 1, NU, Q2(I,I), - $ LDQ2, DWORK(M+1) ) - 140 CONTINUE - END IF - DWORK(1) = DBLE( MAX( 1, M+N ) ) -C *** Last line of MB04WU *** - END diff --git a/mex/sources/libslicot/MB04XD.f b/mex/sources/libslicot/MB04XD.f deleted file mode 100644 index 6d417486a..000000000 --- a/mex/sources/libslicot/MB04XD.f +++ /dev/null @@ -1,652 +0,0 @@ - SUBROUTINE MB04XD( JOBU, JOBV, M, N, RANK, THETA, A, LDA, U, LDU, - $ V, LDV, Q, INUL, TOL, RELTOL, DWORK, LDWORK, - $ IWARN, INFO ) -C -C SLICOT RELEASE 5.0. -C -C Copyright (c) 2002-2009 NICONET e.V. -C -C This program is free software: you can redistribute it and/or -C modify it under the terms of the GNU General Public License as -C published by the Free Software Foundation, either version 2 of -C the License, or (at your option) any later version. -C -C This program is distributed in the hope that it will be useful, -C but WITHOUT ANY WARRANTY; without even the implied warranty of -C MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the -C GNU General Public License for more details. -C -C You should have received a copy of the GNU General Public License -C along with this program. If not, see -C . -C -C PURPOSE -C -C To compute a basis for the left and/or right singular subspace of -C an M-by-N matrix A corresponding to its smallest singular values. -C -C ARGUMENTS -C -C Mode Parameters -C -C JOBU CHARACTER*1 -C Specifies whether to compute the left singular subspace -C as follows: -C = 'N': Do not compute the left singular subspace; -C = 'A': Return the (M - RANK) base vectors of the desired -C left singular subspace in U; -C = 'S': Return the first (min(M,N) - RANK) base vectors -C of the desired left singular subspace in U. -C -C JOBV CHARACTER*1 -C Specifies whether to compute the right singular subspace -C as follows: -C = 'N': Do not compute the right singular subspace; -C = 'A': Return the (N - RANK) base vectors of the desired -C right singular subspace in V; -C = 'S': Return the first (min(M,N) - RANK) base vectors -C of the desired right singular subspace in V. -C -C Input/Output Parameters -C -C M (input) INTEGER -C The number of rows in matrix A. M >= 0. -C -C N (input) INTEGER -C The number of columns in matrix A. N >= 0. -C -C RANK (input/output) INTEGER -C On entry, if RANK < 0, then the rank of matrix A is -C computed by the routine as the number of singular values -C greater than THETA. -C Otherwise, RANK must specify the rank of matrix A. -C RANK <= min(M,N). -C On exit, if RANK < 0 on entry, then RANK contains the -C computed rank of matrix A. That is, the number of singular -C values of A greater than THETA. -C Otherwise, the user-supplied value of RANK may be changed -C by the routine on exit if the RANK-th and the (RANK+1)-th -C singular values of A are considered to be equal. -C See also the description of parameter TOL below. -C -C THETA (input/output) DOUBLE PRECISION -C On entry, if RANK < 0, then THETA must specify an upper -C bound on the smallest singular values of A corresponding -C to the singular subspace to be computed. THETA >= 0.0. -C Otherwise, THETA must specify an initial estimate (t say) -C for computing an upper bound on the (min(M,N) - RANK) -C smallest singular values of A. If THETA < 0.0, then t is -C computed by the routine. -C On exit, if RANK >= 0 on entry, then THETA contains the -C computed upper bound such that precisely RANK singular -C values of A are greater than THETA + TOL. -C Otherwise, THETA is unchanged. -C -C A (input) DOUBLE PRECISION array, dimension (LDA,N) -C The leading M-by-N part of this array must contain the -C matrix A from which the basis of a desired singular -C subspace is to be computed. -C NOTE that this array is destroyed. -C -C LDA INTEGER -C The leading dimension of array A. LDA >= max(1,M). -C -C U (output) DOUBLE PRECISION array, dimension (LDU,*) -C If JOBU = 'A', then the leading M-by-M part of this array -C contains the (M - RANK) M-dimensional base vectors of the -C desired left singular subspace of A corresponding to its -C singular values less than or equal to THETA. These vectors -C are stored in the i-th column(s) of U for which -C INUL(i) = .TRUE., where i = 1,2,...,M. -C -C If JOBU = 'S', then the leading M-by-min(M,N) part of this -C array contains the first (min(M,N) - RANK) M-dimensional -C base vectors of the desired left singular subspace of A -C corresponding to its singular values less than or equal to -C THETA. These vectors are stored in the i-th column(s) of U -C for which INUL(i) = .TRUE., where i = 1,2,..., min(M,N). -C -C Otherwise, U is not referenced (since JOBU = 'N') and can -C be supplied as a dummy array (i.e. set parameter LDU = 1 -C and declare this array to be U(1,1) in the calling -C program). -C -C LDU INTEGER -C The leading dimension of array U. -C LDU >= max(1,M) if JOBU = 'A' or JOBU = 'S', -C LDU >= 1 if JOBU = 'N'. -C -C V (output) DOUBLE PRECISION array, dimension (LDV,*) -C If JOBV = 'A', then the leading N-by-N part of this array -C contains the (N - RANK) N-dimensional base vectors of the -C desired right singular subspace of A corresponding to its -C singular values less than or equal to THETA. These vectors -C are stored in the i-th column(s) of V for which -C INUL(i) = .TRUE., where i = 1,2,...,N. -C -C If JOBV = 'S', then the leading N-by-min(M,N) part of this -C array contains the first (min(M,N) - RANK) N-dimensional -C base vectors of the desired right singular subspace of A -C corresponding to its singular values less than or equal to -C THETA. These vectors are stored in the i-th column(s) of V -C for which INUL(i) = .TRUE., where i = 1,2,...,MIN( M,N). -C -C Otherwise, V is not referenced (since JOBV = 'N') and can -C be supplied as a dummy array (i.e. set parameter LDV = 1 -C and declare this array to be V(1,1) in the calling -C program). -C -C LDV INTEGER -C The leading dimension of array V. -C LDV >= max(1,N) if JOBV = 'A' or JOBV = 'S', -C LDV >= 1 if JOBV = 'N'. -C -C Q (output) DOUBLE PRECISION array, dimension (2*min(M,N)-1) -C This array contains the partially diagonalized bidiagonal -C matrix J computed from A, at the moment that the desired -C singular subspace has been found. Specifically, the -C leading p = min(M,N) entries of Q contain the diagonal -C elements q(1),q(2),...,q(p) and the entries Q(p+1), -C Q(p+2),...,Q(2*p-1) contain the superdiagonal elements -C e(1),e(2),...,e(p-1) of J. -C -C INUL (output) LOGICAL array, dimension (max(M,N)) -C If JOBU <> 'N' or JOBV <> 'N', then the indices of the -C elements of this array with value .TRUE. indicate the -C columns in U and/or V containing the base vectors of the -C desired left and/or right singular subspace of A. They -C also equal the indices of the diagonal elements of the -C bidiagonal submatrices in the array Q, which correspond -C to the computed singular subspaces. -C -C Tolerances -C -C TOL DOUBLE PRECISION -C This parameter defines the multiplicity of singular values -C by considering all singular values within an interval of -C length TOL as coinciding. TOL is used in checking how many -C singular values are less than or equal to THETA. Also in -C computing an appropriate upper bound THETA by a bisection -C method, TOL is used as a stopping criterion defining the -C minimum (absolute) subinterval width. TOL is also taken -C as an absolute tolerance for negligible elements in the -C QR/QL iterations. If the user sets TOL to be less than or -C equal to 0, then the tolerance is taken as specified in -C SLICOT Library routine MB04YD document. -C -C RELTOL DOUBLE PRECISION -C This parameter specifies the minimum relative width of an -C interval. When an interval is narrower than TOL, or than -C RELTOL times the larger (in magnitude) endpoint, then it -C is considered to be sufficiently small and bisection has -C converged. If the user sets RELTOL to be less than -C BASE * EPS, where BASE is machine radix and EPS is machine -C precision (see LAPACK Library routine DLAMCH), then the -C tolerance is taken as BASE * EPS. -C -C Workspace -C -C DWORK DOUBLE PRECISION array, dimension (LDWORK) -C On exit, if INFO = 0, DWORK(1) returns the optimal value -C of LDWORK. -C -C LDWORK INTEGER -C The length of the array DWORK. -C LDWORK = max(1, LDW + max(2*P + max(M,N), LDY)), where -C P = min(M,N); -C LDW = max(2*N, N*(N+1)/2), if JOBU <> 'N' and M large -C enough than N; -C LDW = 0, otherwise; -C LDY = 8*P - 5, if JOBU <> 'N' or JOBV <> 'N'; -C LDY = 6*P - 3, if JOBU = 'N' and JOBV = 'N'. -C For optimum performance LDWORK should be larger. -C -C Warning Indicator -C -C IWARN INTEGER -C = 0: no warning; -C = 1: if the rank of matrix A (as specified by the user) -C has been lowered because a singular value of -C multiplicity greater than 1 was found. -C -C Error Indicator -C -C INFO INTEGER -C = 0: successful exit; -C < 0: if INFO = -i, the i-th argument had an illegal -C value; -C = 1: if the maximum number of QR/QL iteration steps -C (30*MIN(M,N)) has been exceeded. -C -C METHOD -C -C The method used is the Partial Singular Value Decomposition (PSVD) -C approach proposed by Van Huffel, Vandewalle and Haegemans, which -C is an efficient technique (see [1]) for computing the singular -C subspace of a matrix corresponding to its smallest singular -C values. It differs from the classical SVD algorithm [3] at three -C points, which results in high efficiency. Firstly, the Householder -C transformations of the bidiagonalization need only to be applied -C on the base vectors of the desired singular subspaces; secondly, -C the bidiagonal matrix need only be partially diagonalized; and -C thirdly, the convergence rate of the iterative diagonalization can -C be improved by an appropriate choice between QL and QR iterations. -C (Note, however, that LAPACK Library routine DGESVD, for computing -C SVD, also uses either QL and QR iterations.) Depending on the gap, -C the desired numerical accuracy and the dimension of the desired -C singular subspace, the PSVD can be up to three times faster than -C the classical SVD algorithm. -C -C The PSVD algorithm [1-2] for an M-by-N matrix A proceeds as -C follows: -C -C Step 1: Bidiagonalization phase -C ----------------------- -C (a) If M is large enough than N, transform A into upper -C triangular form R. -C -C (b) Transform A (or R) into bidiagonal form: -C -C |q(1) e(1) 0 ... 0 | -C (0) | 0 q(2) e(2) . | -C J = | . . | -C | . e(N-1)| -C | 0 ... q(N) | -C -C if M >= N, or -C -C |q(1) 0 0 ... 0 0 | -C (0) |e(1) q(2) 0 . . | -C J = | . . . | -C | . q(M-1) . | -C | 0 ... e(M-1) q(M)| -C -C if M < N, using Householder transformations. -C In the second case, transform the matrix to the upper bidiagonal -C form by applying Givens rotations. -C -C (c) If U is requested, initialize U with the identity matrix. -C If V is requested, initialize V with the identity matrix. -C -C Step 2: Partial diagonalization phase -C ----------------------------- -C If the upper bound THETA is not given, then compute THETA such -C that precisely (min(M,N) - RANK) singular values of the bidiagonal -C matrix are less than or equal to THETA, using a bisection method -C [4]. Diagonalize the given bidiagonal matrix J partially, using -C either QR iterations (if the upper left diagonal element of the -C considered bidiagonal submatrix is larger than the lower right -C diagonal element) or QL iterations, such that J is split into -C unreduced bidiagonal submatrices whose singular values are either -C all larger than THETA or all less than or equal to THETA. -C Accumulate the Givens rotations in U and/or V (if desired). -C -C Step 3: Back transformation phase -C ------------------------- -C (a) Apply the Householder transformations of Step 1(b) onto the -C columns of U and/or V associated with the bidiagonal -C submatrices with all singular values less than or equal to -C THETA (if U and/or V is desired). -C -C (b) If M is large enough than N, and U is desired, then apply the -C Householder transformations of Step 1(a) onto each computed -C column of U in Step 3(a). -C -C REFERENCES -C -C [1] Van Huffel, S., Vandewalle, J. and Haegemans, A. -C An efficient and reliable algorithm for computing the singular -C subspace of a matrix associated with its smallest singular -C values. -C J. Comput. and Appl. Math., 19, pp. 313-330, 1987. -C -C [2] Van Huffel, S. -C Analysis of the total least squares problem and its use in -C parameter estimation. -C Doctoral dissertation, Dept. of Electr. Eng., Katholieke -C Universiteit Leuven, Belgium, June 1987. -C -C [3] Chan, T.F. -C An improved algorithm for computing the singular value -C decomposition. -C ACM TOMS, 8, pp. 72-83, 1982. -C -C [4] Van Huffel, S. and Vandewalle, J. -C The partial total least squares algorithm. -C J. Comput. and Appl. Math., 21, pp. 333-341, 1988. -C -C NUMERICAL ASPECTS -C -C Using the PSVD a large reduction in computation time can be -C gained in total least squares applications (cf [2 - 4]), in the -C computation of the null space of a matrix and in solving -C (non)homogeneous linear equations. -C -C CONTRIBUTOR -C -C Release 3.0: V. Sima, Katholieke Univ. Leuven, Belgium, June 1997. -C Supersedes Release 2.0 routine MB04PD by S. Van Huffel, Katholieke -C University Leuven, Belgium. -C -C REVISIONS -C -C July 10, 1997. -C -C KEYWORDS -C -C Bidiagonalization, singular subspace, singular value -C decomposition, singular values. -C -C ****************************************************************** -C -C .. Parameters .. - DOUBLE PRECISION ZERO, ONE - PARAMETER ( ZERO = 0.0D0, ONE = 1.0D0 ) -C .. Scalar Arguments .. - CHARACTER JOBU, JOBV - INTEGER INFO, IWARN, LDA, LDU, LDV, LDWORK, M, N, RANK - DOUBLE PRECISION RELTOL, THETA, TOL -C .. Array Arguments .. - LOGICAL INUL(*) - DOUBLE PRECISION A(LDA,*), DWORK(*), Q(*), U(LDU,*), V(LDV,*) -C .. Local Scalars .. - CHARACTER*1 JOBUY, JOBVY - LOGICAL ALL, LJOBUA, LJOBUS, LJOBVA, LJOBVS, QR, WANTU, - $ WANTV - INTEGER I, IHOUSH, IJ, ITAU, ITAUP, ITAUQ, J, JU, JV, - $ JWORK, K, LDW, LDY, MA, P, PP1, WRKOPT - DOUBLE PRECISION CS, SN, TEMP -C .. External Functions .. - LOGICAL LSAME - INTEGER ILAENV - EXTERNAL ILAENV, LSAME -C .. External Subroutines .. - EXTERNAL DCOPY, DGEBRD, DGEQRF, DLARTG, DLASET, DLASR, - $ MB04XY, MB04YD, XERBLA -C .. Intrinsic Functions .. - INTRINSIC INT, MAX, MIN -C .. Executable Statements .. -C - IWARN = 0 - INFO = 0 - P = MIN( M, N ) - K = MAX( M, N ) -C -C Determine whether U and/or V are/is to be computed. -C - LJOBUA = LSAME( JOBU, 'A' ) - LJOBUS = LSAME( JOBU, 'S' ) - LJOBVA = LSAME( JOBV, 'A' ) - LJOBVS = LSAME( JOBV, 'S' ) - WANTU = LJOBUA.OR.LJOBUS - WANTV = LJOBVA.OR.LJOBVS - ALL = ( LJOBUA .AND. M.GT.N ) .OR. ( LJOBVA .AND. M.LT.N ) - QR = M.GE.ILAENV( 6, 'DGESVD', 'N' // 'N', M, N, 0, 0 ) - IF ( QR.AND.WANTU ) THEN - LDW = MAX( 2*N, N*( N + 1 )/2 ) - ELSE - LDW = 0 - END IF - IF ( WANTU.OR.WANTV ) THEN - LDY = 8*P - 5 - ELSE - LDY = 6*P - 3 - END IF -C -C Test the input scalar arguments. -C - IF( .NOT.WANTU .AND. .NOT.LSAME( JOBU, 'N' ) ) THEN - INFO = -1 - ELSE IF( .NOT.WANTV .AND. .NOT.LSAME( JOBV, 'N' ) ) THEN - INFO = -2 - ELSE IF( M.LT.0 ) THEN - INFO = -3 - ELSE IF( N.LT.0 ) THEN - INFO = -4 - ELSE IF( RANK.GT.P ) THEN - INFO = -5 - ELSE IF( RANK.LT.0 .AND. THETA.LT.ZERO ) THEN - INFO = -6 - ELSE IF( LDA.LT.MAX( 1, M ) ) THEN - INFO = -8 - ELSE IF( ( .NOT.WANTU .AND. LDU.LT.1 ) .OR. - $ ( WANTU .AND. LDU.LT.MAX( 1, M ) ) ) THEN - INFO = -10 - ELSE IF( ( .NOT.WANTV .AND. LDV.LT.1 ) .OR. - $ ( WANTV .AND. LDV.LT.MAX( 1, N ) ) ) THEN - INFO = -12 - ELSE IF( LDWORK.LT.MAX( 1, LDW + MAX( 2*P + K, LDY ) ) ) THEN - INFO = -18 - END IF -C - IF ( INFO.NE.0 ) THEN -C -C Error return. -C - CALL XERBLA( 'MB04XD', -INFO ) - RETURN - END IF -C -C Quick return if possible. -C - IF ( P.EQ.0 ) THEN - IF ( RANK.GE.0 ) - $ THETA = ZERO - RANK = 0 - RETURN - END IF -C -C Initializations. -C - PP1 = P + 1 -C - IF ( ALL .AND. ( .NOT.QR ) ) THEN -C - DO 20 I = 1, P - INUL(I) = .FALSE. - 20 CONTINUE -C - DO 40 I = PP1, K - INUL(I) = .TRUE. - 40 CONTINUE -C - ELSE -C - DO 60 I = 1, K - INUL(I) = .FALSE. - 60 CONTINUE -C - END IF -C -C Step 1: Bidiagonalization phase -C ----------------------- -C (Note: Comments in the code beginning "Workspace:" describe the -C minimal amount of real workspace needed at that point in the -C code, as well as the preferred amount for good performance. -C NB refers to the optimal block size for the immediately -C following subroutine, as returned by ILAENV.) -C - IF ( QR ) THEN -C -C 1.a.: M is large enough than N; transform A into upper -C triangular form R by Householder transformations. -C -C Workspace: need 2*N; prefer N + N*NB. -C - ITAU = 1 - JWORK = ITAU + N - CALL DGEQRF( M, N, A, LDA, DWORK(ITAU), DWORK(JWORK), - $ LDWORK-JWORK+1, INFO ) - WRKOPT = INT( DWORK(JWORK) )+JWORK-1 -C -C If (WANTU), store information on the Householder -C transformations performed on the columns of A in N*(N+1)/2 -C extra storage locations DWORK(K), for K = 1,2,...,N*(N+1)/2. -C (The first N locations store the scalar factors of Householder -C transformations.) -C -C Workspace: LDW = max(2*N, N*(N+1)/2). -C - IF ( WANTU ) THEN - IHOUSH = JWORK - K = IHOUSH - I = N - ELSE - K = 1 - END IF -C - DO 100 J = 1, N - 1 - IF ( WANTU ) THEN - I = I - 1 - CALL DCOPY( I, A(J+1,J), 1, DWORK(K), 1 ) - K = K + I - END IF -C - DO 80 IJ = J + 1, N - A(IJ,J) = ZERO - 80 CONTINUE -C - 100 CONTINUE -C - MA = N - WRKOPT = MAX( WRKOPT, K ) - ELSE -C -C Workspace: LDW = 0. -C - K = 1 - MA = M - WRKOPT = 1 - END IF -C -C 1.b.: Transform A (or R) into bidiagonal form Q using Householder -C transformations. -C -C Workspace: need LDW + 2*min(M,N) + max(M,N); -C prefer LDW + 2*min(M,N) + (M+N)*NB. -C - ITAUQ = K - ITAUP = ITAUQ + P - JWORK = ITAUP + P - CALL DGEBRD( MA, N, A, LDA, Q, Q(PP1), DWORK(ITAUQ), - $ DWORK(ITAUP), DWORK(JWORK), LDWORK-JWORK+1, INFO ) - WRKOPT = MAX( WRKOPT, INT( DWORK(JWORK) )+JWORK-1 ) -C -C 1.c.: Initialize U (if WANTU) and V (if WANTV) with the identity -C matrix. -C - IF ( WANTU ) THEN - IF ( ALL ) THEN - JU = M - ELSE - JU = P - END IF - CALL DLASET( 'Full', M, JU, ZERO, ONE, U, LDU ) - JOBUY = 'U' - ELSE - JOBUY = 'N' - END IF - IF ( WANTV ) THEN - IF ( ALL ) THEN - JV = N - ELSE - JV = P - END IF - CALL DLASET( 'Full', N, JV, ZERO, ONE, V, LDV ) - JOBVY = 'U' - ELSE - JOBVY = 'N' - END IF -C -C If the matrix is lower bidiagonal, rotate to be upper bidiagonal -C by applying Givens rotations on the left. -C - IF ( M.LT.N ) THEN -C - DO 120 I = 1, P - 1 - CALL DLARTG( Q(I), Q(P+I), CS, SN, TEMP ) - Q(I) = TEMP - Q(P+I) = SN*Q(I+1) - Q(I+1) = CS*Q(I+1) - IF ( WANTU ) THEN -C -C Workspace: LDW + 4*min(M,N) - 2. -C - DWORK(JWORK+I-1) = CS - DWORK(JWORK+P+I-2) = SN - END IF - 120 CONTINUE -C -C Update left singular vectors if desired. -C - IF( WANTU ) - $ CALL DLASR( 'Right', 'Variable pivot', 'Forward', M, JU, - $ DWORK(JWORK), DWORK(JWORK+P-1), U, LDU ) -C - END IF -C -C Step 2: Partial diagonalization phase. -C ----------------------------- -C Diagonalize the bidiagonal Q partially until convergence -C to the desired left and/or right singular subspace. -C -C Workspace: LDW + 8*min(M,N) - 5, if WANTU or WANTV; -C Workspace: LDW + 6*min(M,N) - 3, if JOBU = JOBV = 'N'. -C - CALL MB04YD( JOBUY, JOBVY, M, N, RANK, THETA, Q, Q(PP1), U, LDU, - $ V, LDV, INUL, TOL, RELTOL, DWORK(JWORK), - $ LDWORK-JWORK+1, IWARN, INFO ) - IF ( WANTU.OR.WANTV ) THEN - WRKOPT = MAX( WRKOPT, JWORK - 6 + 8*P ) - ELSE - WRKOPT = MAX( WRKOPT, JWORK - 4 + 6*P ) - END IF - IF ( INFO.GT.0 ) - $ RETURN -C -C Step 3: Back transformation phase. -C ------------------------- -C 3.a.: Apply the Householder transformations of the bidiagonaliza- -C tion onto the base vectors associated with the desired -C bidiagonal submatrices. -C -C Workspace: LDW + 2*min(M,N). -C - CALL MB04XY( JOBU, JOBV, MA, N, A, LDA, DWORK(ITAUQ), - $ DWORK(ITAUP), U, LDU, V, LDV, INUL, INFO ) -C -C 3.b.: If A was reduced to upper triangular form R and JOBU = 'A' -C or JOBU = 'S' apply the Householder transformations of the -C triangularization of A onto the desired base vectors. -C - IF ( QR.AND.WANTU ) THEN - IF ( ALL ) THEN -C - DO 140 I = PP1, M - INUL(I) = .TRUE. - 140 CONTINUE -C - END IF - K = IHOUSH - I = N -C - DO 160 J = 1, N - 1 - I = I - 1 - CALL DCOPY( I, DWORK(K), 1, A(J+1,J), 1 ) - K = K + I - 160 CONTINUE -C -C Workspace: MIN(M,N) + 1. -C - JWORK = PP1 - CALL MB04XY( JOBU, 'No V', M, N, A, LDA, DWORK(ITAU), - $ DWORK(ITAU), U, LDU, DWORK(JWORK), 1, INUL, INFO ) - WRKOPT = MAX( WRKOPT, PP1 ) - END IF -C -C Set the optimal workspace. -C - DWORK(1) = WRKOPT - RETURN -C *** Last line of MB04XD *** - END diff --git a/mex/sources/libslicot/MB04XY.f b/mex/sources/libslicot/MB04XY.f deleted file mode 100644 index 02e8e7e22..000000000 --- a/mex/sources/libslicot/MB04XY.f +++ /dev/null @@ -1,274 +0,0 @@ - SUBROUTINE MB04XY( JOBU, JOBV, M, N, X, LDX, TAUP, TAUQ, U, - $ LDU, V, LDV, INUL, INFO ) -C -C SLICOT RELEASE 5.0. -C -C Copyright (c) 2002-2009 NICONET e.V. -C -C This program is free software: you can redistribute it and/or -C modify it under the terms of the GNU General Public License as -C published by the Free Software Foundation, either version 2 of -C the License, or (at your option) any later version. -C -C This program is distributed in the hope that it will be useful, -C but WITHOUT ANY WARRANTY; without even the implied warranty of -C MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the -C GNU General Public License for more details. -C -C You should have received a copy of the GNU General Public License -C along with this program. If not, see -C . -C -C PURPOSE -C -C To apply the Householder transformations Pj stored in factored -C form into the columns of the array X, to the desired columns of -C the matrix U by premultiplication, and/or the Householder -C transformations Qj stored in factored form into the rows of the -C array X, to the desired columns of the matrix V by -C premultiplication. The Householder transformations Pj and Qj -C are stored as produced by LAPACK Library routine DGEBRD. -C -C ARGUMENTS -C -C Mode Parameters -C -C JOBU CHARACTER*1 -C Specifies whether to transform the columns in U as -C follows: -C = 'N': Do not transform the columns in U; -C = 'A': Transform the columns in U (U has M columns); -C = 'S': Transform the columns in U (U has min(M,N) -C columns). -C -C JOBV CHARACTER*1 -C Specifies whether to transform the columns in V as -C follows: -C = 'N': Do not transform the columns in V; -C = 'A': Transform the columns in V (V has N columns); -C = 'S': Transform the columns in V (V has min(M,N) -C columns). -C -C Input/Output Parameters -C -C M (input) INTEGER -C The number of rows of the matrix X. M >= 0. -C -C N (input) INTEGER -C The number of columns of the matrix X. N >= 0. -C -C X (input) DOUBLE PRECISION array, dimension (LDX,N) -C The leading M-by-N part contains in the columns of its -C lower triangle the Householder transformations Pj, and -C in the rows of its upper triangle the Householder -C transformations Qj in factored form. -C X is modified by the routine but restored on exit. -C -C LDX INTEGER -C The leading dimension of the array X. LDX >= MAX(1,M). -C -C TAUP (input) DOUBLE PRECISION array, dimension (MIN(M,N)) -C The scalar factors of the Householder transformations Pj. -C -C TAUQ (input) DOUBLE PRECISION array, dimension (MIN(M,N)) -C The scalar factors of the Householder transformations Qj. -C -C U (input/output) DOUBLE PRECISION array, dimension (LDU,*) -C On entry, U contains the M-by-M (if JOBU = 'A') or -C M-by-min(M,N) (if JOBU = 'S') matrix U. -C On exit, the Householder transformations Pj have been -C applied to each column i of U corresponding to a parameter -C INUL(i) = .TRUE. -C NOTE that U is not referenced if JOBU = 'N'. -C -C LDU INTEGER -C The leading dimension of the array U. -C LDU >= MAX(1,M), if JOBU = 'A' or JOBU = 'S'; -C LDU >= 1, if JOBU = 'N'. -C -C V (input/output) DOUBLE PRECISION array, dimension (LDV,*) -C On entry, V contains the N-by-N (if JOBV = 'A') or -C N-by-min(M,N) (if JOBV = 'S') matrix V. -C On exit, the Householder transformations Qj have been -C applied to each column i of V corresponding to a parameter -C INUL(i) = .TRUE. -C NOTE that V is not referenced if JOBV = 'N'. -C -C LDV INTEGER -C The leading dimension of the array V. -C LDV >= MAX(1,M), if JOBV = 'A' or JOBV = 'S'; -C LDV >= 1, if JOBV = 'N'. -C -C INUL (input) LOGICAL array, dimension (MAX(M,N)) -C INUL(i) = .TRUE. if the i-th column of U and/or V is to be -C transformed, and INUL(i) = .FALSE., otherwise. -C (1 <= i <= MAX(M,N)). -C -C Error Indicator -C -C INFO INTEGER -C = 0: successful exit; -C < 0: if INFO = -i, the i-th argument had an illegal -C value. -C -C METHOD -C -C The Householder transformations Pj or Qj are applied to the -C columns of U or V indexed by I for which INUL(I) = .TRUE.. -C -C NUMERICAL ASPECTS -C -C The algorithm is backward stable. -C -C CONTRIBUTOR -C -C Release 3.0: V. Sima, Katholieke Univ. Leuven, Belgium, June 1997. -C Supersedes Release 2.0 routine MB04PZ by S. Van Huffel, Katholieke -C University Leuven, Belgium. -C -C REVISIONS -C -C - -C -C KEYWORDS -C -C Bidiagonalization, orthogonal transformation, singular subspace, -C singular value decomposition. -C -C ****************************************************************** -C -C .. Parameters .. - DOUBLE PRECISION ZERO, ONE - PARAMETER ( ZERO = 0.0D0, ONE = 1.0D0 ) -C .. Scalar Arguments .. - CHARACTER JOBU, JOBV - INTEGER INFO, LDU, LDV, LDX, M, N -C .. Array Arguments .. - LOGICAL INUL(*) - DOUBLE PRECISION TAUP(*), TAUQ(*), U(LDU,*), V(LDV,*), - $ X(LDX,*) -C .. Local Scalars .. - LOGICAL LJOBUA, LJOBUS, LJOBVA, LJOBVS, WANTU, WANTV - INTEGER I, IM, IOFF, L, NCOL, P - DOUBLE PRECISION FIRST -C .. Local Arrays .. - DOUBLE PRECISION DWORK(1) -C .. External Functions .. - LOGICAL LSAME - EXTERNAL LSAME -C .. External Subroutines .. - EXTERNAL DLARF, XERBLA -C .. Intrinsic Functions .. - INTRINSIC MIN, MAX -C .. Executable Statements .. -C - INFO = 0 - LJOBUA = LSAME( JOBU, 'A' ) - LJOBUS = LSAME( JOBU, 'S' ) - LJOBVA = LSAME( JOBV, 'A' ) - LJOBVS = LSAME( JOBV, 'S' ) - WANTU = LJOBUA.OR.LJOBUS - WANTV = LJOBVA.OR.LJOBVS -C -C Test the input scalar arguments. -C - IF( .NOT.WANTU .AND. .NOT.LSAME( JOBU, 'N' ) ) THEN - INFO = -1 - ELSE IF( .NOT.WANTV .AND. .NOT.LSAME( JOBV, 'N' ) ) THEN - INFO = -2 - ELSE IF( M.LT.0 ) THEN - INFO = -3 - ELSE IF( N.LT.0 ) THEN - INFO = -4 - ELSE IF( LDX.LT.MAX( 1, M ) ) THEN - INFO = -6 - ELSE IF( ( WANTU.AND.LDU.LT.MAX( 1, M ) ) .OR. - $ ( .NOT.WANTU.AND.LDU.LT.1 ) ) THEN - INFO = -10 - ELSE IF( ( WANTV.AND.LDV.LT.MAX( 1, N ) ) .OR. - $ ( .NOT.WANTV.AND.LDV.LT.1 ) ) THEN - INFO = -12 - END IF -C - IF ( INFO.NE.0 ) THEN -C -C Error return -C - CALL XERBLA( 'MB04XY', -INFO ) - RETURN - END IF -C -C Quick return if possible. -C - P = MIN( M, N ) - IF ( P.EQ.0 ) - $ RETURN -C - IF ( M.LT.N ) THEN - IOFF = 1 - ELSE - IOFF = 0 - END IF -C -C Apply the Householder transformations Pj onto the desired -C columns of U. -C - IM = MIN( M-1, N ) - IF ( WANTU .AND. ( IM.GT.0 ) ) THEN - IF ( LJOBUA ) THEN - NCOL = M - ELSE - NCOL = P - END IF -C - DO 40 I = 1, NCOL - IF ( INUL(I) ) THEN -C - DO 20 L = IM, 1, -1 - IF ( TAUP(L).NE.ZERO ) THEN - FIRST = X(L+IOFF,L) - X(L+IOFF,L) = ONE - CALL DLARF( 'Left', M-L+1-IOFF, 1, X(L+IOFF,L), 1, - $ TAUP(L), U(L+IOFF,I), LDU, DWORK ) - X(L+IOFF,L) = FIRST - END IF - 20 CONTINUE -C - END IF - 40 CONTINUE -C - END IF -C -C Apply the Householder transformations Qj onto the desired columns -C of V. -C - IM = MIN( N-1, M ) - IF ( WANTV .AND. ( IM.GT.0 ) ) THEN - IF ( LJOBVA ) THEN - NCOL = N - ELSE - NCOL = P - END IF -C - DO 80 I = 1, NCOL - IF ( INUL(I) ) THEN -C - DO 60 L = IM, 1, -1 - IF ( TAUQ(L).NE.ZERO ) THEN - FIRST = X(L,L+1-IOFF) - X(L,L+1-IOFF) = ONE - CALL DLARF( 'Left', N-L+IOFF, 1, X(L,L+1-IOFF), - $ LDX, TAUQ(L), V(L+1-IOFF,I), LDV, - $ DWORK ) - X(L,L+1-IOFF) = FIRST - END IF - 60 CONTINUE -C - END IF - 80 CONTINUE -C - END IF -C - RETURN -C *** Last line of MB04XY *** - END diff --git a/mex/sources/libslicot/MB04YD.f b/mex/sources/libslicot/MB04YD.f deleted file mode 100644 index 90ef68b27..000000000 --- a/mex/sources/libslicot/MB04YD.f +++ /dev/null @@ -1,623 +0,0 @@ - SUBROUTINE MB04YD( JOBU, JOBV, M, N, RANK, THETA, Q, E, U, LDU, V, - $ LDV, INUL, TOL, RELTOL, DWORK, LDWORK, IWARN, - $ INFO ) -C -C SLICOT RELEASE 5.0. -C -C Copyright (c) 2002-2009 NICONET e.V. -C -C This program is free software: you can redistribute it and/or -C modify it under the terms of the GNU General Public License as -C published by the Free Software Foundation, either version 2 of -C the License, or (at your option) any later version. -C -C This program is distributed in the hope that it will be useful, -C but WITHOUT ANY WARRANTY; without even the implied warranty of -C MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the -C GNU General Public License for more details. -C -C You should have received a copy of the GNU General Public License -C along with this program. If not, see -C . -C -C PURPOSE -C -C To partially diagonalize the bidiagonal matrix -C -C |q(1) e(1) 0 ... 0 | -C | 0 q(2) e(2) . | -C J = | . . | (1) -C | . e(MIN(M,N)-1)| -C | 0 ... ... q(MIN(M,N)) | -C -C using QR or QL iterations in such a way that J is split into -C unreduced bidiagonal submatrices whose singular values are either -C all larger than a given bound or are all smaller than (or equal -C to) this bound. The left- and right-hand Givens rotations -C performed on J (corresponding to each QR or QL iteration step) may -C be optionally accumulated in the arrays U and V. -C -C ARGUMENTS -C -C Mode Parameters -C -C JOBU CHARACTER*1 -C Indicates whether the user wishes to accumulate in a -C matrix U the left-hand Givens rotations, as follows: -C = 'N': Do not form U; -C = 'I': U is initialized to the M-by-MIN(M,N) submatrix of -C the unit matrix and the left-hand Givens rotations -C are accumulated in U; -C = 'U': The given matrix U is updated by the left-hand -C Givens rotations used in the calculation. -C -C JOBV CHARACTER*1 -C Indicates whether the user wishes to accumulate in a -C matrix V the right-hand Givens rotations, as follows: -C = 'N': Do not form V; -C = 'I': V is initialized to the N-by-MIN(M,N) submatrix of -C the unit matrix and the right-hand Givens -C rotations are accumulated in V; -C = 'U': The given matrix V is updated by the right-hand -C Givens rotations used in the calculation. -C -C Input/Output Parameters -C -C M (input) INTEGER -C The number of rows in matrix U. M >= 0. -C -C N (input) INTEGER -C The number of rows in matrix V. N >= 0. -C -C RANK (input/output) INTEGER -C On entry, if RANK < 0, then the rank of matrix J is -C computed by the routine as the number of singular values -C larger than THETA. -C Otherwise, RANK must specify the rank of matrix J. -C RANK <= MIN(M,N). -C On exit, if RANK < 0 on entry, then RANK contains the -C computed rank of J. That is, the number of singular -C values of J larger than THETA. -C Otherwise, the user-supplied value of RANK may be -C changed by the routine on exit if the RANK-th and the -C (RANK+1)-th singular values of J are considered to be -C equal. See also the parameter TOL. -C -C THETA (input/output) DOUBLE PRECISION -C On entry, if RANK < 0, then THETA must specify an upper -C bound on the smallest singular values of J. THETA >= 0.0. -C Otherwise, THETA must specify an initial estimate (t say) -C for computing an upper bound such that precisely RANK -C singular values are greater than this bound. -C If THETA < 0.0, then t is computed by the routine. -C On exit, if RANK >= 0 on entry, then THETA contains the -C computed upper bound such that precisely RANK singular -C values of J are greater than THETA + TOL. -C Otherwise, THETA is unchanged. -C -C Q (input/output) DOUBLE PRECISION array, dimension -C (MIN(M,N)) -C On entry, this array must contain the diagonal elements -C q(1),q(2),...,q(MIN(M,N)) of the bidiagonal matrix J. That -C is, Q(i) = J(i,i) for i = 1,2,...,MIN(M,N). -C On exit, this array contains the leading diagonal of the -C transformed bidiagonal matrix J. -C -C E (input/output) DOUBLE PRECISION array, dimension -C (MIN(M,N)-1) -C On entry, this array must contain the superdiagonal -C elements e(1),e(2),...,e(MIN(M,N)-1) of the bidiagonal -C matrix J. That is, E(k) = J(k,k+1) for k = 1,2,..., -C MIN(M,N)-1. -C On exit, this array contains the superdiagonal of the -C transformed bidiagonal matrix J. -C -C U (input/output) DOUBLE PRECISION array, dimension (LDU,*) -C On entry, if JOBU = 'U', the leading M-by-MIN(M,N) part -C of this array must contain a left transformation matrix -C applied to the original matrix of the problem, and -C on exit, the leading M-by-MIN(M,N) part of this array -C contains the product of the input matrix U and the -C left-hand Givens rotations. -C On exit, if JOBU = 'I', then the leading M-by-MIN(M,N) -C part of this array contains the matrix of accumulated -C left-hand Givens rotations used. -C If JOBU = 'N', the array U is not referenced and can be -C supplied as a dummy array (i.e. set parameter LDU = 1 and -C declare this array to be U(1,1) in the calling program). -C -C LDU INTEGER -C The leading dimension of array U. If JOBU = 'U' or -C JOBU = 'I', LDU >= MAX(1,M); if JOBU = 'N', LDU >= 1. -C -C V (input/output) DOUBLE PRECISION array, dimension (LDV,*) -C On entry, if JOBV = 'U', the leading N-by-MIN(M,N) part -C of this array must contain a right transformation matrix -C applied to the original matrix of the problem, and -C on exit, the leading N-by-MIN(M,N) part of this array -C contains the product of the input matrix V and the -C right-hand Givens rotations. -C On exit, if JOBV = 'I', then the leading N-by-MIN(M,N) -C part of this array contains the matrix of accumulated -C right-hand Givens rotations used. -C If JOBV = 'N', the array V is not referenced and can be -C supplied as a dummy array (i.e. set parameter LDV = 1 and -C declare this array to be V(1,1) in the calling program). -C -C LDV INTEGER -C The leading dimension of array V. If JOBV = 'U' or -C JOBV = 'I', LDV >= MAX(1,N); if JOBV = 'N', LDV >= 1. -C -C INUL (input/output) LOGICAL array, dimension (MIN(M,N)) -C On entry, the leading MIN(M,N) elements of this array must -C be set to .FALSE. unless the i-th columns of U (if JOBU = -C 'U') and V (if JOBV = 'U') already contain a computed base -C vector of the desired singular subspace of the original -C matrix, in which case INUL(i) must be set to .TRUE. -C for 1 <= i <= MIN(M,N). -C On exit, the indices of the elements of this array with -C value .TRUE. indicate the indices of the diagonal entries -C of J which belong to those bidiagonal submatrices whose -C singular values are all less than or equal to THETA. -C -C Tolerances -C -C TOL DOUBLE PRECISION -C This parameter defines the multiplicity of singular values -C by considering all singular values within an interval of -C length TOL as coinciding. TOL is used in checking how many -C singular values are less than or equal to THETA. Also in -C computing an appropriate upper bound THETA by a bisection -C method, TOL is used as a stopping criterion defining the -C minimum (absolute) subinterval width. TOL is also taken -C as an absolute tolerance for negligible elements in the -C QR/QL iterations. If the user sets TOL to be less than or -C equal to 0, then the tolerance is taken as -C EPS * MAX(ABS(Q(i)), ABS(E(k))), where EPS is the -C machine precision (see LAPACK Library routine DLAMCH), -C i = 1,2,...,MIN(M,N) and k = 1,2,...,MIN(M,N)-1. -C -C RELTOL DOUBLE PRECISION -C This parameter specifies the minimum relative width of an -C interval. When an interval is narrower than TOL, or than -C RELTOL times the larger (in magnitude) endpoint, then it -C is considered to be sufficiently small and bisection has -C converged. If the user sets RELTOL to be less than -C BASE * EPS, where BASE is machine radix and EPS is machine -C precision (see LAPACK Library routine DLAMCH), then the -C tolerance is taken as BASE * EPS. -C -C Workspace -C -C DWORK DOUBLE PRECISION array, dimension (LDWORK) -C -C LDWORK INTEGER -C The length of the array DWORK. -C LDWORK >= MAX(1,6*MIN(M,N)-5), if JOBU = 'I' or 'U', or -C JOBV = 'I' or 'U'; -C LDWORK >= MAX(1,4*MIN(M,N)-3), if JOBU = 'N' and -C JOBV = 'N'. -C -C Warning Indicator -C -C IWARN INTEGER -C = 0: no warning; -C = 1: if the rank of the bidiagonal matrix J (as specified -C by the user) has been lowered because a singular -C value of multiplicity larger than 1 was found. -C -C Error Indicator -C -C INFO INTEGER -C = 0: successful exit; -C < 0: if INFO = -i, the i-th argument had an illegal -C value; this includes values like RANK > MIN(M,N), or -C THETA < 0.0 and RANK < 0; -C = 1: if the maximum number of QR/QL iteration steps -C (30*MIN(M,N)) has been exceeded. -C -C METHOD -C -C If the upper bound THETA is not specified by the user, then it is -C computed by the routine (using a bisection method) such that -C precisely (MIN(M,N) - RANK) singular values of J are less than or -C equal to THETA + TOL. -C -C The method used by the routine (see [1]) then proceeds as follows. -C -C The unreduced bidiagonal submatrices of J(j), where J(j) is the -C transformed bidiagonal matrix after the j-th iteration step, are -C classified into the following three classes: -C -C - C1 contains the bidiagonal submatrices with all singular values -C > THETA, -C - C2 contains the bidiagonal submatrices with all singular values -C <= THETA and -C - C3 contains the bidiagonal submatrices with singular values -C > THETA and also singular values <= THETA. -C -C If C3 is empty, then the partial diagonalization is complete, and -C RANK is the sum of the dimensions of the bidiagonal submatrices of -C C1. -C Otherwise, QR or QL iterations are performed on each bidiagonal -C submatrix of C3, until this bidiagonal submatrix has been split -C into two bidiagonal submatrices. These two submatrices are then -C classified and the iterations are restarted. -C If the upper left diagonal element of the bidiagonal submatrix is -C larger than its lower right diagonal element, then QR iterations -C are performed, else QL iterations are used. The shift is taken as -C the smallest diagonal element of the bidiagonal submatrix (in -C magnitude) unless its value exceeds THETA, in which case it is -C taken as zero. -C -C REFERENCES -C -C [1] Van Huffel, S., Vandewalle, J. and Haegemans, A. -C An efficient and reliable algorithm for computing the -C singular subspace of a matrix associated with its smallest -C singular values. -C J. Comput. and Appl. Math., 19, pp. 313-330, 1987. -C -C NUMERICAL ASPECTS -C -C The algorithm is backward stable. -C -C To avoid overflow, matrix J is scaled so that its largest element -C is no greater than overflow**(1/2) * underflow**(1/4) in absolute -C value (and not much smaller than that, for maximal accuracy). -C -C CONTRIBUTOR -C -C Release 3.0: V. Sima, Katholieke Univ. Leuven, Belgium, June 1997. -C Supersedes Release 2.0 routine MB04QD by S. Van Huffel, Katholieke -C University Leuven, Belgium. -C -C REVISIONS -C -C July 10, 1997. V. Sima. -C November 25, 1997. V. Sima: Setting INUL(K) = .TRUE. when handling -C 2-by-2 submatrix. -C -C KEYWORDS -C -C Bidiagonal matrix, orthogonal transformation, singular values. -C -C ****************************************************************** -C -C .. Parameters .. - DOUBLE PRECISION ZERO, ONE, TEN, HNDRD - PARAMETER ( ZERO = 0.0D0, ONE = 1.0D0, TEN = 10.0D0, - $ HNDRD = 100.0D0 ) - DOUBLE PRECISION MEIGTH - PARAMETER ( MEIGTH = -0.125D0 ) - INTEGER MAXITR - PARAMETER ( MAXITR = 30 ) -C .. Scalar Arguments .. - CHARACTER JOBU, JOBV - INTEGER INFO, IWARN, LDU, LDV, LDWORK, M, N, RANK - DOUBLE PRECISION RELTOL, THETA, TOL -C .. Array Arguments .. - LOGICAL INUL(*) - DOUBLE PRECISION DWORK(*), E(*), Q(*), U(LDU,*), V(LDV,*) -C .. Local Scalars .. - LOGICAL LJOBUA, LJOBUI, LJOBVA, LJOBVI, NOC12, QRIT - INTEGER I, I1, IASCL, INFO1, ITER, J, K, MAXIT, NUMEIG, - $ OLDI, OLDK, P, R - DOUBLE PRECISION COSL, COSR, EPS, PIVMIN, RMAX, RMIN, SAFEMN, - $ SHIFT, SIGMA, SIGMN, SIGMX, SINL, SINR, SMAX, - $ SMLNUM, THETAC, THRESH, TOLABS, TOLREL, X -C .. External Functions .. - LOGICAL LSAME - INTEGER MB03ND - DOUBLE PRECISION DLAMCH - EXTERNAL DLAMCH, LSAME, MB03ND -C .. External Subroutines .. - EXTERNAL DLASET, DLASV2, DROT, DSCAL, MB02NY, MB03MD, - $ MB04YW, XERBLA -C .. Intrinsic Functions .. - INTRINSIC ABS, MAX, MIN, SQRT -C .. Executable Statements .. -C - P = MIN( M, N ) - INFO = 0 - IWARN = 0 - LJOBUI = LSAME( JOBU, 'I' ) - LJOBVI = LSAME( JOBV, 'I' ) - LJOBUA = LJOBUI.OR.LSAME( JOBU, 'U' ) - LJOBVA = LJOBVI.OR.LSAME( JOBV, 'U' ) -C -C Test the input scalar arguments. -C - IF( .NOT.LJOBUA .AND. .NOT.LSAME( JOBU, 'N' ) ) THEN - INFO = -1 - ELSE IF( .NOT.LJOBVA .AND. .NOT.LSAME( JOBV, 'N' ) ) THEN - INFO = -2 - ELSE IF( M.LT.0 ) THEN - INFO = -3 - ELSE IF( N.LT.0 ) THEN - INFO = -4 - ELSE IF( RANK.GT.P ) THEN - INFO = -5 - ELSE IF( RANK.LT.0 .AND. THETA.LT.ZERO ) THEN - INFO = -6 - ELSE IF( .NOT.LJOBUA .AND. LDU.LT.1 .OR. - $ LJOBUA .AND. LDU.LT.MAX( 1, M ) ) THEN - INFO = -10 - ELSE IF( .NOT.LJOBVA .AND. LDV.LT.1 .OR. - $ LJOBVA .AND. LDV.LT.MAX( 1, N ) ) THEN - INFO = -12 - ELSE IF( ( ( LJOBUA.OR.LJOBVA ) .AND. LDWORK.LT.MAX( 1, 6*P-5 ) ) - $ .OR.(.NOT.( LJOBUA.OR.LJOBVA ) .AND. LDWORK.LT.MAX( 1, 4*P-3 ) ) - $ ) THEN - INFO = -17 - END IF -C - IF ( INFO.NE.0 ) THEN -C -C Error return. -C - CALL XERBLA( 'MB04YD', -INFO ) - RETURN - END IF -C -C Quick return if possible. -C - IF ( P.EQ.0 ) THEN - IF ( RANK.GE.0 ) - $ THETA = ZERO - RANK = 0 - RETURN - END IF -C -C Set tolerances and machine parameters. -C - TOLABS = TOL - TOLREL = RELTOL - SMAX = ABS( Q(P) ) -C - DO 20 J = 1, P - 1 - SMAX = MAX( SMAX, ABS( Q(J) ), ABS( E(J) ) ) - 20 CONTINUE -C - SAFEMN = DLAMCH( 'Safe minimum' ) - EPS = DLAMCH( 'Epsilon' ) - IF ( TOLABS.LE.ZERO ) TOLABS = EPS*SMAX - X = DLAMCH( 'Base' )*EPS - IF ( TOLREL.LE.X ) TOLREL = X - THRESH = MAX( TEN, MIN( HNDRD, EPS**MEIGTH ) )*EPS - SMLNUM = SAFEMN / EPS - RMIN = SQRT( SMLNUM ) - RMAX = MIN( ONE / RMIN, ONE / SQRT( SQRT( SAFEMN ) ) ) - THETAC = THETA -C -C Scale the matrix to allowable range, if necessary, and set PIVMIN, -C using the squares of Q and E (saved in DWORK). -C - IASCL = 0 - IF( SMAX.GT.ZERO .AND. SMAX.LT.RMIN ) THEN - IASCL = 1 - SIGMA = RMIN / SMAX - ELSE IF( SMAX.GT.RMAX ) THEN - IASCL = 1 - SIGMA = RMAX / SMAX - END IF - IF( IASCL.EQ.1 ) THEN - CALL DSCAL( P, SIGMA, Q, 1 ) - CALL DSCAL( P-1, SIGMA, E, 1 ) - THETAC = SIGMA*THETA - TOLABS = SIGMA*TOLABS - END IF -C - PIVMIN = Q(P)**2 - DWORK(P) = PIVMIN -C - DO 40 J = 1, P - 1 - DWORK(J) = Q(J)**2 - DWORK(P+J) = E(J)**2 - PIVMIN = MAX( PIVMIN, DWORK(J), DWORK(P+J) ) - 40 CONTINUE -C - PIVMIN = MAX( PIVMIN*SAFEMN, SAFEMN ) -C -C Initialize U and/or V to the identity matrix, if needed. -C - IF ( LJOBUI ) - $ CALL DLASET( 'Full', M, P, ZERO, ONE, U, LDU ) - IF ( LJOBVI ) - $ CALL DLASET( 'Full', N, P, ZERO, ONE, V, LDV ) -C -C Estimate THETA (if not fixed by the user), and set R. -C - IF ( RANK.GE.0 ) THEN - J = P - RANK - CALL MB03MD( P, J, THETAC, Q, E, DWORK(1), DWORK(P+1), PIVMIN, - $ TOLABS, TOLREL, IWARN, INFO1 ) - THETA = THETAC - IF ( IASCL.EQ.1 ) THETA = THETA / SIGMA - IF ( J.LE.0 ) - $ RETURN - R = P - J - ELSE - R = P - MB03ND( P, THETAC, DWORK, DWORK(P+1), PIVMIN, INFO1 ) - END IF -C - RANK = P -C - DO 60 I = 1, P - IF ( INUL(I) ) RANK = RANK - 1 - 60 CONTINUE -C -C From now on K is the smallest known index such that the elements -C of the bidiagonal matrix J with indices larger than K belong to C1 -C or C2. -C RANK = P - SUM(dimensions of known bidiagonal matrices of C2). -C - K = P - OLDI = -1 - OLDK = -1 - ITER = 0 - MAXIT = MAXITR*P -C WHILE ( C3 NOT EMPTY ) DO - 80 IF ( RANK.GT.R .AND. K.GT.0 ) THEN -C WHILE ( K.GT.0 .AND. INUL(K) ) DO -C -C Search for the rightmost index of a bidiagonal submatrix, -C not yet classified. -C - 100 IF ( K.GT.0 ) THEN - IF ( INUL(K) ) THEN - K = K - 1 - GO TO 100 - END IF - END IF -C END WHILE 100 -C - IF ( K.EQ.0 ) - $ RETURN -C - NOC12 = .TRUE. -C WHILE ((ITER < MAXIT).AND.(No bidiagonal matrix of C1 or -C C2 found)) DO - 120 IF ( ( ITER.LT.MAXIT ) .AND. NOC12 ) THEN -C -C Search for negligible Q(I) or E(I-1) (for I > 1) and find -C the shift. -C - I = K - X = ABS( Q(I) ) - SHIFT = X -C WHILE ABS( Q(I) ) > TOLABS .AND. ABS( E(I-1) ) > TOLABS ) DO - 140 IF ( I.GT.1 ) THEN - IF ( ( X.GT.TOLABS ).AND.( ABS( E(I-1) ).GT.TOLABS ) ) - $ THEN - I = I - 1 - X = ABS( Q(I) ) - IF ( X.LT.SHIFT ) SHIFT = X - GO TO 140 - END IF - END IF -C END WHILE 140 -C -C Classify the bidiagonal submatrix (of order J) found. -C - J = K - I + 1 - IF ( ( X.LE.TOLABS ) .OR. ( K.EQ.I ) ) THEN - NOC12 = .FALSE. - ELSE - NUMEIG = MB03ND( J, THETAC, DWORK(I), DWORK(P+I), PIVMIN, - $ INFO1 ) - IF ( NUMEIG.GE.J .OR. NUMEIG.LE.0 ) NOC12 = .FALSE. - END IF - IF ( NOC12 ) THEN - IF ( J.EQ.2 ) THEN -C -C Handle separately the 2-by-2 submatrix. -C - CALL DLASV2( Q(I), E(I), Q(K), SIGMN, SIGMX, SINR, - $ COSR, SINL, COSL ) - Q(I) = SIGMX - Q(K) = SIGMN - E(I) = ZERO - RANK = RANK - 1 - INUL(K) = .TRUE. - NOC12 = .FALSE. -C -C Update U and/or V, if needed. -C - IF( LJOBUA ) - $ CALL DROT( M, U(1,I), 1, U(1,K), 1, COSL, SINL ) - IF( LJOBVA ) - $ CALL DROT( N, V(1,I), 1, V(1,K), 1, COSR, SINR ) - ELSE -C -C If working on new submatrix, choose QR or -C QL iteration. -C - IF ( I.NE.OLDI .OR. K.NE.OLDK ) - $ QRIT = ABS( Q(I) ).GE.ABS( Q(K) ) - OLDI = I - IF ( QRIT ) THEN - IF ( ABS( E(K-1) ).LE.THRESH*ABS( Q(K) ) ) - $ E(K-1) = ZERO - ELSE - IF ( ABS( E(I) ).LE.THRESH*ABS( Q(I) ) ) - $ E(I) = ZERO - END IF -C - CALL MB04YW( QRIT, LJOBUA, LJOBVA, M, N, I, K, SHIFT, - $ Q, E, U, LDU, V, LDV, DWORK(2*P) ) -C - IF ( QRIT ) THEN - IF ( ABS( E(K-1) ).LE.TOLABS ) E(K-1) = ZERO - ELSE - IF ( ABS( E(I) ).LE.TOLABS ) E(I) = ZERO - END IF - DWORK(K) = Q(K)**2 -C - DO 160 I1 = I, K - 1 - DWORK(I1) = Q(I1)**2 - DWORK(P+I1) = E(I1)**2 - 160 CONTINUE -C - ITER = ITER + 1 - END IF - END IF - GO TO 120 - END IF -C END WHILE 120 -C - IF ( ITER.GE.MAXIT ) THEN - INFO = 1 - GO TO 200 - END IF -C - IF ( X.LE.TOLABS ) THEN -C -C Split at negligible diagonal element ABS( Q(I) ) <= TOLABS. -C - CALL MB02NY( LJOBUA, LJOBVA, M, N, I, K, Q, E, U, LDU, V, - $ LDV, DWORK(2*P) ) - INUL(I) = .TRUE. - RANK = RANK - 1 - ELSE -C -C A negligible superdiagonal element ABS( E(I-1) ) <= TOL -C has been found, the corresponding bidiagonal submatrix -C belongs to C1 or C2. Treat this bidiagonal submatrix. -C - IF ( J.GE.2 ) THEN - IF ( NUMEIG.EQ.J ) THEN -C - DO 180 I1 = I, K - INUL(I1) = .TRUE. - 180 CONTINUE -C - RANK = RANK - J - K = K - J - ELSE - K = I - 1 - END IF - ELSE - IF ( X.LE.( THETAC + TOLABS ) ) THEN - INUL(I) = .TRUE. - RANK = RANK - 1 - END IF - K = K - 1 - END IF - OLDK = K - END IF - GO TO 80 - END IF -C END WHILE 80 -C -C If matrix was scaled, then rescale Q and E appropriately. -C - 200 CONTINUE - IF( IASCL.EQ.1 ) THEN - CALL DSCAL( P, ONE / SIGMA, Q, 1 ) - CALL DSCAL( P-1, ONE / SIGMA, E, 1 ) - END IF -C - RETURN -C *** Last line of MB04YD *** - END diff --git a/mex/sources/libslicot/MB04YW.f b/mex/sources/libslicot/MB04YW.f deleted file mode 100644 index 0090d5111..000000000 --- a/mex/sources/libslicot/MB04YW.f +++ /dev/null @@ -1,513 +0,0 @@ - SUBROUTINE MB04YW( QRIT, UPDATU, UPDATV, M, N, L, K, SHIFT, D, E, - $ U, LDU, V, LDV, DWORK ) -C -C SLICOT RELEASE 5.0. -C -C Copyright (c) 2002-2009 NICONET e.V. -C -C This program is free software: you can redistribute it and/or -C modify it under the terms of the GNU General Public License as -C published by the Free Software Foundation, either version 2 of -C the License, or (at your option) any later version. -C -C This program is distributed in the hope that it will be useful, -C but WITHOUT ANY WARRANTY; without even the implied warranty of -C MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the -C GNU General Public License for more details. -C -C You should have received a copy of the GNU General Public License -C along with this program. If not, see -C . -C -C PURPOSE -C -C To perform either one QR or QL iteration step onto the unreduced -C bidiagonal submatrix Jk: -C -C |D(l) E(l) 0 ... 0 | -C | 0 D(l+1) E(l+1) . | -C Jk = | . . | -C | . . | -C | . E(k-1)| -C | 0 ... ... D(k) | -C -C with k <= p and l >= 1, p = MIN(M,N), of the bidiagonal matrix J: -C -C |D(1) E(1) 0 ... 0 | -C | 0 D(2) E(2) . | -C J = | . . |. -C | . . | -C | . E(p-1)| -C | 0 ... ... D(p) | -C -C Hereby, Jk is transformed to S' Jk T with S and T products of -C Givens rotations. These Givens rotations S (respectively, T) are -C postmultiplied into U (respectively, V), if UPDATU (respectively, -C UPDATV) is .TRUE.. -C -C ARGUMENTS -C -C Mode Parameters -C -C QRIT LOGICAL -C Indicates whether a QR or QL iteration step is to be -C taken (from larger end diagonal element towards smaller), -C as follows: -C = .TRUE. : QR iteration step (chase bulge from top to -C bottom); -C = .FALSE.: QL iteration step (chase bulge from bottom to -C top). -C -C UPDATU LOGICAL -C Indicates whether the user wishes to accumulate in a -C matrix U the left-hand Givens rotations S, as follows: -C = .FALSE.: Do not form U; -C = .TRUE. : The given matrix U is updated (postmultiplied) -C by the left-hand Givens rotations S. -C -C UPDATV LOGICAL -C Indicates whether the user wishes to accumulate in a -C matrix V the right-hand Givens rotations S, as follows: -C = .FALSE.: Do not form V; -C = .TRUE. : The given matrix V is updated (postmultiplied) -C by the right-hand Givens rotations T. -C -C Input/Output Parameters -C -C M (input) INTEGER -C The number of rows of the matrix U. M >= 0. -C -C N (input) INTEGER -C The number of rows of the matrix V. N >= 0. -C -C L (input) INTEGER -C The index of the first diagonal entry of the considered -C unreduced bidiagonal submatrix Jk of J. -C -C K (input) INTEGER -C The index of the last diagonal entry of the considered -C unreduced bidiagonal submatrix Jk of J. -C -C SHIFT (input) DOUBLE PRECISION -C Value of the shift used in the QR or QL iteration step. -C -C D (input/output) DOUBLE PRECISION array, dimension (p) -C where p = MIN(M,N) -C On entry, D must contain the diagonal entries of the -C bidiagonal matrix J. -C On exit, D contains the diagonal entries of the -C transformed bidiagonal matrix S' J T. -C -C E (input/output) DOUBLE PRECISION array, dimension (p-1) -C On entry, E must contain the superdiagonal entries of J. -C On exit, E contains the superdiagonal entries of the -C transformed matrix S' J T. -C -C U (input/output) DOUBLE PRECISION array, dimension (LDU,p) -C On entry, if UPDATU = .TRUE., U must contain the M-by-p -C left transformation matrix. -C On exit, if UPDATU = .TRUE., the Givens rotations S on the -C left have been postmultiplied into U, i.e., U * S is -C returned. -C U is not referenced if UPDATU = .FALSE.. -C -C LDU INTEGER -C The leading dimension of the array U. -C LDU >= max(1,M) if UPDATU = .TRUE.; -C LDU >= 1 if UPDATU = .FALSE.. -C -C V (input/output) DOUBLE PRECISION array, dimension (LDV,p) -C On entry, if UPDATV = .TRUE., V must contain the N-by-p -C right transformation matrix. -C On exit, if UPDATV = .TRUE., the Givens rotations T on the -C right have been postmultiplied into V, i.e., V * T is -C returned. -C V is not referenced if UPDATV = .FALSE.. -C -C LDV INTEGER -C The leading dimension of the array V. -C LDV >= max(1,N) if UPDATV = .TRUE.; -C LDV >= 1 if UPDATV = .FALSE.. -C -C Workspace -C -C DWORK DOUBLE PRECISION array, dimension (MAX(1,LDWORK)) -C LDWORK >= 4*MIN(M,N)-4, if UPDATU = UPDATV = .TRUE.; -C LDWORK >= 2*MIN(M,N)-2, if -C UPDATU = .TRUE. and UPDATV = .FALSE. or -C UPDATV = .TRUE. and UPDATU = .FALSE.; -C LDWORK >= 1, if UPDATU = UPDATV = .FALSE.. -C -C METHOD -C -C QR iterations diagonalize the bidiagonal matrix by zeroing the -C super-diagonal elements of Jk from bottom to top. -C QL iterations diagonalize the bidiagonal matrix by zeroing the -C super-diagonal elements of Jk from top to bottom. -C The routine overwrites Jk with the bidiagonal matrix S' Jk T, -C where S and T are products of Givens rotations. -C T is essentially the orthogonal matrix that would be obtained by -C applying one implicit symmetric shift QR (QL) step onto the matrix -C Jk'Jk. This step factors the matrix (Jk'Jk - shift*I) into a -C product of an orthogonal matrix T and a upper (lower) triangular -C matrix. See [1,Sec.8.2-8.3] and [2] for more details. -C -C REFERENCES -C -C [1] Golub, G.H. and Van Loan, C.F. -C Matrix Computations. -C The Johns Hopkins University Press, Baltimore, Maryland, 1983. -C -C [2] Bowdler, H., Martin, R.S. and Wilkinson, J.H. -C The QR and QL algorithms for symmetric matrices. -C Numer. Math., 11, pp. 293-306, 1968. -C -C [3] Demmel, J. and Kahan, W. -C Computing small singular values of bidiagonal matrices with -C guaranteed high relative accuracy. -C SIAM J. Sci. Statist. Comput., 11, pp. 873-912, 1990. -C -C NUMERICAL ASPECTS -C -C The algorithm is backward stable. -C -C CONTRIBUTOR -C -C Release 3.0: V. Sima, Katholieke Univ. Leuven, Belgium, June 1997. -C Supersedes Release 2.0 routines MB04QY and MB04QZ by S. Van -C Huffel, Katholieke University Leuven, Belgium. -C This subroutine is based on the QR/QL step implemented in LAPACK -C routine DBDSQR. -C -C REVISIONS -C -C - -C -C KEYWORDS -C -C Bidiagonal matrix, orthogonal transformation, singular values. -C -C ****************************************************************** -C - DOUBLE PRECISION ZERO, ONE - PARAMETER ( ZERO = 0.0D0, ONE = 1.0D0 ) -C .. Scalar Arguments .. - LOGICAL QRIT, UPDATU, UPDATV - INTEGER K, L, LDU, LDV, M, N - DOUBLE PRECISION SHIFT -C .. -C .. Array Arguments .. - DOUBLE PRECISION D( * ), DWORK( * ), E( * ), U( LDU, * ), - $ V( LDV, * ) -C .. -C .. Local Scalars .. - INTEGER I, IROT, NCV, NM1, NM12, NM13 - DOUBLE PRECISION COSL, COSR, CS, F, G, H, OLDCS, OLDSN, R, SINL, - $ SINR, SN -C .. -C .. External Subroutines .. - EXTERNAL DLARTG, DLASR -C .. -C .. Intrinsic Functions .. - INTRINSIC ABS, MIN, SIGN -C .. -C .. Executable Statements .. -C -C For speed, no tests of the input scalar arguments are done. -C -C Quick return if possible. -C - NCV = MIN( M, N ) - IF ( NCV.LE.1 .OR. L.EQ.K ) - $ RETURN -C - NM1 = NCV - 1 - NM12 = NM1 + NM1 - NM13 = NM12 + NM1 - IF ( .NOT.UPDATV ) THEN - NM12 = 0 - NM13 = NM1 - END IF -C -C If SHIFT = 0, do simplified QR iteration. -C - IF( SHIFT.EQ.ZERO ) THEN - IF( QRIT ) THEN -C -C Chase bulge from top to bottom. -C Save cosines and sines for later U and/or V updates, -C if needed. -C - CS = ONE - OLDCS = ONE - CALL DLARTG( D( L )*CS, E( L ), CS, SN, R ) - CALL DLARTG( OLDCS*R, D( L+1 )*SN, OLDCS, OLDSN, D( L ) ) - IF ( UPDATV ) THEN - DWORK( 1 ) = CS - DWORK( 1+NM1 ) = SN - END IF - IF ( UPDATU ) THEN - DWORK( 1+NM12 ) = OLDCS - DWORK( 1+NM13 ) = OLDSN - END IF - IROT = 1 -C - DO 110 I = L + 1, K - 1 - CALL DLARTG( D( I )*CS, E( I ), CS, SN, R ) - E( I-1 ) = OLDSN*R - CALL DLARTG( OLDCS*R, D( I+1 )*SN, OLDCS, OLDSN, D( I ) ) - IROT = IROT + 1 - IF ( UPDATV ) THEN - DWORK( IROT ) = CS - DWORK( IROT+NM1 ) = SN - END IF - IF ( UPDATU ) THEN - DWORK( IROT+NM12 ) = OLDCS - DWORK( IROT+NM13 ) = OLDSN - END IF - 110 CONTINUE -C - H = D( K )*CS - D( K ) = H*OLDCS - E( K-1 ) = H*OLDSN -C -C Update U and/or V. -C - IF( UPDATV ) - $ CALL DLASR( 'R', 'V', 'F', N, K-L+1, DWORK( 1 ), - $ DWORK( NCV ), V( 1, L ), LDV ) - IF( UPDATU ) - $ CALL DLASR( 'R', 'V', 'F', M, K-L+1, DWORK( NM12+1 ), - $ DWORK( NM13+1 ), U( 1, L ), LDU ) -C - ELSE -C -C Chase bulge from bottom to top. -C Save cosines and sines for later U and/or V updates, -C if needed. -C - CS = ONE - OLDCS = ONE - CALL DLARTG( D( K )*CS, E( K-1 ), CS, SN, R ) - CALL DLARTG( OLDCS*R, D( K-1 )*SN, OLDCS, OLDSN, D( K ) ) - IF ( UPDATV ) THEN - DWORK( K-L ) = OLDCS - DWORK( K-L+NM1 ) = -OLDSN - END IF - IF ( UPDATU ) THEN - DWORK( K-L+NM12 ) = CS - DWORK( K-L+NM13 ) = -SN - END IF - IROT = K - L -C - DO 120 I = K - 1, L + 1, -1 - CALL DLARTG( D( I )*CS, E( I-1 ), CS, SN, R ) - E( I ) = OLDSN*R - CALL DLARTG( OLDCS*R, D( I-1 )*SN, OLDCS, OLDSN, D( I ) ) - IROT = IROT - 1 - IF ( UPDATV ) THEN - DWORK( IROT ) = OLDCS - DWORK( IROT+NM1 ) = -OLDSN - END IF - IF ( UPDATU ) THEN - DWORK( IROT+NM12 ) = CS - DWORK( IROT+NM13 ) = -SN - END IF - 120 CONTINUE -C - H = D( L )*CS - D( L ) = H*OLDCS - E( L ) = H*OLDSN -C -C Update U and/or V. -C - IF( UPDATV ) - $ CALL DLASR( 'R', 'V', 'B', N, K-L+1, DWORK( 1 ), - $ DWORK( NCV ), V( 1, L ), LDV ) - IF( UPDATU ) - $ CALL DLASR( 'R', 'V', 'B', M, K-L+1, DWORK( NM12+1 ), - $ DWORK( NM13+1 ), U( 1, L ), LDU ) - END IF - ELSE -C -C Use nonzero shift. -C - IF( QRIT ) THEN -C -C Chase bulge from top to bottom. -C Save cosines and sines for later U and/or V updates, -C if needed. -C - F = ( ABS( D( L ) ) - SHIFT )* - $ ( SIGN( ONE, D( L ) ) + SHIFT / D( L ) ) - G = E( L ) - CALL DLARTG( F, G, COSR, SINR, R ) - F = COSR*D( L ) + SINR*E( L ) - E( L ) = COSR*E( L ) - SINR*D( L ) - G = SINR*D( L+1 ) - D( L+1 ) = COSR*D( L+1 ) - CALL DLARTG( F, G, COSL, SINL, R ) - D( L ) = R - F = COSL*E( L ) + SINL*D( L+1 ) - D( L+1 ) = COSL*D( L+1 ) - SINL*E( L ) - G = SINL*E( L+1 ) - E( L+1 ) = COSL*E( L+1 ) - IF ( UPDATV ) THEN - DWORK( 1 ) = COSR - DWORK( 1+NM1 ) = SINR - END IF - IF ( UPDATU ) THEN - DWORK( 1+NM12 ) = COSL - DWORK( 1+NM13 ) = SINL - END IF - IROT = 1 -C - DO 130 I = L + 1, K - 2 - CALL DLARTG( F, G, COSR, SINR, R ) - E( I-1 ) = R - F = COSR*D( I ) + SINR*E( I ) - E( I ) = COSR*E( I ) - SINR*D( I ) - G = SINR*D( I+1 ) - D( I+1 ) = COSR*D( I+1 ) - CALL DLARTG( F, G, COSL, SINL, R ) - D( I ) = R - F = COSL*E( I ) + SINL*D( I+1 ) - D( I+1 ) = COSL*D( I+1 ) - SINL*E( I ) - G = SINL*E( I+1 ) - E( I+1 ) = COSL*E( I+1 ) - IROT = IROT + 1 - IF ( UPDATV ) THEN - DWORK( IROT ) = COSR - DWORK( IROT+NM1 ) = SINR - END IF - IF ( UPDATU ) THEN - DWORK( IROT+NM12 ) = COSL - DWORK( IROT+NM13 ) = SINL - END IF - 130 CONTINUE -C - IF ( L.LT.K-1 ) THEN - CALL DLARTG( F, G, COSR, SINR, R ) - E( K-2 ) = R - F = COSR*D( K-1 ) + SINR*E( K-1 ) - E( K-1 ) = COSR*E( K-1 ) - SINR*D( K-1 ) - G = SINR*D( K ) - D( K ) = COSR*D( K ) - CALL DLARTG( F, G, COSL, SINL, R ) - D( K-1 ) = R - F = COSL*E( K-1 ) + SINL*D( K ) - D( K ) = COSL*D( K ) - SINL*E( K-1 ) - IROT = IROT + 1 - IF ( UPDATV ) THEN - DWORK( IROT ) = COSR - DWORK( IROT+NM1 ) = SINR - END IF - IF ( UPDATU ) THEN - DWORK( IROT+NM12 ) = COSL - DWORK( IROT+NM13 ) = SINL - END IF - END IF - E( K-1 ) = F -C -C Update U and/or V. -C - IF( UPDATV ) - $ CALL DLASR( 'R', 'V', 'F', N, K-L+1, DWORK( 1 ), - $ DWORK( NCV ), V( 1, L ), LDV ) - IF( UPDATU ) - $ CALL DLASR( 'R', 'V', 'F', M, K-L+1, DWORK( NM12+1 ), - $ DWORK( NM13+1 ), U( 1, L ), LDU ) -C - ELSE -C -C Chase bulge from bottom to top. -C Save cosines and sines for later U and/or V updates, -C if needed. -C - F = ( ABS( D( K ) ) - SHIFT )* - $ ( SIGN( ONE, D( K ) ) + SHIFT / D( K ) ) - G = E( K-1 ) - IF ( L.LT.K-1 ) THEN - CALL DLARTG( F, G, COSR, SINR, R ) - F = COSR*D( K ) + SINR*E( K-1 ) - E( K-1 ) = COSR*E( K-1 ) - SINR*D( K ) - G = SINR*D( K-1 ) - D( K-1 ) = COSR*D( K-1 ) - CALL DLARTG( F, G, COSL, SINL, R ) - D( K ) = R - F = COSL*E( K-1 ) + SINL*D( K-1 ) - D( K-1 ) = COSL*D( K-1 ) - SINL*E( K-1 ) - G = SINL*E( K-2 ) - E( K-2 ) = COSL*E( K-2 ) - IF ( UPDATV ) THEN - DWORK( K-L ) = COSL - DWORK( K-L+NM1 ) = -SINL - END IF - IF ( UPDATU ) THEN - DWORK( K-L+NM12 ) = COSR - DWORK( K-L+NM13 ) = -SINR - END IF - IROT = K - L - ELSE - IROT = K - L + 1 - END IF -C - DO 140 I = K - 1, L + 2, -1 - CALL DLARTG( F, G, COSR, SINR, R ) - E( I ) = R - F = COSR*D( I ) + SINR*E( I-1 ) - E( I-1 ) = COSR*E( I-1 ) - SINR*D( I ) - G = SINR*D( I-1 ) - D( I-1 ) = COSR*D( I-1 ) - CALL DLARTG( F, G, COSL, SINL, R ) - D( I ) = R - F = COSL*E( I-1 ) + SINL*D( I-1 ) - D( I-1 ) = COSL*D( I-1 ) - SINL*E( I-1 ) - G = SINL*E( I-2 ) - E( I-2 ) = COSL*E( I-2 ) - IROT = IROT - 1 - IF ( UPDATV ) THEN - DWORK( IROT ) = COSL - DWORK( IROT+NM1 ) = -SINL - END IF - IF ( UPDATU ) THEN - DWORK( IROT+NM12 ) = COSR - DWORK( IROT+NM13 ) = -SINR - END IF - 140 CONTINUE -C - CALL DLARTG( F, G, COSR, SINR, R ) - E( L+1 ) = R - F = COSR*D( L+1 ) + SINR*E( L ) - E( L ) = COSR*E( L ) - SINR*D( L+1 ) - G = SINR*D( L ) - D( L ) = COSR*D( L ) - CALL DLARTG( F, G, COSL, SINL, R ) - D( L+1 ) = R - F = COSL*E( L ) + SINL*D( L ) - D( L ) = COSL*D( L ) - SINL*E( L ) - IROT = IROT - 1 - IF ( UPDATV ) THEN - DWORK( IROT ) = COSL - DWORK( IROT+NM1 ) = -SINL - END IF - IF ( UPDATU ) THEN - DWORK( IROT+NM12 ) = COSR - DWORK( IROT+NM13 ) = -SINR - END IF - E( L ) = F -C -C Update U and/or V if desired. -C - IF( UPDATV ) - $ CALL DLASR( 'R', 'V', 'B', N, K-L+1, DWORK( 1 ), - $ DWORK( NCV ), V( 1, L ), LDV ) - IF( UPDATU ) - $ CALL DLASR( 'R', 'V', 'B', M, K-L+1, DWORK( NM12+1 ), - $ DWORK( NM13+1 ), U( 1, L ), LDU ) - END IF - END IF -C - RETURN -C *** Last line of MB04YW *** - END diff --git a/mex/sources/libslicot/MB04ZD.f b/mex/sources/libslicot/MB04ZD.f deleted file mode 100644 index 63c77e6a1..000000000 --- a/mex/sources/libslicot/MB04ZD.f +++ /dev/null @@ -1,486 +0,0 @@ - SUBROUTINE MB04ZD( COMPU, N, A, LDA, QG, LDQG, U, LDU, DWORK, INFO - $ ) -C -C SLICOT RELEASE 5.0. -C -C Copyright (c) 2002-2009 NICONET e.V. -C -C This program is free software: you can redistribute it and/or -C modify it under the terms of the GNU General Public License as -C published by the Free Software Foundation, either version 2 of -C the License, or (at your option) any later version. -C -C This program is distributed in the hope that it will be useful, -C but WITHOUT ANY WARRANTY; without even the implied warranty of -C MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the -C GNU General Public License for more details. -C -C You should have received a copy of the GNU General Public License -C along with this program. If not, see -C . -C -C PURPOSE -C -C To transform a Hamiltonian matrix -C -C ( A G ) -C H = ( T ) (1) -C ( Q -A ) -C -C into a square-reduced Hamiltonian matrix -C -C ( A' G' ) -C H' = ( T ) (2) -C ( Q' -A' ) -C T -C by an orthogonal symplectic similarity transformation H' = U H U, -C where -C ( U1 U2 ) -C U = ( ). (3) -C ( -U2 U1 ) -C T -C The square-reduced Hamiltonian matrix satisfies Q'A' - A' Q' = 0, -C and -C -C 2 T 2 ( A'' G'' ) -C H' := (U H U) = ( T ). -C ( 0 A'' ) -C -C In addition, A'' is upper Hessenberg and G'' is skew symmetric. -C The square roots of the eigenvalues of A'' = A'*A' + G'*Q' are the -C eigenvalues of H. -C -C ARGUMENTS -C -C Mode Parameters -C -C COMPU CHARACTER*1 -C Indicates whether the orthogonal symplectic similarity -C transformation matrix U in (3) is returned or -C accumulated into an orthogonal symplectic matrix, or if -C the transformation matrix is not required, as follows: -C = 'N': U is not required; -C = 'I' or 'F': on entry, U need not be set; -C on exit, U contains the orthogonal -C symplectic matrix U from (3); -C = 'V' or 'A': the orthogonal symplectic similarity -C transformations are accumulated into U; -C on input, U must contain an orthogonal -C symplectic matrix S; -C on exit, U contains S*U with U from (3). -C See the description of U below for details. -C -C Input/Output Parameters -C -C N (input) INTEGER -C The order of the matrices A, G, and Q. N >= 0. -C -C A (input/output) DOUBLE PRECISION array, dimension (LDA,N) -C On input, the leading N-by-N part of this array must -C contain the upper left block A of the Hamiltonian matrix H -C in (1). -C On output, the leading N-by-N part of this array contains -C the upper left block A' of the square-reduced Hamiltonian -C matrix H' in (2). -C -C LDA INTEGER -C The leading dimension of the array A. LDA >= MAX(1,N). -C -C QG (input/output) DOUBLE PRECISION array, dimension -C (LDQG,N+1) -C On input, the leading N-by-N lower triangular part of this -C array must contain the lower triangle of the lower left -C symmetric block Q of the Hamiltonian matrix H in (1), and -C the N-by-N upper triangular part of the submatrix in the -C columns 2 to N+1 of this array must contain the upper -C triangle of the upper right symmetric block G of H in (1). -C So, if i >= j, then Q(i,j) = Q(j,i) is stored in QG(i,j) -C and G(i,j) = G(j,i) is stored in QG(j,i+1). -C On output, the leading N-by-N lower triangular part of -C this array contains the lower triangle of the lower left -C symmetric block Q', and the N-by-N upper triangular part -C of the submatrix in the columns 2 to N+1 of this array -C contains the upper triangle of the upper right symmetric -C block G' of the square-reduced Hamiltonian matrix H' -C in (2). -C -C LDQG INTEGER -C The leading dimension of the array QG. LDQG >= MAX(1,N). -C -C U (input/output) DOUBLE PRECISION array, dimension (LDU,2*N) -C If COMPU = 'N', then this array is not referenced. -C If COMPU = 'I' or 'F', then the input contents of this -C array are not specified. On output, the leading -C N-by-(2*N) part of this array contains the first N rows -C of the orthogonal symplectic matrix U in (3). -C If COMPU = 'V' or 'A', then, on input, the leading -C N-by-(2*N) part of this array must contain the first N -C rows of an orthogonal symplectic matrix S. On output, the -C leading N-by-(2*N) part of this array contains the first N -C rows of the product S*U where U is the orthogonal -C symplectic matrix from (3). -C The storage scheme implied by (3) is used for orthogonal -C symplectic matrices, i.e., only the first N rows are -C stored, as they contain all relevant information. -C -C LDU INTEGER -C The leading dimension of the array U. -C LDU >= MAX(1,N), if COMPU <> 'N'; -C LDU >= 1, if COMPU = 'N'. -C -C Workspace -C -C DWORK DOUBLE PRECISION array, dimension (2*N) -C -C Error Indicator -C -C INFO INTEGER -C = 0: successful exit; -C < 0: if INFO = -i, then the i-th argument had an illegal -C value. -C -C METHOD -C -C The Hamiltonian matrix H is transformed into a square-reduced -C Hamiltonian matrix H' using the implicit version of Van Loan's -C method as proposed in [1,2,3]. -C -C REFERENCES -C -C [1] Van Loan, C. F. -C A Symplectic Method for Approximating All the Eigenvalues of -C a Hamiltonian Matrix. -C Linear Algebra and its Applications, 61, pp. 233-251, 1984. -C -C [2] Byers, R. -C Hamiltonian and Symplectic Algorithms for the Algebraic -C Riccati Equation. -C Ph. D. Thesis, Cornell University, Ithaca, NY, January 1983. -C -C [3] Benner, P., Byers, R., and Barth, E. -C Fortran 77 Subroutines for Computing the Eigenvalues of -C Hamiltonian Matrices. I: The Square-Reduced Method. -C ACM Trans. Math. Software, 26, 1, pp. 49-77, 2000. -C -C NUMERICAL ASPECTS -C -C This algorithm requires approximately 20*N**3 flops for -C transforming H into square-reduced form. If the transformations -C are required, this adds another 8*N**3 flops. The method is -C strongly backward stable in the sense that if H' and U are the -C computed square-reduced Hamiltonian and computed orthogonal -C symplectic similarity transformation, then there is an orthogonal -C symplectic matrix T and a Hamiltonian matrix M such that -C -C H T = T M -C -C || T - U || <= c1 * eps -C -C || H' - M || <= c2 * eps * || H || -C -C where c1, c2 are modest constants depending on the dimension N and -C eps is the machine precision. -C -C Eigenvalues computed by explicitly forming the upper Hessenberg -C matrix A'' = A'A' + G'Q', with A', G', and Q' as in (2), and -C applying the Hessenberg QR iteration to A'' are exactly -C eigenvalues of a perturbed Hamiltonian matrix H + E, where -C -C || E || <= c3 * sqrt(eps) * || H ||, -C -C and c3 is a modest constant depending on the dimension N and eps -C is the machine precision. Moreover, if the norm of H and an -C eigenvalue lambda are of roughly the same magnitude, the computed -C eigenvalue is essentially as accurate as the computed eigenvalue -C from traditional methods. See [1] or [2]. -C -C CONTRIBUTOR -C -C P. Benner, Universitaet Bremen, Germany, -C R. Byers, University of Kansas, Lawrence, USA, and -C E. Barth, Kalamazoo College, Kalamazoo, USA, -C Aug. 1998, routine DHASRD. -C V. Sima, Research Institute for Informatics, Bucharest, Romania, -C Oct. 1998, SLICOT Library version. -C -C REVISIONS -C -C May 2001, A. Varga, German Aeropsce Center, DLR Oberpfaffenhofen. -C May 2009, V. Sima, Research Institute for Informatics, Bucharest. -C -C KEYWORDS -C -C Orthogonal transformation, (square-reduced) Hamiltonian matrix, -C symplectic similarity transformation. -C -C ****************************************************************** -C -C .. Parameters .. -C - DOUBLE PRECISION ZERO, ONE, TWO - PARAMETER ( ZERO = 0.0D0, ONE = 1.0D0, TWO = 2.0D0 ) -C -C .. Scalar Arguments .. - INTEGER INFO, LDA, LDQG, LDU, N - CHARACTER COMPU -C .. -C .. Array Arguments .. - DOUBLE PRECISION A(LDA,*), DWORK(*), QG(LDQG,*), U(LDU,*) -C .. -C .. Local Scalars .. - DOUBLE PRECISION COSINE, SINE, TAU, TEMP, X, Y - INTEGER J - LOGICAL ACCUM, FORGET, FORM -C .. -C .. Local Arrays .. - DOUBLE PRECISION DUMMY(1), T(2,2) -C .. -C .. External Functions .. - DOUBLE PRECISION DDOT - LOGICAL LSAME - EXTERNAL DDOT, LSAME -C .. -C .. External Subroutines .. - EXTERNAL DAXPY, DCOPY, DGEMV, DLARFG, DLARFX, DLARTG, - $ DROT, DSYMV, DSYR2, XERBLA -C .. -C .. Intrinsic Functions .. - INTRINSIC MAX -C .. -C .. Executable Statements .. -C - INFO = 0 - ACCUM = LSAME( COMPU, 'A' ) .OR. LSAME( COMPU, 'V' ) - FORM = LSAME( COMPU, 'F' ) .OR. LSAME( COMPU, 'I' ) - FORGET = LSAME( COMPU, 'N' ) -C - IF ( .NOT.ACCUM .AND. .NOT.FORM .AND. .NOT.FORGET ) THEN - INFO = -1 - ELSE IF( N.LT.0 ) THEN - INFO = -2 - ELSE IF( LDA.LT.MAX( 1, N ) ) THEN - INFO = -4 - ELSE IF( LDQG.LT.MAX( 1, N ) ) THEN - INFO = -6 - ELSE IF( LDU.LT.1 .OR. ( .NOT.FORGET .AND. LDU.LT.MAX( 1, N ) ) ) - $ THEN - INFO = -8 - END IF -C - IF ( INFO.NE.0 ) THEN - CALL XERBLA( 'MB04ZD', -INFO ) - RETURN - END IF -C -C Quick return if possible. -C - IF( N.EQ.0 ) - $ RETURN -C -C Transform to square-reduced form. -C - DO 10 J = 1, N - 1 -C T -C DWORK <- (Q*A - A *Q)(J+1:N,J). -C - CALL DCOPY( J-1, QG(J,1), LDQG, DWORK(N+1), 1 ) - CALL DCOPY( N-J+1, QG(J,J), 1, DWORK(N+J), 1 ) - CALL DGEMV( 'Transpose', N, N-J, -ONE, A(1,J+1), LDA, - $ DWORK(N+1), 1, ZERO, DWORK(J+1), 1 ) - CALL DGEMV( 'NoTranspose', N-J, J, ONE, QG(J+1,1), LDQG, - $ A(1,J), 1, ONE, DWORK(J+1), 1 ) - CALL DSYMV( 'Lower', N-J, ONE, QG(J+1,J+1), LDQG, A(J+1,J), 1, - $ ONE, DWORK(J+1), 1 ) -C -C Symplectic reflection to zero (H*H)((N+J+2):2N,J). -C - CALL DLARFG( N-J, DWORK(J+1), DWORK(J+2), 1, TAU ) - Y = DWORK(J+1) - DWORK(J+1) = ONE -C - CALL DLARFX( 'Left', N-J, N, DWORK(J+1), TAU, A(J+1,1), LDA, - $ DWORK(N+1) ) - CALL DLARFX( 'Right', N, N-J, DWORK(J+1), TAU, A(1,J+1), LDA, - $ DWORK(N+1) ) -C - CALL DLARFX( 'Left', N-J, J, DWORK(J+1), TAU, QG(J+1,1), LDQG, - $ DWORK(N+1) ) - CALL DSYMV( 'Lower', N-J, TAU, QG(J+1,J+1), LDQG, DWORK(J+1), - $ 1, ZERO, DWORK(N+J+1), 1 ) - CALL DAXPY( N-J, -TAU*DDOT( N-J, DWORK(N+J+1), 1, DWORK(J+1), - $ 1 )/TWO, DWORK(J+1), 1, DWORK(N+J+1), 1 ) - CALL DSYR2( 'Lower', N-J, -ONE, DWORK(J+1), 1, DWORK(N+J+1), 1, - $ QG(J+1,J+1), LDQG ) -C - CALL DLARFX( 'Right', J, N-J, DWORK(J+1), TAU, QG(1,J+2), LDQG, - $ DWORK(N+1) ) - CALL DSYMV( 'Upper', N-J, TAU, QG(J+1,J+2), LDQG, DWORK(J+1), - $ 1, ZERO, DWORK(N+J+1), 1 ) - CALL DAXPY( N-J, -TAU*DDOT( N-J, DWORK(N+J+1), 1, DWORK(J+1), - $ 1 )/TWO, DWORK(J+1), 1, DWORK(N+J+1), 1 ) - CALL DSYR2( 'Upper', N-J, -ONE, DWORK(J+1), 1, DWORK(N+J+1), 1, - $ QG(J+1,J+2), LDQG ) -C - IF ( FORM ) THEN -C -C Save reflection. -C - CALL DCOPY( N-J, DWORK(J+1), 1, U(J+1,J), 1 ) - U(J+1,J) = TAU -C - ELSE IF ( ACCUM ) THEN -C -C Accumulate reflection. -C - CALL DLARFX( 'Right', N, N-J, DWORK(J+1), TAU, U(1,J+1), - $ LDU, DWORK(N+1) ) - CALL DLARFX( 'Right', N, N-J, DWORK(J+1), TAU, U(1,N+J+1), - $ LDU, DWORK(N+1) ) - END IF -C -C (X,Y) := ((J+1,J),(N+J+1,J)) component of H*H. -C - X = DDOT( J, QG(1,J+2), 1, QG(J,1), LDQG ) + - $ DDOT( N-J, QG(J+1,J+2), LDQG, QG(J+1,J), 1 ) + - $ DDOT( N, A(J+1,1), LDA, A(1,J), 1 ) -C -C Symplectic rotation to zero (H*H)(N+J+1,J). -C - CALL DLARTG( X, Y, COSINE, SINE, TEMP ) -C - CALL DROT( J, A(J+1,1), LDA, QG(J+1,1), LDQG, COSINE, SINE ) - CALL DROT( J, A(1,J+1), 1, QG(1,J+2), 1, COSINE, SINE ) - IF( J.LT.N-1 ) THEN - CALL DROT( N-J-1, A(J+1,J+2), LDA, QG(J+2,J+1), 1, - $ COSINE, SINE ) - CALL DROT( N-J-1, A(J+2,J+1), 1, QG(J+1,J+3), LDQG, - $ COSINE, SINE ) - END IF -C - T(1,1) = A(J+1,J+1) - T(1,2) = QG(J+1,J+2) - T(2,1) = QG(J+1,J+1) - T(2,2) = -T(1,1) - CALL DROT( 2, T(1,1), 1, T(1,2), 1, COSINE, SINE ) - CALL DROT( 2, T(1,1), 2, T(2,1), 2, COSINE, SINE ) - A(J+1,J+1) = T(1,1) - QG(J+1,J+2) = T(1,2) - QG(J+1,J+1) = T(2,1) -C - IF ( FORM ) THEN -C -C Save rotation. -C - U(J,J) = COSINE - U(J,N+J) = SINE -C - ELSE IF ( ACCUM ) THEN -C -C Accumulate rotation. -C - CALL DROT( N, U(1,J+1), 1, U(1,N+J+1), 1, COSINE, SINE ) - END IF -C -C DWORK := (A*A + G*Q)(J+1:N,J). -C - CALL DGEMV( 'NoTranspose', N-J, N, ONE, A(J+1,1), LDA, A(1,J), - $ 1, ZERO, DWORK(J+1), 1 ) - CALL DGEMV( 'Transpose', J, N-J, ONE, QG(1,J+2), LDQG, QG(J,1), - $ LDQG, ONE, DWORK(J+1), 1 ) - CALL DSYMV( 'Upper', N-J, ONE, QG(J+1,J+2), LDQG, QG(J+1,J), 1, - $ ONE, DWORK(J+1), 1 ) -C -C Symplectic reflection to zero (H*H)(J+2:N,J). -C - CALL DLARFG( N-J, DWORK(J+1), DWORK(J+2), 1, TAU ) - DWORK(J+1) = ONE -C - CALL DLARFX( 'Left', N-J, N, DWORK(J+1), TAU, A(J+1,1), LDA, - $ DWORK(N+1) ) - CALL DLARFX( 'Right', N, N-J, DWORK(J+1), TAU, A(1,J+1), LDA, - $ DWORK(N+1) ) -C - CALL DLARFX( 'Left', N-J, J, DWORK(J+1), TAU, QG(J+1,1), LDQG, - $ DWORK(N+1) ) - CALL DSYMV( 'Lower', N-J, TAU, QG(J+1,J+1), LDQG, DWORK(J+1), - $ 1, ZERO, DWORK(N+J+1), 1 ) - CALL DAXPY( N-J, -TAU*DDOT( N-J, DWORK(N+J+1), 1, DWORK(J+1), - $ 1 )/TWO, DWORK(J+1), 1, DWORK(N+J+1), 1 ) - CALL DSYR2( 'Lower', N-J, -ONE, DWORK(J+1), 1, DWORK(N+J+1), 1, - $ QG(J+1,J+1), LDQG ) -C - CALL DLARFX( 'Right', J, N-J, DWORK(J+1), TAU, QG(1,J+2), LDQG, - $ DWORK(N+1) ) - CALL DSYMV( 'Upper', N-J, TAU, QG(J+1,J+2), LDQG, DWORK(J+1), - $ 1, ZERO, DWORK(N+J+1), 1 ) - CALL DAXPY( N-J, -TAU*DDOT( N-J, DWORK(N+J+1), 1, DWORK(J+1), - $ 1 )/TWO, DWORK(J+1), 1, DWORK(N+J+1), 1 ) - CALL DSYR2( 'Upper', N-J, -ONE, DWORK(J+1), 1, DWORK(N+J+1), 1, - $ QG(J+1,J+2), LDQG ) -C - IF ( FORM ) THEN -C -C Save reflection. -C - CALL DCOPY( N-J, DWORK(J+1), 1, U(J+1,N+J), 1 ) - U(J+1,N+J) = TAU -C - ELSE IF ( ACCUM ) THEN -C -C Accumulate reflection. -C - CALL DLARFX( 'Right', N, N-J, DWORK(J+1), TAU, U(1,J+1), - $ LDU, DWORK(N+1) ) - CALL DLARFX( 'Right', N, N-J, DWORK(J+1), TAU, U(1,N+J+1), - $ LDU, DWORK(N+1) ) - END IF -C - 10 CONTINUE -C - IF ( FORM ) THEN - DUMMY(1) = ZERO -C -C Form S by accumulating transformations. -C - DO 20 J = N - 1, 1, -1 -C -C Initialize (J+1)st column of S. -C - CALL DCOPY( N, DUMMY, 0, U(1,J+1), 1 ) - U(J+1,J+1) = ONE - CALL DCOPY( N, DUMMY, 0, U(1,N+J+1), 1 ) -C -C Second reflection. -C - TAU = U(J+1,N+J) - U(J+1,N+J) = ONE - CALL DLARFX( 'Left', N-J, N-J, U(J+1,N+J), TAU, - $ U(J+1,J+1), LDU, DWORK(N+1) ) - CALL DLARFX( 'Left', N-J, N-J, U(J+1,N+J), TAU, - $ U(J+1,N+J+1), LDU, DWORK(N+1) ) -C -C Rotation. -C - CALL DROT( N-J, U(J+1,J+1), LDU, U(J+1,N+J+1), LDU, - $ U(J,J), U(J,N+J) ) -C -C First reflection. -C - TAU = U(J+1,J) - U(J+1,J) = ONE - CALL DLARFX( 'Left', N-J, N-J, U(J+1,J), TAU, U(J+1,J+1), - $ LDU, DWORK(N+1) ) - CALL DLARFX( 'Left', N-J, N-J, U(J+1,J), TAU, - $ U(J+1,N+J+1), LDU, DWORK(N+1) ) - 20 CONTINUE -C -C The first column is the first column of identity. -C - CALL DCOPY( N, DUMMY, 0, U, 1 ) - U(1,1) = ONE - CALL DCOPY( N, DUMMY, 0, U(1,N+1), 1 ) - END IF -C - RETURN -C *** Last line of MB04ZD *** - END diff --git a/mex/sources/libslicot/MB05MD.f b/mex/sources/libslicot/MB05MD.f deleted file mode 100644 index 58da11528..000000000 --- a/mex/sources/libslicot/MB05MD.f +++ /dev/null @@ -1,356 +0,0 @@ - SUBROUTINE MB05MD( BALANC, N, DELTA, A, LDA, V, LDV, Y, LDY, VALR, - $ VALI, IWORK, DWORK, LDWORK, INFO ) -C -C SLICOT RELEASE 5.0. -C -C Copyright (c) 2002-2009 NICONET e.V. -C -C This program is free software: you can redistribute it and/or -C modify it under the terms of the GNU General Public License as -C published by the Free Software Foundation, either version 2 of -C the License, or (at your option) any later version. -C -C This program is distributed in the hope that it will be useful, -C but WITHOUT ANY WARRANTY; without even the implied warranty of -C MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the -C GNU General Public License for more details. -C -C You should have received a copy of the GNU General Public License -C along with this program. If not, see -C . -C -C PURPOSE -C -C To compute exp(A*delta) where A is a real N-by-N non-defective -C matrix with real or complex eigenvalues and delta is a scalar -C value. The routine also returns the eigenvalues and eigenvectors -C of A as well as (if all eigenvalues are real) the matrix product -C exp(Lambda*delta) times the inverse of the eigenvector matrix -C of A, where Lambda is the diagonal matrix of eigenvalues. -C Optionally, the routine computes a balancing transformation to -C improve the conditioning of the eigenvalues and eigenvectors. -C -C ARGUMENTS -C -C Mode Parameters -C -C BALANC CHARACTER*1 -C Indicates how the input matrix should be diagonally scaled -C to improve the conditioning of its eigenvalues as follows: -C = 'N': Do not diagonally scale; -C = 'S': Diagonally scale the matrix, i.e. replace A by -C D*A*D**(-1), where D is a diagonal matrix chosen -C to make the rows and columns of A more equal in -C norm. Do not permute. -C -C Input/Output Parameters -C -C N (input) INTEGER -C The order of the matrix A. N >= 0. -C -C DELTA (input) DOUBLE PRECISION -C The scalar value delta of the problem. -C -C A (input/output) DOUBLE PRECISION array, dimension (LDA,N) -C On entry, the leading N-by-N part of this array must -C contain the matrix A of the problem. -C On exit, the leading N-by-N part of this array contains -C the solution matrix exp(A*delta). -C -C LDA INTEGER -C The leading dimension of array A. LDA >= max(1,N). -C -C V (output) DOUBLE PRECISION array, dimension (LDV,N) -C The leading N-by-N part of this array contains the -C eigenvector matrix for A. -C If the k-th eigenvalue is real the k-th column of the -C eigenvector matrix holds the eigenvector corresponding -C to the k-th eigenvalue. -C Otherwise, the k-th and (k+1)-th eigenvalues form a -C complex conjugate pair and the k-th and (k+1)-th columns -C of the eigenvector matrix hold the real and imaginary -C parts of the eigenvectors corresponding to these -C eigenvalues as follows. -C If p and q denote the k-th and (k+1)-th columns of the -C eigenvector matrix, respectively, then the eigenvector -C corresponding to the complex eigenvalue with positive -C (negative) imaginary value is given by -C 2 -C p + q*j (p - q*j), where j = -1. -C -C LDV INTEGER -C The leading dimension of array V. LDV >= max(1,N). -C -C Y (output) DOUBLE PRECISION array, dimension (LDY,N) -C The leading N-by-N part of this array contains an -C intermediate result for computing the matrix exponential. -C Specifically, exp(A*delta) is obtained as the product V*Y, -C where V is the matrix stored in the leading N-by-N part of -C the array V. If all eigenvalues of A are real, then the -C leading N-by-N part of this array contains the matrix -C product exp(Lambda*delta) times the inverse of the (right) -C eigenvector matrix of A, where Lambda is the diagonal -C matrix of eigenvalues. -C -C LDY INTEGER -C The leading dimension of array Y. LDY >= max(1,N). -C -C VALR (output) DOUBLE PRECISION array, dimension (N) -C VALI (output) DOUBLE PRECISION array, dimension (N) -C These arrays contain the real and imaginary parts, -C respectively, of the eigenvalues of the matrix A. The -C eigenvalues are unordered except that complex conjugate -C pairs of values appear consecutively with the eigenvalue -C having positive imaginary part first. -C -C Workspace -C -C IWORK INTEGER array, dimension (N) -C -C DWORK DOUBLE PRECISION array, dimension (LDWORK) -C On exit, if INFO = 0, DWORK(1) returns the optimal value -C of LDWORK, and if N > 0, DWORK(2) returns the reciprocal -C condition number of the triangular matrix used to obtain -C the inverse of the eigenvector matrix. -C -C LDWORK INTEGER -C The length of the array DWORK. LDWORK >= max(1,4*N). -C For good performance, LDWORK must generally be larger. -C -C Error Indicator -C -C INFO INTEGER -C = 0: successful exit; -C < 0: if INFO = -i, the i-th argument had an illegal -C value; -C = i: if INFO = i, the QR algorithm failed to compute all -C the eigenvalues; no eigenvectors have been computed; -C elements i+1:N of VALR and VALI contain eigenvalues -C which have converged; -C = N+1: if the inverse of the eigenvector matrix could not -C be formed due to an attempt to divide by zero, i.e., -C the eigenvector matrix is singular; -C = N+2: if the matrix A is defective, possibly due to -C rounding errors. -C -C METHOD -C -C This routine is an implementation of "Method 15" of the set of -C methods described in reference [1], which uses an eigenvalue/ -C eigenvector decomposition technique. A modification of LAPACK -C Library routine DGEEV is used for obtaining the right eigenvector -C matrix. A condition estimate is then employed to determine if the -C matrix A is near defective and hence the exponential solution is -C inaccurate. In this case the routine returns with the Error -C Indicator (INFO) set to N+2, and SLICOT Library routines MB05ND or -C MB05OD are the preferred alternative routines to be used. -C -C REFERENCES -C -C [1] Moler, C.B. and Van Loan, C.F. -C Nineteen dubious ways to compute the exponential of a matrix. -C SIAM Review, 20, pp. 801-836, 1978. -C -C [2] Anderson, E., Bai, Z., Bischof, C., Demmel, J., Dongarra, J., -C Du Croz, J., Greenbaum, A., Hammarling, S., McKenney, A., -C Ostrouchov, S., and Sorensen, D. -C LAPACK Users' Guide: Second Edition. -C SIAM, Philadelphia, 1995. -C -C NUMERICAL ASPECTS -C 3 -C The algorithm requires 0(N ) operations. -C -C CONTRIBUTOR -C -C Release 3.0: V. Sima, Katholieke Univ. Leuven, Belgium, Apr. 1997. -C Supersedes Release 2.0 routine MB05AD by M.J. Denham, Kingston -C Polytechnic, March 1981. -C -C REVISIONS -C -C V. Sima, June 13, 1997, April 25, 2003, Feb. 15, 2004. -C -C KEYWORDS -C -C Eigenvalue, eigenvector decomposition, matrix exponential. -C -C ****************************************************************** -C -C .. Parameters .. - DOUBLE PRECISION ZERO, ONE - PARAMETER ( ZERO = 0.0D0, ONE = 1.0D0 ) -C .. Scalar Arguments .. - CHARACTER BALANC - INTEGER INFO, LDA, LDV, LDWORK, LDY, N - DOUBLE PRECISION DELTA -C .. Array Arguments .. - INTEGER IWORK(*) - DOUBLE PRECISION A(LDA,*), DWORK(*), V(LDV,*), VALI(*), VALR(*), - $ Y(LDY,*) -C .. Local Scalars .. - LOGICAL SCALE - INTEGER I - DOUBLE PRECISION RCOND, TEMPI, TEMPR, WRKOPT -C .. Local Arrays .. - DOUBLE PRECISION TMP(2,2) -C .. External Functions .. - LOGICAL LSAME - DOUBLE PRECISION DLAMCH - EXTERNAL DLAMCH, LSAME -C .. External Subroutines .. - EXTERNAL DGEBAK, DGEMM, DLACPY, DSCAL, DSWAP, DTRCON, - $ DTRMM, DTRSM, MB05MY, XERBLA -C .. Intrinsic Functions .. - INTRINSIC COS, EXP, MAX, SIN -C .. Executable Statements .. -C -C Test the input scalar arguments. -C - INFO = 0 - SCALE = LSAME( BALANC, 'S' ) - IF( .NOT.( LSAME( BALANC, 'N' ) .OR. SCALE ) ) THEN - INFO = -1 - ELSE IF( N.LT.0 ) THEN - INFO = -2 - ELSE IF( LDA.LT.MAX( 1, N ) ) THEN - INFO = -5 - ELSE IF( LDV.LT.MAX( 1, N ) ) THEN - INFO = -7 - ELSE IF( LDY.LT.MAX( 1, N ) ) THEN - INFO = -9 - ELSE IF( LDWORK.LT.MAX( 1, 4*N ) ) THEN - INFO = -14 - END IF -C - IF ( INFO.NE.0 ) THEN -C -C Error return. -C - CALL XERBLA( 'MB05MD', -INFO ) - RETURN - END IF -C -C Quick return if possible. -C - IF ( N.EQ.0 ) THEN - DWORK(1) = ONE - RETURN - END IF -C -C (Note: Comments in the code beginning "Workspace:" describe the -C minimal amount of workspace needed at that point in the code, -C as well as the preferred amount for good performance. -C NB refers to the optimal block size for the immediately -C following subroutine, as returned by ILAENV.) -C -C Compute the eigenvalues and right eigenvectors of the real -C nonsymmetric matrix A; optionally, compute a balancing -C transformation. -C Workspace: need: 4*N. -C - CALL MB05MY( BALANC, N, A, LDA, VALR, VALI, V, LDV, Y, LDY, - $ DWORK, LDWORK, INFO ) -C - IF ( INFO.GT.0 ) - $ RETURN - WRKOPT = DWORK(1) - IF ( SCALE ) THEN - DO 10 I = 1, N - DWORK(I) = DWORK(I+1) - 10 CONTINUE - END IF -C -C Exit with INFO = N + 1 if V is exactly singular. -C - DO 20 I = 1, N - IF ( V(I,I).EQ.ZERO ) THEN - INFO = N + 1 - RETURN - END IF - 20 CONTINUE -C -C Compute the reciprocal condition number of the triangular matrix. -C - CALL DTRCON( '1-norm', 'Upper', 'Non unit', N, V, LDV, RCOND, - $ DWORK(N+1), IWORK, INFO ) -C -C Return if the matrix is singular to working precision. -C - IF( RCOND.LT.DLAMCH( 'Epsilon' ) ) THEN - DWORK(2) = RCOND - INFO = N + 2 - RETURN - END IF -C -C Compute the right eigenvector matrix (temporarily) in A. -C - CALL DLACPY( 'Full', N, N, Y, LDY, A, LDA ) - CALL DTRMM( 'Right', 'Upper', 'No transpose', 'Non unit', N, N, - $ ONE, V, LDV, A, LDA ) - IF ( SCALE ) - $ CALL DGEBAK( BALANC, 'Right', N, 1, N, DWORK, N, A, LDA, INFO ) -C -C Compute the inverse of the right eigenvector matrix, by solving -C a set of linear systems, V * X = Y' (if BALANC = 'N'). -C - DO 40 I = 2, N - CALL DSWAP( I-1, Y(I,1), LDY, Y(1,I), 1 ) - 40 CONTINUE -C - CALL DTRSM( 'Left', 'Upper', 'No transpose', 'Non unit', N, N, - $ ONE, V, LDV, Y, LDY ) - IF( SCALE ) THEN -C - DO 60 I = 1, N - TEMPR = ONE / DWORK(I) - CALL DSCAL( N, TEMPR, Y(1,I), 1 ) - 60 CONTINUE -C - END IF -C -C Save the right eigenvector matrix in V. -C - CALL DLACPY( 'Full', N, N, A, LDA, V, LDV ) -C -C Premultiply the inverse eigenvector matrix by the exponential of -C quasi-diagonal matrix Lambda * DELTA, where Lambda is the matrix -C of eigenvalues. -C Note that only real arithmetic is used, taking the special storing -C of eigenvalues/eigenvectors into account. -C - I = 0 -C REPEAT - 80 CONTINUE - I = I + 1 - IF ( VALI(I).EQ.ZERO ) THEN - TEMPR = EXP( VALR(I)*DELTA ) - CALL DSCAL( N, TEMPR, Y(I,1), LDY ) - ELSE - TEMPR = VALR(I)*DELTA - TEMPI = VALI(I)*DELTA - TMP(1,1) = COS( TEMPI )*EXP( TEMPR ) - TMP(1,2) = SIN( TEMPI )*EXP( TEMPR ) - TMP(2,1) = -TMP(1,2) - TMP(2,2) = TMP(1,1) - CALL DLACPY( 'Full', 2, N, Y(I,1), LDY, DWORK, 2 ) - CALL DGEMM( 'No transpose', 'No transpose', 2, N, 2, ONE, - $ TMP, 2, DWORK, 2, ZERO, Y(I,1), LDY ) - I = I + 1 - END IF - IF ( I.LT.N ) GO TO 80 -C UNTIL I = N. -C -C Compute the matrix exponential as the product V * Y. -C - CALL DGEMM( 'No transpose', 'No transpose', N, N, N, ONE, V, LDV, - $ Y, LDY, ZERO, A, LDA ) -C -C Set optimal workspace dimension and reciprocal condition number. -C - DWORK(1) = WRKOPT - DWORK(2) = RCOND -C - RETURN -C *** Last line of MB05MD *** - END diff --git a/mex/sources/libslicot/MB05MY.f b/mex/sources/libslicot/MB05MY.f deleted file mode 100644 index 7d7063494..000000000 --- a/mex/sources/libslicot/MB05MY.f +++ /dev/null @@ -1,327 +0,0 @@ - SUBROUTINE MB05MY( BALANC, N, A, LDA, WR, WI, R, LDR, Q, LDQ, - $ DWORK, LDWORK, INFO ) -C -C SLICOT RELEASE 5.0. -C -C Copyright (c) 2002-2009 NICONET e.V. -C -C This program is free software: you can redistribute it and/or -C modify it under the terms of the GNU General Public License as -C published by the Free Software Foundation, either version 2 of -C the License, or (at your option) any later version. -C -C This program is distributed in the hope that it will be useful, -C but WITHOUT ANY WARRANTY; without even the implied warranty of -C MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the -C GNU General Public License for more details. -C -C You should have received a copy of the GNU General Public License -C along with this program. If not, see -C . -C -C PURPOSE -C -C To compute, for an N-by-N real nonsymmetric matrix A, the -C orthogonal matrix Q reducing it to real Schur form T, the -C eigenvalues, and the right eigenvectors of T. -C -C The right eigenvector r(j) of T satisfies -C T * r(j) = lambda(j) * r(j) -C where lambda(j) is its eigenvalue. -C -C The matrix of right eigenvectors R is upper triangular, by -C construction. -C -C ARGUMENTS -C -C Mode Parameters -C -C BALANC CHARACTER*1 -C Indicates how the input matrix should be diagonally scaled -C to improve the conditioning of its eigenvalues as follows: -C = 'N': Do not diagonally scale; -C = 'S': Diagonally scale the matrix, i.e. replace A by -C D*A*D**(-1), where D is a diagonal matrix chosen -C to make the rows and columns of A more equal in -C norm. Do not permute. -C -C Input/Output Parameters -C -C N (input) INTEGER -C The order of the matrix A. N >= 0. -C -C A (input/output) DOUBLE PRECISION array, dimension (LDA,N) -C On entry, the leading N-by-N part of this array must -C contain the given matrix A. -C On exit, the leading N-by-N upper quasi-triangular part of -C this array contains the real Schur canonical form of A. -C -C LDA INTEGER -C The leading dimension of array A. LDA >= max(1,N). -C -C WR (output) DOUBLE PRECISION array, dimension (N) -C WI (output) DOUBLE PRECISION array, dimension (N) -C WR and WI contain the real and imaginary parts, -C respectively, of the computed eigenvalues. Complex -C conjugate pairs of eigenvalues appear consecutively -C with the eigenvalue having the positive imaginary part -C first. -C -C R (output) DOUBLE PRECISION array, dimension (LDR,N) -C The leading N-by-N upper triangular part of this array -C contains the matrix of right eigenvectors R, in the same -C order as their eigenvalues. The real and imaginary parts -C of a complex eigenvector corresponding to an eigenvalue -C with positive imaginary part are stored in consecutive -C columns. (The corresponding conjugate eigenvector is not -C stored.) The eigenvectors are not backward transformed -C for balancing (when BALANC = 'S'). -C -C LDR INTEGER -C The leading dimension of array R. LDR >= max(1,N). -C -C Q (output) DOUBLE PRECISION array, dimension (LDQ,N) -C The leading N-by-N part of this array contains the -C orthogonal matrix Q which has reduced A to real Schur -C form. -C -C LDQ INTEGER -C The leading dimension of array Q. LDQ >= MAX(1,N). -C -C Workspace -C -C DWORK DOUBLE PRECISION array, dimension (LDWORK) -C On exit, if INFO = 0, DWORK(1) returns the optimal LDWORK. -C If BALANC = 'S', DWORK(2),...,DWORK(N+1) return the -C scaling factors used for balancing. -C -C LDWORK INTEGER -C The length of the array DWORK. LDWORK >= max(1,4*N). -C For good performance, LDWORK must generally be larger. -C -C Error Indicator -C -C INFO INTEGER -C = 0: successful exit; -C < 0: if INFO = -i, the i-th argument had an illegal -C value; -C > 0: if INFO = i, the QR algorithm failed to compute all -C the eigenvalues, and no eigenvectors have been -C computed; elements i+1:N of WR and WI contain -C eigenvalues which have converged. -C -C METHOD -C -C This routine uses the QR algorithm to obtain the real Schur form -C T of matrix A. Then, the right eigenvectors of T are computed, -C but they are not backtransformed into the eigenvectors of A. -C MB05MY is a modification of the LAPACK driver routine DGEEV. -C -C REFERENCES -C -C [1] Anderson, E., Bai, Z., Bischof, C., Demmel, J., Dongarra, J., -C Du Croz, J., Greenbaum, A., Hammarling, S., McKenney, A., -C Ostrouchov, S., and Sorensen, D. -C LAPACK Users' Guide: Second Edition. -C SIAM, Philadelphia, 1995. -C -C NUMERICAL ASPECTS -C 3 -C The algorithm requires 0(N ) operations. -C -C CONTRIBUTOR -C -C Release 3.0: V. Sima, Katholieke Univ. Leuven, Belgium, Apr. 1997. -C Supersedes Release 2.0 routine MB05AY. -C -C REVISIONS -C -C V. Sima, April 25, 2003, Feb. 15, 2004. -C -C KEYWORDS -C -C Eigenvalue, eigenvector decomposition, real Schur form. -C -C ****************************************************************** -C -C .. Parameters .. - DOUBLE PRECISION ZERO, ONE - PARAMETER ( ZERO = 0.0D0, ONE = 1.0D0 ) -C .. Scalar Arguments .. - CHARACTER BALANC - INTEGER INFO, LDA, LDQ, LDR, LDWORK, N -C .. -C .. Array Arguments .. - DOUBLE PRECISION A( LDA, * ), DWORK( * ), Q( LDQ, * ), - $ R( LDR, * ), WI( * ), WR( * ) -C .. -C .. Local Scalars .. - LOGICAL SCALE, SCALEA - INTEGER HSDWOR, IBAL, IERR, IHI, ILO, ITAU, JWORK, K, - $ MAXB, MAXWRK, MINWRK, NOUT - DOUBLE PRECISION ANRM, BIGNUM, CSCALE, EPS, SMLNUM -C .. -C .. Local Arrays .. - LOGICAL SELECT( 1 ) - DOUBLE PRECISION DUM( 1 ) -C .. -C .. External Functions .. - LOGICAL LSAME - INTEGER ILAENV - DOUBLE PRECISION DLAMCH, DLANGE - EXTERNAL DLAMCH, DLANGE, ILAENV, LSAME -C .. -C .. External Subroutines .. - EXTERNAL DGEBAL, DGEHRD, DHSEQR, DLABAD, DLACPY, DLASCL, - $ DORGHR, DTREVC, XERBLA -C .. -C .. Intrinsic Functions .. - INTRINSIC MAX, MIN, SQRT -C .. -C .. Executable Statements .. -C -C Test the input scalar arguments. -C - INFO = 0 - SCALE = LSAME( BALANC, 'S' ) - IF( .NOT.( LSAME( BALANC, 'N' ) .OR. SCALE ) ) THEN - INFO = -1 - ELSE IF( N.LT.0 ) THEN - INFO = -2 - ELSE IF( LDA.LT.MAX( 1, N ) ) THEN - INFO = -4 - ELSE IF( LDR.LT.MAX( 1, N ) ) THEN - INFO = -8 - ELSE IF( LDQ.LT.MAX( 1, N ) ) THEN - INFO = -10 - END IF -C -C Compute workspace. -C (Note: Comments in the code beginning "Workspace:" describe the -C minimal amount of workspace needed at that point in the code, -C as well as the preferred amount for good performance. -C NB refers to the optimal block size for the immediately -C following subroutine, as returned by ILAENV. -C HSDWOR refers to the workspace preferred by DHSEQR, as -C calculated below. HSDWOR is computed assuming ILO=1 and IHI=N, -C the worst case.) -C - MINWRK = 1 - IF( INFO.EQ.0 .AND. LDWORK.GE.1 ) THEN - MAXWRK = 2*N + N*ILAENV( 1, 'DGEHRD', ' ', N, 1, N, 0 ) - MINWRK = MAX( 1, 4*N ) - MAXWRK = MAX( MAXWRK, 2*N+( N-1 )* - $ ILAENV( 1, 'DORGHR', ' ', N, 1, N, -1 ) ) - MAXB = MAX( ILAENV( 8, 'DHSEQR', 'SV', N, 1, N, -1 ), 2 ) - K = MIN( MAXB, N, MAX( 2, ILAENV( 4, 'DHSEQR', 'SV', N, 1, - $ N, -1 ) ) ) - HSDWOR = MAX( K*( K+2 ), 2*N ) - MAXWRK = MAX( MAXWRK, N+1, N+HSDWOR ) - MAXWRK = MAX( MAXWRK, 4*N ) - DWORK( 1 ) = MAXWRK - END IF - IF( LDWORK.LT.MINWRK ) THEN - INFO = -12 - END IF - IF( INFO.NE.0 ) THEN - CALL XERBLA( 'MB05MY', -INFO ) - RETURN - END IF -C -C Quick return if possible. -C - IF( N.EQ.0 ) - $ RETURN -C -C Get machine constants. -C - EPS = DLAMCH( 'P' ) - SMLNUM = DLAMCH( 'S' ) - BIGNUM = ONE / SMLNUM - CALL DLABAD( SMLNUM, BIGNUM ) - SMLNUM = SQRT( SMLNUM ) / EPS - BIGNUM = ONE / SMLNUM -C -C Scale A if max element outside range [SMLNUM,BIGNUM]. -C - ANRM = DLANGE( 'M', N, N, A, LDA, DUM ) - SCALEA = .FALSE. - IF( ANRM.GT.ZERO .AND. ANRM.LT.SMLNUM ) THEN - SCALEA = .TRUE. - CSCALE = SMLNUM - ELSE IF( ANRM.GT.BIGNUM ) THEN - SCALEA = .TRUE. - CSCALE = BIGNUM - END IF - IF( SCALEA ) - $ CALL DLASCL( 'G', 0, 0, ANRM, CSCALE, N, N, A, LDA, IERR ) -C -C Balance the matrix, if requested. (Permutation is not possible.) -C (Workspace: need N) -C - IBAL = 1 - CALL DGEBAL( BALANC, N, A, LDA, ILO, IHI, DWORK( IBAL ), IERR ) -C -C Reduce to upper Hessenberg form. -C (Workspace: need 3*N, prefer 2*N+N*NB) -C - ITAU = IBAL + N - JWORK = ITAU + N - CALL DGEHRD( N, ILO, IHI, A, LDA, DWORK( ITAU ), DWORK( JWORK ), - $ LDWORK-JWORK+1, IERR ) -C -C Compute right eigenvectors of T. -C Copy Householder vectors to Q. -C - CALL DLACPY( 'Lower', N, N, A, LDA, Q, LDQ ) -C -C Generate orthogonal matrix in Q. -C (Workspace: need 3*N-1, prefer 2*N+(N-1)*NB) -C - CALL DORGHR( N, ILO, IHI, Q, LDQ, DWORK( ITAU ), DWORK( JWORK ), - $ LDWORK-JWORK+1, IERR ) -C -C Perform QR iteration, accumulating Schur vectors in Q. -C (Workspace: need N+1, prefer N+HSDWOR (see comments) ) -C - JWORK = ITAU - CALL DHSEQR( 'S', 'V', N, ILO, IHI, A, LDA, WR, WI, Q, LDQ, - $ DWORK( JWORK ), LDWORK-JWORK+1, INFO ) -C -C If INFO > 0 from DHSEQR, then quit. -C - IF( INFO.GT.0 ) - $ GO TO 10 -C -C Compute right eigenvectors of T in R. -C (Workspace: need 4*N) -C - CALL DTREVC( 'Right', 'All', SELECT, N, A, LDA, DUM, 1, R, LDR, N, - $ NOUT, DWORK( JWORK ), IERR ) -C -C Undo scaling if necessary. -C - 10 CONTINUE - IF( SCALEA ) THEN - CALL DLASCL( 'G', 0, 0, CSCALE, ANRM, N-INFO, 1, WR( INFO+1 ), - $ MAX( N-INFO, 1 ), IERR ) - CALL DLASCL( 'G', 0, 0, CSCALE, ANRM, N-INFO, 1, WI( INFO+1 ), - $ MAX( N-INFO, 1 ), IERR ) - IF( INFO.GT.0 ) THEN - CALL DLASCL( 'G', 0, 0, CSCALE, ANRM, ILO-1, 1, WR, N, - $ IERR ) - CALL DLASCL( 'G', 0, 0, CSCALE, ANRM, ILO-1, 1, WI, N, - $ IERR ) - END IF - END IF -C - IF ( SCALE ) THEN - DO 20 K = N, 1, -1 - DWORK( K+1 ) = DWORK( K ) - 20 CONTINUE - END IF - DWORK( 1 ) = MAXWRK -C - RETURN -C *** Last line of MB05MY *** - END diff --git a/mex/sources/libslicot/MB05ND.f b/mex/sources/libslicot/MB05ND.f deleted file mode 100644 index 37bbe61a6..000000000 --- a/mex/sources/libslicot/MB05ND.f +++ /dev/null @@ -1,377 +0,0 @@ - SUBROUTINE MB05ND( N, DELTA, A, LDA, EX, LDEX, EXINT, LDEXIN, - $ TOL, IWORK, DWORK, LDWORK, INFO ) -C -C SLICOT RELEASE 5.0. -C -C Copyright (c) 2002-2009 NICONET e.V. -C -C This program is free software: you can redistribute it and/or -C modify it under the terms of the GNU General Public License as -C published by the Free Software Foundation, either version 2 of -C the License, or (at your option) any later version. -C -C This program is distributed in the hope that it will be useful, -C but WITHOUT ANY WARRANTY; without even the implied warranty of -C MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the -C GNU General Public License for more details. -C -C You should have received a copy of the GNU General Public License -C along with this program. If not, see -C . -C -C PURPOSE -C -C To compute -C -C (a) F(delta) = exp(A*delta) and -C -C (b) H(delta) = Int[F(s) ds] from s = 0 to s = delta, -C -C where A is a real N-by-N matrix and delta is a scalar value. -C -C ARGUMENTS -C -C Input/Output Parameters -C -C N (input) INTEGER -C The order of the matrix A. N >= 0. -C -C DELTA (input) DOUBLE PRECISION -C The scalar value delta of the problem. -C -C A (input) DOUBLE PRECISION array, dimension (LDA,N) -C The leading N-by-N part of this array must contain the -C matrix A of the problem. (Array A need not be set if -C DELTA = 0.) -C -C LDA INTEGER -C The leading dimension of array A. LDA >= max(1,N). -C -C EX (output) DOUBLE PRECISION array, dimension (LDEX,N) -C The leading N-by-N part of this array contains an -C approximation to F(delta). -C -C LDEX INTEGER -C The leading dimension of array EX. LDEX >= MAX(1,N). -C -C EXINT (output) DOUBLE PRECISION array, dimension (LDEXIN,N) -C The leading N-by-N part of this array contains an -C approximation to H(delta). -C -C LDEXIN INTEGER -C The leading dimension of array EXINT. LDEXIN >= MAX(1,N). -C -C Tolerances -C -C TOL DOUBLE PRECISION -C The tolerance to be used in determining the order of the -C Pade approximation to H(t), where t is a scale factor -C determined by the routine. A reasonable value for TOL may -C be SQRT(EPS), where EPS is the machine precision (see -C LAPACK Library routine DLAMCH). -C -C Workspace -C -C IWORK INTEGER array, dimension (N) -C -C DWORK DOUBLE PRECISION array, dimension (LDWORK) -C On exit, if INFO = 0, DWORK(1) returns the optimal value -C of LDWORK. -C -C LDWORK INTEGER -C The length of the array DWORK. LDWORK >= MAX(1,N*(N+1)). -C For optimum performance LDWORK should be larger (2*N*N). -C -C Error Indicator -C -C INFO INTEGER -C = 0: successful exit; -C < 0: if INFO = -i, the i-th argument had an illegal -C value; -C > 0: if INFO = i, the (i,i) element of the denominator of -C the Pade approximation is zero, so the denominator -C is exactly singular; -C = N+1: if DELTA = (delta * frobenius norm of matrix A) is -C probably too large to permit meaningful computation. -C That is, DELTA > SQRT(BIG), where BIG is a -C representable number near the overflow threshold of -C the machine (see LAPACK Library Routine DLAMCH). -C -C METHOD -C -C This routine uses a Pade approximation to H(t) for some small -C value of t (where 0 < t <= delta) and then calculates F(t) from -C H(t). Finally, the results are re-scaled to give F(delta) and -C H(delta). For a detailed description of the implementation of this -C algorithm see [1]. -C -C REFERENCES -C -C [1] Benson, C.J. -C The numerical evaluation of the matrix exponential and its -C integral. -C Report 82/03, Control Systems Research Group, -C School of Electronic Engineering and Computer -C Science, Kingston Polytechnic, January 1982. -C -C [2] Ward, R.C. -C Numerical computation of the matrix exponential with accuracy -C estimate. -C SIAM J. Numer. Anal., 14, pp. 600-610, 1977. -C -C [3] Moler, C.B. and Van Loan, C.F. -C Nineteen Dubious Ways to Compute the Exponential of a Matrix. -C SIAM Rev., 20, pp. 801-836, 1978. -C -C NUMERICAL ASPECTS -C 3 -C The algorithm requires 0(N ) operations. -C -C CONTRIBUTOR -C -C Release 3.0: V. Sima, Katholieke Univ. Leuven, Belgium, May 1997. -C Supersedes Release 2.0 routine MB05BD by C.J. Benson, Kingston -C Polytechnic, January 1982. -C -C REVISIONS -C -C - -C -C KEYWORDS -C -C Continuous-time system, matrix algebra, matrix exponential, -C matrix operations, Pade approximation. -C -C ****************************************************************** -C -C .. Parameters .. - DOUBLE PRECISION ZERO, HALF, ONE, ONE64, THREE, FOUR8 - PARAMETER ( ZERO = 0.0D0, HALF = 0.5D0, ONE = 1.0D0, - $ ONE64 = 1.64D0, THREE = 3.0D0, FOUR8 = 4.8D0 ) -C .. Scalar Arguments .. - INTEGER INFO, LDA, LDEX, LDEXIN, LDWORK, N - DOUBLE PRECISION DELTA, TOL -C .. Array Arguments .. - INTEGER IWORK(*) - DOUBLE PRECISION A(LDA,*), DWORK(*), EX(LDEX,*), EXINT(LDEXIN,*) -C .. Local Scalars .. - INTEGER I, I2IQ1, IJ, IQ, J, JSCAL, KK, L, NN - DOUBLE PRECISION COEFFD, COEFFN, DELSC, EPS, ERR, F2IQ1, - $ FNORM, FNORM2, QMAX, SMALL -C .. External Functions .. - LOGICAL LSAME - DOUBLE PRECISION DLAMCH, DLANGE - EXTERNAL DLAMCH, DLANGE, LSAME -C .. External Subroutines .. - EXTERNAL DAXPY, DCOPY, DGEMM, DGEMV, DGESV, DLACPY, - $ DLASET, DSCAL, XERBLA -C .. Intrinsic Functions .. - INTRINSIC ABS, DBLE, EXP, MAX, MOD, SQRT -C .. Executable Statements .. -C - INFO = 0 - NN = N*N -C -C Test the input scalar arguments. -C - IF( N.LT.0 ) THEN - INFO = -1 - ELSE IF( LDA.LT.MAX( 1, N ) ) THEN - INFO = -4 - ELSE IF( LDEX.LT.MAX( 1, N ) ) THEN - INFO = -6 - ELSE IF( LDEXIN.LT.MAX( 1, N ) ) THEN - INFO = -8 - ELSE IF( LDWORK.LT.MAX( 1, NN + N ) ) THEN - INFO = -12 - END IF -C - IF ( INFO.NE.0 ) THEN -C -C Error return. -C - CALL XERBLA( 'MB05ND', -INFO ) - RETURN - END IF -C -C Quick return if possible. -C - DWORK(1) = ONE - IF ( N.EQ.0 ) - $ RETURN -C - CALL DLASET( 'Full', N, N, ZERO, ZERO, EX, LDEX ) - CALL DLASET( 'Full', N, N, ZERO, ZERO, EXINT, LDEXIN ) -C - IF ( DELTA.EQ.ZERO ) THEN - CALL DLASET( 'Upper', N, N, ZERO, ONE, EX, LDEX ) - RETURN - END IF -C - IF ( N.EQ.1 ) THEN - EX(1,1) = EXP( DELTA*A(1,1) ) - IF ( A(1,1).EQ.ZERO ) THEN - EXINT(1,1) = DELTA - ELSE - EXINT(1,1) = ( ( ONE/A(1,1) )*EX(1,1) ) - ( ONE/A(1,1) ) - END IF - RETURN - END IF -C -C Set some machine parameters. -C - EPS = DLAMCH( 'Epsilon' ) - SMALL = DLAMCH( 'Safe minimum' )/EPS -C -C First calculate the Frobenius norm of A, and the scaling factor. -C - FNORM = DELTA*DLANGE( 'Frobenius', N, N, A, LDA, DWORK ) -C - IF ( FNORM.GT.SQRT( ONE/SMALL ) ) THEN - INFO = N + 1 - RETURN - END IF -C - JSCAL = 0 - DELSC = DELTA -C WHILE ( FNORM >= HALF ) DO - 20 CONTINUE - IF ( FNORM.GE.HALF ) THEN - JSCAL = JSCAL + 1 - DELSC = DELSC*HALF - FNORM = FNORM*HALF - GO TO 20 - END IF -C END WHILE 20 -C -C Calculate the order of the Pade approximation needed to satisfy -C the requested relative error TOL. -C - FNORM2 = FNORM**2 - IQ = 1 - QMAX = FNORM/THREE - ERR = DELTA/DELSC*FNORM2**2/FOUR8 -C WHILE ( ERR > TOL*( 2*IQ + 3 - FNORM )/1.64 and QMAX >= EPS ) DO - 40 CONTINUE - IF ( ERR.GT.TOL*( DBLE( 2*IQ + 3 ) - FNORM )/ONE64 ) THEN - IQ = IQ + 1 - QMAX = QMAX*DBLE( IQ + 1 )*FNORM/DBLE( 2*IQ*( 2*IQ + 1 ) ) - IF ( QMAX.GE.EPS ) THEN - ERR = ERR*FNORM2*DBLE( 2*IQ + 5 )/DBLE( ( 2*IQ + 3 )**2 - $ *( 2*IQ + 4 ) ) - GO TO 40 - END IF - END IF -C END WHILE 40 -C -C Initialise DWORK (to contain succesive powers of A), -C EXINT (to contain the numerator) and -C EX (to contain the denominator). -C - I2IQ1 = 2*IQ + 1 - F2IQ1 = DBLE( I2IQ1 ) - COEFFD = -DBLE( IQ )/F2IQ1 - COEFFN = HALF/F2IQ1 - IJ = 1 -C - DO 80 J = 1, N -C - DO 60 I = 1, N - DWORK(IJ) = DELSC*A(I,J) - EXINT(I,J) = COEFFN*DWORK(IJ) - EX(I,J) = COEFFD*DWORK(IJ) - IJ = IJ + 1 - 60 CONTINUE -C - EXINT(J,J) = EXINT(J,J) + ONE - EX(J,J) = EX(J,J) + ONE - 80 CONTINUE -C - DO 140 KK = 2, IQ -C -C Calculate the next power of A*DELSC, and update the numerator -C and denominator. -C - COEFFD = -COEFFD*DBLE( IQ+1-KK )/DBLE( KK*( I2IQ1+1-KK ) ) - IF ( MOD( KK, 2 ).EQ.0 ) THEN - COEFFN = COEFFD/DBLE( KK + 1 ) - ELSE - COEFFN = -COEFFD/DBLE( I2IQ1 - KK ) - END IF - IJ = 1 -C - IF ( LDWORK.GE.2*NN ) THEN -C -C Enough space for a BLAS 3 calculation. -C - CALL DGEMM( 'No transpose', 'No transpose', N, N, N, DELSC, - $ A, LDA, DWORK, N, ZERO, DWORK(NN+1), N ) - CALL DCOPY( NN, DWORK(NN+1), 1, DWORK, 1 ) -C - DO 100 J = 1, N - CALL DAXPY( N, COEFFN, DWORK(IJ), 1, EXINT(1,J), 1 ) - CALL DAXPY( N, COEFFD, DWORK(IJ), 1, EX(1,J), 1 ) - IJ = IJ + N - 100 CONTINUE -C - ELSE -C -C Not enough space for a BLAS 3 calculation. Use BLAS 2. -C - DO 120 J = 1, N - CALL DGEMV( 'No transpose', N, N, ONE, A, LDA, DWORK(IJ), - $ 1, ZERO, DWORK(NN+1), 1 ) - CALL DCOPY( N, DWORK(NN+1), 1, DWORK(IJ), 1 ) - CALL DSCAL( N, DELSC, DWORK(IJ), 1 ) - CALL DAXPY( N, COEFFN, DWORK(IJ), 1, EXINT(1,J), 1 ) - CALL DAXPY( N, COEFFD, DWORK(IJ), 1, EX(1,J), 1 ) - IJ = IJ + N - 120 CONTINUE -C - END IF - 140 CONTINUE -C -C We now have numerator in EXINT, denominator in EX. -C -C Solve the set of N systems of linear equations for the columns of -C EXINT using the LU factorization of EX. -C - CALL DGESV( N, N, EX, LDEX, IWORK, EXINT, LDEXIN, INFO ) - IF ( INFO.NE.0 ) - $ RETURN -C -C Now we can form EX from EXINT using the formula: -C EX = EXINT * A + I -C - DO 160 J = 1, N - CALL DSCAL( N, DELSC, EXINT(1,J), 1 ) - 160 CONTINUE -C - CALL DGEMM( 'No transpose', 'No transpose', N, N, N, ONE, EXINT, - $ LDEXIN, A, LDA, ZERO, EX, LDEX ) -C - DO 180 J = 1, N - EX(J,J) = EX(J,J) + ONE - 180 CONTINUE -C -C EX and EXINT have been evaluated at DELSC, so the results -C must be re-scaled to give the function values at DELTA. -C -C EXINT(2t) = EXINT(t) * ^ EX(t) + I [ -C EX(2t) = EX(t) * EX(t) -C -C DWORK is used to accumulate products. -C - DO 200 L = 1, JSCAL - CALL DLACPY( 'Full', N, N, EXINT, LDEXIN, DWORK, N ) - CALL DGEMM( 'No transpose', 'No transpose', N, N, N, ONE, - $ DWORK, N, EX, LDEX, ONE, EXINT, LDEXIN ) - CALL DLACPY( 'Full', N, N, EX, LDEX, DWORK, N ) - CALL DGEMM( 'No transpose', 'No transpose', N, N, N, ONE, - $ DWORK, N, DWORK, N, ZERO, EX, LDEX ) - 200 CONTINUE -C - DWORK(1) = 2*NN - RETURN -C *** Last line of MB05ND *** - END diff --git a/mex/sources/libslicot/MB05OD.f b/mex/sources/libslicot/MB05OD.f deleted file mode 100644 index ec87a2ee7..000000000 --- a/mex/sources/libslicot/MB05OD.f +++ /dev/null @@ -1,574 +0,0 @@ - SUBROUTINE MB05OD( BALANC, N, NDIAG, DELTA, A, LDA, MDIG, IDIG, - $ IWORK, DWORK, LDWORK, IWARN, INFO ) -C -C SLICOT RELEASE 5.0. -C -C Copyright (c) 2002-2009 NICONET e.V. -C -C This program is free software: you can redistribute it and/or -C modify it under the terms of the GNU General Public License as -C published by the Free Software Foundation, either version 2 of -C the License, or (at your option) any later version. -C -C This program is distributed in the hope that it will be useful, -C but WITHOUT ANY WARRANTY; without even the implied warranty of -C MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the -C GNU General Public License for more details. -C -C You should have received a copy of the GNU General Public License -C along with this program. If not, see -C . -C -C PURPOSE -C -C To compute exp(A*delta) where A is a real N-by-N matrix and delta -C is a scalar value. The routine also returns the minimal number of -C accurate digits in the 1-norm of exp(A*delta) and the number of -C accurate digits in the 1-norm of exp(A*delta) at 95% confidence -C level. -C -C ARGUMENTS -C -C Mode Parameters -C -C BALANC CHARACTER*1 -C Specifies whether or not a balancing transformation (done -C by SLICOT Library routine MB04MD) is required, as follows: -C = 'N', do not use balancing; -C = 'S', use balancing (scaling). -C -C Input/Output Parameters -C -C N (input) INTEGER -C The order of the matrix A. N >= 0. -C -C NDIAG (input) INTEGER -C The specified order of the diagonal Pade approximant. -C In the absence of further information NDIAG should -C be set to 9. NDIAG should not exceed 15. NDIAG >= 1. -C -C DELTA (input) DOUBLE PRECISION -C The scalar value delta of the problem. -C -C A (input/output) DOUBLE PRECISION array, dimension (LDA,N) -C On input, the leading N-by-N part of this array must -C contain the matrix A of the problem. (This is not needed -C if DELTA = 0.) -C On exit, if INFO = 0, the leading N-by-N part of this -C array contains the solution matrix exp(A*delta). -C -C LDA INTEGER -C The leading dimension of array A. LDA >= MAX(1,N). -C -C MDIG (output) INTEGER -C The minimal number of accurate digits in the 1-norm of -C exp(A*delta). -C -C IDIG (output) INTEGER -C The number of accurate digits in the 1-norm of -C exp(A*delta) at 95% confidence level. -C -C Workspace -C -C IWORK INTEGER array, dimension (N) -C -C DWORK DOUBLE PRECISION array, dimension (LDWORK) -C -C LDWORK INTEGER -C The length of the array DWORK. -C LDWORK >= N*(2*N+NDIAG+1)+NDIAG, if N > 1. -C LDWORK >= 1, if N <= 1. -C -C Warning Indicator -C -C IWARN INTEGER -C = 0: no warning; -C = 1: if MDIG = 0 and IDIG > 0, warning for possible -C inaccuracy (the exponential has been computed); -C = 2: if MDIG = 0 and IDIG = 0, warning for severe -C inaccuracy (the exponential has been computed); -C = 3: if balancing has been requested, but it failed to -C reduce the matrix norm and was not actually used. -C -C Error Indicator -C -C INFO INTEGER -C = 0: successful exit; -C < 0: if INFO = -i, the i-th argument had an illegal -C value; -C = 1: if the norm of matrix A*delta (after a possible -C balancing) is too large to obtain an accurate -C result; -C = 2: if the coefficient matrix (the denominator of the -C Pade approximant) is exactly singular; try a -C different value of NDIAG; -C = 3: if the solution exponential would overflow, possibly -C due to a too large value DELTA; the calculations -C stopped prematurely. This error is not likely to -C appear. -C -C METHOD -C -C The exponential of the matrix A is evaluated from a diagonal Pade -C approximant. This routine is a modification of the subroutine -C PADE, described in reference [1]. The routine implements an -C algorithm which exploits the identity -C -C (exp[(2**-m)*A]) ** (2**m) = exp(A), -C -C where m is an integer determined by the algorithm, to improve the -C accuracy for matrices with large norms. -C -C REFERENCES -C -C [1] Ward, R.C. -C Numerical computation of the matrix exponential with accuracy -C estimate. -C SIAM J. Numer. Anal., 14, pp. 600-610, 1977. -C -C NUMERICAL ASPECTS -C 3 -C The algorithm requires 0(N ) operations. -C -C CONTRIBUTOR -C -C Release 3.0: V. Sima, Katholieke Univ. Leuven, Belgium, Apr. 1997. -C Supersedes Release 2.0 routine MB05CD by T.W.C. Williams, Kingston -C Polytechnic, March 1982. -C -C REVISIONS -C -C June 14, 1997, April 25, 2003, December 12, 2004. -C -C KEYWORDS -C -C Continuous-time system, matrix algebra, matrix exponential, -C matrix operations, Pade approximation. -C -C ****************************************************************** -C -C .. Parameters .. - DOUBLE PRECISION ZERO, HALF, ONE, TWO, FOUR, EIGHT, TEN, TWELVE, - $ NINTEN, TWO4, FOUR7, TWOHND - PARAMETER ( ZERO = 0.0D0, HALF = 0.5D0, ONE = 1.0D0, - $ TWO = 2.0D0, FOUR = 4.0D0, EIGHT = 8.0D0, - $ TEN = 10.0D0, TWELVE = 12.0D0, - $ NINTEN = 19.0D0, TWO4 = 24.0D0, - $ FOUR7 = 47.0D0, TWOHND = 200.0D0 ) -C .. Scalar Arguments .. - CHARACTER BALANC - INTEGER IDIG, INFO, IWARN, LDA, LDWORK, MDIG, N, - $ NDIAG - DOUBLE PRECISION DELTA -C .. Array Arguments .. - INTEGER IWORK(*) - DOUBLE PRECISION A(LDA,*), DWORK(*) -C .. Local Scalars .. - LOGICAL LBALS - CHARACTER ACTBAL - INTEGER BASE, I, IFAIL, IJ, IK, IM1, J, JWORA1, JWORA2, - $ JWORA3, JWORV1, JWORV2, K, M, MPOWER, NDAGM1, - $ NDAGM2, NDEC, NDECM1 - DOUBLE PRECISION ANORM, AVGEV, BD, BIG, EABS, EAVGEV, EMNORM, - $ EPS, FACTOR, FN, GN, MAXRED, OVRTH2, OVRTHR, P, - $ RERL, RERR, S, SD2, SIZE, SMALL, SS, SUM2D, - $ TEMP, TMP1, TR, U, UNDERF, VAR, VAREPS, XN -C .. External Functions .. - LOGICAL LSAME - DOUBLE PRECISION DASUM, DLAMCH, DLANGE, DNRM2 - EXTERNAL DASUM, DLAMCH, DLANGE, DNRM2, LSAME -C .. External Subroutines .. - EXTERNAL DCOPY, DGEMM, DGEMV, DGETRF, DGETRS, DLACPY, - $ DLASCL, DLASET, DSCAL, MB04MD, MB05OY, XERBLA -C .. Intrinsic Functions .. - INTRINSIC DBLE, EXP, INT, LOG, LOG10, MAX, MIN, MOD, SQRT -C .. Executable Statements .. -C - IWARN = 0 - INFO = 0 - LBALS = LSAME( BALANC, 'S' ) -C -C Test the input scalar arguments. -C - IF( .NOT.( LSAME( BALANC, 'N' ) .OR. LBALS ) ) THEN - INFO = -1 - ELSE IF( N.LT.0 ) THEN - INFO = -2 - ELSE IF( NDIAG.LT.1 ) THEN - INFO = -3 - ELSE IF( LDA.LT.MAX( 1, N ) ) THEN - INFO = -6 - ELSE IF( LDWORK.LT.1 .OR. - $ ( LDWORK.LT.N*( 2*N + NDIAG + 1 ) + NDIAG .AND. N.GT.1 ) - $ ) THEN - INFO = -11 - END IF -C - IF ( INFO.NE.0 ) THEN -C -C Error return. -C - CALL XERBLA( 'MB05OD', -INFO ) - RETURN - END IF -C -C Quick return if possible. -C - EPS = DLAMCH( 'Epsilon' ) - NDEC = INT( LOG10( ONE/EPS ) + ONE ) -C - IF ( N.EQ.0 ) THEN - MDIG = NDEC - IDIG = NDEC - RETURN - END IF -C -C Set some machine parameters. -C - BASE = DLAMCH( 'Base' ) - NDECM1 = NDEC - 1 - UNDERF = DLAMCH( 'Underflow' ) - OVRTHR = DLAMCH( 'Overflow' ) - OVRTH2 = SQRT( OVRTHR ) -C - IF ( DELTA.EQ.ZERO ) THEN -C -C The DELTA = 0 case. -C - CALL DLASET( 'Full', N, N, ZERO, ONE, A, LDA ) - MDIG = NDECM1 - IDIG = NDECM1 - RETURN - END IF -C - IF ( N.EQ.1 ) THEN -C -C The 1-by-1 case. -C - A(1,1) = EXP( A(1,1)*DELTA ) - MDIG = NDECM1 - IDIG = NDECM1 - RETURN - END IF -C -C Set pointers for the workspace. -C - JWORA1 = 1 - JWORA2 = JWORA1 + N*N - JWORA3 = JWORA2 + N*NDIAG - JWORV1 = JWORA3 + N*N - JWORV2 = JWORV1 + N -C -C Compute Pade coefficients in DWORK(JWORV2:JWORV2+NDIAG-1). -C - DWORK(JWORV2) = HALF -C - DO 20 I = 2, NDIAG - IM1 = I - 1 - DWORK(JWORV2+IM1) = DWORK(JWORV2+I-2)*DBLE( NDIAG - IM1 )/ - $ DBLE( I*( 2*NDIAG - IM1 ) ) - 20 CONTINUE -C - VAREPS = EPS**2*( ( DBLE( BASE )**2 - ONE )/ - $ ( TWO4*LOG( DBLE( BASE ) ) ) ) - XN = DBLE( N ) - TR = ZERO -C -C Apply a translation with the mean of the eigenvalues of A*DELTA. -C - DO 40 I = 1, N - CALL DSCAL( N, DELTA, A(1,I), 1 ) - TR = TR + A(I,I) - 40 CONTINUE -C - AVGEV = TR/XN - IF ( AVGEV.GT.LOG( OVRTHR ) .OR. AVGEV.LT.LOG( UNDERF ) ) - $ AVGEV = ZERO - IF ( AVGEV.NE.ZERO ) THEN - ANORM = DLANGE( '1-norm', N, N, A, LDA, DWORK(JWORA1) ) -C - DO 60 I = 1, N - A(I,I) = A(I,I) - AVGEV - 60 CONTINUE -C - TEMP = DLANGE( '1-norm', N, N, A, LDA, DWORK(JWORA1) ) - IF ( TEMP.GT.HALF*ANORM ) THEN -C - DO 80 I = 1, N - A(I,I) = A(I,I) + AVGEV - 80 CONTINUE -C - AVGEV = ZERO - END IF - END IF - ACTBAL = BALANC - IF ( LBALS ) THEN -C -C Balancing (scaling) has been requested. First, save A. -C - CALL DLACPY( 'Full', N, N, A, LDA, DWORK(JWORA1), N ) - MAXRED = TWOHND - CALL MB04MD( N, MAXRED, A, LDA, DWORK(JWORV1), INFO ) - IF ( MAXRED.LT.ONE ) THEN -C -C Recover the matrix and reset DWORK(JWORV1,...,JWORV1+N-1) -C to 1, as no reduction of the norm occured (unlikely event). -C - CALL DLACPY( 'Full', N, N, DWORK(JWORA1), N, A, LDA ) - ACTBAL = 'N' - DWORK(JWORV1) = ONE - CALL DCOPY( N-1, DWORK(JWORV1), 0, DWORK(JWORV1+1), 1 ) - IWARN = 3 - END IF - END IF -C -C Scale the matrix by 2**(-M), where M is the minimum integer -C so that the resulted matrix has the 1-norm less than 0.5. -C - ANORM = DLANGE( '1-norm', N, N, A, LDA, DWORK(JWORA1) ) - M = 0 - IF ( ANORM.GE.HALF ) THEN - MPOWER = INT( LOG( OVRTHR )/LOG( TWO ) ) - M = INT( LOG( ANORM )/LOG( TWO ) ) + 1 - IF ( M.GT.MPOWER ) THEN -C -C Error return: The norm of A*DELTA is too large. -C - INFO = 1 - RETURN - END IF - FACTOR = TWO**M - IF ( M+1.LT.MPOWER ) THEN - M = M + 1 - FACTOR = FACTOR*TWO - END IF -C - DO 120 I = 1, N - CALL DSCAL( N, ONE/FACTOR, A(1,I), 1 ) - 120 CONTINUE -C - END IF - NDAGM1 = NDIAG - 1 - NDAGM2 = NDAGM1 - 1 - IJ = 0 -C -C Compute the factors of the diagonal Pade approximant. -C The loop 200 takes the accuracy requirements into account: -C Pade coefficients decrease with K, so the calculations should -C be performed in backward order, one column at a time. -C (A BLAS 3 implementation in forward order, using DGEMM, could -C possibly be less accurate.) -C - DO 200 J = 1, N - CALL DGEMV( 'No transpose', N, N, ONE, A, LDA, A(1,J), 1, ZERO, - $ DWORK(JWORA2), 1 ) - IK = 0 -C - DO 140 K = 1, NDAGM2 - CALL DGEMV( 'No transpose', N, N, ONE, A, LDA, - $ DWORK(JWORA2+IK), 1, ZERO, DWORK(JWORA2+IK+N), - $ 1 ) - IK = IK + N - 140 CONTINUE -C - DO 180 I = 1, N - S = ZERO - U = ZERO - IK = NDAGM2*N + I - 1 -C - DO 160 K = NDAGM1, 1, -1 - P = DWORK(JWORV2+K)*DWORK(JWORA2+IK) - IK = IK - N - S = S + P - IF ( MOD( K+1, 2 ).EQ.0 ) THEN - U = U + P - ELSE - U = U - P - END IF - 160 CONTINUE -C - P = DWORK(JWORV2)*A(I,J) - S = S + P - U = U - P - IF ( I.EQ.J ) THEN - S = S + ONE - U = U + ONE - END IF - DWORK(JWORA3+IJ) = S - DWORK(JWORA1+IJ) = U - IJ = IJ + 1 - 180 CONTINUE -C - 200 CONTINUE -C -C Compute the exponential of the scaled matrix, using diagonal Pade -C approximants. As, in theory [1], the denominator of the Pade -C approximant should be very well conditioned, no condition estimate -C is computed. -C - CALL DGETRF( N, N, DWORK(JWORA1), N, IWORK, IFAIL ) - IF ( IFAIL.GT.0 ) THEN -C -C Error return: The matrix is exactly singular. -C - INFO = 2 - RETURN - END IF -C - CALL DLACPY( 'Full', N, N, DWORK(JWORA3), N, A, LDA ) - CALL DGETRS( 'No transpose', N, N, DWORK(JWORA1), N, IWORK, A, - $ LDA, IFAIL ) -C -C Prepare for the calculation of the accuracy estimates. -C Note that ANORM here is in the range [1, e]. -C - ANORM = DLANGE( '1-norm', N, N, A, LDA, DWORK(JWORA1) ) - IF ( ANORM.GE.ONE ) THEN - EABS = ( NINTEN*XN + FOUR7 )*( EPS*ANORM ) - ELSE - EABS = ( ( NINTEN*XN + FOUR7 )*EPS )*ANORM - END IF - IF ( M.NE.0 ) THEN - VAR = XN*VAREPS - FN = ( FOUR*XN )/( ( XN + TWO )*( XN + ONE ) ) - GN = ( ( TWO*XN + TEN )*XN - FOUR )/( ( ( XN + TWO )**2 ) - $ *( ( XN + ONE )**2 ) ) -C -C Square-up the computed exponential matrix M times, with caution -C for avoiding overflows. -C - DO 220 K = 1, M - IF ( ANORM.GT.OVRTH2 ) THEN -C -C The solution could overflow. -C - CALL DGEMM( 'No transpose', 'No transpose', N, N, N, - $ ONE/ANORM, A, LDA, A, LDA, ZERO, - $ DWORK(JWORA1), N ) - S = DLANGE( '1-norm', N, N, DWORK(JWORA1), N, - $ DWORK(JWORA1) ) - IF ( ANORM.LE.OVRTHR/S ) THEN - CALL DLASCL( 'General', N, N, ONE, ANORM, N, N, - $ DWORK(JWORA1), N, INFO ) - TEMP = OVRTHR - ELSE -C -C Error return: The solution would overflow. -C This will not happen on most machines, due to the -C selection of M. -C - INFO = 3 - RETURN - END IF - ELSE - CALL DGEMM( 'No transpose', 'No transpose', N, N, N, ONE, - $ A, LDA, A, LDA, ZERO, DWORK(JWORA1), N ) - TEMP = ANORM**2 - END IF - IF ( EABS.LT.ONE ) THEN - EABS = ( TWO*ANORM + EABS )*EABS + XN*( EPS*TEMP ) - ELSE IF ( EABS.LT.SQRT( ONE - XN*EPS + OVRTHR/TEMP )*ANORM - - $ ANORM ) THEN - EABS = XN*( EPS*TEMP ) + TWO*( ANORM*EABS ) + EABS**2 - ELSE - EABS = OVRTHR - END IF -C - TMP1 = FN*VAR + GN*( TEMP*VAREPS ) - IF ( TMP1.GT.OVRTHR/TEMP ) THEN - VAR = OVRTHR - ELSE - VAR = TMP1*TEMP - END IF -C - CALL DLACPY( 'Full', N, N, DWORK(JWORA1), N, A, LDA ) - ANORM = DLANGE( '1-norm', N, N, A, LDA, DWORK(JWORA1) ) - 220 CONTINUE -C - ELSE - VAR = ( TWELVE*XN )*VAREPS - END IF -C -C Apply back transformations, if balancing was effectively used. -C - CALL MB05OY( ACTBAL, N, 1, N, A, LDA, DWORK(JWORV1), INFO ) - EAVGEV = EXP( AVGEV ) - EMNORM = DLANGE( '1-norm', N, N, A, LDA, DWORK(JWORA1) ) -C -C Compute auxiliary quantities needed for the accuracy estimates. -C - BIG = ONE - SMALL = ONE - IF ( LBALS ) THEN -C -C Compute norms of the diagonal scaling matrix and its inverse. -C - DO 240 I = 1, N - U = DWORK(JWORV1+I-1) - IF ( BIG.LT.U ) BIG = U - IF ( SMALL.GT.U ) SMALL = U - 240 CONTINUE -C - SUM2D = DNRM2( N, DWORK(JWORV1), 1 ) - ELSE - SUM2D = SQRT( XN ) - END IF -C -C Update the exponential for the initial translation, and update the -C auxiliary quantities needed for the accuracy estimates. -C - SD2 = SQRT( EIGHT*XN*VAREPS )*ANORM - BD = SQRT( VAR ) - SS = MAX( BD, SD2 ) - BD = MIN( BD, SD2 ) - SD2 = SS*SQRT( ONE + ( BD/SS )**2 ) - IF ( SD2.LE.ONE ) THEN - SD2 = ( TWO/XN )*SUM2D*SD2 - ELSE IF ( SUM2D/XN.LT.OVRTHR/TWO/SD2 ) THEN - SD2 = ( TWO/XN )*SUM2D*SD2 - ELSE - SD2 = OVRTHR - END IF - IF ( LBALS ) THEN - SIZE = ZERO - ELSE - IF ( SD2.LT.OVRTHR - EMNORM ) THEN - SIZE = EMNORM + SD2 - ELSE - SIZE = OVRTHR - END IF - END IF -C - DO 260 J = 1, N - SS = DASUM( N, A(1,J), 1 ) - CALL DSCAL( N, EAVGEV, A(1,J), 1 ) - IF ( LBALS ) THEN - BD = DWORK(JWORV1+J-1) - SIZE = MAX( SIZE, SS + SD2/BD ) - END IF - 260 CONTINUE -C -C Set the accuracy estimates and warning errors, if any. -C - RERR = LOG10( BIG ) + LOG10( EABS ) - LOG10( SMALL ) - - $ LOG10( EMNORM ) - LOG10( EPS ) - IF ( SIZE.GT.EMNORM ) THEN - RERL = LOG10( ( SIZE/EMNORM - ONE )/EPS ) - ELSE - RERL = ZERO - END IF - MDIG = MIN( NDEC - INT( RERR + HALF ), NDECM1 ) - IDIG = MIN( NDEC - INT( RERL + HALF ), NDECM1 ) -C - IF ( MDIG.LE.0 ) THEN - MDIG = 0 - IWARN = 1 - END IF - IF ( IDIG.LE.0 ) THEN - IDIG = 0 - IWARN = 2 - END IF -C - RETURN -C *** Last line of MB05OD *** - END diff --git a/mex/sources/libslicot/MB05OY.f b/mex/sources/libslicot/MB05OY.f deleted file mode 100644 index a73de7039..000000000 --- a/mex/sources/libslicot/MB05OY.f +++ /dev/null @@ -1,179 +0,0 @@ - SUBROUTINE MB05OY( JOB, N, LOW, IGH, A, LDA, SCALE, INFO ) -C -C SLICOT RELEASE 5.0. -C -C Copyright (c) 2002-2009 NICONET e.V. -C -C This program is free software: you can redistribute it and/or -C modify it under the terms of the GNU General Public License as -C published by the Free Software Foundation, either version 2 of -C the License, or (at your option) any later version. -C -C This program is distributed in the hope that it will be useful, -C but WITHOUT ANY WARRANTY; without even the implied warranty of -C MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the -C GNU General Public License for more details. -C -C You should have received a copy of the GNU General Public License -C along with this program. If not, see -C . -C -C PURPOSE -C -C To restore a matrix after it has been transformed by applying -C balancing transformations (permutations and scalings), as -C determined by LAPACK Library routine DGEBAL. -C -C ARGUMENTS -C -C Mode Parameters -C -C JOB CHARACTER*1 -C Specifies the type of backward transformation required, -C as follows: -C = 'N', do nothing, return immediately; -C = 'P', do backward transformation for permutation only; -C = 'S', do backward transformation for scaling only; -C = 'B', do backward transformations for both permutation -C and scaling. -C JOB must be the same as the argument JOB supplied -C to DGEBAL. -C -C Input/Output Parameters -C -C N (input) INTEGER -C The order of the matrix A. N >= 0. -C -C LOW (input) INTEGER -C IGH (input) INTEGER -C The integers LOW and IGH determined by DGEBAL. -C 1 <= LOW <= IGH <= N, if N > 0; LOW=1 and IGH=0, if N=0. -C -C A (input/output) DOUBLE PRECISION array, dimension (LDA,N) -C On entry, the leading N-by-N part of this array must -C contain the matrix to be back-transformed. -C On exit, the leading N-by-N part of this array contains -C the transformed matrix. -C -C LDA INTEGER -C The leading dimension of the array A. LDA >= max(1,N). -C -C SCALE (input) DOUBLE PRECISION array, dimension (N) -C Details of the permutation and scaling factors, as -C returned by DGEBAL. -C -C Error Indicator -C -C INFO INTEGER -C = 0: successful exit; -C < 0: if INFO = -i, the i-th argument had an illegal -C value. -C -C METHOD -C -C Let P be a permutation matrix, and D a diagonal matrix of scaling -C factors, both of order N. The routine computes -C -1 -C A <-- P D A D P'. -C -C where the permutation and scaling factors are encoded in the -C array SCALE. -C -C REFERENCES -C -C None. -C -C NUMERICAL ASPECTS -C 2 -C The algorithm requires O(N ) operations. -C -C CONTRIBUTORS -C -C Release 3.0: V. Sima, Katholieke Univ. Leuven, Belgium, Apr. 1997. -C Supersedes Release 2.0 routine MB05CY. -C -C REVISIONS -C -C - -C -C KEYWORDS -C -C Elementary matrix operations, matrix algebra, matrix operations. -C -C ****************************************************************** -C - DOUBLE PRECISION ONE - PARAMETER ( ONE = 1.0D0 ) -C .. Scalar Arguments .. - CHARACTER JOB - INTEGER IGH, INFO, LDA, LOW, N -C .. Array Arguments .. - DOUBLE PRECISION A(LDA,*), SCALE(*) -C .. Local Scalars .. - INTEGER I, II, J, K -C .. External Functions .. - LOGICAL LSAME - EXTERNAL LSAME -C .. External Subroutines .. - EXTERNAL DSCAL, DSWAP, XERBLA -C .. Intrinsic Functions .. - INTRINSIC MAX, MIN -C .. Executable Statements .. -C -C Test the input scalar arguments. -C - INFO = 0 - IF( .NOT.LSAME( JOB, 'N' ) .AND. .NOT.LSAME( JOB, 'P' ) .AND. - $ .NOT.LSAME( JOB, 'S' ) .AND. .NOT.LSAME( JOB, 'B' ) ) THEN - INFO = -1 - ELSE IF( N.LT.0 )THEN - INFO = -2 - ELSE IF( LOW.LT.1 .OR. LOW.GT.MAX( 1, N ) ) THEN - INFO = -3 - ELSE IF( IGH.LT.MIN( LOW, N ) .OR. IGH.GT.N ) THEN - INFO = -4 - ELSE IF( LDA.LT.MAX( 1, N ) )THEN - INFO = -6 - END IF -C - IF( INFO.NE.0 ) THEN - CALL XERBLA( 'MB05OY', -INFO ) - RETURN - END IF -C -C Quick return if possible. -C - IF( N.EQ.0 .OR. LSAME( JOB, 'N' ) ) - $ RETURN -C - IF ( .NOT.LSAME( JOB, 'P' ) .AND. IGH.NE.LOW ) THEN -C - DO 20 I = LOW, IGH - CALL DSCAL( N, SCALE(I), A(I,1), LDA ) - 20 CONTINUE -C - DO 40 J = LOW, IGH - CALL DSCAL( N, ONE/SCALE(J), A(1,J), 1 ) - 40 CONTINUE -C - END IF -C - IF( .NOT.LSAME( JOB, 'S' ) ) THEN -C - DO 60 II = 1, N - I = II - IF ( I.LT.LOW .OR. I.GT.IGH ) THEN - IF ( I.LT.LOW ) I = LOW - II - K = SCALE(I) - IF ( K.NE.I ) THEN - CALL DSWAP( N, A(I,1), LDA, A(K,1), LDA ) - CALL DSWAP( N, A(1,I), 1, A(1,K), 1 ) - END IF - END IF - 60 CONTINUE -C - END IF -C - RETURN -C *** Last line of MB05OY *** - END diff --git a/mex/sources/libslicot/MB3OYZ.f b/mex/sources/libslicot/MB3OYZ.f deleted file mode 100644 index 054e570ad..000000000 --- a/mex/sources/libslicot/MB3OYZ.f +++ /dev/null @@ -1,395 +0,0 @@ - SUBROUTINE MB3OYZ( M, N, A, LDA, RCOND, SVLMAX, RANK, SVAL, JPVT, - $ TAU, DWORK, ZWORK, INFO ) -C -C SLICOT RELEASE 5.0. -C -C Copyright (c) 2002-2009 NICONET e.V. -C -C This program is free software: you can redistribute it and/or -C modify it under the terms of the GNU General Public License as -C published by the Free Software Foundation, either version 2 of -C the License, or (at your option) any later version. -C -C This program is distributed in the hope that it will be useful, -C but WITHOUT ANY WARRANTY; without even the implied warranty of -C MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the -C GNU General Public License for more details. -C -C You should have received a copy of the GNU General Public License -C along with this program. If not, see -C . -C -C PURPOSE -C -C To compute a rank-revealing QR factorization of a complex general -C M-by-N matrix A, which may be rank-deficient, and estimate its -C effective rank using incremental condition estimation. -C -C The routine uses a truncated QR factorization with column pivoting -C [ R11 R12 ] -C A * P = Q * R, where R = [ ], -C [ 0 R22 ] -C with R11 defined as the largest leading upper triangular submatrix -C whose estimated condition number is less than 1/RCOND. The order -C of R11, RANK, is the effective rank of A. Condition estimation is -C performed during the QR factorization process. Matrix R22 is full -C (but of small norm), or empty. -C -C MB3OYZ does not perform any scaling of the matrix A. -C -C ARGUMENTS -C -C Input/Output Parameters -C -C M (input) INTEGER -C The number of rows of the matrix A. M >= 0. -C -C N (input) INTEGER -C The number of columns of the matrix A. N >= 0. -C -C A (input/output) COMPLEX*16 array, dimension ( LDA, N ) -C On entry, the leading M-by-N part of this array must -C contain the given matrix A. -C On exit, the leading RANK-by-RANK upper triangular part -C of A contains the triangular factor R11, and the elements -C below the diagonal in the first RANK columns, with the -C array TAU, represent the unitary matrix Q as a product -C of RANK elementary reflectors. -C The remaining N-RANK columns contain the result of the -C QR factorization process used. -C -C LDA INTEGER -C The leading dimension of the array A. LDA >= max(1,M). -C -C RCOND (input) DOUBLE PRECISION -C RCOND is used to determine the effective rank of A, which -C is defined as the order of the largest leading triangular -C submatrix R11 in the QR factorization with pivoting of A, -C whose estimated condition number is less than 1/RCOND. -C 0 <= RCOND <= 1. -C NOTE that when SVLMAX > 0, the estimated rank could be -C less than that defined above (see SVLMAX). -C -C SVLMAX (input) DOUBLE PRECISION -C If A is a submatrix of another matrix B, and the rank -C decision should be related to that matrix, then SVLMAX -C should be an estimate of the largest singular value of B -C (for instance, the Frobenius norm of B). If this is not -C the case, the input value SVLMAX = 0 should work. -C SVLMAX >= 0. -C -C RANK (output) INTEGER -C The effective (estimated) rank of A, i.e., the order of -C the submatrix R11. -C -C SVAL (output) DOUBLE PRECISION array, dimension ( 3 ) -C The estimates of some of the singular values of the -C triangular factor R: -C SVAL(1): largest singular value of R(1:RANK,1:RANK); -C SVAL(2): smallest singular value of R(1:RANK,1:RANK); -C SVAL(3): smallest singular value of R(1:RANK+1,1:RANK+1), -C if RANK < MIN( M, N ), or of R(1:RANK,1:RANK), -C otherwise. -C If the triangular factorization is a rank-revealing one -C (which will be the case if the leading columns were well- -C conditioned), then SVAL(1) will also be an estimate for -C the largest singular value of A, and SVAL(2) and SVAL(3) -C will be estimates for the RANK-th and (RANK+1)-st singular -C values of A, respectively. -C By examining these values, one can confirm that the rank -C is well defined with respect to the chosen value of RCOND. -C The ratio SVAL(1)/SVAL(2) is an estimate of the condition -C number of R(1:RANK,1:RANK). -C -C JPVT (output) INTEGER array, dimension ( N ) -C If JPVT(i) = k, then the i-th column of A*P was the k-th -C column of A. -C -C TAU (output) COMPLEX*16 array, dimension ( MIN( M, N ) ) -C The leading RANK elements of TAU contain the scalar -C factors of the elementary reflectors. -C -C Workspace -C -C DWORK DOUBLE PRECISION array, dimension ( 2*N ) -C -C ZWORK COMPLEX*16 array, dimension ( 3*N-1 ) -C -C Error Indicator -C -C INFO INTEGER -C = 0: successful exit; -C < 0: if INFO = -i, the i-th argument had an illegal -C value. -C -C METHOD -C -C The routine computes a truncated QR factorization with column -C pivoting of A, A * P = Q * R, with R defined above, and, -C during this process, finds the largest leading submatrix whose -C estimated condition number is less than 1/RCOND, taking the -C possible positive value of SVLMAX into account. This is performed -C using the LAPACK incremental condition estimation scheme and a -C slightly modified rank decision test. The factorization process -C stops when RANK has been determined. -C -C The matrix Q is represented as a product of elementary reflectors -C -C Q = H(1) H(2) . . . H(k), where k = rank <= min(m,n). -C -C Each H(i) has the form -C -C H = I - tau * v * v' -C -C where tau is a complex scalar, and v is a complex vector with -C v(1:i-1) = 0 and v(i) = 1; v(i+1:m) is stored on exit in -C A(i+1:m,i), and tau in TAU(i). -C -C The matrix P is represented in jpvt as follows: If -C jpvt(j) = i -C then the jth column of P is the ith canonical unit vector. -C -C REFERENCES -C -C [1] Bischof, C.H. and P. Tang. -C Generalizing Incremental Condition Estimation. -C LAPACK Working Notes 32, Mathematics and Computer Science -C Division, Argonne National Laboratory, UT, CS-91-132, -C May 1991. -C -C [2] Bischof, C.H. and P. Tang. -C Robust Incremental Condition Estimation. -C LAPACK Working Notes 33, Mathematics and Computer Science -C Division, Argonne National Laboratory, UT, CS-91-133, -C May 1991. -C -C NUMERICAL ASPECTS -C -C The algorithm is backward stable. -C -C CONTRIBUTOR -C -C V. Sima, Katholieke Univ. Leuven, Belgium, Feb. 1998. -C Complex version: V. Sima, Research Institute for Informatics, -C Bucharest, Nov. 2008. -C -C REVISIONS -C -C - -C -C KEYWORDS -C -C Eigenvalue problem, matrix operations, unitary transformation, -C singular values. -C -C ****************************************************************** -C -C .. Parameters .. - INTEGER IMAX, IMIN - PARAMETER ( IMAX = 1, IMIN = 2 ) - DOUBLE PRECISION ZERO, ONE, P05 - PARAMETER ( ZERO = 0.0D+0, ONE = 1.0D+0, P05 = 0.05D+0 ) - COMPLEX*16 CZERO, CONE - PARAMETER ( CZERO = ( 0.0D+0, 0.0D+0 ), - $ CONE = ( 1.0D+0, 0.0D+0 ) ) -C .. Scalar Arguments .. - INTEGER INFO, LDA, M, N, RANK - DOUBLE PRECISION RCOND, SVLMAX -C .. Array Arguments .. - INTEGER JPVT( * ) - COMPLEX*16 A( LDA, * ), TAU( * ), ZWORK( * ) - DOUBLE PRECISION DWORK( * ), SVAL( 3 ) -C .. -C .. Local Scalars .. - INTEGER I, ISMAX, ISMIN, ITEMP, J, MN, PVT - COMPLEX*16 AII, C1, C2, S1, S2 - DOUBLE PRECISION SMAX, SMAXPR, SMIN, SMINPR, TEMP, TEMP2 -C .. -C .. External Functions .. - INTEGER IDAMAX - DOUBLE PRECISION DZNRM2 - EXTERNAL DZNRM2, IDAMAX -C .. External Subroutines .. - EXTERNAL XERBLA, ZLAIC1, ZLARF, ZLARFG, ZSCAL, ZSWAP -C .. Intrinsic Functions .. - INTRINSIC ABS, DCONJG, MAX, MIN, SQRT -C .. -C .. Executable Statements .. -C -C Test the input scalar arguments. -C - INFO = 0 - IF( M.LT.0 ) THEN - INFO = -1 - ELSE IF( N.LT.0 ) THEN - INFO = -2 - ELSE IF( LDA.LT.MAX( 1, M ) ) THEN - INFO = -4 - ELSE IF( RCOND.LT.ZERO .OR. RCOND.GT.ONE ) THEN - INFO = -5 - ELSE IF( SVLMAX.LT.ZERO ) THEN - INFO = -6 - END IF -C - IF( INFO.NE.0 ) THEN - CALL XERBLA( 'MB3OYZ', -INFO ) - RETURN - END IF -C -C Quick return if possible. -C - MN = MIN( M, N ) - IF( MN.EQ.0 ) THEN - RANK = 0 - SVAL( 1 ) = ZERO - SVAL( 2 ) = ZERO - SVAL( 3 ) = ZERO - RETURN - END IF -C - ISMIN = 1 - ISMAX = ISMIN + N -C -C Initialize partial column norms and pivoting vector. The first n -C elements of DWORK store the exact column norms. -C - DO 10 I = 1, N - DWORK( I ) = DZNRM2( M, A( 1, I ), 1 ) - DWORK( N+I ) = DWORK( I ) - JPVT( I ) = I - 10 CONTINUE -C -C Compute factorization and determine RANK using incremental -C condition estimation. -C - RANK = 0 -C - 20 CONTINUE - IF( RANK.LT.MN ) THEN - I = RANK + 1 -C -C Determine ith pivot column and swap if necessary. -C - PVT = ( I-1 ) + IDAMAX( N-I+1, DWORK( I ), 1 ) -C - IF( PVT.NE.I ) THEN - CALL ZSWAP( M, A( 1, PVT ), 1, A( 1, I ), 1 ) - ITEMP = JPVT( PVT ) - JPVT( PVT ) = JPVT( I ) - JPVT( I ) = ITEMP - DWORK( PVT ) = DWORK( I ) - DWORK( N+PVT ) = DWORK( N+I ) - END IF -C -C Save A(I,I) and generate elementary reflector H(i) -C such that H(i)'*[A(i,i);*] = [*;0]. -C - IF( I.LT.M ) THEN - AII = A( I, I ) - CALL ZLARFG( M-I+1, A( I, I ), A( I+1, I ), 1, TAU( I ) ) - ELSE - TAU( M ) = CZERO - END IF -C - IF( RANK.EQ.0 ) THEN -C -C Initialize; exit if matrix is zero (RANK = 0). -C - SMAX = ABS( A( 1, 1 ) ) - IF ( SMAX.EQ.ZERO ) THEN - SVAL( 1 ) = ZERO - SVAL( 2 ) = ZERO - SVAL( 3 ) = ZERO - RETURN - END IF - SMIN = SMAX - SMAXPR = SMAX - SMINPR = SMIN - C1 = CONE - C2 = CONE - ELSE -C -C One step of incremental condition estimation. -C - CALL ZLAIC1( IMIN, RANK, ZWORK( ISMIN ), SMIN, A( 1, I ), - $ A( I, I ), SMINPR, S1, C1 ) - CALL ZLAIC1( IMAX, RANK, ZWORK( ISMAX ), SMAX, A( 1, I ), - $ A( I, I ), SMAXPR, S2, C2 ) - END IF -C - IF( SVLMAX*RCOND.LE.SMAXPR ) THEN - IF( SVLMAX*RCOND.LE.SMINPR ) THEN - IF( SMAXPR*RCOND.LE.SMINPR ) THEN -C -C Continue factorization, as rank is at least RANK. -C - IF( I.LT.N ) THEN -C -C Apply H(i)' to A(i:m,i+1:n) from the left. -C - AII = A( I, I ) - A( I, I ) = CONE - CALL ZLARF( 'Left', M-I+1, N-I, A( I, I ), 1, - $ DCONJG( TAU( I ) ), A( I, I+1 ), LDA, - $ ZWORK( 2*N+1 ) ) - A( I, I ) = AII - END IF -C -C Update partial column norms. -C - DO 30 J = I + 1, N - IF( DWORK( J ).NE.ZERO ) THEN - TEMP = ONE - - $ ( ABS( A( I, J ) ) / DWORK( J ) )**2 - TEMP = MAX( TEMP, ZERO ) - TEMP2 = ONE + P05*TEMP* - $ ( DWORK( J ) / DWORK( N+J ) )**2 - IF( TEMP2.EQ.ONE ) THEN - IF( M-I.GT.0 ) THEN - DWORK( J ) = DZNRM2( M-I, A( I+1, J ), 1 ) - DWORK( N+J ) = DWORK( J ) - ELSE - DWORK( J ) = ZERO - DWORK( N+J ) = ZERO - END IF - ELSE - DWORK( J ) = DWORK( J )*SQRT( TEMP ) - END IF - END IF - 30 CONTINUE -C - DO 40 I = 1, RANK - ZWORK( ISMIN+I-1 ) = S1*ZWORK( ISMIN+I-1 ) - ZWORK( ISMAX+I-1 ) = S2*ZWORK( ISMAX+I-1 ) - 40 CONTINUE -C - ZWORK( ISMIN+RANK ) = C1 - ZWORK( ISMAX+RANK ) = C2 - SMIN = SMINPR - SMAX = SMAXPR - RANK = RANK + 1 - GO TO 20 - END IF - END IF - END IF - END IF -C -C Restore the changed part of the (RANK+1)-th column and set SVAL. -C - IF ( RANK.LT.N ) THEN - IF ( I.LT.M ) THEN - CALL ZSCAL( M-I, -A( I, I )*TAU( I ), A( I+1, I ), 1 ) - A( I, I ) = AII - END IF - END IF - IF ( RANK.EQ.0 ) THEN - SMIN = ZERO - SMINPR = ZERO - END IF - SVAL( 1 ) = SMAX - SVAL( 2 ) = SMIN - SVAL( 3 ) = SMINPR -C - RETURN -C *** Last line of MB3OYZ *** - END diff --git a/mex/sources/libslicot/MB3PYZ.f b/mex/sources/libslicot/MB3PYZ.f deleted file mode 100644 index 119bca081..000000000 --- a/mex/sources/libslicot/MB3PYZ.f +++ /dev/null @@ -1,398 +0,0 @@ - SUBROUTINE MB3PYZ( M, N, A, LDA, RCOND, SVLMAX, RANK, SVAL, JPVT, - $ TAU, DWORK, ZWORK, INFO ) -C -C SLICOT RELEASE 5.0. -C -C Copyright (c) 2002-2009 NICONET e.V. -C -C This program is free software: you can redistribute it and/or -C modify it under the terms of the GNU General Public License as -C published by the Free Software Foundation, either version 2 of -C the License, or (at your option) any later version. -C -C This program is distributed in the hope that it will be useful, -C but WITHOUT ANY WARRANTY; without even the implied warranty of -C MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the -C GNU General Public License for more details. -C -C You should have received a copy of the GNU General Public License -C along with this program. If not, see -C . -C -C PURPOSE -C -C To compute a rank-revealing RQ factorization of a complex general -C M-by-N matrix A, which may be rank-deficient, and estimate its -C effective rank using incremental condition estimation. -C -C The routine uses a truncated RQ factorization with row pivoting: -C [ R11 R12 ] -C P * A = R * Q, where R = [ ], -C [ 0 R22 ] -C with R22 defined as the largest trailing upper triangular -C submatrix whose estimated condition number is less than 1/RCOND. -C The order of R22, RANK, is the effective rank of A. Condition -C estimation is performed during the RQ factorization process. -C Matrix R11 is full (but of small norm), or empty. -C -C MB3PYZ does not perform any scaling of the matrix A. -C -C ARGUMENTS -C -C Input/Output Parameters -C -C M (input) INTEGER -C The number of rows of the matrix A. M >= 0. -C -C N (input) INTEGER -C The number of columns of the matrix A. N >= 0. -C -C A (input/output) COMPLEX*16 array, dimension ( LDA, N ) -C On entry, the leading M-by-N part of this array must -C contain the given matrix A. -C On exit, the upper triangle of the subarray -C A(M-RANK+1:M,N-RANK+1:N) contains the RANK-by-RANK upper -C triangular matrix R22; the remaining elements in the last -C RANK rows, with the array TAU, represent the unitary -C matrix Q as a product of RANK elementary reflectors -C (see METHOD). The first M-RANK rows contain the result -C of the RQ factorization process used. -C -C LDA INTEGER -C The leading dimension of the array A. LDA >= max(1,M). -C -C RCOND (input) DOUBLE PRECISION -C RCOND is used to determine the effective rank of A, which -C is defined as the order of the largest trailing triangular -C submatrix R22 in the RQ factorization with pivoting of A, -C whose estimated condition number is less than 1/RCOND. -C 0 <= RCOND <= 1. -C NOTE that when SVLMAX > 0, the estimated rank could be -C less than that defined above (see SVLMAX). -C -C SVLMAX (input) DOUBLE PRECISION -C If A is a submatrix of another matrix B, and the rank -C decision should be related to that matrix, then SVLMAX -C should be an estimate of the largest singular value of B -C (for instance, the Frobenius norm of B). If this is not -C the case, the input value SVLMAX = 0 should work. -C SVLMAX >= 0. -C -C RANK (output) INTEGER -C The effective (estimated) rank of A, i.e., the order of -C the submatrix R22. -C -C SVAL (output) DOUBLE PRECISION array, dimension ( 3 ) -C The estimates of some of the singular values of the -C triangular factor R: -C SVAL(1): largest singular value of -C R(M-RANK+1:M,N-RANK+1:N); -C SVAL(2): smallest singular value of -C R(M-RANK+1:M,N-RANK+1:N); -C SVAL(3): smallest singular value of R(M-RANK:M,N-RANK:N), -C if RANK < MIN( M, N ), or of -C R(M-RANK+1:M,N-RANK+1:N), otherwise. -C If the triangular factorization is a rank-revealing one -C (which will be the case if the trailing rows were well- -C conditioned), then SVAL(1) will also be an estimate for -C the largest singular value of A, and SVAL(2) and SVAL(3) -C will be estimates for the RANK-th and (RANK+1)-st singular -C values of A, respectively. -C By examining these values, one can confirm that the rank -C is well defined with respect to the chosen value of RCOND. -C The ratio SVAL(1)/SVAL(2) is an estimate of the condition -C number of R(M-RANK+1:M,N-RANK+1:N). -C -C JPVT (output) INTEGER array, dimension ( M ) -C If JPVT(i) = k, then the i-th row of P*A was the k-th row -C of A. -C -C TAU (output) COMPLEX*16 array, dimension ( MIN( M, N ) ) -C The trailing RANK elements of TAU contain the scalar -C factors of the elementary reflectors. -C -C Workspace -C -C DWORK DOUBLE PRECISION array, dimension ( 2*M ) -C -C ZWORK COMPLEX*16 array, dimension ( 3*M-1 ) -C -C Error Indicator -C -C INFO INTEGER -C = 0: successful exit; -C < 0: if INFO = -i, the i-th argument had an illegal -C value. -C -C METHOD -C -C The routine computes a truncated RQ factorization with row -C pivoting of A, P * A = R * Q, with R defined above, and, -C during this process, finds the largest trailing submatrix whose -C estimated condition number is less than 1/RCOND, taking the -C possible positive value of SVLMAX into account. This is performed -C using an adaptation of the LAPACK incremental condition estimation -C scheme and a slightly modified rank decision test. The -C factorization process stops when RANK has been determined. -C -C The matrix Q is represented as a product of elementary reflectors -C -C Q = H(k-rank+1)' H(k-rank+2)' . . . H(k)', where k = min(m,n). -C -C Each H(i) has the form -C -C H = I - tau * v * v' -C -C where tau is a complex scalar, and v is a complex vector with -C v(n-k+i+1:n) = 0 and v(n-k+i) = 1; conjg(v(1:n-k+i-1)) is stored -C on exit in A(m-k+i,1:n-k+i-1), and tau in TAU(i). -C -C The matrix P is represented in jpvt as follows: If -C jpvt(j) = i -C then the jth row of P is the ith canonical unit vector. -C -C REFERENCES -C -C [1] Bischof, C.H. and P. Tang. -C Generalizing Incremental Condition Estimation. -C LAPACK Working Notes 32, Mathematics and Computer Science -C Division, Argonne National Laboratory, UT, CS-91-132, -C May 1991. -C -C [2] Bischof, C.H. and P. Tang. -C Robust Incremental Condition Estimation. -C LAPACK Working Notes 33, Mathematics and Computer Science -C Division, Argonne National Laboratory, UT, CS-91-133, -C May 1991. -C -C NUMERICAL ASPECTS -C -C The algorithm is backward stable. -C -C CONTRIBUTOR -C -C V. Sima, Katholieke Univ. Leuven, Belgium, Feb. 1998. -C Complex version: V. Sima, Research Institute for Informatics, -C Bucharest, Nov. 2008. -C -C REVISIONS -C -C - -C -C KEYWORDS -C -C Eigenvalue problem, matrix operations, unitary transformation, -C singular values. -C -C ****************************************************************** -C -C .. Parameters .. - INTEGER IMAX, IMIN - PARAMETER ( IMAX = 1, IMIN = 2 ) - DOUBLE PRECISION ZERO, ONE, P05 - PARAMETER ( ZERO = 0.0D+0, ONE = 1.0D+0, P05 = 0.05D+0 ) - COMPLEX*16 CONE - PARAMETER ( CONE = ( 1.0D+0, 0.0D+0 ) ) -C .. Scalar Arguments .. - INTEGER INFO, LDA, M, N, RANK - DOUBLE PRECISION RCOND, SVLMAX -C .. Array Arguments .. - INTEGER JPVT( * ) - COMPLEX*16 A( LDA, * ), TAU( * ), ZWORK( * ) - DOUBLE PRECISION DWORK( * ), SVAL( 3 ) -C .. Local Scalars .. - INTEGER I, ISMAX, ISMIN, ITEMP, J, JWORK, K, MKI, NKI, - $ PVT - COMPLEX*16 AII, C1, C2, S1, S2 - DOUBLE PRECISION SMAX, SMAXPR, SMIN, SMINPR, TEMP, TEMP2 -C .. -C .. External Functions .. - INTEGER IDAMAX - DOUBLE PRECISION DZNRM2 - EXTERNAL DZNRM2, IDAMAX -C .. -C .. External Subroutines .. - EXTERNAL XERBLA, ZCOPY, ZLACGV, ZLAIC1, ZLARF, ZLARFG, - $ ZSCAL, ZSWAP -C .. -C .. Intrinsic Functions .. - INTRINSIC ABS, MAX, MIN, SQRT -C .. -C .. Executable Statements .. -C -C Test the input scalar arguments. -C - INFO = 0 - IF( M.LT.0 ) THEN - INFO = -1 - ELSE IF( N.LT.0 ) THEN - INFO = -2 - ELSE IF( LDA.LT.MAX( 1, M ) ) THEN - INFO = -4 - ELSE IF( RCOND.LT.ZERO .OR. RCOND.GT.ONE ) THEN - INFO = -5 - ELSE IF( SVLMAX.LT.ZERO ) THEN - INFO = -6 - END IF -C - IF( INFO.NE.0 ) THEN - CALL XERBLA( 'MB3PYZ', -INFO ) - RETURN - END IF -C -C Quick return if possible. -C - K = MIN( M, N ) - IF( K.EQ.0 ) THEN - RANK = 0 - SVAL( 1 ) = ZERO - SVAL( 2 ) = ZERO - SVAL( 3 ) = ZERO - RETURN - END IF -C - ISMIN = 1 - ISMAX = ISMIN + M - JWORK = ISMAX + M -C -C Initialize partial row norms and pivoting vector. The first m -C elements of DWORK store the exact row norms. -C - DO 10 I = 1, M - DWORK( I ) = DZNRM2( N, A( I, 1 ), LDA ) - DWORK( M+I ) = DWORK( I ) - JPVT( I ) = I - 10 CONTINUE -C -C Compute factorization and determine RANK using incremental -C condition estimation. -C - RANK = 0 -C - 20 CONTINUE - IF( RANK.LT.K ) THEN - I = K - RANK -C -C Determine ith pivot row and swap if necessary. -C - MKI = M - RANK - NKI = N - RANK - PVT = IDAMAX( MKI, DWORK, 1 ) -C - IF( PVT.NE.MKI ) THEN - CALL ZSWAP( N, A( PVT, 1 ), LDA, A( MKI, 1 ), LDA ) - ITEMP = JPVT( PVT ) - JPVT( PVT ) = JPVT( MKI ) - JPVT( MKI ) = ITEMP - DWORK( PVT ) = DWORK( MKI ) - DWORK( M+PVT ) = DWORK( M+MKI ) - END IF -C - IF( NKI.GT.1 ) THEN -C -C Save A(m-k+i,n-k+i) and generate elementary reflector H(i) -C to annihilate A(m-k+i,1:n-k+i-1), k = min(m,n). -C A(m-k+i,1:n-k+i) * H(tau,v) = [0 , *] <=> -C H(conj(tau),v) A(m-k+i,1:n-k+i)^H = [0 ; *], -C using H(tau,v)^H = H(conj(tau),v). -C - CALL ZLACGV( NKI, A( MKI, 1 ), LDA ) - AII = A( MKI, NKI ) - CALL ZLARFG( NKI, A( MKI, NKI ), A( MKI, 1 ), LDA, TAU( I ) - $ ) - END IF -C - IF( RANK.EQ.0 ) THEN -C -C Initialize; exit if matrix is zero (RANK = 0). -C - SMAX = ABS( A( M, N ) ) - IF ( SMAX.EQ.ZERO ) THEN - SVAL( 1 ) = ZERO - SVAL( 2 ) = ZERO - SVAL( 3 ) = ZERO - RETURN - END IF - SMIN = SMAX - SMAXPR = SMAX - SMINPR = SMIN - C1 = CONE - C2 = CONE - ELSE -C -C One step of incremental condition estimation. -C - CALL ZCOPY ( RANK, A( MKI, NKI+1 ), LDA, ZWORK( JWORK ), 1 ) - CALL ZLAIC1( IMIN, RANK, ZWORK( ISMIN ), SMIN, - $ ZWORK( JWORK ), A( MKI, NKI ), SMINPR, S1, C1 ) - CALL ZLAIC1( IMAX, RANK, ZWORK( ISMAX ), SMAX, - $ ZWORK( JWORK ), A( MKI, NKI ), SMAXPR, S2, C2 ) - END IF -C - IF( SVLMAX*RCOND.LE.SMAXPR ) THEN - IF( SVLMAX*RCOND.LE.SMINPR ) THEN - IF( SMAXPR*RCOND.LE.SMINPR ) THEN -C - IF( MKI.GT.1 ) THEN -C -C Continue factorization, as rank is at least RANK. -C Apply H(i) to A(1:m-k+i-1,1:n-k+i) from the right. -C - AII = A( MKI, NKI ) - A( MKI, NKI ) = CONE - CALL ZLARF( 'Right', MKI-1, NKI, A( MKI, 1 ), LDA, - $ TAU( I ), A, LDA, ZWORK( JWORK ) ) - A( MKI, NKI ) = AII -C -C Update partial row norms. -C - DO 30 J = 1, MKI - 1 - IF( DWORK( J ).NE.ZERO ) THEN - TEMP = ONE - - $ ( ABS( A( J, NKI ) )/DWORK( J ) )**2 - TEMP = MAX( TEMP, ZERO ) - TEMP2 = ONE + P05*TEMP* - $ ( DWORK( J ) / DWORK( M+J ) )**2 - IF( TEMP2.EQ.ONE ) THEN - DWORK( J ) = DZNRM2( NKI-1, A( J, 1 ), - $ LDA ) - DWORK( M+J ) = DWORK( J ) - ELSE - DWORK( J ) = DWORK( J )*SQRT( TEMP ) - END IF - END IF - 30 CONTINUE -C - END IF -C - DO 40 I = 1, RANK - ZWORK( ISMIN+I-1 ) = S1*ZWORK( ISMIN+I-1 ) - ZWORK( ISMAX+I-1 ) = S2*ZWORK( ISMAX+I-1 ) - 40 CONTINUE -C - ZWORK( ISMIN+RANK ) = C1 - ZWORK( ISMAX+RANK ) = C2 - SMIN = SMINPR - SMAX = SMAXPR - RANK = RANK + 1 - CALL ZLACGV( NKI-1, A( MKI, 1 ), LDA ) - GO TO 20 - END IF - END IF - END IF - END IF -C -C Restore the changed part of the (M-RANK)-th row and set SVAL. -C - IF ( RANK.LT.K .AND. NKI.GT.1 ) THEN - CALL ZLACGV( NKI-1, A( MKI, 1 ), LDA ) - CALL ZSCAL( NKI-1, -A( MKI, NKI )*TAU( I ), A( MKI, 1 ), LDA ) - A( MKI, NKI ) = AII - END IF - SVAL( 1 ) = SMAX - SVAL( 2 ) = SMIN - SVAL( 3 ) = SMINPR -C - RETURN -C *** Last line of MB3PYZ *** - END diff --git a/mex/sources/libslicot/MC01MD.f b/mex/sources/libslicot/MC01MD.f deleted file mode 100644 index 9da419a93..000000000 --- a/mex/sources/libslicot/MC01MD.f +++ /dev/null @@ -1,162 +0,0 @@ - SUBROUTINE MC01MD( DP, ALPHA, K, P, Q, INFO ) -C -C SLICOT RELEASE 5.0. -C -C Copyright (c) 2002-2009 NICONET e.V. -C -C This program is free software: you can redistribute it and/or -C modify it under the terms of the GNU General Public License as -C published by the Free Software Foundation, either version 2 of -C the License, or (at your option) any later version. -C -C This program is distributed in the hope that it will be useful, -C but WITHOUT ANY WARRANTY; without even the implied warranty of -C MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the -C GNU General Public License for more details. -C -C You should have received a copy of the GNU General Public License -C along with this program. If not, see -C . -C -C PURPOSE -C -C To calculate, for a given real polynomial P(x) and a real scalar -C alpha, the leading K coefficients of the shifted polynomial -C K-1 -C P(x) = q(1) + q(2) * (x-alpha) + ... + q(K) * (x-alpha) + ... -C -C using Horner's algorithm. -C -C ARGUMENTS -C -C Input/Output Parameters -C -C DP (input) INTEGER -C The degree of the polynomial P(x). DP >= 0. -C -C ALPHA (input) DOUBLE PRECISION -C The scalar value alpha of the problem. -C -C K (input) INTEGER -C The number of coefficients of the shifted polynomial to be -C computed. 1 <= K <= DP+1. -C -C P (input) DOUBLE PRECISION array, dimension (DP+1) -C This array must contain the coefficients of P(x) in -C increasing powers of x. -C -C Q (output) DOUBLE PRECISION array, dimension (DP+1) -C The leading K elements of this array contain the first -C K coefficients of the shifted polynomial in increasing -C powers of (x - alpha), and the next (DP-K+1) elements -C are used as internal workspace. -C -C Error Indicator -C -C INFO INTEGER -C = 0: successful exit; -C < 0: if INFO = -i, the i-th argument had an illegal -C value. -C -C METHOD -C -C Given the real polynomial -C 2 DP -C P(x) = p(1) + p(2) * x + p(3) * x + ... + p(DP+1) * x , -C -C the routine computes the leading K coefficients of the shifted -C polynomial -C K-1 -C P(x) = q(1) + q(2) * (x - alpha) + ... + q(K) * (x - alpha) -C -C as follows. -C -C Applying Horner's algorithm (see [1]) to P(x), i.e. dividing P(x) -C by (x-alpha), yields -C -C P(x) = q(1) + (x-alpha) * D(x), -C -C where q(1) is the value of the constant term of the shifted -C polynomial and D(x) is the quotient polynomial of degree (DP-1) -C given by -C 2 DP-1 -C D(x) = d(2) + d(3) * x + d(4) * x + ... + d(DP+1) * x . -C -C Applying Horner's algorithm to D(x) and subsequent quotient -C polynomials yields q(2) and q(3), q(4), ..., q(K) respectively. -C -C It follows immediately that q(1) = P(alpha), and in general -C (i-1) -C q(i) = P (alpha) / (i - 1)! for i = 1, 2, ..., K. -C -C REFERENCES -C -C [1] STOER, J. and BULIRSCH, R. -C Introduction to Numerical Analysis. -C Springer-Verlag. 1980. -C -C NUMERICAL ASPECTS -C -C None. -C -C CONTRIBUTOR -C -C Release 3.0: V. Sima, Katholieke Univ. Leuven, Belgium, Mar. 1997. -C Supersedes Release 2.0 routine MC01AD by A.J. Geurts. -C -C REVISIONS -C -C - -C -C KEYWORDS -C -C Elementary polynomial operations, polynomial operations. -C -C ****************************************************************** -C -C .. Parameters .. - DOUBLE PRECISION ZERO - PARAMETER ( ZERO = 0.0D0 ) -C .. Scalar Arguments .. - INTEGER DP, INFO, K - DOUBLE PRECISION ALPHA -C .. Array Arguments .. - DOUBLE PRECISION P(*), Q(*) -C .. Local Scalars .. - INTEGER I, J -C .. External Subroutines .. - EXTERNAL DCOPY, XERBLA -C .. Executable Statements .. -C -C Test the input scalar arguments. -C - INFO = 0 - IF( DP.LT.0 ) THEN - INFO = -1 - ELSE IF( K.LE.0 .OR. K.GT.DP+1 ) THEN - INFO = -3 - END IF -C - IF ( INFO.NE.0 ) THEN -C -C Error return. -C - CALL XERBLA( 'MC01MD', -INFO ) - RETURN - END IF -C - CALL DCOPY( DP+1, P, 1, Q, 1 ) - IF ( DP.EQ.0 .OR. ALPHA.EQ.ZERO ) - $ RETURN -C - DO 40 J = 1, K -C - DO 20 I = DP, J, -1 - Q(I) = Q(I) + ALPHA*Q(I+1) - 20 CONTINUE -C - 40 CONTINUE -C - RETURN -C *** Last line of MC01MD *** - END diff --git a/mex/sources/libslicot/MC01ND.f b/mex/sources/libslicot/MC01ND.f deleted file mode 100644 index b45913fe7..000000000 --- a/mex/sources/libslicot/MC01ND.f +++ /dev/null @@ -1,146 +0,0 @@ - SUBROUTINE MC01ND( DP, XR, XI, P, VR, VI, INFO ) -C -C SLICOT RELEASE 5.0. -C -C Copyright (c) 2002-2009 NICONET e.V. -C -C This program is free software: you can redistribute it and/or -C modify it under the terms of the GNU General Public License as -C published by the Free Software Foundation, either version 2 of -C the License, or (at your option) any later version. -C -C This program is distributed in the hope that it will be useful, -C but WITHOUT ANY WARRANTY; without even the implied warranty of -C MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the -C GNU General Public License for more details. -C -C You should have received a copy of the GNU General Public License -C along with this program. If not, see -C . -C -C PURPOSE -C -C To compute the value of the real polynomial P(x) at a given -C complex point x = x0 using Horner's algorithm. -C -C ARGUMENTS -C -C Input/Output Parameters -C -C DP (input) INTEGER -C The degree of the polynomial P(x). DP >= 0. -C -C XR (input) DOUBLE PRECISION -C XI (input) DOUBLE PRECISION -C The real and imaginary parts, respectively, of x0. -C -C P (input) DOUBLE PRECISION array, dimension (DP+1) -C This array must contain the coefficients of the polynomial -C P(x) in increasing powers of x. -C -C VR (output) DOUBLE PRECISION -C VI (output) DOUBLE PRECISION -C The real and imaginary parts, respectively, of P(x0). -C -C Error Indicator -C -C INFO INTEGER -C = 0: successful exit; -C < 0: if INFO = -i, the i-th argument had an illegal -C value. -C -C METHOD -C -C Given the real polynomial -C 2 DP -C P(x) = p(1) + p(2) * x + p(3) * x + ... + p(DP+1) * x , -C -C the routine computes the value of P(x0) using the recursion -C -C q(DP+1) = p(DP+1), -C q(i) = x0*q(i+1) + p(i) for i = DP, DP-1, ..., 1, -C -C which is known as Horner's algorithm (see [1]). Then q(1) = P(x0). -C -C REFERENCES -C -C [1] STOER, J and BULIRSCH, R. -C Introduction to Numerical Analysis. -C Springer-Verlag. 1980. -C -C NUMERICAL ASPECTS -C -C The algorithm requires DP operations for real arguments and 4*DP -C for complex arguments. -C -C CONTRIBUTOR -C -C Release 3.0: V. Sima, Katholieke Univ. Leuven, Belgium, Mar. 1997. -C Supersedes Release 2.0 routine MC01BD by Serge Steer. -C -C REVISIONS -C -C - -C -C KEYWORDS -C -C Elementary polynomial operations, polynomial operations. -C -C ****************************************************************** -C -C .. Parameters .. - DOUBLE PRECISION ZERO - PARAMETER ( ZERO = 0.0D0 ) -C .. Scalar Arguments .. - INTEGER DP, INFO - DOUBLE PRECISION VI, VR, XI, XR -C .. Array Arguments .. - DOUBLE PRECISION P(*) -C .. Local Scalars .. - INTEGER I - DOUBLE PRECISION T -C .. External Subroutines .. - EXTERNAL XERBLA -C .. Executable Statements .. -C -C Test the input scalar arguments. -C - IF( DP.LT.0 ) THEN - INFO = -1 -C -C Error return. -C - CALL XERBLA( 'MC01ND', -INFO ) - RETURN - END IF -C - INFO = 0 - VR = P(DP+1) - VI = ZERO -C - IF ( DP.EQ.0 ) - $ RETURN -C - IF ( XI.EQ.ZERO ) THEN -C -C X real. -C - DO 20 I = DP, 1, -1 - VR = VR*XR + P(I) - 20 CONTINUE -C - ELSE -C -C X complex. -C - DO 40 I = DP, 1, -1 - T = VR*XR - VI*XI + P(I) - VI = VI*XR + VR*XI - VR = T - 40 CONTINUE -C - END IF -C - RETURN -C *** Last line of MC01ND *** - END diff --git a/mex/sources/libslicot/MC01OD.f b/mex/sources/libslicot/MC01OD.f deleted file mode 100644 index 2d148791f..000000000 --- a/mex/sources/libslicot/MC01OD.f +++ /dev/null @@ -1,147 +0,0 @@ - SUBROUTINE MC01OD( K, REZ, IMZ, REP, IMP, DWORK, INFO ) -C -C SLICOT RELEASE 5.0. -C -C Copyright (c) 2002-2009 NICONET e.V. -C -C This program is free software: you can redistribute it and/or -C modify it under the terms of the GNU General Public License as -C published by the Free Software Foundation, either version 2 of -C the License, or (at your option) any later version. -C -C This program is distributed in the hope that it will be useful, -C but WITHOUT ANY WARRANTY; without even the implied warranty of -C MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the -C GNU General Public License for more details. -C -C You should have received a copy of the GNU General Public License -C along with this program. If not, see -C . -C -C PURPOSE -C -C To compute the coefficients of a complex polynomial P(x) from its -C zeros. -C -C ARGUMENTS -C -C Input/Output Parameters -C -C K (input) INTEGER -C The number of zeros (and hence the degree) of P(x). -C K >= 0. -C -C REZ (input) DOUBLE PRECISION array, dimension (K) -C IMZ (input) DOUBLE PRECISION array, dimension (K) -C The real and imaginary parts of the i-th zero of P(x) -C must be stored in REZ(i) and IMZ(i), respectively, where -C i = 1, 2, ..., K. The zeros may be supplied in any order. -C -C REP (output) DOUBLE PRECISION array, dimension (K+1) -C IMP (output) DOUBLE PRECISION array, dimension (K+1) -C These arrays contain the real and imaginary parts, -C respectively, of the coefficients of P(x) in increasing -C powers of x. If K = 0, then REP(1) is set to one and -C IMP(1) is set to zero. -C -C Workspace -C -C DWORK DOUBLE PRECISION array, dimension (2*K+2) -C If K = 0, this array is not referenced. -C -C Error Indicator -C -C INFO INTEGER -C = 0: successful exit; -C < 0: if INFO = -i, the i-th argument had an illegal -C value. -C -C METHOD -C -C The routine computes the coefficients of the complex K-th degree -C polynomial P(x) as -C -C P(x) = (x - r(1)) * (x - r(2)) * ... * (x - r(K)) -C -C where r(i) = (REZ(i),IMZ(i)), using real arithmetic. -C -C NUMERICAL ASPECTS -C -C None. -C -C CONTRIBUTORS -C -C Release 3.0: V. Sima, Katholieke Univ. Leuven, Belgium, Mar. 1997. -C Supersedes Release 2.0 routine MC01CD by Alan Brown and -C A.J. Geurts. -C -C REVISIONS -C -C V. Sima, May 2002. -C -C KEYWORDS -C -C Elementary polynomial operations, polynomial operations. -C -C ****************************************************************** -C -C .. Parameters .. - DOUBLE PRECISION ZERO, ONE - PARAMETER ( ZERO = 0.0D0, ONE = 1.0D0 ) -C .. Scalar Arguments .. - INTEGER INFO, K -C .. Array Arguments .. - DOUBLE PRECISION DWORK(*), IMP(*), IMZ(*), REP(*), REZ(*) -C .. Local Scalars .. - INTEGER I, K2 - DOUBLE PRECISION U, V -C .. External Subroutines .. - EXTERNAL DAXPY, DCOPY, XERBLA -C .. Executable Statements .. -C -C Test the input scalar arguments. -C - IF( K.LT.0 ) THEN - INFO = -1 -C -C Error return. -C - CALL XERBLA( 'MC01OD', -INFO ) - RETURN - END IF -C -C Quick return if possible. -C - INFO = 0 - REP(1) = ONE - IMP(1) = ZERO - IF ( K.EQ.0 ) - $ RETURN -C - K2 = K + 2 -C - DO 20 I = 1, K - U = REZ(I) - V = IMZ(I) - DWORK(1) = ZERO - DWORK(K2) = ZERO - CALL DCOPY( I, REP, 1, DWORK(2), 1 ) - CALL DCOPY( I, IMP, 1, DWORK(K2+1), 1 ) -C - IF ( U.NE.ZERO ) THEN - CALL DAXPY( I, -U, REP, 1, DWORK, 1 ) - CALL DAXPY( I, -U, IMP, 1, DWORK(K2), 1 ) - END IF -C - IF ( V.NE.ZERO ) THEN - CALL DAXPY( I, V, IMP, 1, DWORK, 1 ) - CALL DAXPY( I, -V, REP, 1, DWORK(K2), 1 ) - END IF -C - CALL DCOPY( I+1, DWORK, 1, REP, 1 ) - CALL DCOPY( I+1, DWORK(K2), 1, IMP, 1 ) - 20 CONTINUE -C - RETURN -C *** Last line of MC01OD *** - END diff --git a/mex/sources/libslicot/MC01PD.f b/mex/sources/libslicot/MC01PD.f deleted file mode 100644 index f378a84bd..000000000 --- a/mex/sources/libslicot/MC01PD.f +++ /dev/null @@ -1,159 +0,0 @@ - SUBROUTINE MC01PD( K, REZ, IMZ, P, DWORK, INFO ) -C -C SLICOT RELEASE 5.0. -C -C Copyright (c) 2002-2009 NICONET e.V. -C -C This program is free software: you can redistribute it and/or -C modify it under the terms of the GNU General Public License as -C published by the Free Software Foundation, either version 2 of -C the License, or (at your option) any later version. -C -C This program is distributed in the hope that it will be useful, -C but WITHOUT ANY WARRANTY; without even the implied warranty of -C MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the -C GNU General Public License for more details. -C -C You should have received a copy of the GNU General Public License -C along with this program. If not, see -C . -C -C PURPOSE -C -C To compute the coefficients of a real polynomial P(x) from its -C zeros. -C -C ARGUMENTS -C -C Input/Output Parameters -C -C K (input) INTEGER -C The number of zeros (and hence the degree) of P(x). -C K >= 0. -C -C REZ (input) DOUBLE PRECISION array, dimension (K) -C IMZ (input) DOUBLE PRECISION array, dimension (K) -C The real and imaginary parts of the i-th zero of P(x) -C must be stored in REZ(i) and IMZ(i), respectively, where -C i = 1, 2, ..., K. The zeros may be supplied in any order, -C except that complex conjugate zeros must appear -C consecutively. -C -C P (output) DOUBLE PRECISION array, dimension (K+1) -C This array contains the coefficients of P(x) in increasing -C powers of x. If K = 0, then P(1) is set to one. -C -C Workspace -C -C DWORK DOUBLE PRECISION array, dimension (K+1) -C If K = 0, this array is not referenced. -C -C Error Indicator -C -C INFO INTEGER -C = 0: successful exit; -C < 0: if INFO = -i, the i-th argument had an illegal -C value; -C > 0: if INFO = i, (REZ(i),IMZ(i)) is a complex zero but -C (REZ(i-1),IMZ(i-1)) is not its conjugate. -C -C METHOD -C -C The routine computes the coefficients of the real K-th degree -C polynomial P(x) as -C -C P(x) = (x - r(1)) * (x - r(2)) * ... * (x - r(K)) -C -C where r(i) = (REZ(i),IMZ(i)). -C -C Note that REZ(i) = REZ(j) and IMZ(i) = -IMZ(j) if r(i) and r(j) -C form a complex conjugate pair (where i <> j), and that IMZ(i) = 0 -C if r(i) is real. -C -C NUMERICAL ASPECTS -C -C None. -C -C CONTRIBUTOR -C -C Release 3.0: V. Sima, Katholieke Univ. Leuven, Belgium, Mar. 1997. -C Supersedes Release 2.0 routine MC01DD by A.J. Geurts. -C -C REVISIONS -C -C V. Sima, May 2002. -C -C KEYWORDS -C -C Elementary polynomial operations, polynomial operations. -C -C ****************************************************************** -C -C .. Parameters .. - DOUBLE PRECISION ZERO, ONE - PARAMETER ( ZERO = 0.0D0, ONE = 1.0D0 ) -C .. Scalar Arguments .. - INTEGER INFO, K -C .. Array Arguments .. - DOUBLE PRECISION DWORK(*), IMZ(*), P(*), REZ(*) -C .. Local Scalars .. - INTEGER I - DOUBLE PRECISION U, V -C .. External Subroutines .. - EXTERNAL DAXPY, DCOPY, XERBLA -C .. Executable Statements .. -C -C Test the input scalar arguments. -C - IF( K.LT.0 ) THEN - INFO = -1 -C -C Error return. -C - CALL XERBLA( 'MC01PD', -INFO ) - RETURN - END IF -C -C Quick return if possible. -C - INFO = 0 - P(1) = ONE - IF ( K.EQ.0 ) - $ RETURN -C - I = 1 -C WHILE ( I <= K ) DO - 20 IF ( I.LE.K ) THEN - U = REZ(I) - V = IMZ(I) - DWORK(1) = ZERO -C - IF ( V.EQ.ZERO ) THEN - CALL DCOPY( I, P, 1, DWORK(2), 1 ) - CALL DAXPY( I, -U, P, 1, DWORK, 1 ) - I = I + 1 -C - ELSE - IF ( I.EQ.K ) THEN - INFO = K - RETURN - ELSE IF ( ( U.NE.REZ(I+1) ) .OR. ( V.NE.-IMZ(I+1) ) ) THEN - INFO = I + 1 - RETURN - END IF -C - DWORK(2) = ZERO - CALL DCOPY( I, P, 1, DWORK(3), 1 ) - CALL DAXPY( I, -(U + U), P, 1, DWORK(2), 1 ) - CALL DAXPY( I, U**2+V**2, P, 1, DWORK, 1 ) - I = I + 2 - END IF -C - CALL DCOPY( I, DWORK, 1, P, 1 ) - GO TO 20 - END IF -C END WHILE 20 -C - RETURN -C *** Last line of MC01PD *** - END diff --git a/mex/sources/libslicot/MC01PY.f b/mex/sources/libslicot/MC01PY.f deleted file mode 100644 index d43f9b172..000000000 --- a/mex/sources/libslicot/MC01PY.f +++ /dev/null @@ -1,157 +0,0 @@ - SUBROUTINE MC01PY( K, REZ, IMZ, P, DWORK, INFO ) -C -C SLICOT RELEASE 5.0. -C -C Copyright (c) 2002-2009 NICONET e.V. -C -C This program is free software: you can redistribute it and/or -C modify it under the terms of the GNU General Public License as -C published by the Free Software Foundation, either version 2 of -C the License, or (at your option) any later version. -C -C This program is distributed in the hope that it will be useful, -C but WITHOUT ANY WARRANTY; without even the implied warranty of -C MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the -C GNU General Public License for more details. -C -C You should have received a copy of the GNU General Public License -C along with this program. If not, see -C . -C -C PURPOSE -C -C To compute the coefficients of a real polynomial P(x) from its -C zeros. The coefficients are stored in decreasing order of the -C powers of x. -C -C ARGUMENTS -C -C Input/Output Parameters -C -C K (input) INTEGER -C The number of zeros (and hence the degree) of P(x). -C K >= 0. -C -C REZ (input) DOUBLE PRECISION array, dimension (K) -C IMZ (input) DOUBLE PRECISION array, dimension (K) -C The real and imaginary parts of the i-th zero of P(x) -C must be stored in REZ(i) and IMZ(i), respectively, where -C i = 1, 2, ..., K. The zeros may be supplied in any order, -C except that complex conjugate zeros must appear -C consecutively. -C -C P (output) DOUBLE PRECISION array, dimension (K+1) -C This array contains the coefficients of P(x) in decreasing -C powers of x. -C -C Workspace -C -C DWORK DOUBLE PRECISION array, dimension (K) -C If K = 0, this array is not referenced. -C -C Error Indicator -C -C INFO INTEGER -C = 0: successful exit; -C < 0: if INFO = -i, the i-th argument had an illegal -C value; -C > 0: if INFO = i, (REZ(i),IMZ(i)) is a complex zero but -C (REZ(i-1),IMZ(i-1)) is not its conjugate. -C -C METHOD -C -C The routine computes the coefficients of the real K-th degree -C polynomial P(x) as -C -C P(x) = (x - r(1)) * (x - r(2)) * ... * (x - r(K)) -C -C where r(i) = (REZ(i),IMZ(i)). -C -C Note that REZ(i) = REZ(j) and IMZ(i) = -IMZ(j) if r(i) and r(j) -C form a complex conjugate pair (where i <> j), and that IMZ(i) = 0 -C if r(i) is real. -C -C NUMERICAL ASPECTS -C -C None. -C -C CONTRIBUTOR -C -C V. Sima, Research Institute for Informatics, Bucharest, May 2002. -C -C REVISIONS -C -C - -C -C KEYWORDS -C -C Elementary polynomial operations, polynomial operations. -C -C ****************************************************************** -C -C .. Parameters .. - DOUBLE PRECISION ZERO, ONE - PARAMETER ( ZERO = 0.0D0, ONE = 1.0D0 ) -C .. Scalar Arguments .. - INTEGER INFO, K -C .. Array Arguments .. - DOUBLE PRECISION DWORK(*), IMZ(*), P(*), REZ(*) -C .. Local Scalars .. - INTEGER I - DOUBLE PRECISION U, V -C .. External Subroutines .. - EXTERNAL DAXPY, DCOPY, XERBLA -C .. Executable Statements .. -C -C Test the input scalar arguments. -C - IF( K.LT.0 ) THEN - INFO = -1 -C -C Error return. -C - CALL XERBLA( 'MC01PY', -INFO ) - RETURN - END IF -C -C Quick return if possible. -C - INFO = 0 - P(1) = ONE - IF ( K.EQ.0 ) - $ RETURN -C - I = 1 -C WHILE ( I <= K ) DO - 20 IF ( I.LE.K ) THEN - U = REZ(I) - V = IMZ(I) - DWORK(I) = ZERO -C - IF ( V.EQ.ZERO ) THEN - CALL DAXPY( I, -U, P, 1, DWORK, 1 ) -C - ELSE - IF ( I.EQ.K ) THEN - INFO = K - RETURN - ELSE IF ( ( U.NE.REZ(I+1) ) .OR. ( V.NE.-IMZ(I+1) ) ) THEN - INFO = I + 1 - RETURN - END IF -C - DWORK(I+1) = ZERO - CALL DAXPY( I, -(U + U), P, 1, DWORK, 1 ) - CALL DAXPY( I, U**2+V**2, P, 1, DWORK(2), 1 ) - I = I + 1 - END IF -C - CALL DCOPY( I, DWORK, 1, P(2), 1 ) - I = I + 1 - GO TO 20 - END IF -C END WHILE 20 -C - RETURN -C *** Last line of MC01PY *** - END diff --git a/mex/sources/libslicot/MC01QD.f b/mex/sources/libslicot/MC01QD.f deleted file mode 100644 index 652887bb6..000000000 --- a/mex/sources/libslicot/MC01QD.f +++ /dev/null @@ -1,207 +0,0 @@ - SUBROUTINE MC01QD( DA, DB, A, B, RQ, IWARN, INFO ) -C -C SLICOT RELEASE 5.0. -C -C Copyright (c) 2002-2009 NICONET e.V. -C -C This program is free software: you can redistribute it and/or -C modify it under the terms of the GNU General Public License as -C published by the Free Software Foundation, either version 2 of -C the License, or (at your option) any later version. -C -C This program is distributed in the hope that it will be useful, -C but WITHOUT ANY WARRANTY; without even the implied warranty of -C MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the -C GNU General Public License for more details. -C -C You should have received a copy of the GNU General Public License -C along with this program. If not, see -C . -C -C PURPOSE -C -C To compute, for two given real polynomials A(x) and B(x), the -C quotient polynomial Q(x) and the remainder polynomial R(x) of -C A(x) divided by B(x). -C -C The polynomials Q(x) and R(x) satisfy the relationship -C -C A(x) = B(x) * Q(x) + R(x), -C -C where the degree of R(x) is less than the degree of B(x). -C -C ARGUMENTS -C -C Input/Output Parameters -C -C DA (input) INTEGER -C The degree of the numerator polynomial A(x). DA >= -1. -C -C DB (input/output) INTEGER -C On entry, the degree of the denominator polynomial B(x). -C DB >= 0. -C On exit, if B(DB+1) = 0.0 on entry, then DB contains the -C index of the highest power of x for which B(DB+1) <> 0.0. -C -C A (input) DOUBLE PRECISION array, dimension (DA+1) -C This array must contain the coefficients of the -C numerator polynomial A(x) in increasing powers of x -C unless DA = -1 on entry, in which case A(x) is taken -C to be the zero polynomial. -C -C B (input) DOUBLE PRECISION array, dimension (DB+1) -C This array must contain the coefficients of the -C denominator polynomial B(x) in increasing powers of x. -C -C RQ (output) DOUBLE PRECISION array, dimension (DA+1) -C If DA < DB on exit, then this array contains the -C coefficients of the remainder polynomial R(x) in -C increasing powers of x; Q(x) is the zero polynomial. -C Otherwise, the leading DB elements of this array contain -C the coefficients of R(x) in increasing powers of x, and -C the next (DA-DB+1) elements contain the coefficients of -C Q(x) in increasing powers of x. -C -C Warning Indicator -C -C IWARN INTEGER -C = 0: no warning; -C = k: if the degree of the denominator polynomial B(x) has -C been reduced to (DB - k) because B(DB+1-j) = 0.0 on -C entry for j = 0, 1, ..., k-1 and B(DB+1-k) <> 0.0. -C -C Error Indicator -C -C INFO INTEGER -C = 0: successful exit; -C < 0: if INFO = -i, the i-th argument had an illegal -C value; -C = 1: if on entry, DB >= 0 and B(i) = 0.0, where -C i = 1, 2, ..., DB+1. -C -C METHOD -C -C Given real polynomials -C DA -C A(x) = a(1) + a(2) * x + ... + a(DA+1) * x -C -C and -C DB -C B(x) = b(1) + b(2) * x + ... + b(DB+1) * x -C -C where b(DB+1) is non-zero, the routine computes the coeffcients of -C the quotient polynomial -C DA-DB -C Q(x) = q(1) + q(2) * x + ... + q(DA-DB+1) * x -C -C and the remainder polynomial -C DB-1 -C R(x) = r(1) + r(2) * x + ... + r(DB) * x -C -C such that A(x) = B(x) * Q(x) + R(x). -C -C The algorithm used is synthetic division of polynomials (see [1]), -C which involves the following steps: -C -C (a) compute q(k+1) = a(DB+k+1) / b(DB+1) -C -C and -C -C (b) set a(j) = a(j) - q(k+1) * b(j-k) for j = k+1, ..., DB+k. -C -C Steps (a) and (b) are performed for k = DA-DB, DA-DB-1, ..., 0 and -C the algorithm terminates with r(i) = a(i) for i = 1, 2, ..., DB. -C -C REFERENCES -C -C [1] Knuth, D.E. -C The Art of Computer Programming, (Vol. 2, Seminumerical -C Algorithms). -C Addison-Wesley, Reading, Massachusetts (2nd Edition), 1981. -C -C NUMERICAL ASPECTS -C -C None. -C -C CONTRIBUTOR -C -C Release 3.0: V. Sima, Katholieke Univ. Leuven, Belgium, Mar. 1997. -C Supersedes Release 2.0 routine MC01ED by A.J. Geurts. -C -C REVISIONS -C -C - -C -C KEYWORDS -C -C Elementary polynomial operations, polynomial operations. -C -C ****************************************************************** -C -C .. Parameters .. - DOUBLE PRECISION ZERO - PARAMETER ( ZERO = 0.0D0 ) -C .. Scalar Arguments .. - INTEGER DA, DB, INFO, IWARN -C .. Array Arguments .. - DOUBLE PRECISION A(*), B(*), RQ(*) -C .. Local Scalars .. - INTEGER N - DOUBLE PRECISION Q -C .. External Subroutines .. - EXTERNAL DAXPY, DCOPY, XERBLA -C .. Executable Statements .. -C -C Test the input scalar arguments. -C - IWARN = 0 - INFO = 0 - IF( DA.LT.-1 ) THEN - INFO = -1 - ELSE IF( DB.LT.0 ) THEN - INFO = -2 - END IF -C - IF ( INFO.NE.0 ) THEN -C -C Error return. -C - CALL XERBLA( 'MC01QD', -INFO ) - RETURN - END IF -C -C WHILE ( DB >= 0 and B(DB+1) = 0 ) DO - 20 IF ( DB.GE.0 ) THEN - IF ( B(DB+1).EQ.ZERO ) THEN - DB = DB - 1 - IWARN = IWARN + 1 - GO TO 20 - END IF - END IF -C END WHILE 20 - IF ( DB.EQ.-1 ) THEN - INFO = 1 - RETURN - END IF -C -C B(x) is non-zero. -C - IF ( DA.GE.0 ) THEN - N = DA - CALL DCOPY( N+1, A, 1, RQ, 1 ) -C WHILE ( N >= DB ) DO - 40 IF ( N.GE.DB ) THEN - IF ( RQ(N+1).NE.ZERO ) THEN - Q = RQ(N+1)/B(DB+1) - CALL DAXPY( DB, -Q, B, 1, RQ(N-DB+1), 1 ) - RQ(N+1) = Q - END IF - N = N - 1 - GO TO 40 - END IF -C END WHILE 40 - END IF -C - RETURN -C *** Last line of MC01QD *** - END diff --git a/mex/sources/libslicot/MC01RD.f b/mex/sources/libslicot/MC01RD.f deleted file mode 100644 index da1b3dc2f..000000000 --- a/mex/sources/libslicot/MC01RD.f +++ /dev/null @@ -1,299 +0,0 @@ - SUBROUTINE MC01RD( DP1, DP2, DP3, ALPHA, P1, P2, P3, INFO ) -C -C SLICOT RELEASE 5.0. -C -C Copyright (c) 2002-2009 NICONET e.V. -C -C This program is free software: you can redistribute it and/or -C modify it under the terms of the GNU General Public License as -C published by the Free Software Foundation, either version 2 of -C the License, or (at your option) any later version. -C -C This program is distributed in the hope that it will be useful, -C but WITHOUT ANY WARRANTY; without even the implied warranty of -C MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the -C GNU General Public License for more details. -C -C You should have received a copy of the GNU General Public License -C along with this program. If not, see -C . -C -C PURPOSE -C -C To compute the coefficients of the polynomial -C -C P(x) = P1(x) * P2(x) + alpha * P3(x), -C -C where P1(x), P2(x) and P3(x) are given real polynomials and alpha -C is a real scalar. -C -C Each of the polynomials P1(x), P2(x) and P3(x) may be the zero -C polynomial. -C -C ARGUMENTS -C -C Input/Output Parameters -C -C DP1 (input) INTEGER -C The degree of the polynomial P1(x). DP1 >= -1. -C -C DP2 (input) INTEGER -C The degree of the polynomial P2(x). DP2 >= -1. -C -C DP3 (input/output) INTEGER -C On entry, the degree of the polynomial P3(x). DP3 >= -1. -C On exit, the degree of the polynomial P(x). -C -C ALPHA (input) DOUBLE PRECISION -C The scalar value alpha of the problem. -C -C P1 (input) DOUBLE PRECISION array, dimension (lenp1) -C where lenp1 = DP1 + 1 if DP1 >= 0 and 1 otherwise. -C If DP1 >= 0, then this array must contain the -C coefficients of P1(x) in increasing powers of x. -C If DP1 = -1, then P1(x) is taken to be the zero -C polynomial, P1 is not referenced and can be supplied -C as a dummy array. -C -C P2 (input) DOUBLE PRECISION array, dimension (lenp2) -C where lenp2 = DP2 + 1 if DP2 >= 0 and 1 otherwise. -C If DP2 >= 0, then this array must contain the -C coefficients of P2(x) in increasing powers of x. -C If DP2 = -1, then P2(x) is taken to be the zero -C polynomial, P2 is not referenced and can be supplied -C as a dummy array. -C -C P3 (input/output) DOUBLE PRECISION array, dimension (lenp3) -C where lenp3 = MAX(DP1+DP2,DP3,0) + 1. -C On entry, if DP3 >= 0, then this array must contain the -C coefficients of P3(x) in increasing powers of x. -C On entry, if DP3 = -1, then P3(x) is taken to be the zero -C polynomial. -C On exit, the leading (DP3+1) elements of this array -C contain the coefficients of P(x) in increasing powers of x -C unless DP3 = -1 on exit, in which case the coefficients of -C P(x) (the zero polynomial) are not stored in the array. -C This is the case, for instance, when ALPHA = 0.0 and -C P1(x) or P2(x) is the zero polynomial. -C -C Error Indicator -C -C INFO INTEGER -C = 0: successful exit; -C < 0: if INFO = -i, the i-th argument had an illegal -C value. -C -C METHOD -C -C Given real polynomials -C -C DP1 i DP2 i -C P1(x) = SUM a(i+1) * x , P2(x) = SUM b(i+1) * x and -C i=0 i=0 -C -C DP3 i -C P3(x) = SUM c(i+1) * x , -C i=0 -C -C the routine computes the coefficents of P(x) = P1(x) * P2(x) + -C DP3 i -C alpha * P3(x) = SUM d(i+1) * x as follows. -C i=0 -C -C Let e(i) = c(i) for 1 <= i <= DP3+1 and e(i) = 0 for i > DP3+1. -C Then if DP1 >= DP2, -C -C i -C d(i) = SUM a(k) * b(i-k+1) + f(i), for i = 1, ..., DP2+1, -C k=1 -C -C i -C d(i) = SUM a(k) * b(i-k+1) + f(i), for i = DP2+2, ..., DP1+1 -C k=i-DP2 -C -C and -C DP1+1 -C d(i) = SUM a(k) * b(i-k+1) + f(i) for i = DP1+2,...,DP1+DP2+1, -C k=i-DP2 -C -C where f(i) = alpha * e(i). -C -C Similar formulas hold for the case DP1 < DP2. -C -C NUMERICAL ASPECTS -C -C None. -C -C CONTRIBUTORS -C -C Release 3.0: V. Sima, Katholieke Univ. Leuven, Belgium, Mar. 1997. -C Supersedes Release 2.0 routine MC01FD by C. Klimann and -C A.J. Geurts. -C -C REVISIONS -C -C - -C -C KEYWORDS -C -C Elementary polynomial operations, polynomial operations. -C -C ****************************************************************** -C -C .. Parameters .. - DOUBLE PRECISION ZERO - PARAMETER ( ZERO = 0.0D0 ) -C .. Scalar Arguments .. - INTEGER DP1, DP2, DP3, INFO - DOUBLE PRECISION ALPHA -C .. Array Arguments .. - DOUBLE PRECISION P1(*), P2(*), P3(*) -C .. Local Scalars .. - INTEGER D1, D2, D3, DMAX, DMIN, DSUM, E3, I, J, K, L -C .. External Functions .. - DOUBLE PRECISION DDOT - EXTERNAL DDOT -C .. External Subroutines .. - EXTERNAL DAXPY, DCOPY, DSCAL, XERBLA -C .. Intrinsic Functions .. - INTRINSIC MAX -C .. Executable Statements .. -C -C Test the input scalar arguments. -C - INFO = 0 - IF( DP1.LT.-1 ) THEN - INFO = -1 - ELSE IF( DP2.LT.-1 ) THEN - INFO = -2 - ELSE IF( DP3.LT.-1 ) THEN - INFO = -3 - END IF -C - IF ( INFO.NE.0 ) THEN -C -C Error return. -C - CALL XERBLA( 'MC01RD', -INFO ) - RETURN - END IF -C -C Computation of the exact degree of the polynomials, i.e., Di such -C that either Di = -1 or Pi(Di+1) is non-zero. -C - D1 = DP1 -C WHILE ( D1 >= 0 and P1(D1+1) = 0 ) DO - 20 IF ( D1.GE.0 ) THEN - IF ( P1(D1+1).EQ.ZERO ) THEN - D1 = D1 - 1 - GO TO 20 - END IF - END IF -C END WHILE 20 - D2 = DP2 -C WHILE ( D2 >= 0 and P2(D2+1) = 0 ) DO - 40 IF ( D2.GE.0 ) THEN - IF ( P2(D2+1).EQ.ZERO ) THEN - D2 = D2 - 1 - GO TO 40 - END IF - END IF -C END WHILE 40 - IF ( ALPHA.EQ.ZERO ) THEN - D3 = -1 - ELSE - D3 = DP3 - END IF -C WHILE ( D3 >= 0 and P3(D3+1) = 0 ) DO - 60 IF ( D3.GE.0 ) THEN - IF ( P3(D3+1).EQ.ZERO ) THEN - D3 = D3 - 1 - GO TO 60 - END IF - END IF -C END WHILE 60 -C -C Computation of P3(x) := ALPHA * P3(x). -C - CALL DSCAL( D3+1, ALPHA, P3, 1 ) -C - IF ( ( D1.EQ.-1 ) .OR. ( D2.EQ.-1 ) ) THEN - DP3 = D3 - RETURN - END IF -C -C P1(x) and P2(x) are non-zero polynomials. -C - DSUM = D1 + D2 - DMAX = MAX( D1, D2 ) - DMIN = DSUM - DMAX -C - IF ( D3.LT.DSUM ) THEN - P3(D3+2) = ZERO - CALL DCOPY( DSUM-D3-1, P3(D3+2), 0, P3(D3+3), 1 ) - D3 = DSUM - END IF -C - IF ( ( D1.EQ.0 ) .OR. ( D2.EQ.0 ) ) THEN -C -C D1 or D2 is zero. -C - IF ( D1.NE.0 ) THEN - CALL DAXPY( D1+1, P2(1), P1, 1, P3, 1 ) - ELSE - CALL DAXPY( D2+1, P1(1), P2, 1, P3, 1 ) - END IF - ELSE -C -C D1 and D2 are both nonzero. -C -C First part of the computation. -C - DO 80 I = 1, DMIN + 1 - P3(I) = P3(I) + DDOT( I, P1, 1, P2, -1 ) - 80 CONTINUE -C -C Second part of the computation. -C - DO 100 I = DMIN + 2, DMAX + 1 - IF ( D1.GT.D2 ) THEN - K = I - D2 - P3(I) = P3(I) + DDOT( DMIN+1, P1(K), 1, P2, -1 ) - ELSE - K = I - D1 - P3(I) = P3(I) + DDOT( DMIN+1, P2(K), -1, P1, 1 ) - END IF - 100 CONTINUE -C -C Third part of the computation. -C - E3 = DSUM + 2 -C - DO 120 I = DMAX + 2, DSUM + 1 - J = E3 - I - K = I - DMIN - L = I - DMAX - IF ( D1.GT.D2 ) THEN - P3(I) = P3(I) + DDOT( J, P1(K), 1, P2(L), -1 ) - ELSE - P3(I) = P3(I) + DDOT( J, P1(L), -1, P2(K), 1 ) - END IF - 120 CONTINUE -C - END IF -C -C Computation of the exact degree of P3(x). -C -C WHILE ( D3 >= 0 and P3(D3+1) = 0 ) DO - 140 IF ( D3.GE.0 ) THEN - IF ( P3(D3+1).EQ.ZERO ) THEN - D3 = D3 - 1 - GO TO 140 - END IF - END IF -C END WHILE 140 - DP3 = D3 -C - RETURN -C *** Last line of MC01RD *** - END diff --git a/mex/sources/libslicot/MC01SD.f b/mex/sources/libslicot/MC01SD.f deleted file mode 100644 index d84362ee2..000000000 --- a/mex/sources/libslicot/MC01SD.f +++ /dev/null @@ -1,281 +0,0 @@ - SUBROUTINE MC01SD( DP, P, S, T, MANT, E, IWORK, INFO ) -C -C SLICOT RELEASE 5.0. -C -C Copyright (c) 2002-2009 NICONET e.V. -C -C This program is free software: you can redistribute it and/or -C modify it under the terms of the GNU General Public License as -C published by the Free Software Foundation, either version 2 of -C the License, or (at your option) any later version. -C -C This program is distributed in the hope that it will be useful, -C but WITHOUT ANY WARRANTY; without even the implied warranty of -C MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the -C GNU General Public License for more details. -C -C You should have received a copy of the GNU General Public License -C along with this program. If not, see -C . -C -C PURPOSE -C -C To scale the coefficients of the real polynomial P(x) such that -C the coefficients of the scaled polynomial Q(x) = sP(tx) have -C minimal variation, where s and t are real scalars. -C -C ARGUMENTS -C -C Input/Output Parameters -C -C DP (input) INTEGER -C The degree of the polynomial P(x). DP >= 0. -C -C P (input/output) DOUBLE PRECISION array, dimension (DP+1) -C On entry, this array must contain the coefficients of P(x) -C in increasing powers of x. -C On exit, this array contains the coefficients of the -C scaled polynomial Q(x) in increasing powers of x. -C -C S (output) INTEGER -C The exponent of the floating-point representation of the -C scaling factor s = BASE**S, where BASE is the base of the -C machine representation of floating-point numbers (see -C LAPACK Library Routine DLAMCH). -C -C T (output) INTEGER -C The exponent of the floating-point representation of the -C scaling factor t = BASE**T. -C -C MANT (output) DOUBLE PRECISION array, dimension (DP+1) -C This array contains the mantissas of the standard -C floating-point representation of the coefficients of the -C scaled polynomial Q(x) in increasing powers of x. -C -C E (output) INTEGER array, dimension (DP+1) -C This array contains the exponents of the standard -C floating-point representation of the coefficients of the -C scaled polynomial Q(x) in increasing powers of x. -C -C Workspace -C -C IWORK INTEGER array, dimension (DP+1) -C -C Error Indicator -C -C INFO INTEGER -C = 0: successful exit; -C < 0: if INFO = -i, the i-th argument had an illegal -C value; -C = 1: if on entry, P(x) is the zero polynomial. -C -C METHOD -C -C Define the variation of the coefficients of the real polynomial -C -C 2 DP -C P(x) = p(0) + p(1) * x + p(2) * x + ... + p(DP) x -C -C whose non-zero coefficients can be represented as -C e(i) -C p(i) = m(i) * BASE (where 1 <= ABS(m(i)) < BASE) -C -C by -C -C V = max(e(i)) - min(e(i)), -C -C where max and min are taken over the indices i for which p(i) is -C non-zero. -C DP i i -C For the scaled polynomial P(cx) = SUM p(i) * c * x with -C i=0 -C j -C c = (BASE) , the variation V(j) is given by -C -C V(j) = max(e(i) + j * i) - min(e(i) + j * i). -C -C Using the fact that V(j) is a convex function of j, the routine -C determines scaling factors s = (BASE)**S and t = (BASE)**T such -C that the coefficients of the scaled polynomial Q(x) = sP(tx) -C satisfy the following conditions: -C -C (a) 1 <= q(0) < BASE and -C -C (b) the variation of the coefficients of Q(x) is minimal. -C -C Further details can be found in [1]. -C -C REFERENCES -C -C [1] Dunaway, D.K. -C Calculation of Zeros of a Real Polynomial through -C Factorization using Euclid's Algorithm. -C SIAM J. Numer. Anal., 11, pp. 1087-1104, 1974. -C -C NUMERICAL ASPECTS -C -C Since the scaling is performed on the exponents of the floating- -C point representation of the coefficients of P(x), no rounding -C errors occur during the computation of the coefficients of Q(x). -C -C FURTHER COMMENTS -C -C The scaling factors s and t are BASE dependent. -C -C CONTRIBUTOR -C -C Release 3.0: V. Sima, Katholieke Univ. Leuven, Belgium, Mar. 1997. -C Supersedes Release 2.0 routine MC01GD by A.J. Geurts. -C -C REVISIONS -C -C - -C -C KEYWORDS -C -C Elementary polynomial operations, polynomial operations. -C -C ****************************************************************** -C -C .. Parameters .. - DOUBLE PRECISION ZERO - PARAMETER ( ZERO = 0.0D0 ) -C .. Scalar Arguments .. - INTEGER DP, INFO, S, T -C .. Array Arguments .. - INTEGER E(*), IWORK(*) - DOUBLE PRECISION MANT(*), P(*) -C .. Local Scalars .. - LOGICAL OVFLOW - INTEGER BETA, DV, I, INC, J, LB, M, UB, V0, V1 -C .. External Functions .. - INTEGER MC01SX - DOUBLE PRECISION DLAMCH - EXTERNAL DLAMCH, MC01SX -C .. External Subroutines .. - EXTERNAL MC01SW, MC01SY, XERBLA -C .. Intrinsic Functions .. - INTRINSIC DBLE, NINT -C .. Executable Statements .. -C -C Test the input scalar arguments. -C - IF( DP.LT.0 ) THEN - INFO = -1 -C -C Error return. -C - CALL XERBLA( 'MC01SD', -INFO ) - RETURN - END IF -C - INFO = 0 - LB = 1 -C WHILE ( LB <= DP+1 and P(LB) = 0 ) DO - 20 IF ( LB.LE.DP+1 ) THEN - IF ( P(LB).EQ.ZERO ) THEN - LB = LB + 1 - GO TO 20 - END IF - END IF -C END WHILE 20 -C -C LB = MIN( i: P(i) non-zero). -C - IF ( LB.EQ.DP+2 ) THEN - INFO = 1 - RETURN - END IF -C - UB = DP + 1 -C WHILE ( P(UB) = 0 ) DO - 40 IF ( P(UB).EQ.ZERO ) THEN - UB = UB - 1 - GO TO 40 - END IF -C END WHILE 40 -C -C UB = MAX(i: P(i) non-zero). -C - BETA = DLAMCH( 'Base' ) -C - DO 60 I = 1, DP + 1 - CALL MC01SW( P(I), BETA, MANT(I), E(I) ) - 60 CONTINUE -C -C First prescaling. -C - M = E(LB) - IF ( M.NE.0 ) THEN -C - DO 80 I = LB, UB - IF ( MANT(I).NE.ZERO ) E(I) = E(I) - M - 80 CONTINUE -C - END IF - S = -M -C -C Second prescaling. -C - IF ( UB.GT.1 ) M = NINT( DBLE( E(UB) )/DBLE( UB-1 ) ) -C - DO 100 I = LB, UB - IF ( MANT(I).NE.ZERO ) E(I) = E(I) - M*(I-1) - 100 CONTINUE -C - T = -M -C - V0 = MC01SX( LB, UB, E, MANT ) - J = 1 -C - DO 120 I = LB, UB - IF ( MANT(I).NE.ZERO ) IWORK(I) = E(I) + (I-1) - 120 CONTINUE -C - V1 = MC01SX( LB, UB, IWORK, MANT ) - DV = V1 - V0 - IF ( DV.NE.0 ) THEN - IF ( DV.GT.0 ) THEN - J = 0 - INC = -1 - V1 = V0 - DV = -DV -C - DO 130 I = LB, UB - IWORK(I) = E(I) - 130 CONTINUE -C - ELSE - INC = 1 - END IF -C WHILE ( DV < 0 ) DO - 140 IF ( DV.LT.0 ) THEN - V0 = V1 -C - DO 150 I = LB, UB - E(I) = IWORK(I) - 150 CONTINUE -C - J = J + INC -C - DO 160 I = LB, UB - IWORK(I) = E(I) + INC*(I-1 ) - 160 CONTINUE -C - V1 = MC01SX( LB, UB, IWORK, MANT ) - DV = V1 - V0 - GO TO 140 - END IF -C END WHILE 140 - T = T + J - INC - END IF -C -C Evaluation of the output parameters. -C - DO 180 I = LB, UB - CALL MC01SY( MANT(I), E(I), BETA, P(I), OVFLOW ) - 180 CONTINUE -C - RETURN -C *** Last line of MC01SD *** - END diff --git a/mex/sources/libslicot/MC01SW.f b/mex/sources/libslicot/MC01SW.f deleted file mode 100644 index 55e155e59..000000000 --- a/mex/sources/libslicot/MC01SW.f +++ /dev/null @@ -1,104 +0,0 @@ - SUBROUTINE MC01SW( A, B, M, E ) -C -C SLICOT RELEASE 5.0. -C -C Copyright (c) 2002-2009 NICONET e.V. -C -C This program is free software: you can redistribute it and/or -C modify it under the terms of the GNU General Public License as -C published by the Free Software Foundation, either version 2 of -C the License, or (at your option) any later version. -C -C This program is distributed in the hope that it will be useful, -C but WITHOUT ANY WARRANTY; without even the implied warranty of -C MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the -C GNU General Public License for more details. -C -C You should have received a copy of the GNU General Public License -C along with this program. If not, see -C . -C -C PURPOSE -C -C To find the mantissa M and the exponent E of a real number A such -C that -C A = M * B**E -C 1 <= ABS( M ) < B -C if A is non-zero. If A is zero, then M and E are set to 0. -C -C ARGUMENTS -C -C Input/Output Parameters -C -C A (input) DOUBLE PRECISION -C The number whose mantissa and exponent are required. -C -C B (input) INTEGER -C The base of the floating-point arithmetic. -C -C M (output) DOUBLE PRECISION -C The mantissa of the floating-point representation of A. -C -C E (output) INTEGER -C The exponent of the floating-point representation of A. -C -C NUMERICAL ASPECTS -C -C None. -C -C CONTRIBUTOR -C -C Release 3.0: V. Sima, Katholieke Univ. Leuven, Belgium, Mar. 1997. -C Supersedes Release 2.0 routine MC01GZ by A.J. Geurts. -C -C REVISIONS -C -C - -C -C ****************************************************************** -C -C .. Parameters .. - DOUBLE PRECISION ZERO, ONE - PARAMETER ( ZERO = 0.0D0, ONE = 1.0D0 ) -C .. Scalar Arguments .. - INTEGER B, E - DOUBLE PRECISION A, M -C .. Local Scalars .. - DOUBLE PRECISION DB -C .. Intrinsic Functions .. - INTRINSIC ABS, DBLE -C .. Executable Statements .. -C -C Quick return if possible. -C - IF ( A.EQ.ZERO ) THEN - M = ZERO - E = 0 - RETURN - END IF -C -C A non-zero. -C - DB = DBLE( B ) - M = ABS( A ) - E = 0 -C WHILE ( M >= B ) DO - 20 IF ( M.GE.DB ) THEN - M = M/DB - E = E + 1 - GO TO 20 - END IF -C END WHILE 20 -C WHILE ( M < 1 ) DO - 40 IF ( M.LT.ONE ) THEN - M = M*DB - E = E - 1 - GO TO 40 - END IF -C END WHILE 40 -C - IF ( A.LT.ZERO ) M = -M -C - RETURN -C *** Last line of MC01SW *** - END diff --git a/mex/sources/libslicot/MC01SX.f b/mex/sources/libslicot/MC01SX.f deleted file mode 100644 index c20360154..000000000 --- a/mex/sources/libslicot/MC01SX.f +++ /dev/null @@ -1,68 +0,0 @@ - INTEGER FUNCTION MC01SX( LB, UB, E, MANT ) -C -C SLICOT RELEASE 5.0. -C -C Copyright (c) 2002-2009 NICONET e.V. -C -C This program is free software: you can redistribute it and/or -C modify it under the terms of the GNU General Public License as -C published by the Free Software Foundation, either version 2 of -C the License, or (at your option) any later version. -C -C This program is distributed in the hope that it will be useful, -C but WITHOUT ANY WARRANTY; without even the implied warranty of -C MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the -C GNU General Public License for more details. -C -C You should have received a copy of the GNU General Public License -C along with this program. If not, see -C . -C -C PURPOSE -C -C To compute the variation V of the exponents of a series of -C non-zero floating-point numbers: a(j) = MANT(j) * beta**(E(j)), -C where beta is the base of the machine representation of -C floating-point numbers, i.e., -C V = max(E(j)) - min(E(j)), j = LB,...,UB and MANT(j) non-zero. -C -C CONTRIBUTOR -C -C Release 3.0: V. Sima, Katholieke Univ. Leuven, Belgium, Mar. 1997. -C Supersedes Release 2.0 routine MC01GX by A.J. Geurts. -C -C REVISIONS -C -C - -C -C ****************************************************************** -C -C .. Parameters .. - DOUBLE PRECISION ZERO - PARAMETER ( ZERO = 0.0D0 ) -C .. Scalar Arguments .. - INTEGER LB, UB -C .. Array Arguments .. - INTEGER E(*) - DOUBLE PRECISION MANT(*) -C .. Local Scalars .. - INTEGER J, MAXE, MINE -C .. Intrinsic Functions .. - INTRINSIC MAX, MIN -C .. Executable Statements .. -C - MAXE = E(LB) - MINE = MAXE -C - DO 20 J = LB + 1, UB - IF ( MANT(J).NE.ZERO ) THEN - MAXE = MAX( MAXE, E(J) ) - MINE = MIN( MINE, E(J) ) - END IF - 20 CONTINUE -C - MC01SX = MAXE - MINE -C - RETURN -C *** Last line of MC01SX *** - END diff --git a/mex/sources/libslicot/MC01SY.f b/mex/sources/libslicot/MC01SY.f deleted file mode 100644 index ab187aa50..000000000 --- a/mex/sources/libslicot/MC01SY.f +++ /dev/null @@ -1,146 +0,0 @@ - SUBROUTINE MC01SY( M, E, B, A, OVFLOW ) -C -C SLICOT RELEASE 5.0. -C -C Copyright (c) 2002-2009 NICONET e.V. -C -C This program is free software: you can redistribute it and/or -C modify it under the terms of the GNU General Public License as -C published by the Free Software Foundation, either version 2 of -C the License, or (at your option) any later version. -C -C This program is distributed in the hope that it will be useful, -C but WITHOUT ANY WARRANTY; without even the implied warranty of -C MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the -C GNU General Public License for more details. -C -C You should have received a copy of the GNU General Public License -C along with this program. If not, see -C . -C -C PURPOSE -C -C To find a real number A from its mantissa M and its exponent E, -C i.e., -C A = M * B**E. -C M and E need not be the standard floating-point values. -C If ABS(A) < B**(EMIN-1), i.e. the smallest positive model number, -C then the routine returns A = 0. -C If M = 0, then the routine returns A = 0 regardless of the value -C of E. -C -C ARGUMENTS -C -C Input/Output Parameters -C -C M (input) DOUBLE PRECISION -C The mantissa of the floating-point representation of A. -C -C E (input) INTEGER -C The exponent of the floating-point representation of A. -C -C B (input) INTEGER -C The base of the floating-point arithmetic. -C -C A (output) DOUBLE PRECISION -C The value of M * B**E. -C -C OVFLOW (output) LOGICAL -C The value .TRUE., if ABS(M) * B**E >= B**EMAX (where EMAX -C is the largest possible exponent) and .FALSE. otherwise. -C A is not defined if OVFLOW = .TRUE.. -C -C NUMERICAL ASPECTS -C -C None. -C -C CONTRIBUTOR -C -C Release 3.0: V. Sima, Katholieke Univ. Leuven, Belgium, Mar. 1997. -C Supersedes Release 2.0 routine MC01GY by A.J. Geurts. -C -C REVISIONS -C -C - -C -C ****************************************************************** -C -C .. Parameters .. - DOUBLE PRECISION ZERO, ONE - PARAMETER ( ZERO = 0.0D0, ONE = 1.0D0 ) -C .. Scalar Arguments .. - LOGICAL OVFLOW - INTEGER B, E - DOUBLE PRECISION A, M -C .. Local Scalars .. - INTEGER EMAX, EMIN, ET, EXPON - DOUBLE PRECISION BASE, MT -C .. External Functions .. - DOUBLE PRECISION DLAMCH - EXTERNAL DLAMCH -C .. Intrinsic Functions .. - INTRINSIC ABS, MOD -C .. Executable Statements .. -C - OVFLOW = .FALSE. -C - IF ( ( M.EQ.ZERO ) .OR. ( E.EQ.0 ) ) THEN - A = M - RETURN - END IF -C -C Determination of the mantissa MT and the exponent ET of the -C standard floating-point representation. -C - EMIN = DLAMCH( 'Minimum exponent' ) - EMAX = DLAMCH( 'Largest exponent' ) - MT = M - ET = E -C WHILE ( ABS( MT ) >= B ) DO - 20 IF ( ABS( MT ).GE.B ) THEN - MT = MT/B - ET = ET + 1 - GO TO 20 - END IF -C END WHILE 20 -C WHILE ( ABS( MT ) < 1 ) DO - 40 IF ( ABS( MT ).LT.ONE ) THEN - MT = MT*B - ET = ET - 1 - GO TO 40 - END IF -C END WHILE 40 -C - IF ( ET.LT.EMIN ) THEN - A = ZERO - RETURN - END IF -C - IF ( ET.GE.EMAX ) THEN - OVFLOW = .TRUE. - RETURN - END IF -C -C Computation of the value of A by the relation -C M * B**E = A * (BASE)**EXPON -C - EXPON = ABS( ET ) - A = MT - BASE = B - IF ( ET.LT.0 ) BASE = ONE/BASE -C WHILE ( not EXPON = 0 ) DO - 60 IF ( EXPON.NE.0 ) THEN - IF ( MOD( EXPON, 2 ).EQ.0 ) THEN - BASE = BASE*BASE - EXPON = EXPON/2 - ELSE - A = A*BASE - EXPON = EXPON - 1 - END IF - GO TO 60 - END IF -C END WHILE 60 -C - RETURN -C *** Last line of MC01SY *** - END diff --git a/mex/sources/libslicot/MC01TD.f b/mex/sources/libslicot/MC01TD.f deleted file mode 100644 index 249f5c367..000000000 --- a/mex/sources/libslicot/MC01TD.f +++ /dev/null @@ -1,305 +0,0 @@ - SUBROUTINE MC01TD( DICO, DP, P, STABLE, NZ, DWORK, IWARN, INFO ) -C -C SLICOT RELEASE 5.0. -C -C Copyright (c) 2002-2009 NICONET e.V. -C -C This program is free software: you can redistribute it and/or -C modify it under the terms of the GNU General Public License as -C published by the Free Software Foundation, either version 2 of -C the License, or (at your option) any later version. -C -C This program is distributed in the hope that it will be useful, -C but WITHOUT ANY WARRANTY; without even the implied warranty of -C MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the -C GNU General Public License for more details. -C -C You should have received a copy of the GNU General Public License -C along with this program. If not, see -C . -C -C PURPOSE -C -C To determine whether or not a given polynomial P(x) with real -C coefficients is stable, either in the continuous-time or discrete- -C time case. -C -C A polynomial is said to be stable in the continuous-time case -C if all its zeros lie in the left half-plane, and stable in the -C discrete-time case if all its zeros lie inside the unit circle. -C -C ARGUMENTS -C -C Mode Parameters -C -C DICO CHARACTER*1 -C Indicates whether the stability test to be applied to -C P(x) is in the continuous-time or discrete-time case as -C follows: -C = 'C': Continuous-time case; -C = 'D': Discrete-time case. -C -C Input/Output Parameters -C -C DP (input/output) INTEGER -C On entry, the degree of the polynomial P(x). DP >= 0. -C On exit, if P(DP+1) = 0.0 on entry, then DP contains the -C index of the highest power of x for which P(DP+1) <> 0.0. -C -C P (input) DOUBLE PRECISION array, dimension (DP+1) -C This array must contain the coefficients of P(x) in -C increasing powers of x. -C -C STABLE (output) LOGICAL -C Contains the value .TRUE. if P(x) is stable and the value -C .FALSE. otherwise (see also NUMERICAL ASPECTS). -C -C NZ (output) INTEGER -C If INFO = 0, contains the number of unstable zeros - that -C is, the number of zeros of P(x) in the right half-plane if -C DICO = 'C' or the number of zeros of P(x) outside the unit -C circle if DICO = 'D' (see also NUMERICAL ASPECTS). -C -C Workspace -C -C DWORK DOUBLE PRECISION array, dimension (2*DP+2) -C The leading (DP+1) elements of DWORK contain the Routh -C coefficients, if DICO = 'C', or the constant terms of -C the Schur-Cohn transforms, if DICO = 'D'. -C -C Warning Indicator -C -C IWARN INTEGER -C = 0: no warning; -C = k: if the degree of the polynomial P(x) has been -C reduced to (DB - k) because P(DB+1-j) = 0.0 on entry -C for j = 0, 1,..., k-1 and P(DB+1-k) <> 0.0. -C -C Error Indicator -C -C INFO INTEGER -C = 0: successful exit; -C < 0: if INFO = -i, the i-th argument had an illegal -C value; -C = 1: if on entry, P(x) is the zero polynomial; -C = 2: if the polynomial P(x) is most probably unstable, -C although it may be stable with one or more zeros -C very close to either the imaginary axis if -C DICO = 'C' or the unit circle if DICO = 'D'. -C The number of unstable zeros (NZ) is not determined. -C -C METHOD -C -C The stability of the real polynomial -C 2 DP -C P(x) = p(0) + p(1) * x + p(2) * x + ... + p(DP) x -C -C is determined as follows. -C -C In the continuous-time case (DICO = 'C') the Routh algorithm -C (see [1]) is used. The routine computes the Routh coefficients and -C if they are non-zero then the number of sign changes in the -C sequence of the coefficients is equal to the number of zeros with -C positive imaginary part. -C -C In the discrete-time case (DICO = 'D') the Schur-Cohn -C algorithm (see [2] and [3]) is applied to the reciprocal -C polynomial -C 2 DP -C Q(x) = p(DP) + p(DP-1) * x + p(DP-2) * x + ... + p(0) x . -C -C The routine computes the constant terms of the Schur transforms -C and if all of them are non-zero then the number of zeros of P(x) -C with modulus greater than unity is obtained from the sequence of -C constant terms. -C -C REFERENCES -C -C [1] Gantmacher, F.R. -C Applications of the Theory of Matrices. -C Interscience Publishers, New York, 1959. -C -C [2] Kucera, V. -C Discrete Linear Control. The Algorithmic Approach. -C John Wiley & Sons, Chichester, 1979. -C -C [3] Henrici, P. -C Applied and Computational Complex Analysis (Vol. 1). -C John Wiley & Sons, New York, 1974. -C -C NUMERICAL ASPECTS -C -C The algorithm used by the routine is numerically stable. -C -C Note that if some of the Routh coefficients (DICO = 'C') or -C some of the constant terms of the Schur-Cohn transforms (DICO = -C 'D') are small relative to EPS (the machine precision), then -C the number of unstable zeros (and hence the value of STABLE) may -C be incorrect. -C -C CONTRIBUTORS -C -C Release 3.0: V. Sima, Katholieke Univ. Leuven, Belgium, Mar. 1997. -C Supersedes Release 2.0 routine MC01HD by F. Delebecque and -C A.J. Geurts. -C -C REVISIONS -C -C - -C -C KEYWORDS -C -C Elementary polynomial operations, polynomial operations, -C stability, stability criteria, zeros. -C -C ****************************************************************** -C -C .. Parameters .. - DOUBLE PRECISION ZERO, ONE - PARAMETER ( ZERO = 0.0D0, ONE = 1.0D0 ) -C .. Scalar Arguments .. - CHARACTER DICO - LOGICAL STABLE - INTEGER DP, INFO, IWARN, NZ -C .. Array Arguments .. - DOUBLE PRECISION DWORK(*), P(*) -C .. Local Scalars .. - LOGICAL DICOC - INTEGER I, K, K1, K2, SIGNUM - DOUBLE PRECISION ALPHA, P1, PK1 -C .. External Functions .. - INTEGER IDAMAX - LOGICAL LSAME - EXTERNAL IDAMAX, LSAME -C .. External Subroutines .. - EXTERNAL DCOPY, DRSCL, XERBLA -C .. Intrinsic Functions .. - INTRINSIC SIGN -C .. Executable Statements .. -C - IWARN = 0 - INFO = 0 - DICOC = LSAME( DICO, 'C' ) -C -C Test the input scalar arguments. -C - IF( .NOT.DICOC .AND. .NOT.LSAME( DICO, 'D' ) ) THEN - INFO = -1 - ELSE IF( DP.LT.0 ) THEN - INFO = -2 - END IF -C - IF ( INFO.NE.0 ) THEN -C -C Error return. -C - CALL XERBLA( 'MC01TD', -INFO ) - RETURN - END IF -C -C WHILE (DP >= 0 and P(DP+1) = 0 ) DO - 20 IF ( DP.GE.0 ) THEN - IF ( P(DP+1).EQ.ZERO ) THEN - DP = DP - 1 - IWARN = IWARN + 1 - GO TO 20 - END IF - END IF -C END WHILE 20 -C - IF ( DP.EQ.-1 ) THEN - INFO = 1 - RETURN - END IF -C -C P(x) is not the zero polynomial and its degree is exactly DP. -C - IF ( DICOC ) THEN -C -C Continuous-time case. -C -C Compute the Routh coefficients and the number of sign changes. -C - CALL DCOPY( DP+1, P, 1, DWORK, 1 ) - NZ = 0 - K = DP -C WHILE ( K > 0 and DWORK(K) non-zero) DO - 40 IF ( K.GT.0 ) THEN - IF ( DWORK(K).EQ.ZERO ) THEN - INFO = 2 - ELSE - ALPHA = DWORK(K+1)/DWORK(K) - IF ( ALPHA.LT.ZERO ) NZ = NZ + 1 - K = K - 1 -C - DO 60 I = K, 2, -2 - DWORK(I) = DWORK(I) - ALPHA*DWORK(I-1) - 60 CONTINUE -C - GO TO 40 - END IF - END IF -C END WHILE 40 - ELSE -C -C Discrete-time case. -C -C To apply [3], section 6.8, on the reciprocal of polynomial -C P(x) the elements of the array P are copied in DWORK in -C reverse order. -C - CALL DCOPY( DP+1, P, 1, DWORK, -1 ) -C K-1 -C DWORK(K),...,DWORK(DP+1), are the coefficients of T P(x) -C scaled with a factor alpha(K) in order to avoid over- or -C underflow, -C i-1 -C DWORK(i), i = 1,...,K, contains alpha(i) * T P(0). -C - SIGNUM = ONE - NZ = 0 - K = 1 -C WHILE ( K <= DP and DWORK(K) non-zero ) DO - 80 IF ( ( K.LE.DP ) .AND. ( INFO.EQ.0 ) ) THEN -C K -C Compute the coefficients of T P(x). -C - K1 = DP - K + 2 - K2 = DP + 2 - ALPHA = DWORK(K-1+IDAMAX( K1, DWORK(K), 1 )) - IF ( ALPHA.EQ.ZERO ) THEN - INFO = 2 - ELSE - CALL DCOPY( K1, DWORK(K), 1, DWORK(K2), 1 ) - CALL DRSCL( K1, ALPHA, DWORK(K2), 1 ) - P1 = DWORK(K2) - PK1 = DWORK(K2+K1-1) -C - DO 100 I = 1, K1 - 1 - DWORK(K+I) = P1*DWORK(DP+1+I) - PK1*DWORK(K2+K1-I) - 100 CONTINUE -C -C Compute the number of unstable zeros. -C - K = K + 1 - IF ( DWORK(K).EQ.ZERO ) THEN - INFO = 2 - ELSE - SIGNUM = SIGNUM*SIGN( ONE, DWORK(K) ) - IF ( SIGNUM.LT.ZERO ) NZ = NZ + 1 - END IF - GO TO 80 - END IF -C END WHILE 80 - END IF - END IF -C - IF ( ( INFO.EQ.0 ) .AND. ( NZ.EQ.0 ) ) THEN - STABLE = .TRUE. - ELSE - STABLE = .FALSE. - END IF -C - RETURN -C *** Last line of MC01TD *** - END diff --git a/mex/sources/libslicot/MC01VD.f b/mex/sources/libslicot/MC01VD.f deleted file mode 100644 index 4d03390b1..000000000 --- a/mex/sources/libslicot/MC01VD.f +++ /dev/null @@ -1,304 +0,0 @@ - SUBROUTINE MC01VD( A, B, C, Z1RE, Z1IM, Z2RE, Z2IM, INFO ) -C -C SLICOT RELEASE 5.0. -C -C Copyright (c) 2002-2009 NICONET e.V. -C -C This program is free software: you can redistribute it and/or -C modify it under the terms of the GNU General Public License as -C published by the Free Software Foundation, either version 2 of -C the License, or (at your option) any later version. -C -C This program is distributed in the hope that it will be useful, -C but WITHOUT ANY WARRANTY; without even the implied warranty of -C MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the -C GNU General Public License for more details. -C -C You should have received a copy of the GNU General Public License -C along with this program. If not, see -C . -C -C PURPOSE -C -C To compute the roots of a quadratic equation with real -C coefficients. -C -C ARGUMENTS -C -C Input/Output Parameters -C -C A (input) DOUBLE PRECISION -C The value of the coefficient of the quadratic term. -C -C B (input) DOUBLE PRECISION -C The value of the coefficient of the linear term. -C -C C (input) DOUBLE PRECISION -C The value of the coefficient of the constant term. -C -C Z1RE (output) DOUBLE PRECISION -C Z1IM (output) DOUBLE PRECISION -C The real and imaginary parts, respectively, of the largest -C root in magnitude. -C -C Z2RE (output) DOUBLE PRECISION -C Z2IM (output) DOUBLE PRECISION -C The real and imaginary parts, respectively, of the -C smallest root in magnitude. -C -C Error Indicator -C -C INFO INTEGER -C = 0: successful exit; -C = 1: if on entry, either A = B = 0.0 or A = 0.0 and the -C root -C/B overflows; in this case Z1RE, Z1IM, Z2RE -C and Z2IM are unassigned; -C = 2: if on entry, A = 0.0; in this case Z1RE contains -C BIG and Z1IM contains zero, where BIG is a -C representable number near the overflow threshold -C of the machine (see LAPACK Library Routine DLAMCH); -C = 3: if on entry, either C = 0.0 and the root -B/A -C overflows or A, B and C are non-zero and the largest -C real root in magnitude cannot be computed without -C overflow; in this case Z1RE contains BIG and Z1IM -C contains zero; -C = 4: if the roots cannot be computed without overflow; in -C this case Z1RE, Z1IM, Z2RE and Z2IM are unassigned. -C -C METHOD -C -C The routine computes the roots (r1 and r2) of the real quadratic -C equation -C 2 -C a * x + b * x + c = 0 -C -C as -C - b - SIGN(b) * SQRT(b * b - 4 * a * c) c -C r1 = --------------------------------------- and r2 = ------ -C 2 * a a * r1 -C -C unless a = 0, in which case -C -C -c -C r1 = --. -C b -C -C Precautions are taken to avoid overflow and underflow wherever -C possible. -C -C NUMERICAL ASPECTS -C -C The algorithm is numerically stable. -C -C CONTRIBUTOR -C -C Release 3.0: V. Sima, Katholieke Univ. Leuven, Belgium, Mar. 1997. -C Supersedes Release 2.0 routine MC01JD by A.J. Geurts. -C -C REVISIONS -C -C - -C -C KEYWORDS -C -C Quadratic equation, zeros. -C -C ****************************************************************** -C -C .. Parameters .. - DOUBLE PRECISION ZERO, ONE, FOUR - PARAMETER ( ZERO = 0.0D0, ONE = 1.0D0, FOUR=4.0D0 ) -C .. Scalar Arguments .. - INTEGER INFO - DOUBLE PRECISION A, B, C, Z1IM, Z1RE, Z2IM, Z2RE -C .. Local Scalars .. - LOGICAL OVFLOW - INTEGER BETA, EA, EAPLEC, EB, EB2, EC, ED - DOUBLE PRECISION ABSA, ABSB, ABSC, BIG, M1, M2, MA, MB, MC, MD, - $ SFMIN, W -C .. External Functions .. - DOUBLE PRECISION DLAMCH - EXTERNAL DLAMCH -C .. External Subroutines .. - EXTERNAL MC01SW, MC01SY -C .. Intrinsic Functions .. - INTRINSIC ABS, MOD, SIGN, SQRT -C .. Executable Statements .. -C -C Detect special cases. -C - INFO = 0 - BETA = DLAMCH( 'Base' ) - SFMIN = DLAMCH( 'Safe minimum' ) - BIG = ONE/SFMIN - IF ( A.EQ.ZERO ) THEN - IF ( B.EQ.ZERO ) THEN - INFO = 1 - ELSE - OVFLOW = .FALSE. - Z2RE = ZERO - IF ( C.NE.ZERO ) THEN - ABSB = ABS( B ) - IF ( ABSB.GE.ONE ) THEN - IF ( ABS( C ).GE.ABSB*SFMIN ) Z2RE = -C/B - ELSE - IF ( ABS( C ).LE.ABSB*BIG ) THEN - Z2RE = -C/B - ELSE - OVFLOW = .TRUE. - Z2RE = BIG - IF ( SIGN( ONE, B )*SIGN( ONE, C ).GT.ZERO ) - $ Z2RE = -BIG - END IF - END IF - END IF - IF ( OVFLOW ) THEN - INFO = 1 - ELSE - Z1RE = BIG - Z1IM = ZERO - Z2IM = ZERO - INFO = 2 - END IF - END IF - RETURN - END IF -C - IF ( C.EQ.ZERO ) THEN - OVFLOW = .FALSE. - Z1RE = ZERO - IF ( B.NE.ZERO ) THEN - ABSA = ABS( A ) - IF ( ABSA.GE.ONE ) THEN - IF ( ABS( B ).GE.ABSA*SFMIN ) Z1RE = -B/A - ELSE - IF ( ABS( B ).LE.ABSA*BIG ) THEN - Z1RE = -B/A - ELSE - OVFLOW = .TRUE. - Z1RE = BIG - END IF - END IF - END IF - IF ( OVFLOW ) INFO = 3 - Z1IM = ZERO - Z2RE = ZERO - Z2IM = ZERO - RETURN - END IF -C -C A and C are non-zero. -C - IF ( B.EQ.ZERO ) THEN - OVFLOW = .FALSE. - ABSC = SQRT( ABS( C ) ) - ABSA = SQRT( ABS( A ) ) - W = ZERO - IF ( ABSA.GE.ONE ) THEN - IF ( ABSC.GE.ABSA*SFMIN ) W = ABSC/ABSA - ELSE - IF ( ABSC.LE.ABSA*BIG ) THEN - W = ABSC/ABSA - ELSE - OVFLOW = .TRUE. - W = BIG - END IF - END IF - IF ( OVFLOW ) THEN - INFO = 4 - ELSE - IF ( SIGN( ONE, A )*SIGN( ONE, C ).GT.ZERO ) THEN - Z1RE = ZERO - Z2RE = ZERO - Z1IM = W - Z2IM = -W - ELSE - Z1RE = W - Z2RE = -W - Z1IM = ZERO - Z2IM = ZERO - END IF - END IF - RETURN - END IF -C -C A, B and C are non-zero. -C - CALL MC01SW( A, BETA, MA, EA ) - CALL MC01SW( B, BETA, MB, EB ) - CALL MC01SW( C, BETA, MC, EC ) -C -C Compute a 'near' floating-point representation of the discriminant -C D = MD * BETA**ED. -C - EAPLEC = EA + EC - EB2 = 2*EB - IF ( EAPLEC.GT.EB2 ) THEN - CALL MC01SY( MB*MB, EB2-EAPLEC, BETA, W, OVFLOW ) - W = W - FOUR*MA*MC - CALL MC01SW( W, BETA, MD, ED ) - ED = ED + EAPLEC - ELSE - CALL MC01SY( FOUR*MA*MC, EAPLEC-EB2, BETA, W, OVFLOW ) - W = MB*MB - W - CALL MC01SW( W, BETA, MD, ED ) - ED = ED + EB2 - END IF -C - IF ( MOD( ED, 2 ).NE.0 ) THEN - ED = ED + 1 - MD = MD/BETA - END IF -C -C Complex roots. -C - IF ( MD.LT.ZERO ) THEN - CALL MC01SY( -MB/( 2*MA ), EB-EA, BETA, Z1RE, OVFLOW ) - IF ( OVFLOW ) THEN - INFO = 4 - ELSE - CALL MC01SY( SQRT( -MD )/( 2*MA ), ED/2-EA, BETA, Z1IM, - $ OVFLOW ) - IF ( OVFLOW ) THEN - INFO = 4 - ELSE - Z2RE = Z1RE - Z2IM = -Z1IM - END IF - END IF - RETURN - END IF -C -C Real roots. -C - MD = SQRT( MD ) - ED = ED/2 - IF ( ED.GT.EB ) THEN - CALL MC01SY( ABS( MB ), EB-ED, BETA, W, OVFLOW ) - W = W + MD - M1 = -SIGN( ONE, MB )*W/( 2*MA ) - CALL MC01SY( M1, ED-EA, BETA, Z1RE, OVFLOW ) - IF ( OVFLOW ) THEN - Z1RE = BIG - INFO = 3 - END IF - M2 = -SIGN( ONE, MB )*2*MC/W - CALL MC01SY( M2, EC-ED, BETA, Z2RE, OVFLOW ) - ELSE - CALL MC01SY( MD, ED-EB, BETA, W, OVFLOW ) - W = W + ABS( MB ) - M1 = -SIGN( ONE, MB )*W/( 2*MA ) - CALL MC01SY( M1, EB-EA, BETA, Z1RE, OVFLOW ) - IF ( OVFLOW ) THEN - Z1RE = BIG - INFO = 3 - END IF - M2 = -SIGN( ONE, MB )*2*MC/W - CALL MC01SY( M2, EC-EB, BETA, Z2RE, OVFLOW ) - END IF - Z1IM = ZERO - Z2IM = ZERO -C - RETURN -C *** Last line of MC01VD *** - END diff --git a/mex/sources/libslicot/MC01WD.f b/mex/sources/libslicot/MC01WD.f deleted file mode 100644 index 5ef42154c..000000000 --- a/mex/sources/libslicot/MC01WD.f +++ /dev/null @@ -1,156 +0,0 @@ - SUBROUTINE MC01WD( DP, P, U1, U2, Q, INFO ) -C -C SLICOT RELEASE 5.0. -C -C Copyright (c) 2002-2009 NICONET e.V. -C -C This program is free software: you can redistribute it and/or -C modify it under the terms of the GNU General Public License as -C published by the Free Software Foundation, either version 2 of -C the License, or (at your option) any later version. -C -C This program is distributed in the hope that it will be useful, -C but WITHOUT ANY WARRANTY; without even the implied warranty of -C MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the -C GNU General Public License for more details. -C -C You should have received a copy of the GNU General Public License -C along with this program. If not, see -C . -C -C PURPOSE -C -C To compute, for a given real polynomial P(x) and a quadratic -C polynomial B(x), the quotient polynomial Q(x) and the linear -C remainder polynomial R(x) such that -C -C P(x) = B(x) * Q(x) + R(x), -C -C 2 -C where B(x) = u1 + u2 * x + x , R(x) = q(1) + q(2) * (u2 + x) -C and u1, u2, q(1) and q(2) are real scalars. -C -C ARGUMENTS -C -C Input/Output Parameters -C -C DP (input) INTEGER -C The degree of the polynomial P(x). DP >= 0. -C -C P (input) DOUBLE PRECISION array, dimension (DP+1) -C This array must contain the coefficients of P(x) in -C increasing powers of x. -C -C U1 (input) DOUBLE PRECISION -C The value of the constant term of the quadratic -C polynomial B(x). -C -C U2 (input) DOUBLE PRECISION -C The value of the coefficient of x of the quadratic -C polynomial B(x). -C -C Q (output) DOUBLE PRECISION array, dimension (DP+1) -C If DP >= 1 on entry, then elements Q(1) and Q(2) contain -C the coefficients q(1) and q(2), respectively, of the -C remainder polynomial R(x), and the next (DP-1) elements -C of this array contain the coefficients of the quotient -C polynomial Q(x) in increasing powers of x. -C If DP = 0 on entry, then element Q(1) contains the -C coefficient q(1) of the remainder polynomial R(x) = q(1); -C Q(x) is the zero polynomial. -C -C Error Indicator -C -C INFO INTEGER -C = 0: successful exit; -C < 0: if INFO = -i, the i-th argument had an illegal -C value. -C -C METHOD -C -C Given the real polynomials -C -C DP i 2 -C P(x) = SUM p(i+1) * x and B(x) = u1 + u2 * x + x -C i=0 -C -C the routine uses the recurrence relationships -C -C q(DP+1) = p(DP+1), -C -C q(DP) = p(DP) - u2 * q(DP+1) and -C -C q(i) = p(i) - u2 * q(i+1) - u1 * q(i+2) for i = DP-1, ..., 1 -C -C to determine the coefficients of the quotient polynomial -C -C DP-2 i -C Q(x) = SUM q(i+3) * x -C i=0 -C -C and the remainder polynomial -C -C R(x) = q(1) + q(2) * (u2 + x). -C -C NUMERICAL ASPECTS -C -C None. -C -C CONTRIBUTOR -C -C Release 3.0: V. Sima, Katholieke Univ. Leuven, Belgium, Mar. 1997. -C Supersedes Release 2.0 routine MC01KD by A.J. Geurts. -C -C REVISIONS -C -C - -C -C KEYWORDS -C -C Elementary polynomial operations, polynomial operations, -C quadratic polynomial. -C -C ****************************************************************** -C -C .. Scalar Arguments .. - INTEGER DP, INFO - DOUBLE PRECISION U1, U2 -C .. Array Arguments .. - DOUBLE PRECISION P(*), Q(*) -C .. Local Scalars .. - INTEGER I, N - DOUBLE PRECISION A, B, C -C .. External Subroutines .. - EXTERNAL XERBLA -C .. Executable Statements .. -C -C Test the input scalar arguments. -C - IF ( DP.LT.0 ) THEN - INFO = -1 - CALL XERBLA( 'MC01WD', -INFO ) - RETURN - END IF -C - INFO = 0 - N = DP + 1 - Q(N) = P(N) - IF ( N.GT.1 ) THEN - B = Q(N) - Q(N-1) = P(N-1) - U2*B - IF ( N.GT.2 ) THEN - A = Q(N-1) -C - DO 20 I = N - 2, 1, -1 - C = P(I) - U2*A - U1*B - Q(I) = C - B = A - A = C - 20 CONTINUE -C - END IF - END IF -C - RETURN -C *** Last line of MC01WD *** - END diff --git a/mex/sources/libslicot/MC03MD.f b/mex/sources/libslicot/MC03MD.f deleted file mode 100644 index 36e69719c..000000000 --- a/mex/sources/libslicot/MC03MD.f +++ /dev/null @@ -1,351 +0,0 @@ - SUBROUTINE MC03MD( RP1, CP1, CP2, DP1, DP2, DP3, ALPHA, P1, - $ LDP11, LDP12, P2, LDP21, LDP22, P3, LDP31, - $ LDP32, DWORK, INFO ) -C -C SLICOT RELEASE 5.0. -C -C Copyright (c) 2002-2009 NICONET e.V. -C -C This program is free software: you can redistribute it and/or -C modify it under the terms of the GNU General Public License as -C published by the Free Software Foundation, either version 2 of -C the License, or (at your option) any later version. -C -C This program is distributed in the hope that it will be useful, -C but WITHOUT ANY WARRANTY; without even the implied warranty of -C MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the -C GNU General Public License for more details. -C -C You should have received a copy of the GNU General Public License -C along with this program. If not, see -C . -C -C PURPOSE -C -C To compute the coefficients of the real polynomial matrix -C -C P(x) = P1(x) * P2(x) + alpha * P3(x), -C -C where P1(x), P2(x) and P3(x) are given real polynomial matrices -C and alpha is a real scalar. -C -C Each of the polynomial matrices P1(x), P2(x) and P3(x) may be the -C zero matrix. -C -C ARGUMENTS -C -C Input/Output Parameters -C -C RP1 (input) INTEGER -C The number of rows of the matrices P1(x) and P3(x). -C RP1 >= 0. -C -C CP1 (input) INTEGER -C The number of columns of matrix P1(x) and the number of -C rows of matrix P2(x). CP1 >= 0. -C -C CP2 (input) INTEGER -C The number of columns of the matrices P2(x) and P3(x). -C CP2 >= 0. -C -C DP1 (input) INTEGER -C The degree of the polynomial matrix P1(x). DP1 >= -1. -C -C DP2 (input) INTEGER -C The degree of the polynomial matrix P2(x). DP2 >= -1. -C -C DP3 (input/output) INTEGER -C On entry, the degree of the polynomial matrix P3(x). -C DP3 >= -1. -C On exit, the degree of the polynomial matrix P(x). -C -C ALPHA (input) DOUBLE PRECISION -C The scalar value alpha of the problem. -C -C P1 (input) DOUBLE PRECISION array, dimension (LDP11,LDP12,*) -C If DP1 >= 0, then the leading RP1-by-CP1-by-(DP1+1) part -C of this array must contain the coefficients of the -C polynomial matrix P1(x). Specifically, P1(i,j,k) must -C contain the coefficient of x**(k-1) of the polynomial -C which is the (i,j)-th element of P1(x), where i = 1,2,..., -C RP1, j = 1,2,...,CP1 and k = 1,2,...,DP1+1. -C If DP1 = -1, then P1(x) is taken to be the zero polynomial -C matrix, P1 is not referenced and can be supplied as a -C dummy array (i.e. set the parameters LDP11 = LDP12 = 1 and -C declare this array to be P1(1,1,1) in the calling -C program). -C -C LDP11 INTEGER -C The leading dimension of array P1. -C LDP11 >= MAX(1,RP1) if DP1 >= 0, -C LDP11 >= 1 if DP1 = -1. -C -C LDP12 INTEGER -C The second dimension of array P1. -C LDP12 >= MAX(1,CP1) if DP1 >= 0, -C LDP12 >= 1 if DP1 = -1. -C -C P2 (input) DOUBLE PRECISION array, dimension (LDP21,LDP22,*) -C If DP2 >= 0, then the leading CP1-by-CP2-by-(DP2+1) part -C of this array must contain the coefficients of the -C polynomial matrix P2(x). Specifically, P2(i,j,k) must -C contain the coefficient of x**(k-1) of the polynomial -C which is the (i,j)-th element of P2(x), where i = 1,2,..., -C CP1, j = 1,2,...,CP2 and k = 1,2,...,DP2+1. -C If DP2 = -1, then P2(x) is taken to be the zero polynomial -C matrix, P2 is not referenced and can be supplied as a -C dummy array (i.e. set the parameters LDP21 = LDP22 = 1 and -C declare this array to be P2(1,1,1) in the calling -C program). -C -C LDP21 INTEGER -C The leading dimension of array P2. -C LDP21 >= MAX(1,CP1) if DP2 >= 0, -C LDP21 >= 1 if DP2 = -1. -C -C LDP22 INTEGER -C The second dimension of array P2. -C LDP22 >= MAX(1,CP2) if DP2 >= 0, -C LDP22 >= 1 if DP2 = -1. -C -C P3 (input/output) DOUBLE PRECISION array, dimension -C (LDP31,LDP32,n), where n = MAX(DP1+DP2,DP3,0)+1. -C On entry, if DP3 >= 0, then the leading -C RP1-by-CP2-by-(DP3+1) part of this array must contain the -C coefficients of the polynomial matrix P3(x). Specifically, -C P3(i,j,k) must contain the coefficient of x**(k-1) of the -C polynomial which is the (i,j)-th element of P3(x), where -C i = 1,2,...,RP1, j = 1,2,...,CP2 and k = 1,2,...,DP3+1. -C If DP3 = -1, then P3(x) is taken to be the zero polynomial -C matrix. -C On exit, if DP3 >= 0 on exit (ALPHA <> 0.0 and DP3 <> -1, -C on entry, or DP1 <> -1 and DP2 <> -1), then the leading -C RP1-by-CP2-by-(DP3+1) part of this array contains the -C coefficients of P(x). Specifically, P3(i,j,k) contains the -C coefficient of x**(k-1) of the polynomial which is the -C (i,j)-th element of P(x), where i = 1,2,...,RP1, j = 1,2, -C ...,CP2 and k = 1,2,...,DP3+1. -C If DP3 = -1 on exit, then the coefficients of P(x) (the -C zero polynomial matrix) are not stored in the array. -C -C LDP31 INTEGER -C The leading dimension of array P3. LDP31 >= MAX(1,RP1). -C -C LDP32 INTEGER -C The second dimension of array P3. LDP32 >= MAX(1,CP2). -C -C Workspace -C -C DWORK DOUBLE PRECISION array, dimension (CP1) -C -C Error Indicator -C -C INFO INTEGER -C = 0: successful exit; -C < 0: if INFO = -i, the i-th argument had an illegal -C value. -C -C METHOD -C -C Given real polynomial matrices -C -C DP1 i -C P1(x) = SUM (A(i+1) * x ), -C i=0 -C -C DP2 i -C P2(x) = SUM (B(i+1) * x ), -C i=0 -C -C DP3 i -C P3(x) = SUM (C(i+1) * x ) -C i=0 -C -C and a real scalar alpha, the routine computes the coefficients -C d ,d ,..., of the polynomial matrix -C 1 2 -C -C P(x) = P1(x) * P2(x) + alpha * P3(x) -C -C from the formula -C -C s -C d = SUM (A(k+1) * B(i-k+1)) + alpha * C(i+1), -C i+1 k=r -C -C where i = 0,1,...,DP1+DP2 and r and s depend on the value of i -C (e.g. if i <= DP1 and i <= DP2, then r = 0 and s = i). -C -C NUMERICAL ASPECTS -C -C None. -C -C FURTHER COMMENTS -C -C Other elementary operations involving polynomial matrices can -C easily be obtained by calling the appropriate BLAS routine(s). -C -C CONTRIBUTOR -C -C Release 3.0: V. Sima, Katholieke Univ. Leuven, Belgium, Mar. 1997. -C Supersedes Release 2.0 routine MC03AD by A.J. Geurts. -C -C REVISIONS -C -C - -C -C KEYWORDS -C -C Elementary polynomial operations, input output description, -C polynomial matrix, polynomial operations. -C -C ****************************************************************** -C -C .. Parameters .. - DOUBLE PRECISION ZERO - PARAMETER ( ZERO = 0.0D0 ) -C .. Scalar Arguments .. - INTEGER CP1, CP2, DP1, DP2, DP3, INFO, LDP11, LDP12, - $ LDP21, LDP22, LDP31, LDP32, RP1 - DOUBLE PRECISION ALPHA -C .. Array Arguments .. - DOUBLE PRECISION DWORK(*), P1(LDP11,LDP12,*), P2(LDP21,LDP22,*), - $ P3(LDP31,LDP32,*) -C .. Local Scalars .. - LOGICAL CFZERO - INTEGER DPOL3, E, H, I, J, K -C .. External Functions .. - DOUBLE PRECISION DDOT - EXTERNAL DDOT -C .. External Subroutines .. - EXTERNAL DCOPY, DLASET, DSCAL, XERBLA -C .. Executable Statements .. -C -C Test the input scalar arguments. -C - INFO = 0 - IF( RP1.LT.0 ) THEN - INFO = -1 - ELSE IF( CP1.LT.0 ) THEN - INFO = -2 - ELSE IF( CP2.LT.0 ) THEN - INFO = -3 - ELSE IF( DP1.LT.-1 ) THEN - INFO = -4 - ELSE IF( DP2.LT.-1 ) THEN - INFO = -5 - ELSE IF( DP3.LT.-1 ) THEN - INFO = -6 - ELSE IF( ( DP1.EQ.-1 .AND. LDP11.LT.1 ) .OR. - $ ( DP1.GE. 0 .AND. LDP11.LT.MAX( 1, RP1 ) ) ) THEN - INFO = -9 - ELSE IF( ( DP1.EQ.-1 .AND. LDP12.LT.1 ) .OR. - $ ( DP1.GE. 0 .AND. LDP12.LT.MAX( 1, CP1 ) ) ) THEN - INFO = -10 - ELSE IF( ( DP2.EQ.-1 .AND. LDP21.LT.1 ) .OR. - $ ( DP2.GE. 0 .AND. LDP21.LT.MAX( 1, CP1 ) ) ) THEN - INFO = -12 - ELSE IF( ( DP2.EQ.-1 .AND. LDP22.LT.1 ) .OR. - $ ( DP2.GE. 0 .AND. LDP22.LT.MAX( 1, CP2 ) ) ) THEN - INFO = -13 - ELSE IF( LDP31.LT.MAX( 1, RP1 ) ) THEN - INFO = -15 - ELSE IF( LDP32.LT.MAX( 1, CP2 ) ) THEN - INFO = -16 - END IF -C - IF ( INFO.NE.0 ) THEN -C -C Error return. -C - CALL XERBLA( 'MC03MD', -INFO ) - RETURN - END IF -C -C Quick return if possible. -C - IF ( RP1.EQ.0 .OR. CP2.EQ.0 ) - $ RETURN -C - IF ( ALPHA.EQ.ZERO ) - $ DP3 = -1 -C - IF ( DP3.GE.0 ) THEN -C -C P3(x) := ALPHA * P3(x). -C - DO 40 K = 1, DP3 + 1 -C - DO 20 J = 1, CP2 - CALL DSCAL( RP1, ALPHA, P3(1,J,K), 1 ) - 20 CONTINUE -C - 40 CONTINUE - END IF -C - IF ( ( DP1.EQ.-1 ) .OR. ( DP2.EQ.-1 ) .OR. ( CP1.EQ.0 ) ) - $ RETURN -C -C Neither of P1(x) and P2(x) is the zero polynomial. -C - DPOL3 = DP1 + DP2 - IF ( DPOL3.GT.DP3 ) THEN -C -C Initialize the additional part of P3(x) to zero. -C - DO 80 K = DP3 + 2, DPOL3 + 1 - CALL DLASET( 'Full', RP1, CP2, ZERO, ZERO, P3(1,1,K), - $ LDP31 ) - 80 CONTINUE -C - DP3 = DPOL3 - END IF -C k-1 -C The inner product of the j-th row of the coefficient of x of P1 -C i-1 -C and the h-th column of the coefficient of x of P2(x) contribute -C k+i-2 -C the (j,h)-th element of the coefficient of x of P3(x). -C - DO 160 K = 1, DP1 + 1 -C - DO 140 J = 1, RP1 - CALL DCOPY( CP1, P1(J,1,K), LDP11, DWORK, 1 ) -C - DO 120 I = 1, DP2 + 1 - E = K + I - 1 -C - DO 100 H = 1, CP2 - P3(J,H,E) = DDOT( CP1, DWORK, 1, P2(1,H,I), 1 ) + - $ P3(J,H,E) - 100 CONTINUE -C - 120 CONTINUE -C - 140 CONTINUE -C - 160 CONTINUE -C -C Computation of the exact degree of P3(x). -C - CFZERO = .TRUE. -C WHILE ( DP3 >= 0 and CFZERO ) DO - 180 IF ( ( DP3.GE.0 ) .AND. CFZERO ) THEN - DPOL3 = DP3 + 1 -C - DO 220 J = 1, CP2 -C - DO 200 I = 1, RP1 - IF ( P3(I,J,DPOL3 ).NE.ZERO ) CFZERO = .FALSE. - 200 CONTINUE -C - 220 CONTINUE -C - IF ( CFZERO ) DP3 = DP3 - 1 - GO TO 180 - END IF -C END WHILE 180 -C - RETURN -C *** Last line of MC03MD *** - END diff --git a/mex/sources/libslicot/MC03ND.f b/mex/sources/libslicot/MC03ND.f deleted file mode 100644 index 5ee0fd02a..000000000 --- a/mex/sources/libslicot/MC03ND.f +++ /dev/null @@ -1,495 +0,0 @@ - SUBROUTINE MC03ND( MP, NP, DP, P, LDP1, LDP2, DK, GAM, NULLSP, - $ LDNULL, KER, LDKER1, LDKER2, TOL, IWORK, DWORK, - $ LDWORK, INFO ) -C -C SLICOT RELEASE 5.0. -C -C Copyright (c) 2002-2009 NICONET e.V. -C -C This program is free software: you can redistribute it and/or -C modify it under the terms of the GNU General Public License as -C published by the Free Software Foundation, either version 2 of -C the License, or (at your option) any later version. -C -C This program is distributed in the hope that it will be useful, -C but WITHOUT ANY WARRANTY; without even the implied warranty of -C MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the -C GNU General Public License for more details. -C -C You should have received a copy of the GNU General Public License -C along with this program. If not, see -C . -C -C PURPOSE -C -C To compute the coefficients of a minimal polynomial basis -C DK -C K(s) = K(0) + K(1) * s + ... + K(DK) * s -C -C for the right nullspace of the MP-by-NP polynomial matrix of -C degree DP, given by -C DP -C P(s) = P(0) + P(1) * s + ... + P(DP) * s , -C -C which corresponds to solving the polynomial matrix equation -C P(s) * K(s) = 0. -C -C ARGUMENTS -C -C Input/Output Parameters -C -C MP (input) INTEGER -C The number of rows of the polynomial matrix P(s). -C MP >= 0. -C -C NP (input) INTEGER -C The number of columns of the polynomial matrix P(s). -C NP >= 0. -C -C DP (input) INTEGER -C The degree of the polynomial matrix P(s). DP >= 1. -C -C P (input) DOUBLE PRECISION array, dimension (LDP1,LDP2,DP+1) -C The leading MP-by-NP-by-(DP+1) part of this array must -C contain the coefficients of the polynomial matrix P(s). -C Specifically, P(i,j,k) must contain the (i,j)-th element -C of P(k-1), which is the cofficient of s**(k-1) of P(s), -C where i = 1,2,...,MP, j = 1,2,...,NP and k = 1,2,...,DP+1. -C -C LDP1 INTEGER -C The leading dimension of array P. LDP1 >= MAX(1,MP). -C -C LDP2 INTEGER -C The second dimension of array P. LDP2 >= MAX(1,NP). -C -C DK (output) INTEGER -C The degree of the minimal polynomial basis K(s) for the -C right nullspace of P(s) unless DK = -1, in which case -C there is no right nullspace. -C -C GAM (output) INTEGER array, dimension (DP*MP+1) -C The leading (DK+1) elements of this array contain -C information about the ordering of the right nullspace -C vectors stored in array NULLSP. -C -C NULLSP (output) DOUBLE PRECISION array, dimension -C (LDNULL,(DP*MP+1)*NP) -C The leading NP-by-SUM(i*GAM(i)) part of this array -C contains the right nullspace vectors of P(s) in condensed -C form (as defined in METHOD), where i = 1,2,...,DK+1. -C -C LDNULL INTEGER -C The leading dimension of array NULLSP. -C LDNULL >= MAX(1,NP). -C -C KER (output) DOUBLE PRECISION array, dimension -C (LDKER1,LDKER2,DP*MP+1) -C The leading NP-by-nk-by-(DK+1) part of this array contains -C the coefficients of the minimal polynomial basis K(s), -C where nk = SUM(GAM(i)) and i = 1,2,...,DK+1. Specifically, -C KER(i,j,m) contains the (i,j)-th element of K(m-1), which -C is the coefficient of s**(m-1) of K(s), where i = 1,2,..., -C NP, j = 1,2,...,nk and m = 1,2,...,DK+1. -C -C LDKER1 INTEGER -C The leading dimension of array KER. LDKER1 >= MAX(1,NP). -C -C LDKER2 INTEGER -C The second dimension of array KER. LDKER2 >= MAX(1,NP). -C -C Tolerances -C -C TOL DOUBLE PRECISION -C A tolerance below which matrix elements are considered -C to be zero. If the user sets TOL to be less than -C 10 * EPS * MAX( ||A|| , ||E|| ), then the tolerance is -C F F -C taken as 10 * EPS * MAX( ||A|| , ||E|| ), where EPS is the -C F F -C machine precision (see LAPACK Library Routine DLAMCH) and -C A and E are matrices (as defined in METHOD). -C -C Workspace -C -C IWORK INTEGER array, dimension (m+2*MAX(n,m+1)+n), -C where m = DP*MP and n = (DP-1)*MP + NP. -C -C DWORK DOUBLE PRECISION array, dimension (LDWORK) -C -C LDWORK The length of the array DWORK. -C LDWORK >= m*n*n + 2*m*n + 2*n*n. -C -C Error Indicator -C -C INFO INTEGER -C = 0: successful exit; -C < 0: if INFO = -i, the i-th argument had an illegal -C value. -C > 0: if incorrect rank decisions were taken during the -C computations. This failure is not likely to occur. -C The possible values are: -C k, 1 <= k <= DK+1, the k-th diagonal submatrix had -C not a full row rank; -C DK+2, if incorrect dimensions of a full column -C rank submatrix; -C DK+3, if incorrect dimensions of a full row rank -C submatrix. -C -C METHOD -C -C The computation of the right nullspace of the MP-by-NP polynomial -C matrix P(s) of degree DP given by -C DP-1 DP -C P(s) = P(0) + P(1) * s + ... + P(DP-1) * s + P(DP) * s -C -C is performed via the pencil s*E - A, associated with P(s), where -C -C | I | | 0 -P(DP) | -C | . | | I . . | -C A = | . | and E = | . . . |. (1) -C | . | | . 0 . | -C | I | | I 0 -P(2) | -C | P(0) | | I -P(1) | -C -C The pencil s*E - A is transformed by unitary matrices Q and Z such -C that -C -C | sE(eps)-A(eps) | X | X | -C |----------------|----------------|------------| -C | 0 | sE(inf)-A(inf) | X | -C Q'(s*E-A)Z = |=================================|============|. -C | | | -C | 0 | sE(r)-A(r) | -C -C Since s*E(inf)-A(inf) and s*E(r)-A(r) have full column rank, the -C minimal polynomial basis for the right nullspace of Q'(s*E-A)Z -C (and consequently the basis for the right nullspace of s*E - A) is -C completely determined by s*E(eps)-A(eps). -C -C Let Veps(s) be a minimal polynomial basis for the right nullspace -C of s*E(eps)-A(eps). Then -C -C | Veps(s) | -C V(s) = Z * |---------| -C | 0 | -C -C is a minimal polynomial basis for the right nullspace of s*E - A. -C From the structure of s*E - A it can be shown that if V(s) is -C partitioned as -C -C | Vo(s) | (DP-1)*MP -C V(s) = |------ | -C | Ve(s) | NP -C -C then the columns of Ve(s) form a minimal polynomial basis for the -C right nullspace of P(s). -C -C The vectors of Ve(s) are computed and stored in array NULLSP in -C the following condensed form: -C -C || || | || | | || | | -C || U1,0 || U2,0 | U2,1 || U3,0 | U3,1 | U3,2 || U4,0 | ... |, -C || || | || | | || | | -C -C where Ui,j is an NP-by-GAM(i) matrix which contains the i-th block -C of columns of K(j), the j-th coefficient of the polynomial matrix -C representation for the right nullspace -C DK -C K(s) = K(0) + K(1) * s + . . . + K(DK) * s . -C -C The coefficients K(0), K(1), ..., K(DK) are NP-by-nk matrices -C given by -C -C K(0) = | U1,0 | U2,0 | U3,0 | . . . | U(DK+1,0) | -C -C K(1) = | 0 | U2,1 | U3,1 | . . . | U(DK+1,1) | -C -C K(2) = | 0 | 0 | U3,2 | . . . | U(DK+1,2) | -C -C . . . . . . . . . . -C -C K(DK) = | 0 | 0 | 0 | . . . | 0 | U(DK+1,DK)|. -C -C Note that the degree of K(s) satisfies the inequality DK <= -C DP * MIN(MP,NP) and that the dimension of K(s) satisfies the -C inequality (NP-MP) <= nk <= NP. -C -C REFERENCES -C -C [1] Beelen, Th.G.J. -C New Algorithms for Computing the Kronecker structure of a -C Pencil with Applications to Systems and Control Theory. -C Ph.D.Thesis, Eindhoven University of Technology, 1987. -C -C [2] Van Den Hurk, G.J.H.H. -C New Algorithms for Solving Polynomial Matrix Problems. -C Master's Thesis, Eindhoven University of Technology, 1987. -C -C NUMERICAL ASPECTS -C -C The algorithm used by the routine involves the construction of a -C special block echelon form with pivots considered to be non-zero -C when they are larger than TOL. These pivots are then inverted in -C order to construct the columns of the kernel of the polynomial -C matrix. If TOL is chosen to be too small then these inversions may -C be sensitive whereas increasing TOL will make the inversions more -C robust but will affect the block echelon form (and hence the -C column degrees of the polynomial kernel). Furthermore, if the -C elements of the computed polynomial kernel are large relative to -C the polynomial matrix, then the user should consider trying -C several values of TOL. -C -C FURTHER COMMENTS -C -C It also possible to compute a minimal polynomial basis for the -C right nullspace of a pencil, since a pencil is a polynomial matrix -C of degree 1. Thus for the pencil (s*E - A), the required input is -C P(1) = E and P(0) = -A. -C -C The routine can also be used to compute a minimal polynomial -C basis for the left nullspace of a polynomial matrix by simply -C transposing P(s). -C -C CONTRIBUTOR -C -C Release 3.0: V. Sima, Katholieke Univ. Leuven, Belgium, Mar. 1997. -C Supersedes Release 2.0 routine MC03BD by A.J. Geurts and MC03BZ by -C Th.G.J. Beelen, A.J. Geurts, and G.J.H.H. van den Hurk. -C -C REVISIONS -C -C Jan. 1998. -C -C KEYWORDS -C -C Echelon form, elementary polynomial operations, input output -C description, polynomial matrix, polynomial operations. -C -C ****************************************************************** -C -C .. Parameters .. - DOUBLE PRECISION ZERO, ONE, TEN - PARAMETER ( ZERO = 0.0D0, ONE = 1.0D0, TEN = 10.0D0 ) -C .. Scalar Arguments .. - INTEGER DK, DP, INFO, LDKER1, LDKER2, LDNULL, LDP1, - $ LDP2, LDWORK, MP, NP - DOUBLE PRECISION TOL -C .. Array Arguments .. - INTEGER GAM(*), IWORK(*) - DOUBLE PRECISION DWORK(*), KER(LDKER1,LDKER2,*), - $ NULLSP(LDNULL,*), P(LDP1,LDP2,*) -C .. Local Scalars .. - INTEGER GAMJ, H, I, IDIFF, IFIR, J, JWORKA, JWORKE, - $ JWORKQ, JWORKV, JWORKZ, K, M, MUK, N, NBLCKS, - $ NBLCKI, NCA, NCV, NRA, NUK, RANKE, SGAMK, TAIL, - $ VC1, VR2 - DOUBLE PRECISION TOLER -C .. Local Arrays .. - INTEGER MNEI(3) -C .. External Functions .. - DOUBLE PRECISION DLAMCH, DLANGE, DLAPY2 - EXTERNAL DLAMCH, DLANGE, DLAPY2 -C .. External Subroutines .. - EXTERNAL DGEMM, DLACPY, DLASET, MB04UD, MB04VD, MC03NX, - $ MC03NY, XERBLA -C .. Intrinsic Functions .. - INTRINSIC DBLE, MAX, SQRT -C .. Executable Statements .. -C -C Test the input scalar arguments. -C - M = DP*MP - H = M - MP - N = H + NP - INFO = 0 - IF( MP.LT.0 ) THEN - INFO = -1 - ELSE IF( NP.LT.0 ) THEN - INFO = -2 - ELSE IF( DP.LE.0 ) THEN - INFO = -3 - ELSE IF( LDP1.LT.MAX( 1, MP ) ) THEN - INFO = -5 - ELSE IF( LDP2.LT.MAX( 1, NP ) ) THEN - INFO = -6 - ELSE IF( LDNULL.LT.MAX( 1, NP ) ) THEN - INFO = -10 - ELSE IF( LDKER1.LT.MAX( 1, NP ) ) THEN - INFO = -12 - ELSE IF( LDKER2.LT.MAX( 1, NP ) ) THEN - INFO = -13 - ELSE IF( LDWORK.LT.( N*( M*N + 2*( M + N ) ) ) ) THEN - INFO = -17 - END IF -C - IF ( INFO.NE.0 ) THEN -C -C Error return. -C - CALL XERBLA( 'MC03ND', -INFO ) - RETURN - END IF -C -C Quick return if possible. -C - IF ( MP.EQ.0 .OR. NP.EQ.0 ) THEN - DK = -1 - RETURN - END IF -C - JWORKA = 1 - JWORKE = JWORKA + M*N - JWORKZ = JWORKE + M*N - JWORKV = JWORKZ + N*N - JWORKQ = JWORKA -C -C Construct the matrices A and E in the pencil s*E-A in (1). -C Workspace: 2*M*N. -C - CALL MC03NX( MP, NP, DP, P, LDP1, LDP2, DWORK(JWORKA), M, - $ DWORK(JWORKE), M ) -C -C Computation of the tolerance. -C - TOLER = MAX( DLANGE( 'F', M, NP, DWORK(JWORKE+H*M), M, DWORK ), - $ DLANGE( 'F', MP, NP, P, LDP1, DWORK ) ) - TOLER = TEN*DLAMCH( 'Epsilon' ) - $ *DLAPY2( TOLER, SQRT( DBLE( H ) ) ) - IF ( TOLER.LE.TOL ) TOLER = TOL -C -C Reduction of E to column echelon form E0 = Q' x E x Z and -C transformation of A, A0 = Q' x A x Z. -C Workspace: 2*M*N + N*N + max(M,N). -C - CALL MB04UD( 'No Q', 'Identity Z', M, N, DWORK(JWORKA), M, - $ DWORK(JWORKE), M, DWORK(JWORKQ), M, DWORK(JWORKZ), N, - $ RANKE, IWORK, TOLER, DWORK(JWORKV), INFO ) -C -C The contents of ISTAIR is transferred from MB04UD to MB04VD by -C IWORK(i), i=1,...,M. -C In the sequel the arrays IMUK and INUK are part of IWORK, namely: -C IWORK(i), i = M+1,...,M+max(N,M+1), contains IMUK, -C IWORK(i), i = M+max(N,M+1)+1,...,M+2*max(N,M+1), contains INUK. -C IWORK(i), i = M+2*max(N,M+1)+1,...,M+2*max(N,M+1)+N, contains -C IMUK0 (not needed), and is also used as workspace. -C - MUK = M + 1 - NUK = MUK + MAX( N, M+1 ) - TAIL = NUK + MAX( N, M+1 ) -C - CALL MB04VD( 'Separation', 'No Q', 'Update Z', M, N, RANKE, - $ DWORK(JWORKA), M, DWORK(JWORKE), M, DWORK(JWORKQ), M, - $ DWORK(JWORKZ), N, IWORK, NBLCKS, NBLCKI, IWORK(MUK), - $ IWORK(NUK), IWORK(TAIL), MNEI, TOLER, IWORK(TAIL), - $ INFO ) - IF ( INFO.GT.0 ) THEN -C -C Incorrect rank decisions. -C - INFO = INFO + NBLCKS - RETURN - END IF -C -C If NBLCKS < 1, or the column dimension of s*E(eps) - A(eps) is -C zero, then there is no right nullspace. -C - IF ( NBLCKS.LT.1 .OR. MNEI(2).EQ.0 ) THEN - DK = -1 - RETURN - END IF -C -C Start of the computation of the minimal basis. -C - DK = NBLCKS - 1 - NRA = MNEI(1) - NCA = MNEI(2) -C -C Determine a minimal basis VEPS(s) for the right nullspace of the -C pencil s*E(eps)-A(eps) associated with the polynomial matrix P(s). -C Workspace: 2*M*N + N*N + N*N*(M+1). -C - CALL MC03NY( NBLCKS, NRA, NCA, DWORK(JWORKA), M, DWORK(JWORKE), M, - $ IWORK(MUK), IWORK(NUK), DWORK(JWORKV), N, INFO ) -C - IF ( INFO.GT.0 ) - $ RETURN -C - NCV = IWORK(MUK) - IWORK(NUK) - GAM(1) = NCV - IWORK(1) = 0 - IWORK(TAIL) = IWORK(MUK) -C - DO 20 I = 2, NBLCKS - IDIFF = IWORK(MUK+I-1) - IWORK(NUK+I-1) - GAM(I) = IDIFF - IWORK(I) = NCV - NCV = NCV + I*IDIFF - IWORK(TAIL+I-1) = IWORK(TAIL+I-2) + IWORK(MUK+I-1) - 20 CONTINUE -C -C Determine a basis for the right nullspace of the polynomial -C matrix P(s). This basis is stored in array NULLSP in condensed -C form. -C - CALL DLASET( 'Full', NP, NCV, ZERO, ZERO, NULLSP, LDNULL ) -C -C |VEPS(s)| -C The last NP rows of the product matrix Z x |-------| contain the -C | 0 | -C polynomial basis for the right nullspace of the polynomial matrix -C P(s) in condensed form. The multiplication is restricted to the -C nonzero submatrices Vij,k of VEPS, the result is stored in the -C array NULLSP. -C - VC1 = 1 -C - DO 60 I = 1, NBLCKS - VR2 = IWORK(TAIL+I-1) -C - DO 40 J = 1, I -C -C Multiplication of Z(H+1:N,1:VR2) with V.i,j-1 stored in -C VEPS(1:VR2,VC1:VC1+GAM(I)-1). -C - CALL DGEMM( 'No transpose', 'No transpose', NP, GAM(I), VR2, - $ ONE, DWORK(JWORKZ+H), N, - $ DWORK(JWORKV+(VC1-1)*N), N, ZERO, NULLSP(1,VC1), - $ LDNULL ) - VC1 = VC1 + GAM(I) - VR2 = VR2 - IWORK(MUK+I-J) - 40 CONTINUE -C - 60 CONTINUE -C -C Transfer of the columns of NULLSP to KER in order to obtain the -C polynomial matrix representation of K(s), the right nullspace -C of P(s). -C - SGAMK = 1 -C - DO 100 K = 1, NBLCKS - CALL DLASET( 'Full', NP, SGAMK-1, ZERO, ZERO, KER(1,1,K), - $ LDKER1 ) - IFIR = SGAMK -C -C Copy the appropriate columns of NULLSP into KER(k). -C SGAMK = 1 + SUM(i=1,..,k-1) GAM(i), is the first nontrivial -C column of KER(k), the first SGAMK - 1 columns of KER(k) are -C zero. IFIR denotes the position of the first column in KER(k) -C in the set of columns copied for a value of J. -C VC1 is the first column of NULLSP to be copied. -C - DO 80 J = K, NBLCKS - GAMJ = GAM(J) - VC1 = IWORK(J) + (K-1)*GAMJ + 1 - CALL DLACPY( 'Full', NP, GAMJ, NULLSP(1,VC1), LDNULL, - $ KER(1,IFIR,K), LDKER1 ) - IFIR = IFIR + GAMJ - 80 CONTINUE -C - SGAMK = SGAMK + GAM(K) - 100 CONTINUE -C - RETURN -C *** Last line of MC03ND *** - END diff --git a/mex/sources/libslicot/MC03NX.f b/mex/sources/libslicot/MC03NX.f deleted file mode 100644 index 7376234df..000000000 --- a/mex/sources/libslicot/MC03NX.f +++ /dev/null @@ -1,146 +0,0 @@ - SUBROUTINE MC03NX( MP, NP, DP, P, LDP1, LDP2, A, LDA, E, LDE ) -C -C SLICOT RELEASE 5.0. -C -C Copyright (c) 2002-2009 NICONET e.V. -C -C This program is free software: you can redistribute it and/or -C modify it under the terms of the GNU General Public License as -C published by the Free Software Foundation, either version 2 of -C the License, or (at your option) any later version. -C -C This program is distributed in the hope that it will be useful, -C but WITHOUT ANY WARRANTY; without even the implied warranty of -C MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the -C GNU General Public License for more details. -C -C You should have received a copy of the GNU General Public License -C along with this program. If not, see -C . -C -C PURPOSE -C -C Given an MP-by-NP polynomial matrix of degree dp -C dp-1 dp -C P(s) = P(0) + ... + P(dp-1) * s + P(dp) * s (1) -C -C the routine composes the related pencil s*E-A where -C -C | I | | O -P(dp) | -C | . | | I . . | -C A = | . | and E = | . . . |. (2) -C | . | | . O . | -C | I | | I O -P(2) | -C | P(0) | | I -P(1) | -C -C ================================================================== -C REMARK: This routine is intended to be called only from the SLICOT -C routine MC03ND. -C ================================================================== -C -C ARGUMENTS -C -C Input/Output Parameters -C -C MP (input) INTEGER -C The number of rows of the polynomial matrix P(s). -C MP >= 0. -C -C NP (input) INTEGER -C The number of columns of the polynomial matrix P(s). -C NP >= 0. -C -C DP (input) INTEGER -C The degree of the polynomial matrix P(s). DP >= 1. -C -C P (input) DOUBLE PRECISION array, dimension (LDP1,LDP2,DP+1) -C The leading MP-by-NP-by-(DP+1) part of this array must -C contain the coefficients of the polynomial matrix P(s) -C in (1) in increasing powers of s. -C -C LDP1 INTEGER -C The leading dimension of array P. LDP1 >= MAX(1,MP). -C -C LDP2 INTEGER -C The second dimension of array P. LDP2 >= MAX(1,NP). -C -C A (output) DOUBLE PRECISION array, dimension -C (LDA,(DP-1)*MP+NP) -C The leading DP*MP-by-((DP-1)*MP+NP) part of this array -C contains the matrix A as described in (2). -C -C LDA INTEGER -C The leading dimension of array A. LDA >= MAX(1,DP*MP). -C -C E (output) DOUBLE PRECISION array, dimension -C (LDE,(DP-1)*MP+NP) -C The leading DP*MP-by-((DP-1)*MP+NP) part of this array -C contains the matrix E as described in (2). -C -C LDE INTEGER -C The leading dimension of array E. LDE >= MAX(1,DP*MP). -C -C NUMERICAL ASPECTS -C -C None. -C -C CONTRIBUTOR -C -C Release 3.0: V. Sima, Katholieke Univ. Leuven, Belgium, Mar. 1997. -C Supersedes Release 2.0 routine MC03BX by G.J.H.H. van den Hurk. -C -C REVISIONS -C -C - -C -C KEYWORDS -C -C Elementary polynomial operations, input output description, -C polynomial matrix, polynomial operations. -C -C ****************************************************************** -C -C .. Parameters .. - DOUBLE PRECISION ZERO, ONE - PARAMETER ( ZERO = 0.0D0, ONE = 1.0D0 ) -C .. Scalar Arguments .. - INTEGER DP, LDA, LDE, LDP1, LDP2, MP, NP -C .. Array Arguments .. - DOUBLE PRECISION A(LDA,*), E(LDE,*), P(LDP1,LDP2,*) -C .. Local Scalars .. - INTEGER H1, HB, HE, HI, J, K -C .. External Subroutines .. - EXTERNAL DLACPY, DLASET, DSCAL -C .. Executable Statements .. -C - IF ( MP.LE.0 .OR. NP.LE.0 ) - $ RETURN -C -C Initialisation of matrices A and E. -C - H1 = DP*MP - HB = H1 - MP - HE = HB + NP - CALL DLASET( 'Full', H1, HE, ZERO, ONE, A, LDA ) - CALL DLASET( 'Full', MP, HB, ZERO, ZERO, E, LDE ) - CALL DLACPY( 'Full', HB, HB, A, LDA, E(MP+1,1), LDE ) -C -C Insert the matrices P(0), P(1), ..., P(dp) at the right places -C in the matrices A and E. -C - HB = HB + 1 - CALL DLACPY( 'Full', MP, NP, P(1,1,1), LDP1, A(HB,HB), LDA ) - HI = 1 -C - DO 20 K = DP + 1, 2, -1 - CALL DLACPY( 'Full', MP, NP, P(1,1,K), LDP1, E(HI,HB), LDE ) - HI = HI + MP - 20 CONTINUE -C - DO 40 J = HB, HE - CALL DSCAL( H1, -ONE, E(1,J), 1 ) - 40 CONTINUE -C - RETURN -C *** Last line of MC03NX *** - END diff --git a/mex/sources/libslicot/MC03NY.f b/mex/sources/libslicot/MC03NY.f deleted file mode 100644 index 9966e02a5..000000000 --- a/mex/sources/libslicot/MC03NY.f +++ /dev/null @@ -1,412 +0,0 @@ - SUBROUTINE MC03NY( NBLCKS, NRA, NCA, A, LDA, E, LDE, IMUK, INUK, - $ VEPS, LDVEPS, INFO ) -C -C SLICOT RELEASE 5.0. -C -C Copyright (c) 2002-2009 NICONET e.V. -C -C This program is free software: you can redistribute it and/or -C modify it under the terms of the GNU General Public License as -C published by the Free Software Foundation, either version 2 of -C the License, or (at your option) any later version. -C -C This program is distributed in the hope that it will be useful, -C but WITHOUT ANY WARRANTY; without even the implied warranty of -C MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the -C GNU General Public License for more details. -C -C You should have received a copy of the GNU General Public License -C along with this program. If not, see -C . -C -C PURPOSE -C -C To determine a minimal basis of the right nullspace of the -C subpencil s*E(eps)-A(eps) using the method given in [1] (see -C Eqs.(4.6.8), (4.6.9)). -C This pencil only contains Kronecker column indices, and it must be -C in staircase form as supplied by SLICOT Library Routine MB04VD. -C The basis vectors are represented by matrix V(s) having the form -C -C | V11(s) V12(s) V13(s) . . V1n(s) | -C | V22(s) V23(s) V2n(s) | -C | V33(s) . | -C V(s) = | . . | -C | . . | -C | . . | -C | Vnn(s) | -C -C where n is the number of full row rank blocks in matrix A(eps) and -C -C k j-i -C Vij(s) = Vij,0 + Vij,1*s +...+ Vij,k*s +...+ Vij,j-i*s . (1) -C -C In other words, Vij,k is the coefficient corresponding to degree k -C in the matrix polynomial Vij(s). -C Vij,k has dimensions mu(i)-by-(mu(j)-nu(j)). -C The coefficients Vij,k are stored in the matrix VEPS as follows -C (for the case n = 3): -C -C sizes m1-n1 m2-n2 m2-n2 m3-n3 m3-n3 m3-n3 -C -C m1 { | V11,0 || V12,0 | V12,1 || V13,0 | V13,1 | V13,2 || -C | || | || | | || -C VEPS = m2 { | || V22,0 | || V23,0 | V23,1 | || -C | || | || | | || -C m3 { | || | || V33,0 | | || -C -C where mi = mu(i), ni = nu(i). -C Matrix VEPS has dimensions nrv-by-ncv where -C nrv = Sum(i=1,...,n) mu(i) -C ncv = Sum(i=1,...,n) i*(mu(i)-nu(i)) -C -C ================================================================== -C REMARK: This routine is intended to be called only from the SLICOT -C routine MC03ND. -C ================================================================== -C -C ARGUMENTS -C -C Input/Output Parameters -C -C NBLCKS (input) INTEGER -C Number of full row rank blocks in subpencil -C s*E(eps)-A(eps) that contains all Kronecker column indices -C of s*E-A. NBLCKS >= 0. -C -C NRA (input) INTEGER -C Number of rows of the subpencil s*E(eps)-A(eps) in s*E-A. -C NRA = nu(1) + nu(2) + ... + nu(NBLCKS). NRA >= 0. -C -C NCA (input) INTEGER -C Number of columns of the subpencil s*E(eps)-A(eps) in -C s*E-A. -C NCA = mu(1) + mu(2) + ... + mu(NBLCKS). NCA >= 0. -C -C A (input/output) DOUBLE PRECISION array, dimension (LDA,NCA) -C E (input/output) DOUBLE PRECISION array, dimension (LDE,NCA) -C On entry, the leading NRA-by-NCA part of these arrays must -C contain the matrices A and E, where s*E-A is the -C transformed pencil s*E0-A0 which is the pencil associated -C with P(s) as described in [1] Section 4.6. The pencil -C s*E-A is assumed to be in generalized Schur form. -C On exit, these arrays contain no useful information. -C -C LDA INTEGER -C The leading dimension of array A. LDA >= MAX(1,NRA). -C -C LDE INTEGER -C The leading dimension of array E. LDE >= MAX(1,NRA). -C -C IMUK (input) INTEGER array, dimension (NBLCKS) -C This array must contain the column dimensions mu(k) of the -C full column rank blocks in the subpencil s*E(eps)-A(eps) -C of s*E-A. The content of IMUK is modified by the routine -C but restored on exit. -C -C INUK (input) INTEGER array, dimension (NBLCKS) -C This array must contain the row dimensions nu(k) of the -C full row rank blocks in the subpencil s*E(eps)-A(eps) of -C s*E-A. -C -C VEPS (output) DOUBLE PRECISION array, dimension (LDVEPS,ncv) -C Let nrv = Sum(i=1,...,NBLCKS) mu(i) = NCA, -C ncv = Sum(i=1,...,NBLCKS) i*(mu(i)-nu(i)). -C The leading nrv-by-ncv part of this array contains the -C column vectors of a minimal polynomial basis for the right -C nullspace of the subpencil s*E(eps)-A(eps). (See [1] -C Section 4.6.4.) An upper bound for ncv is (NRA+1)*NCA. -C -C LDVEPS INTEGER -C The leading dimension of array VEPS. -C LDVEPS >= MAX(1,NCA). -C -C Error Indicator -C -C INFO INTEGER -C = 0: successful exit; -C < 0: if INFO = -i, the i-th argument had an illegal -C value; -C > 0: if INFO = k, the k-th diagonal block of A had not a -C full row rank. -C -C REFERENCES -C -C [1] Th.G.J. Beelen, New Algorithms for Computing the Kronecker -C structure of a Pencil with Applications to Systems and -C Control Theory. -C Ph.D.Thesis, Eindhoven University of Technology, 1987. -C -C NUMERICAL ASPECTS -C -C None. -C -C CONTRIBUTORS -C -C Release 3.0: V. Sima, Katholieke Univ. Leuven, Belgium, Mar. 1997. -C Supersedes Release 2.0 routine MC03BY by Th.G.J. Beelen, -C A.J. Geurts, and G.J.H.H. van den Hurk. -C -C REVISIONS -C -C Dec. 1997. -C -C KEYWORDS -C -C Elementary polynomial operations, Kronecker form, polynomial -C matrix, polynomial operations, staircase form. -C -C ****************************************************************** -C -C .. Parameters .. - DOUBLE PRECISION ZERO, ONE - PARAMETER ( ZERO = 0.0D0, ONE = 1.0D0 ) -C .. Scalar Arguments .. - INTEGER INFO, LDA, LDE, LDVEPS, NBLCKS, NCA, NRA -C .. Array Arguments .. - INTEGER IMUK(*), INUK(*) - DOUBLE PRECISION A(LDA,*), E(LDE,*), VEPS(LDVEPS,*) -C .. Local Scalars .. - INTEGER AC1, AC2, AR1, ARI, ARK, DIF, EC1, ER1, I, J, K, - $ MUI, NCV, NRV, NUI, SMUI, SMUI1, VC1, VC2, VR1, - $ VR2, WC1, WR1 -C .. Local Arrays .. - DOUBLE PRECISION DUMMY(1) -C .. External Subroutines .. - EXTERNAL DCOPY, DGEMM, DLASET, DSCAL, DTRTRS, XERBLA -C .. Executable Statements .. -C - INFO = 0 - IF( NBLCKS.LT.0 ) THEN - INFO = -1 - ELSE IF( NRA.LT.0 ) THEN - INFO = -2 - ELSE IF( NCA.LT.0 ) THEN - INFO = -3 - ELSE IF( LDA.LT.MAX( 1, NRA ) ) THEN - INFO = -5 - ELSE IF( LDE.LT.MAX( 1, NRA ) ) THEN - INFO = -7 - ELSE IF( LDVEPS.LT.MAX( 1, NCA ) ) THEN - INFO = -11 - END IF -C - IF ( INFO.NE.0 ) THEN -C -C Error return. -C - CALL XERBLA( 'MC03NY', -INFO ) - RETURN - END IF -C -C Quick return if possible. -C - IF ( NBLCKS.EQ.0 .OR. NRA.EQ.0 .OR. NCA.EQ.0 ) - $ RETURN -C -C Computation of the nonzero parts of W1 and W2: -C -C | AH11 AH12 ... AH1n | | EH11 EH12 ... EH1n | -C | AH22 AH2n | | EH22 EH2n | -C W1 = | . . |, W2 = | . . | -C | . . | | . . | -C | AHnn | | EHnn | -C -C with AHij = -pinv(Aii) * Aij, EHij = pinv(Aii) * Eij and EHii = 0, -C AHij and EHij have dimensions mu(i)-by-mu(j), Aii = [ Oi | Ri ], -C and -C Ri is a regular nu(i)-by-nu(i) upper triangular matrix; -C Oi is a not necessarily square null matrix. -C Note that the first mu(i)-nu(i) rows in AHij and EHij are zero. -C For memory savings, the nonzero parts of W1 and W2 are constructed -C over A and E, respectively. -C -C (AR1,AC1) denotes the position of the first element of the -C submatrix Ri in matrix Aii. -C EC1 is the index of the first column of Ai,i+1/Ei,i+1. -C - EC1 = 1 - AR1 = 1 -C - DO 40 I = 1, NBLCKS - 1 - NUI = INUK(I) - IF ( NUI.EQ.0 ) GO TO 60 - MUI = IMUK(I) - EC1 = EC1 + MUI - AC1 = EC1 - NUI - CALL DTRTRS( 'Upper', 'No transpose', 'Non-unit', NUI, - $ NCA-EC1+1, A(AR1,AC1), LDA, E(AR1,EC1), LDE, - $ INFO ) - IF ( INFO.GT.0 ) THEN - INFO = I - RETURN - END IF -C - DO 20 J = 1, NUI - CALL DSCAL( J, -ONE, A(AR1,AC1+J-1), 1 ) - 20 CONTINUE -C - CALL DTRTRS( 'Upper', 'No transpose', 'Non-unit', NUI, - $ NCA-EC1+1, A(AR1,AC1), LDA, A(AR1,EC1), LDA, - $ INFO ) - AR1 = AR1 + NUI - 40 CONTINUE -C - 60 CONTINUE -C -C The contents of the array IMUK is changed for temporary use in -C this routine as follows: -C -C IMUK(i) = Sum(j=1,...,i) mu(j). -C -C On return, the original contents of IMUK is restored. -C In the same loop the actual number of columns of VEPS is computed. -C The number of rows of VEPS is NCA. -C -C NRV = Sum(i=1,...,NBLCKS) mu(i) = NCA, -C NCV = Sum(i=1,...,NBLCKS) i*(mu(i)-nu(i)). -C - SMUI = 0 - NCV = 0 -C - DO 80 I = 1, NBLCKS - MUI = IMUK(I) - SMUI = SMUI + MUI - IMUK(I) = SMUI - NCV = NCV + I*( MUI - INUK(I) ) - 80 CONTINUE -C - NRV = NCA -C -C Computation of the matrix VEPS. -C -C Initialisation of VEPS to zero. -C - CALL DLASET( 'Full', NRV, NCV, ZERO, ZERO, VEPS, LDVEPS ) -C | I | -C Set Vii,0 = Kii in VEPS , i=1,...,NBLCKS, where Kii = |---| -C | O | -C and I is an identity matrix of size mu(i)-nu(i), -C O is a null matrix, dimensions nu(i)-by-(mu(i)-nu(i)). -C -C WR1 := Sum(j=1,...,i-1) mu(j) + 1 -C is the index of the first row in Vii,0 in VEPS. -C WC1 := Sum(j=1,...,i-1) j*(mu(j)-nu(j)) + 1 -C is the index of the first column in Vii,0 in VEPS. -C - DUMMY(1) = ONE - NUI = IMUK(1) - INUK(1) - CALL DCOPY( NUI, DUMMY, 0, VEPS, LDVEPS+1 ) - WR1 = IMUK(1) + 1 - WC1 = NUI + 1 -C - DO 100 I = 2, NBLCKS - NUI = IMUK(I) - IMUK(I-1) - INUK(I) - CALL DCOPY( NUI, DUMMY, 0, VEPS(WR1,WC1), LDVEPS+1 ) - WR1 = IMUK(I) + 1 - WC1 = WC1 + I*NUI - 100 CONTINUE -C -C Determination of the remaining nontrivial matrices in Vij,k -C block column by block column with decreasing block row index. -C -C The computation starts with the second block column since V11,0 -C has already been determined. -C The coefficients Vij,k satisfy the recurrence relation: -C -C Vij,k = Sum(r=i+1,...,j-k) AHir*Vrj,k + -C + Sum(r=i+1,...,j-k+1) EHir*Vrj,k-1, i + k < j, -C -C = EHi,i+1 * Vi+1,j,k-1 i + k = j. -C -C This recurrence relation can be derived from [1], (4.6.8) -C and formula (1) in Section PURPOSE. -C - VC1 = IMUK(1) - INUK(1) + 1 - ARI = 1 -C - DO 180 J = 2, NBLCKS - DIF = IMUK(J) - IMUK(J-1) - INUK(J) - ARI = ARI + INUK(J-1) - ARK = ARI -C -C Computation of the matrices Vij,k where i + k < j. -C Each matrix Vij,k has dimension mu(i)-by-(mu(j) - nu(j)). -C - DO 160 K = 0, J - 2 -C -C VC1, VC2 are the first and last column index of Vij,k. -C - VC2 = VC1 + DIF - 1 - AC2 = IMUK(J-K) - AR1 = ARK - ARK = ARK - INUK(J-K-1) -C - DO 120 I = J - K - 1, 1, -1 -C -C Compute the first part of Vij,k in decreasing order: -C Vij,k := Vij,k + Sum(r=i+1,..,j-k) AHir*Vrj,k. -C The non-zero parts of AHir are stored in -C A(AR1:AR1+nu(i)-1,AC1:AC2) and Vrj,k are stored in -C VEPS(AC1:AC2,VC1:VC2). -C The non-zero part of the result is stored in -C VEPS(VR1:VR2,VC1:VC2). -C - VR2 = IMUK(I) - AC1 = VR2 + 1 - VR1 = AC1 - INUK(I) - AR1 = AR1 - INUK(I) - CALL DGEMM( 'No transpose', 'No transpose', INUK(I), - $ DIF, AC2-VR2, ONE, A(AR1,AC1), LDA, - $ VEPS(AC1,VC1), LDVEPS, ONE, VEPS(VR1,VC1), - $ LDVEPS ) - 120 CONTINUE -C - ER1 = 1 -C - DO 140 I = 1, J - K - 1 -C -C Compute the second part of Vij,k+1 in normal order: -C Vij,k+1 := Sum(r=i+1,..,j-k) EHir*Vrj,k. -C The non-zero parts of EHir are stored in -C E(ER1:ER1+nu(i)-1,EC1:AC2) and Vrj,k are stored in -C VEPS(EC1:AC2,VC1:VC2). -C The non-zero part of the result is stored in -C VEPS(VR1:VR2,VC2+1:VC2+DIF), where -C DIF = VC2 - VC1 + 1 = mu(j) - nu(j). -C This code portion also computes Vij,k+1 for i + k = j. -C - VR2 = IMUK(I) - EC1 = VR2 + 1 - VR1 = EC1 - INUK(I) - CALL DGEMM( 'No transpose', 'No transpose', INUK(I), - $ DIF, AC2-VR2, ONE, E(ER1,EC1), LDE, - $ VEPS(EC1,VC1), LDVEPS, ZERO, VEPS(VR1,VC2+1), - $ LDVEPS ) - ER1 = ER1 + INUK(I) - 140 CONTINUE -C - VC1 = VC2 + 1 - 160 CONTINUE -C - VC1 = VC1 + DIF - 180 CONTINUE -C -C Restore original contents of the array IMUK. -C -C Since, at the moment: -C IMUK(i) = Sum(j=1,...,i) mu(j), (i=1,...,NBLCKS), -C the original values are: -C mu(i) = IMUK(i) - IMUK(i-1) with IMUK(0 ) = 0. -C - SMUI1 = 0 -C - DO 200 I = 1, NBLCKS - SMUI = IMUK(I) - IMUK(I) = SMUI - SMUI1 - SMUI1 = SMUI - 200 CONTINUE -C - RETURN -C *** Last line of MC03NY *** - END diff --git a/mex/sources/libslicot/MD03AD.f b/mex/sources/libslicot/MD03AD.f deleted file mode 100644 index 6eca057c4..000000000 --- a/mex/sources/libslicot/MD03AD.f +++ /dev/null @@ -1,973 +0,0 @@ - SUBROUTINE MD03AD( XINIT, ALG, STOR, UPLO, FCN, JPJ, M, N, ITMAX, - $ NPRINT, IPAR, LIPAR, DPAR1, LDPAR1, DPAR2, - $ LDPAR2, X, NFEV, NJEV, TOL, CGTOL, DWORK, - $ LDWORK, IWARN, INFO ) -C -C SLICOT RELEASE 5.0. -C -C Copyright (c) 2002-2009 NICONET e.V. -C -C This program is free software: you can redistribute it and/or -C modify it under the terms of the GNU General Public License as -C published by the Free Software Foundation, either version 2 of -C the License, or (at your option) any later version. -C -C This program is distributed in the hope that it will be useful, -C but WITHOUT ANY WARRANTY; without even the implied warranty of -C MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the -C GNU General Public License for more details. -C -C You should have received a copy of the GNU General Public License -C along with this program. If not, see -C . -C -C PURPOSE -C -C To minimize the sum of the squares of m nonlinear functions, e, in -C n variables, x, by a modification of the Levenberg-Marquardt -C algorithm, using either a Cholesky-based or a conjugate gradients -C solver. The user must provide a subroutine FCN which calculates -C the functions and the Jacobian J (possibly by finite differences), -C and another subroutine JPJ, which computes either J'*J + par*I -C (if ALG = 'D'), or (J'*J + par*I)*x (if ALG = 'I'), where par is -C the Levenberg factor, exploiting the possible structure of the -C Jacobian matrix. Template implementations of these routines are -C included in the SLICOT Library. -C -C ARGUMENTS -C -C Mode Parameters -C -C XINIT CHARACTER*1 -C Specifies how the variables x are initialized, as follows: -C = 'R' : the array X is initialized to random values; the -C entries DWORK(1:4) are used to initialize the -C random number generator: the first three values -C are converted to integers between 0 and 4095, and -C the last one is converted to an odd integer -C between 1 and 4095; -C = 'G' : the given entries of X are used as initial values -C of variables. -C -C ALG CHARACTER*1 -C Specifies the algorithm used for solving the linear -C systems involving a Jacobian matrix J, as follows: -C = 'D' : a direct algorithm, which computes the Cholesky -C factor of the matrix J'*J + par*I is used; -C = 'I' : an iterative Conjugate Gradients algorithm, which -C only needs the matrix J, is used. -C In both cases, matrix J is stored in a compressed form. -C -C STOR CHARACTER*1 -C If ALG = 'D', specifies the storage scheme for the -C symmetric matrix J'*J, as follows: -C = 'F' : full storage is used; -C = 'P' : packed storage is used. -C The option STOR = 'F' usually ensures a faster execution. -C This parameter is not relevant if ALG = 'I'. -C -C UPLO CHARACTER*1 -C If ALG = 'D', specifies which part of the matrix J'*J -C is stored, as follows: -C = 'U' : the upper triagular part is stored; -C = 'L' : the lower triagular part is stored. -C The option UPLO = 'U' usually ensures a faster execution. -C This parameter is not relevant if ALG = 'I'. -C -C Function Parameters -C -C FCN EXTERNAL -C Subroutine which evaluates the functions and the Jacobian. -C FCN must be declared in an external statement in the user -C calling program, and must have the following interface: -C -C SUBROUTINE FCN( IFLAG, M, N, IPAR, LIPAR, DPAR1, LDPAR1, -C $ DPAR2, LDPAR2, X, NFEVL, E, J, LDJ, JTE, -C $ DWORK, LDWORK, INFO ) -C -C where -C -C IFLAG (input/output) INTEGER -C On entry, this parameter must contain a value -C defining the computations to be performed: -C = 0 : Optionally, print the current iterate X, -C function values E, and Jacobian matrix J, -C or other results defined in terms of these -C values. See the argument NPRINT of MD03AD. -C Do not alter E and J. -C = 1 : Calculate the functions at X and return -C this vector in E. Do not alter J. -C = 2 : Calculate the Jacobian at X and return -C this matrix in J. Also return J'*e in JTE -C and NFEVL (see below). Do not alter E. -C = 3 : Do not compute neither the functions nor -C the Jacobian, but return in LDJ and -C IPAR/DPAR1,DPAR2 (some of) the integer/real -C parameters needed. -C On exit, the value of this parameter should not be -C changed by FCN unless the user wants to terminate -C execution of MD03AD, in which case IFLAG must be -C set to a negative integer. -C -C M (input) INTEGER -C The number of functions. M >= 0. -C -C N (input) INTEGER -C The number of variables. M >= N >= 0. -C -C IPAR (input/output) INTEGER array, dimension (LIPAR) -C The integer parameters describing the structure of -C the Jacobian matrix or needed for problem solving. -C IPAR is an input parameter, except for IFLAG = 3 -C on entry, when it is also an output parameter. -C On exit, if IFLAG = 3, IPAR(1) contains the length -C of the array J, for storing the Jacobian matrix, -C and the entries IPAR(2:5) contain the workspace -C required by FCN for IFLAG = 1, FCN for IFLAG = 2, -C JPJ for ALG = 'D', and JPJ for ALG = 'I', -C respectively. -C -C LIPAR (input) INTEGER -C The length of the array IPAR. LIPAR >= 5. -C -C DPAR1 (input/output) DOUBLE PRECISION array, dimension -C (LDPAR1,*) or (LDPAR1) -C A first set of real parameters needed for -C describing or solving the problem. -C DPAR1 can also be used as an additional array for -C intermediate results when computing the functions -C or the Jacobian. For control problems, DPAR1 could -C store the input trajectory of a system. -C -C LDPAR1 (input) INTEGER -C The leading dimension or the length of the array -C DPAR1, as convenient. LDPAR1 >= 0. (LDPAR1 >= 1, -C if leading dimension.) -C -C DPAR2 (input/output) DOUBLE PRECISION array, dimension -C (LDPAR2,*) or (LDPAR2) -C A second set of real parameters needed for -C describing or solving the problem. -C DPAR2 can also be used as an additional array for -C intermediate results when computing the functions -C or the Jacobian. For control problems, DPAR2 could -C store the output trajectory of a system. -C -C LDPAR2 (input) INTEGER -C The leading dimension or the length of the array -C DPAR2, as convenient. LDPAR2 >= 0. (LDPAR2 >= 1, -C if leading dimension.) -C -C X (input) DOUBLE PRECISION array, dimension (N) -C This array must contain the value of the -C variables x where the functions or the Jacobian -C must be evaluated. -C -C NFEVL (input/output) INTEGER -C The number of function evaluations needed to -C compute the Jacobian by a finite difference -C approximation. -C NFEVL is an input parameter if IFLAG = 0, or an -C output parameter if IFLAG = 2. If the Jacobian is -C computed analytically, NFEVL should be set to a -C non-positive value. -C -C E (input/output) DOUBLE PRECISION array, -C dimension (M) -C This array contains the value of the (error) -C functions e evaluated at X. -C E is an input parameter if IFLAG = 0 or 2, or an -C output parameter if IFLAG = 1. -C -C J (input/output) DOUBLE PRECISION array, dimension -C (LDJ,NC), where NC is the number of columns -C needed. -C This array contains a possibly compressed -C representation of the Jacobian matrix evaluated -C at X. If full Jacobian is stored, then NC = N. -C J is an input parameter if IFLAG = 0, or an output -C parameter if IFLAG = 2. -C -C LDJ (input/output) INTEGER -C The leading dimension of array J. LDJ >= 1. -C LDJ is essentially used inside the routines FCN -C and JPJ. -C LDJ is an input parameter, except for IFLAG = 3 -C on entry, when it is an output parameter. -C It is assumed in MD03AD that LDJ is not larger -C than needed. -C -C JTE (output) DOUBLE PRECISION array, dimension (N) -C If IFLAG = 2, the matrix-vector product J'*e. -C -C DWORK DOUBLE PRECISION array, dimension (LDWORK) -C The workspace array for subroutine FCN. -C On exit, if INFO = 0, DWORK(1) returns the optimal -C value of LDWORK. -C -C LDWORK (input) INTEGER -C The size of the array DWORK (as large as needed -C in the subroutine FCN). LDWORK >= 1. -C -C INFO INTEGER -C Error indicator, set to a negative value if an -C input (scalar) argument is erroneous, and to -C positive values for other possible errors in the -C subroutine FCN. The LAPACK Library routine XERBLA -C should be used in conjunction with negative INFO. -C INFO must be zero if the subroutine finished -C successfully. -C -C Parameters marked with "(input)" must not be changed. -C -C JPJ EXTERNAL -C Subroutine which computes J'*J + par*I, if ALG = 'D', and -C J'*J*x + par*x, if ALG = 'I', where J is the Jacobian as -C described above. -C -C JPJ must have the following interface: -C -C SUBROUTINE JPJ( STOR, UPLO, N, IPAR, LIPAR, DPAR, LDPAR, -C $ J, LDJ, JTJ, LDJTJ, DWORK, LDWORK, INFO ) -C -C if ALG = 'D', and -C -C SUBROUTINE JPJ( N, IPAR, LIPAR, DPAR, LDPAR, J, LDJ, X, -C $ INCX, DWORK, LDWORK, INFO ) -C -C if ALG = 'I', where -C -C STOR (input) CHARACTER*1 -C Specifies the storage scheme for the symmetric -C matrix J'*J, as follows: -C = 'F' : full storage is used; -C = 'P' : packed storage is used. -C -C UPLO (input) CHARACTER*1 -C Specifies which part of the matrix J'*J is stored, -C as follows: -C = 'U' : the upper triagular part is stored; -C = 'L' : the lower triagular part is stored. -C -C N (input) INTEGER -C The number of columns of the matrix J. N >= 0. -C -C IPAR (input) INTEGER array, dimension (LIPAR) -C The integer parameters describing the structure of -C the Jacobian matrix. -C -C LIPAR (input) INTEGER -C The length of the array IPAR. LIPAR >= 0. -C -C DPAR (input) DOUBLE PRECISION array, dimension (LDPAR) -C DPAR(1) must contain an initial estimate of the -C Levenberg-Marquardt parameter, par. DPAR(1) >= 0. -C -C LDPAR (input) INTEGER -C The length of the array DPAR. LDPAR >= 1. -C -C J (input) DOUBLE PRECISION array, dimension -C (LDJ, NC), where NC is the number of columns. -C The leading NR-by-NC part of this array must -C contain the (compressed) representation of the -C Jacobian matrix J, where NR is the number of rows -C of J (function of IPAR entries). -C -C LDJ (input) INTEGER -C The leading dimension of array J. -C LDJ >= MAX(1,NR). -C -C JTJ (output) DOUBLE PRECISION array, -C dimension (LDJTJ,N), if STOR = 'F', -C dimension (N*(N+1)/2), if STOR = 'P'. -C The leading N-by-N (if STOR = 'F'), or N*(N+1)/2 -C (if STOR = 'P') part of this array contains the -C upper or lower triangle of the matrix J'*J+par*I, -C depending on UPLO = 'U', or UPLO = 'L', -C respectively, stored either as a two-dimensional, -C or one-dimensional array, depending on STOR. -C -C LDJTJ (input) INTEGER -C The leading dimension of the array JTJ. -C LDJTJ >= MAX(1,N), if STOR = 'F'. -C LDJTJ >= 1, if STOR = 'P'. -C -C DWORK DOUBLE PRECISION array, dimension (LDWORK) -C The workspace array for subroutine JPJ. -C -C LDWORK (input) INTEGER -C The size of the array DWORK (as large as needed -C in the subroutine JPJ). -C -C INFO INTEGER -C Error indicator, set to a negative value if an -C input (scalar) argument is erroneous, and to -C positive values for other possible errors in the -C subroutine JPJ. The LAPACK Library routine XERBLA -C should be used in conjunction with negative INFO -C values. INFO must be zero if the subroutine -C finished successfully. -C -C If ALG = 'I', the parameters in common with those for -C ALG = 'D', have the same meaning, and the additional -C parameters are: -C -C X (input/output) DOUBLE PRECISION array, dimension -C (1+(N-1)*INCX) -C On entry, this incremented array must contain the -C vector x. -C On exit, this incremented array contains the value -C of the matrix-vector product (J'*J + par)*x. -C -C INCX (input) INTEGER -C The increment for the elements of X. INCX > 0. -C -C Parameters marked with "(input)" must not be changed. -C -C Input/Output Parameters -C -C M (input) INTEGER -C The number of functions. M >= 0. -C -C N (input) INTEGER -C The number of variables. M >= N >= 0. -C -C ITMAX (input) INTEGER -C The maximum number of iterations. ITMAX >= 0. -C -C NPRINT (input) INTEGER -C This parameter enables controlled printing of iterates if -C it is positive. In this case, FCN is called with IFLAG = 0 -C at the beginning of the first iteration and every NPRINT -C iterations thereafter and immediately prior to return, -C with X, E, and J available for printing. If NPRINT is not -C positive, no special calls of FCN with IFLAG = 0 are made. -C -C IPAR (input) INTEGER array, dimension (LIPAR) -C The integer parameters needed, for instance, for -C describing the structure of the Jacobian matrix, which -C are handed over to the routines FCN and JPJ. -C The first five entries of this array are modified -C internally by a call to FCN (with IFLAG = 3), but are -C restored on exit. -C -C LIPAR (input) INTEGER -C The length of the array IPAR. LIPAR >= 5. -C -C DPAR1 (input/output) DOUBLE PRECISION array, dimension -C (LDPAR1,*) or (LDPAR1) -C A first set of real parameters needed for describing or -C solving the problem. This argument is not used by MD03AD -C routine, but it is passed to the routine FCN. -C -C LDPAR1 (input) INTEGER -C The leading dimension or the length of the array DPAR1, as -C convenient. LDPAR1 >= 0. (LDPAR1 >= 1, if leading -C dimension.) -C -C DPAR2 (input/output) DOUBLE PRECISION array, dimension -C (LDPAR2,*) or (LDPAR2) -C A second set of real parameters needed for describing or -C solving the problem. This argument is not used by MD03AD -C routine, but it is passed to the routine FCN. -C -C LDPAR2 (input) INTEGER -C The leading dimension or the length of the array DPAR2, as -C convenient. LDPAR2 >= 0. (LDPAR2 >= 1, if leading -C dimension.) -C -C X (input/output) DOUBLE PRECISION array, dimension (N) -C On entry, if XINIT = 'G', this array must contain the -C vector of initial variables x to be optimized. -C If XINIT = 'R', this array need not be set before entry, -C and random values will be used to initialize x. -C On exit, if INFO = 0, this array contains the vector of -C values that (approximately) minimize the sum of squares of -C error functions. The values returned in IWARN and -C DWORK(1:5) give details on the iterative process. -C -C NFEV (output) INTEGER -C The number of calls to FCN with IFLAG = 1. If FCN is -C properly implemented, this includes the function -C evaluations needed for finite difference approximation -C of the Jacobian. -C -C NJEV (output) INTEGER -C The number of calls to FCN with IFLAG = 2. -C -C Tolerances -C -C TOL DOUBLE PRECISION -C If TOL >= 0, the tolerance which measures the relative -C error desired in the sum of squares. Termination occurs -C when the actual relative reduction in the sum of squares -C is at most TOL. If the user sets TOL < 0, then SQRT(EPS) -C is used instead TOL, where EPS is the machine precision -C (see LAPACK Library routine DLAMCH). -C -C CGTOL DOUBLE PRECISION -C If ALG = 'I' and CGTOL > 0, the tolerance which measures -C the relative residual of the solutions computed by the -C conjugate gradients (CG) algorithm. Termination of a -C CG process occurs when the relative residual is at -C most CGTOL. If the user sets CGTOL <= 0, then SQRT(EPS) -C is used instead CGTOL. -C -C Workspace -C -C DWORK DOUBLE PRECISION array, dimension (LDWORK) -C On exit, if INFO = 0, DWORK(1) returns the optimal value -C of LDWORK, DWORK(2) returns the residual error norm (the -C sum of squares), DWORK(3) returns the number of iterations -C performed, DWORK(4) returns the total number of conjugate -C gradients iterations performed (zero, if ALG = 'D'), and -C DWORK(5) returns the final Levenberg factor. -C -C LDWORK INTEGER -C The length of the array DWORK. -C LDWORK >= max( 5, M + 2*N + size(J) + -C max( DW( FCN|IFLAG = 1 ) + N, -C DW( FCN|IFLAG = 2 ), -C DW( sol ) ) ), -C where size(J) is the size of the Jacobian (provided by FCN -C in IPAR(1), for IFLAG = 3), DW( f ) is the workspace -C needed by the routine f, where f is FCN or JPJ (provided -C by FCN in IPAR(2:5), for IFLAG = 3), and DW( sol ) is the -C workspace needed for solving linear systems, -C DW( sol ) = N*N + DW( JPJ ), if ALG = 'D', STOR = 'F'; -C DW( sol ) = N*(N+1)/2 + DW( JPJ ), -C if ALG = 'D', STOR = 'P'; -C DW( sol ) = 3*N + DW( JPJ ), if ALG = 'I'. -C -C Warning Indicator -C -C IWARN INTEGER -C < 0: the user set IFLAG = IWARN in the subroutine FCN; -C = 0: no warning; -C = 1: if the iterative process did not converge in ITMAX -C iterations with tolerance TOL; -C = 2: if ALG = 'I', and in one or more iterations of the -C Levenberg-Marquardt algorithm, the conjugate -C gradient algorithm did not finish after 3*N -C iterations, with the accuracy required in the -C call; -C = 3: the cosine of the angle between e and any column of -C the Jacobian is at most FACTOR*EPS in absolute -C value, where FACTOR = 100 is defined in a PARAMETER -C statement; -C = 4: TOL is too small: no further reduction in the sum -C of squares is possible. -C In all these cases, DWORK(1:5) are set as described -C above. -C -C Error Indicator -C -C INFO INTEGER -C = 0: successful exit; -C < 0: if INFO = -i, the i-th argument had an illegal -C value; -C = 1: user-defined routine FCN returned with INFO <> 0 -C for IFLAG = 1; -C = 2: user-defined routine FCN returned with INFO <> 0 -C for IFLAG = 2; -C = 3: SLICOT Library routine MB02XD, if ALG = 'D', or -C SLICOT Library routine MB02WD, if ALG = 'I' (or -C user-defined routine JPJ), returned with INFO <> 0. -C -C METHOD -C -C If XINIT = 'R', the initial value for X is set to a vector of -C pseudo-random values uniformly distributed in [-1,1]. -C -C The Levenberg-Marquardt algorithm (described in [1]) is used for -C optimizing the parameters. This algorithm needs the Jacobian -C matrix J, which is provided by the subroutine FCN. The algorithm -C tries to update x by the formula -C -C x = x - p, -C -C using the solution of the system of linear equations -C -C (J'*J + PAR*I)*p = J'*e, -C -C where I is the identity matrix, and e the error function vector. -C The Levenberg factor PAR is decreased after each successfull step -C and increased in the other case. -C -C If ALG = 'D', a direct method, which evaluates the matrix product -C J'*J + par*I and then factors it using Cholesky algorithm, -C implemented in the SLICOT Libray routine MB02XD, is used for -C solving the linear system above. -C -C If ALG = 'I', the Conjugate Gradients method, described in [2], -C and implemented in the SLICOT Libray routine MB02WD, is used for -C solving the linear system above. The main advantage of this method -C is that in most cases the solution of the system can be computed -C in less time than the time needed to compute the matrix J'*J -C This is, however, problem dependent. -C -C REFERENCES -C -C [1] Kelley, C.T. -C Iterative Methods for Optimization. -C Society for Industrial and Applied Mathematics (SIAM), -C Philadelphia (Pa.), 1999. -C -C [2] Golub, G.H. and van Loan, C.F. -C Matrix Computations. Third Edition. -C M. D. Johns Hopkins University Press, Baltimore, pp. 520-528, -C 1996. -C -C [3] More, J.J. -C The Levenberg-Marquardt algorithm: implementation and theory. -C In Watson, G.A. (Ed.), Numerical Analysis, Lecture Notes in -C Mathematics, vol. 630, Springer-Verlag, Berlin, Heidelberg -C and New York, pp. 105-116, 1978. -C -C NUMERICAL ASPECTS -C -C The Levenberg-Marquardt algorithm described in [3] is scaling -C invariant and globally convergent to (maybe local) minima. -C According to [1], the convergence rate near a local minimum is -C quadratic, if the Jacobian is computed analytically, and linear, -C if the Jacobian is computed numerically. -C -C Whether or not the direct algorithm is faster than the iterative -C Conjugate Gradients algorithm for solving the linear systems -C involved depends on several factors, including the conditioning -C of the Jacobian matrix, and the ratio between its dimensions. -C -C CONTRIBUTORS -C -C A. Riedel, R. Schneider, Chemnitz University of Technology, -C Oct. 2000. -C V. Sima, Research Institute for Informatics, Bucharest, Dec. 2001. -C -C REVISIONS -C -C V. Sima, Research Institute for Informatics, Bucharest, Mar. 2001, -C Mar. 2002. -C -C KEYWORDS -C -C Conjugate gradients, least-squares approximation, -C Levenberg-Marquardt algorithm, matrix operations, optimization. -C -C ****************************************************************** -C -C .. Parameters .. - DOUBLE PRECISION ZERO, ONE, FOUR, FIVE - PARAMETER ( ZERO = 0.0D0, ONE = 1.0D0, FOUR = 4.0D0, - $ FIVE = 5.0D0 ) - DOUBLE PRECISION FACTOR, MARQF, MINIMP, PARMAX - PARAMETER ( FACTOR = 10.0D0**2, MARQF = 2.0D0**2, - $ MINIMP = 2.0D0**(-3), PARMAX = 1.0D20 ) -C .. Scalar Arguments .. - CHARACTER ALG, STOR, UPLO, XINIT - INTEGER INFO, ITMAX, IWARN, LDPAR1, LDPAR2, LDWORK, - $ LIPAR, M, N, NFEV, NJEV, NPRINT - DOUBLE PRECISION CGTOL, TOL -C .. Array Arguments .. - DOUBLE PRECISION DPAR1(LDPAR1,*), DPAR2(LDPAR2,*), DWORK(*), X(*) - INTEGER IPAR(*) -C .. Local Scalars .. - LOGICAL CHOL, FULL, INIT, UPPER - INTEGER DWJTJ, E, I, IFLAG, INFOL, ITER, ITERCG, IW1, - $ IW2, IWARNL, JAC, JTE, JW1, JW2, JWORK, LDJ, - $ LDW, LFCN1, LFCN2, LJTJ, LJTJD, LJTJI, NFEVL, - $ SIZEJ, WRKOPT - DOUBLE PRECISION ACTRED, BIGNUM, CGTDEF, EPSMCH, FNORM, FNORM1, - $ GNORM, GSMIN, PAR, SMLNUM, SQREPS, TOLDEF -C .. Local Arrays .. - INTEGER SEED(4) -C .. External Functions .. - DOUBLE PRECISION DDOT, DLAMCH, DNRM2 - LOGICAL LSAME - EXTERNAL DDOT, DLAMCH, DNRM2, LSAME -C .. External Subroutines .. - EXTERNAL DCOPY, DLABAD, DLARNV, FCN, JPJ, MB02WD, MB02XD, - $ XERBLA -C .. Intrinsic Functions .. - INTRINSIC INT, MAX, MIN, MOD, SQRT -C .. -C .. Executable Statements .. -C -C Decode the scalar input parameters. -C - INIT = LSAME( XINIT, 'R' ) - CHOL = LSAME( ALG, 'D' ) - FULL = LSAME( STOR, 'F' ) - UPPER = LSAME( UPLO, 'U' ) -C -C Check the scalar input parameters. -C - IWARN = 0 - INFO = 0 - IF( .NOT.( INIT .OR. LSAME( XINIT, 'G' ) ) ) THEN - INFO = -1 - ELSEIF ( .NOT.( CHOL .OR. LSAME( ALG, 'I' ) ) ) THEN - INFO = -2 - ELSEIF ( CHOL .AND. .NOT.( FULL .OR. LSAME( STOR, 'P' ) ) ) THEN - INFO = -3 - ELSEIF ( CHOL .AND. .NOT.( UPPER .OR. LSAME( UPLO, 'L' ) ) ) THEN - INFO = -4 - ELSEIF ( M.LT.0 ) THEN - INFO = -7 - ELSEIF ( N.LT.0 .OR. N.GT.M ) THEN - INFO = -8 - ELSEIF ( ITMAX.LT.0 ) THEN - INFO = -9 - ELSEIF ( LIPAR.LT.5 ) THEN - INFO = -12 - ELSEIF( LDPAR1.LT.0 ) THEN - INFO = -14 - ELSEIF( LDPAR2.LT.0 ) THEN - INFO = -16 - ELSEIF ( LDWORK.LT.5 ) THEN - INFO = -23 - ENDIF -C -C Return if there are illegal arguments. -C - IF( INFO.NE.0 ) THEN - CALL XERBLA( 'MD03AD', -INFO ) - RETURN - ENDIF -C -C Quick return if possible. -C - NFEV = 0 - NJEV = 0 - IF ( MIN( N, ITMAX ).EQ.0 ) THEN - DWORK(1) = FIVE - DWORK(2) = ZERO - DWORK(3) = ZERO - DWORK(4) = ZERO - DWORK(5) = ZERO - RETURN - ENDIF -C -C Call FCN to get the size of the array J, for storing the Jacobian -C matrix, the leading dimension LDJ and the workspace required -C by FCN for IFLAG = 1 and IFLAG = 2, and JPJ. The entries -C DWORK(1:4) should not be modified by the special call of FCN -C below, if XINIT = 'R' and the values in DWORK(1:4) are explicitly -C desired for initialization of the random number generator. -C - IFLAG = 3 - IW1 = IPAR(1) - IW2 = IPAR(2) - JW1 = IPAR(3) - JW2 = IPAR(4) - LJTJ = IPAR(5) -C - CALL FCN( IFLAG, M, N, IPAR, LIPAR, DPAR1, LDPAR1, DPAR2, LDPAR2, - $ X, NFEVL, DWORK, DWORK, LDJ, DWORK, DWORK, LDWORK, - $ INFOL ) -C - SIZEJ = IPAR(1) - LFCN1 = IPAR(2) - LFCN2 = IPAR(3) - LJTJD = IPAR(4) - LJTJI = IPAR(5) -C - IPAR(1) = IW1 - IPAR(2) = IW2 - IPAR(3) = JW1 - IPAR(4) = JW2 - IPAR(5) = LJTJ -C -C Define pointers to the array variables stored in DWORK. -C - JAC = 1 - E = JAC + SIZEJ - JTE = E + M - IW1 = JTE + N - IW2 = IW1 + N - JW1 = IW2 - JW2 = IW2 + N -C -C Check the workspace length. -C - JWORK = JW1 - IF ( CHOL ) THEN - IF ( FULL ) THEN - LDW = N*N - ELSE - LDW = ( N*( N + 1 ) ) / 2 - ENDIF - DWJTJ = JWORK - JWORK = DWJTJ + LDW - LJTJ = LJTJD - ELSE - LDW = 3*N - LJTJ = LJTJI - ENDIF - IF ( LDWORK.LT.MAX( 5, SIZEJ + M + 2*N + - $ MAX( LFCN1 + N, LFCN2, LDW + LJTJ ) ) ) - $ THEN - INFO = -23 - ENDIF - IF( INFO.NE.0 ) THEN - CALL XERBLA( 'MD03AD', -INFO ) - RETURN - ENDIF -C -C Set default tolerances. SQREPS is the square root of the machine -C precision, and GSMIN is used in the tests of the gradient norm. -C - EPSMCH = DLAMCH( 'Epsilon' ) - SQREPS = SQRT( EPSMCH ) - TOLDEF = TOL - IF ( TOLDEF.LT.ZERO ) - $ TOLDEF = SQREPS - CGTDEF = CGTOL - IF ( CGTDEF.LE.ZERO ) - $ CGTDEF = SQREPS - GSMIN = FACTOR*EPSMCH - WRKOPT = 5 -C - SMLNUM = DLAMCH( 'Safe minimum' ) / DLAMCH( 'Precision' ) - BIGNUM = ONE / SMLNUM - CALL DLABAD( SMLNUM, BIGNUM ) -C -C Initialization. -C - IF ( INIT ) THEN -C -C SEED is the initial state of the random number generator. -C SEED(4) must be odd. -C - SEED(1) = MOD( INT( DWORK(1) ), 4096 ) - SEED(2) = MOD( INT( DWORK(2) ), 4096 ) - SEED(3) = MOD( INT( DWORK(3) ), 4096 ) - SEED(4) = MOD( 2*INT( DWORK(4) ) + 1, 4096 ) - CALL DLARNV( 2, SEED, N, X ) - ENDIF -C -C Evaluate the function at the starting point and calculate -C its norm. -C Workspace: need: SIZEJ + M + 2*N + LFCN1; -C prefer: larger. -C - IFLAG = 1 - CALL FCN( IFLAG, M, N, IPAR, LIPAR, DPAR1, LDPAR1, DPAR2, LDPAR2, - $ X, NFEVL, DWORK(E), DWORK(JAC), LDJ, DWORK(JTE), - $ DWORK(JW1), LDWORK-JW1+1, INFOL ) -C - IF ( INFOL.NE.0 ) THEN - INFO = 1 - RETURN - END IF - WRKOPT = MAX( WRKOPT, INT( DWORK(JW1) ) + JW1 - 1 ) - NFEV = 1 - FNORM = DNRM2( M, DWORK(E), 1 ) - ACTRED = ZERO - ITERCG = 0 - ITER = 0 - IWARNL = 0 - PAR = ZERO - IF ( IFLAG.LT.0 .OR. FNORM.EQ.ZERO ) - $ GO TO 40 -C -C Set the initial vector for the conjugate gradients algorithm. -C - DWORK(IW1) = ZERO - CALL DCOPY( N, DWORK(IW1), 0, DWORK(IW1), 1 ) -C -C WHILE ( nonconvergence and ITER < ITMAX ) DO -C -C Beginning of the outer loop. -C - 10 CONTINUE -C -C Calculate the Jacobian matrix. -C Workspace: need: SIZEJ + M + 2*N + LFCN2; -C prefer: larger. -C - ITER = ITER + 1 - IFLAG = 2 - CALL FCN( IFLAG, M, N, IPAR, LIPAR, DPAR1, LDPAR1, DPAR2, - $ LDPAR2, X, NFEVL, DWORK(E), DWORK(JAC), LDJ, - $ DWORK(JTE), DWORK(JW1), LDWORK-JW1+1, INFOL ) -C - IF ( INFOL.NE.0 ) THEN - INFO = 2 - RETURN - END IF -C -C Compute the gradient norm. -C - GNORM = DNRM2( N, DWORK(JTE), 1 ) - IF ( NFEVL.GT.0 ) - $ NFEV = NFEV + NFEVL - NJEV = NJEV + 1 - IF ( GNORM.LE.GSMIN ) - $ IWARN = 3 - IF ( IWARN.NE.0 ) - $ GO TO 40 - IF ( ITER.EQ.1 ) THEN - WRKOPT = MAX( WRKOPT, INT( DWORK(JW1) ) + JW1 - 1 ) - PAR = MIN( GNORM, SQRT( PARMAX ) ) - END IF - IF ( IFLAG.LT.0 ) - $ GO TO 40 -C -C If requested, call FCN to enable printing of iterates. -C - IF ( NPRINT.GT.0 ) THEN - IFLAG = 0 - IF ( MOD( ITER-1, NPRINT ).EQ.0 ) THEN - CALL FCN( IFLAG, M, N, IPAR, LIPAR, DPAR1, LDPAR1, DPAR2, - $ LDPAR2, X, NFEV, DWORK(E), DWORK(JAC), LDJ, - $ DWORK(JTE), DWORK(JW1), LDWORK-JW1+1, INFOL ) -C - IF ( IFLAG.LT.0 ) - $ GO TO 40 - END IF - END IF -C -C Beginning of the inner loop. -C - 20 CONTINUE -C -C Store the Levenberg factor in DWORK(E) (which is no longer -C needed), to pass it to JPJ routine. -C - DWORK(E) = PAR -C -C Solve (J'*J + PAR*I)*x = J'*e, and store x in DWORK(IW1). -C Additional workspace: -C N*N + DW(JPJ), if ALG = 'D', STOR = 'F'; -C N*( N + 1)/2 + DW(JPJ), if ALG = 'D', STOR = 'P'; -C 3*N + DW(JPJ), if ALG = 'I'. -C - IF ( CHOL ) THEN - CALL DCOPY( N, DWORK(JTE), 1, DWORK(IW1), 1 ) - CALL MB02XD( 'Function', STOR, UPLO, JPJ, M, N, 1, IPAR, - $ LIPAR, DWORK(E), 1, DWORK(JAC), LDJ, - $ DWORK(IW1), N, DWORK(DWJTJ), N, - $ DWORK(JWORK), LDWORK-JWORK+1, INFOL ) - ELSE - CALL MB02WD( 'Function', JPJ, N, IPAR, LIPAR, DWORK(E), - $ 1, 3*N, DWORK(JAC), LDJ, DWORK(JTE), 1, - $ DWORK(IW1), 1, CGTOL*GNORM, DWORK(JWORK), - $ LDWORK-JWORK+1, IWARN, INFOL ) - ITERCG = ITERCG + INT( DWORK(JWORK) ) - IWARNL = MAX( 2*IWARN, IWARNL ) - ENDIF -C - IF ( INFOL.NE.0 ) THEN - INFO = 3 - RETURN - ENDIF -C -C Compute updated X. -C - DO 30 I = 0, N - 1 - DWORK(IW2+I) = X(I+1) - DWORK(IW1+I) - 30 CONTINUE -C -C Evaluate the function at x - p and calculate its norm. -C Workspace: need: SIZEJ + M + 3*N + LFCN1; -C prefer: larger. -C - IFLAG = 1 - CALL FCN( IFLAG, M, N, IPAR, LIPAR, DPAR1, LDPAR1, DPAR2, - $ LDPAR2, DWORK(IW2), NFEVL, DWORK(E), DWORK(JAC), - $ LDJ, DWORK(JTE), DWORK(JW2), LDWORK-JW2+1, INFOL ) -C - IF ( INFOL.NE.0 ) THEN - INFO = 1 - RETURN - END IF -C - NFEV = NFEV + 1 - IF ( IFLAG.LT.0 ) - $ GO TO 40 - FNORM1 = DNRM2( M, DWORK(E), 1 ) -C -C Now, check whether this step was successful and update the -C Levenberg factor. -C - IF ( FNORM.LT.FNORM1 ) THEN -C -C Unsuccessful step: increase PAR. -C - ACTRED = ONE - IF ( PAR.GT.PARMAX ) THEN - IF ( PAR/MARQF.LE.BIGNUM ) - $ PAR = PAR*MARQF - ELSE - PAR = PAR*MARQF - END IF -C - ELSE -C -C Successful step: update PAR, X, and FNORM. -C - ACTRED = ONE - ( FNORM1/FNORM )**2 - IF ( ( FNORM - FNORM1 )*( FNORM + FNORM1 ) .LT. - $ MINIMP*DDOT( N, DWORK(IW1), 1, - $ DWORK(JTE), 1 ) ) THEN - IF ( PAR.GT.PARMAX ) THEN - IF ( PAR/MARQF.LE.BIGNUM ) - $ PAR = PAR*MARQF - ELSE - PAR = PAR*MARQF - END IF - ELSE - PAR = MAX( PAR/MARQF, SMLNUM ) - ENDIF - CALL DCOPY( N, DWORK(IW2), 1, X, 1 ) - FNORM = FNORM1 - ENDIF -C - IF ( ( ACTRED.LE.TOLDEF ) .OR. ( ITER.GT.ITMAX ) .OR. - $ ( PAR.GT.PARMAX ) ) - $ GO TO 40 - IF ( ACTRED.LE.EPSMCH ) THEN - IWARN = 4 - GO TO 40 - ENDIF -C -C End of the inner loop. Repeat if unsuccessful iteration. -C - IF ( FNORM.LT.FNORM1 ) - $ GO TO 20 -C -C End of the outer loop. -C - GO TO 10 -C -C END WHILE 10 -C - 40 CONTINUE -C -C Termination, either normal or user imposed. -C - IF ( ACTRED.GT.TOLDEF ) - $ IWARN = 1 - IF ( IWARNL.NE.0 ) - $ IWARN = 2 -C - IF ( IFLAG.LT.0 ) - $ IWARN = IFLAG - IF ( NPRINT.GT.0 ) THEN - IFLAG = 0 - CALL FCN( IFLAG, M, N, IPAR, LIPAR, DPAR1, LDPAR1, DPAR2, - $ LDPAR2, X, NFEV, DWORK(E), DWORK(JAC), LDJ, - $ DWORK(JTE), DWORK(JW1), LDWORK-JW1+1, INFOL ) - IF ( IFLAG.LT.0 ) - $ IWARN = IFLAG - END IF -C - DWORK(1) = WRKOPT - DWORK(2) = FNORM - DWORK(3) = ITER - DWORK(4) = ITERCG - DWORK(5) = PAR -C - RETURN -C *** Last line of MD03AD *** - END diff --git a/mex/sources/libslicot/MD03BA.f b/mex/sources/libslicot/MD03BA.f deleted file mode 100644 index ac2782e3a..000000000 --- a/mex/sources/libslicot/MD03BA.f +++ /dev/null @@ -1,151 +0,0 @@ - SUBROUTINE MD03BA( N, IPAR, LIPAR, FNORM, J, LDJ, E, JNORMS, - $ GNORM, IPVT, DWORK, LDWORK, INFO ) -C -C SLICOT RELEASE 5.0. -C -C Copyright (c) 2002-2009 NICONET e.V. -C -C This program is free software: you can redistribute it and/or -C modify it under the terms of the GNU General Public License as -C published by the Free Software Foundation, either version 2 of -C the License, or (at your option) any later version. -C -C This program is distributed in the hope that it will be useful, -C but WITHOUT ANY WARRANTY; without even the implied warranty of -C MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the -C GNU General Public License for more details. -C -C You should have received a copy of the GNU General Public License -C along with this program. If not, see -C . -C -C PURPOSE -C -C To compute the QR factorization with column pivoting of an -C m-by-n Jacobian matrix J (m >= n), that is, J*P = Q*R, where Q is -C a matrix with orthogonal columns, P a permutation matrix, and -C R an upper trapezoidal matrix with diagonal elements of -C nonincreasing magnitude, and to apply the transformation Q' on -C the error vector e (in-situ). The 1-norm of the scaled gradient -C is also returned. -C -C This routine is an interface to SLICOT Library routine MD03BX, -C for solving standard nonlinear least squares problems using SLICOT -C routine MD03BD. -C -C ARGUMENTS -C -C Input/Output Parameters -C -C N (input) INTEGER -C The number of columns of the Jacobian matrix J. N >= 0. -C -C IPAR (input) INTEGER array, dimension (LIPAR) -C The integer parameters describing the structure of the -C matrix J, as follows: -C IPAR(1) must contain the number of rows M of the Jacobian -C matrix J. M >= N. -C IPAR is provided for compatibility with SLICOT Library -C routine MD03BD. -C -C LIPAR (input) INTEGER -C The length of the array IPAR. LIPAR >= 1. -C -C FNORM (input) DOUBLE PRECISION -C The Euclidean norm of the vector e. FNORM >= 0. -C -C J (input/output) DOUBLE PRECISION array, dimension (LDJ, N) -C On entry, the leading M-by-N part of this array must -C contain the Jacobian matrix J. -C On exit, the leading N-by-N upper triangular part of this -C array contains the upper triangular factor R of the -C Jacobian matrix. Note that for efficiency of the later -C calculations, the matrix R is delivered with the leading -C dimension MAX(1,N), possibly much smaller than the value -C of LDJ on entry. -C -C LDJ (input/output) INTEGER -C The leading dimension of array J. -C On entry, LDJ >= MAX(1,M). -C On exit, LDJ >= MAX(1,N). -C -C E (input/output) DOUBLE PRECISION array, dimension (M) -C On entry, this array must contain the error vector e. -C On exit, this array contains the updated vector Q'*e. -C -C JNORMS (output) DOUBLE PRECISION array, dimension (N) -C This array contains the Euclidean norms of the columns -C of the Jacobian matrix, considered in the initial order. -C -C GNORM (output) DOUBLE PRECISION -C If FNORM > 0, the 1-norm of the scaled vector -C J'*Q'*e/FNORM, with each element i further divided -C by JNORMS(i) (if JNORMS(i) is nonzero). -C If FNORM = 0, the returned value of GNORM is 0. -C -C IPVT (output) INTEGER array, dimension (N) -C This array defines the permutation matrix P such that -C J*P = Q*R. Column j of P is column IPVT(j) of the identity -C matrix. -C -C Workspace -C -C DWORK DOUBLE PRECISION array, dimension (LDWORK) -C On exit, if INFO = 0, DWORK(1) returns the optimal value -C of LDWORK. -C -C LDWORK INTEGER -C The length of the array DWORK. -C LDWORK >= 1, if N = 0 or M = 1; -C LDWORK >= 4*N+1, if N > 1. -C For optimum performance LDWORK should be larger. -C -C Error Indicator -C -C INFO INTEGER -C = 0: successful exit; -C < 0: if INFO = -i, the i-th argument had an illegal -C value. -C -C METHOD -C -C This routine calls SLICOT Library routine MD03BX to perform the -C calculations. -C -C FURTHER COMMENTS -C -C For efficiency, the arguments are not checked. This is done in -C the routine MD03BX (except for LIPAR). -C -C CONTRIBUTORS -C -C V. Sima, Research Institute for Informatics, Bucharest, Dec. 2001. -C -C REVISIONS -C -C - -C -C KEYWORDS -C -C Elementary matrix operations, Jacobian matrix, matrix algebra, -C matrix operations. -C -C ****************************************************************** -C -C .. Scalar Arguments .. - INTEGER INFO, LDJ, LDWORK, LIPAR, N - DOUBLE PRECISION FNORM, GNORM -C .. Array Arguments .. - INTEGER IPAR(*), IPVT(*) - DOUBLE PRECISION DWORK(*), E(*), J(*), JNORMS(*) -C .. External Subroutines .. - EXTERNAL MD03BX -C .. -C .. Executable Statements .. -C - CALL MD03BX( IPAR(1), N, FNORM, J, LDJ, E, JNORMS, GNORM, IPVT, - $ DWORK, LDWORK, INFO ) - RETURN -C -C *** Last line of MD03BA *** - END diff --git a/mex/sources/libslicot/MD03BB.f b/mex/sources/libslicot/MD03BB.f deleted file mode 100644 index 67772e407..000000000 --- a/mex/sources/libslicot/MD03BB.f +++ /dev/null @@ -1,203 +0,0 @@ - SUBROUTINE MD03BB( COND, N, IPAR, LIPAR, R, LDR, IPVT, DIAG, QTB, - $ DELTA, PAR, RANKS, X, RX, TOL, DWORK, LDWORK, - $ INFO ) -C -C SLICOT RELEASE 5.0. -C -C Copyright (c) 2002-2009 NICONET e.V. -C -C This program is free software: you can redistribute it and/or -C modify it under the terms of the GNU General Public License as -C published by the Free Software Foundation, either version 2 of -C the License, or (at your option) any later version. -C -C This program is distributed in the hope that it will be useful, -C but WITHOUT ANY WARRANTY; without even the implied warranty of -C MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the -C GNU General Public License for more details. -C -C You should have received a copy of the GNU General Public License -C along with this program. If not, see -C . -C -C PURPOSE -C -C To determine a value for the parameter PAR such that if x solves -C the system -C -C A*x = b , sqrt(PAR)*D*x = 0 , -C -C in the least squares sense, where A is an m-by-n matrix, D is an -C n-by-n nonsingular diagonal matrix, and b is an m-vector, and if -C DELTA is a positive number, DXNORM is the Euclidean norm of D*x, -C then either PAR is zero and -C -C ( DXNORM - DELTA ) .LE. 0.1*DELTA , -C -C or PAR is positive and -C -C ABS( DXNORM - DELTA ) .LE. 0.1*DELTA . -C -C It is assumed that a QR factorization, with column pivoting, of A -C is available, that is, A*P = Q*R, where P is a permutation matrix, -C Q has orthogonal columns, and R is an upper triangular matrix -C with diagonal elements of nonincreasing magnitude. -C The routine needs the full upper triangle of R, the permutation -C matrix P, and the first n components of Q'*b (' denotes the -C transpose). On output, MD03BB also provides an upper triangular -C matrix S such that -C -C P'*(A'*A + PAR*D*D)*P = S'*S . -C -C Matrix S is used in the solution process. -C -C This routine is an interface to SLICOT Library routine MD03BY, -C for solving standard nonlinear least squares problems using SLICOT -C routine MD03BD. -C -C ARGUMENTS -C -C Mode Parameters -C -C COND CHARACTER*1 -C Specifies whether the condition of the matrices R and S -C should be estimated, as follows: -C = 'E' : use incremental condition estimation for R and S; -C = 'N' : do not use condition estimation, but check the -C diagonal entries of R and S for zero values; -C = 'U' : use the rank already stored in RANKS (for R). -C -C Input/Output Parameters -C -C N (input) INTEGER -C The order of the matrix R. N >= 0. -C -C IPAR (input) INTEGER array, dimension (LIPAR) -C The integer parameters describing the structure of the -C matrix R. IPAR and LIPAR are not used by this routine, -C but are provided for compatibility with SLICOT Library -C routine MD03BD. -C -C LIPAR (input) INTEGER -C The length of the array IPAR. LIPAR >= 0. -C -C R (input/output) DOUBLE PRECISION array, dimension (LDR, N) -C On entry, the leading N-by-N upper triangular part of this -C array must contain the upper triangular matrix R. -C On exit, the full upper triangle is unaltered, and the -C strict lower triangle contains the strict upper triangle -C (transposed) of the upper triangular matrix S. -C -C LDR INTEGER -C The leading dimension of array R. LDR >= MAX(1,N). -C -C IPVT (input) INTEGER array, dimension (N) -C This array must define the permutation matrix P such that -C A*P = Q*R. Column j of P is column IPVT(j) of the identity -C matrix. -C -C DIAG (input) DOUBLE PRECISION array, dimension (N) -C This array must contain the diagonal elements of the -C matrix D. DIAG(I) <> 0, I = 1,...,N. -C -C QTB (input) DOUBLE PRECISION array, dimension (N) -C This array must contain the first n elements of the -C vector Q'*b. -C -C DELTA (input) DOUBLE PRECISION -C An upper bound on the Euclidean norm of D*x. DELTA > 0. -C -C PAR (input/output) DOUBLE PRECISION -C On entry, PAR must contain an initial estimate of the -C Levenberg-Marquardt parameter. PAR >= 0. -C On exit, it contains the final estimate of this parameter. -C -C RANKS (input or output) INTEGER array, dimension (1) -C On entry, if COND = 'U' and N > 0, this array must contain -C the numerical rank of the matrix R. -C On exit, this array contains the numerical rank of the -C matrix S. -C RANKS is defined as an array for compatibility with SLICOT -C Library routine MD03BD. -C -C X (output) DOUBLE PRECISION array, dimension (N) -C This array contains the least squares solution of the -C system A*x = b, sqrt(PAR)*D*x = 0. -C -C RX (output) DOUBLE PRECISION array, dimension (N) -C This array contains the matrix-vector product -R*P'*x. -C -C Tolerances -C -C TOL DOUBLE PRECISION -C If COND = 'E', the tolerance to be used for finding the -C rank of the matrices R and S. If the user sets TOL > 0, -C then the given value of TOL is used as a lower bound for -C the reciprocal condition number; a (sub)matrix whose -C estimated condition number is less than 1/TOL is -C considered to be of full rank. If the user sets TOL <= 0, -C then an implicitly computed, default tolerance, defined by -C TOLDEF = N*EPS, is used instead, where EPS is the machine -C precision (see LAPACK Library routine DLAMCH). -C This parameter is not relevant if COND = 'U' or 'N'. -C -C Workspace -C -C DWORK DOUBLE PRECISION array, dimension (LDWORK) -C On exit, the first N elements of this array contain the -C diagonal elements of the upper triangular matrix S. -C -C LDWORK INTEGER -C The length of the array DWORK. -C LDWORK >= 4*N, if COND = 'E'; -C LDWORK >= 2*N, if COND <> 'E'. -C -C Error Indicator -C -C INFO INTEGER -C = 0: successful exit; -C < 0: if INFO = -i, the i-th argument had an illegal -C value. -C -C METHOD -C -C This routine calls SLICOT Library routine MD03BY to perform the -C calculations. -C -C FURTHER COMMENTS -C -C For efficiency, the arguments are not checked. This is done in -C the routine MD03BY (except for LIPAR). -C -C CONTRIBUTORS -C -C V. Sima, Research Institute for Informatics, Bucharest, Dec. 2001. -C -C REVISIONS -C -C - -C -C KEYWORDS -C -C Linear system of equations, matrix operations, plane rotations. -C -C ****************************************************************** -C -C .. Scalar Arguments .. - CHARACTER COND - INTEGER INFO, LDR, LDWORK, LIPAR, N - DOUBLE PRECISION DELTA, PAR, TOL -C .. Array Arguments .. - INTEGER IPAR(*), IPVT(*), RANKS(*) - DOUBLE PRECISION DIAG(*), DWORK(*), QTB(*), R(LDR,*), RX(*), X(*) -C .. External Subroutines .. - EXTERNAL MD03BY -C .. -C .. Executable Statements .. -C - CALL MD03BY( COND, N, R, LDR, IPVT, DIAG, QTB, DELTA, PAR, - $ RANKS(1), X, RX, TOL, DWORK, LDWORK, INFO ) - RETURN -C -C *** Last line of MD03BB *** - END diff --git a/mex/sources/libslicot/MD03BD.f b/mex/sources/libslicot/MD03BD.f deleted file mode 100644 index eccd179e7..000000000 --- a/mex/sources/libslicot/MD03BD.f +++ /dev/null @@ -1,1206 +0,0 @@ - SUBROUTINE MD03BD( XINIT, SCALE, COND, FCN, QRFACT, LMPARM, M, N, - $ ITMAX, FACTOR, NPRINT, IPAR, LIPAR, DPAR1, - $ LDPAR1, DPAR2, LDPAR2, X, DIAG, NFEV, NJEV, - $ FTOL, XTOL, GTOL, TOL, IWORK, DWORK, LDWORK, - $ IWARN, INFO ) -C -C SLICOT RELEASE 5.0. -C -C Copyright (c) 2002-2009 NICONET e.V. -C -C This program is free software: you can redistribute it and/or -C modify it under the terms of the GNU General Public License as -C published by the Free Software Foundation, either version 2 of -C the License, or (at your option) any later version. -C -C This program is distributed in the hope that it will be useful, -C but WITHOUT ANY WARRANTY; without even the implied warranty of -C MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the -C GNU General Public License for more details. -C -C You should have received a copy of the GNU General Public License -C along with this program. If not, see -C . -C -C PURPOSE -C -C To minimize the sum of the squares of m nonlinear functions, e, in -C n variables, x, by a modification of the Levenberg-Marquardt -C algorithm. The user must provide a subroutine FCN which calculates -C the functions and the Jacobian (possibly by finite differences). -C In addition, specialized subroutines QRFACT, for QR factorization -C with pivoting of the Jacobian, and LMPARM, for the computation of -C Levenberg-Marquardt parameter, exploiting the possible structure -C of the Jacobian matrix, should be provided. Template -C implementations of these routines are included in SLICOT Library. -C -C ARGUMENTS -C -C Mode Parameters -C -C XINIT CHARACTER*1 -C Specifies how the variables x are initialized, as follows: -C = 'R' : the array X is initialized to random values; the -C entries DWORK(1:4) are used to initialize the -C random number generator: the first three values -C are converted to integers between 0 and 4095, and -C the last one is converted to an odd integer -C between 1 and 4095; -C = 'G' : the given entries of X are used as initial values -C of variables. -C -C SCALE CHARACTER*1 -C Specifies how the variables will be scaled, as follows: -C = 'I' : use internal scaling; -C = 'S' : use specified scaling factors, given in DIAG. -C -C COND CHARACTER*1 -C Specifies whether the condition of the linear systems -C involved should be estimated, as follows: -C = 'E' : use incremental condition estimation to find the -C numerical rank; -C = 'N' : do not use condition estimation, but check the -C diagonal entries of matrices for zero values. -C -C Function Parameters -C -C FCN EXTERNAL -C Subroutine which evaluates the functions and the Jacobian. -C FCN must be declared in an external statement in the user -C calling program, and must have the following interface: -C -C SUBROUTINE FCN( IFLAG, M, N, IPAR, LIPAR, DPAR1, LDPAR1, -C $ DPAR2, LDPAR2, X, NFEVL, E, J, LDJ, DWORK, -C $ LDWORK, INFO ) -C -C where -C -C IFLAG (input/output) INTEGER -C On entry, this parameter must contain a value -C defining the computations to be performed: -C = 0 : Optionally, print the current iterate X, -C function values E, and Jacobian matrix J, -C or other results defined in terms of these -C values. See the argument NPRINT of MD03BD. -C Do not alter E and J. -C = 1 : Calculate the functions at X and return -C this vector in E. Do not alter J. -C = 2 : Calculate the Jacobian at X and return -C this matrix in J. Also return NFEVL -C (see below). Do not alter E. -C = 3 : Do not compute neither the functions nor -C the Jacobian, but return in LDJ and -C IPAR/DPAR1,DPAR2 (some of) the integer/real -C parameters needed. -C On exit, the value of this parameter should not be -C changed by FCN unless the user wants to terminate -C execution of MD03BD, in which case IFLAG must be -C set to a negative integer. -C -C M (input) INTEGER -C The number of functions. M >= 0. -C -C N (input) INTEGER -C The number of variables. M >= N >= 0. -C -C IPAR (input/output) INTEGER array, dimension (LIPAR) -C The integer parameters describing the structure of -C the Jacobian matrix or needed for problem solving. -C IPAR is an input parameter, except for IFLAG = 3 -C on entry, when it is also an output parameter. -C On exit, if IFLAG = 3, IPAR(1) contains the length -C of the array J, for storing the Jacobian matrix, -C and the entries IPAR(2:5) contain the workspace -C required by FCN for IFLAG = 1, FCN for IFLAG = 2, -C QRFACT, and LMPARM, respectively. -C -C LIPAR (input) INTEGER -C The length of the array IPAR. LIPAR >= 5. -C -C DPAR1 (input/output) DOUBLE PRECISION array, dimension -C (LDPAR1,*) or (LDPAR1) -C A first set of real parameters needed for -C describing or solving the problem. -C DPAR1 can also be used as an additional array for -C intermediate results when computing the functions -C or the Jacobian. For control problems, DPAR1 could -C store the input trajectory of a system. -C -C LDPAR1 (input) INTEGER -C The leading dimension or the length of the array -C DPAR1, as convenient. LDPAR1 >= 0. (LDPAR1 >= 1, -C if leading dimension.) -C -C DPAR2 (input/output) DOUBLE PRECISION array, dimension -C (LDPAR2,*) or (LDPAR2) -C A second set of real parameters needed for -C describing or solving the problem. -C DPAR2 can also be used as an additional array for -C intermediate results when computing the functions -C or the Jacobian. For control problems, DPAR2 could -C store the output trajectory of a system. -C -C LDPAR2 (input) INTEGER -C The leading dimension or the length of the array -C DPAR2, as convenient. LDPAR2 >= 0. (LDPAR2 >= 1, -C if leading dimension.) -C -C X (input) DOUBLE PRECISION array, dimension (N) -C This array must contain the value of the -C variables x where the functions or the Jacobian -C must be evaluated. -C -C NFEVL (input/output) INTEGER -C The number of function evaluations needed to -C compute the Jacobian by a finite difference -C approximation. -C NFEVL is an input parameter if IFLAG = 0, or an -C output parameter if IFLAG = 2. If the Jacobian is -C computed analytically, NFEVL should be set to a -C non-positive value. -C -C E (input/output) DOUBLE PRECISION array, -C dimension (M) -C This array contains the value of the (error) -C functions e evaluated at X. -C E is an input parameter if IFLAG = 0 or 2, or an -C output parameter if IFLAG = 1. -C -C J (input/output) DOUBLE PRECISION array, dimension -C (LDJ,NC), where NC is the number of columns -C needed. -C This array contains a possibly compressed -C representation of the Jacobian matrix evaluated -C at X. If full Jacobian is stored, then NC = N. -C J is an input parameter if IFLAG = 0, or an output -C parameter if IFLAG = 2. -C -C LDJ (input/output) INTEGER -C The leading dimension of array J. LDJ >= 1. -C LDJ is essentially used inside the routines FCN, -C QRFACT and LMPARM. -C LDJ is an input parameter, except for IFLAG = 3 -C on entry, when it is an output parameter. -C It is assumed in MD03BD that LDJ is not larger -C than needed. -C -C DWORK DOUBLE PRECISION array, dimension (LDWORK) -C The workspace array for subroutine FCN. -C On exit, if INFO = 0, DWORK(1) returns the optimal -C value of LDWORK. -C -C LDWORK (input) INTEGER -C The size of the array DWORK (as large as needed -C in the subroutine FCN). LDWORK >= 1. -C -C INFO INTEGER -C Error indicator, set to a negative value if an -C input (scalar) argument is erroneous, and to -C positive values for other possible errors in the -C subroutine FCN. The LAPACK Library routine XERBLA -C should be used in conjunction with negative INFO. -C INFO must be zero if the subroutine finished -C successfully. -C -C Parameters marked with "(input)" must not be changed. -C -C QRFACT EXTERNAL -C Subroutine which computes the QR factorization with -C (block) column pivoting of the Jacobian matrix, J*P = Q*R. -C QRFACT must be declared in an external statement in the -C calling program, and must have the following interface: -C -C SUBROUTINE QRFACT( N, IPAR, LIPAR, FNORM, J, LDJ, E, -C $ JNORMS, GNORM, IPVT, DWORK, LDWORK, -C $ INFO ) -C -C where -C -C N (input) INTEGER -C The number of columns of the Jacobian matrix J. -C N >= 0. -C -C IPAR (input) INTEGER array, dimension (LIPAR) -C The integer parameters describing the structure of -C the Jacobian matrix. -C -C LIPAR (input) INTEGER -C The length of the array IPAR. LIPAR >= 0. -C -C FNORM (input) DOUBLE PRECISION -C The Euclidean norm of the vector e. FNORM >= 0. -C -C J (input/output) DOUBLE PRECISION array, dimension -C (LDJ, NC), where NC is the number of columns. -C On entry, the leading NR-by-NC part of this array -C must contain the (compressed) representation -C of the Jacobian matrix J, where NR is the number -C of rows of J (function of IPAR entries). -C On exit, the leading N-by-NC part of this array -C contains a (compressed) representation of the -C upper triangular factor R of the Jacobian matrix. -C For efficiency of the later calculations, the -C matrix R is delivered with the leading dimension -C MAX(1,N), possibly much smaller than the value -C of LDJ on entry. -C -C LDJ (input/output) INTEGER -C The leading dimension of array J. -C On entry, LDJ >= MAX(1,NR). -C On exit, LDJ >= MAX(1,N). -C -C E (input/output) DOUBLE PRECISION array, dimension -C (NR) -C On entry, this array contains the error vector e. -C On exit, this array contains the updated vector -C Z*Q'*e, where Z is a block row permutation matrix -C (possibly identity) used in the QR factorization -C of J. (See, for example, the SLICOT Library -C routine NF01BS, Section METHOD.) -C -C JNORMS (output) DOUBLE PRECISION array, dimension (N) -C This array contains the Euclidean norms of the -C columns of the Jacobian matrix (in the original -C order). -C -C GNORM (output) DOUBLE PRECISION -C If FNORM > 0, the 1-norm of the scaled vector -C J'*e/FNORM, with each element i further divided -C by JNORMS(i) (if JNORMS(i) is nonzero). -C If FNORM = 0, the returned value of GNORM is 0. -C -C IPVT (output) INTEGER array, dimension (N) -C This array defines the permutation matrix P such -C that J*P = Q*R. Column j of P is column IPVT(j) of -C the identity matrix. -C -C DWORK DOUBLE PRECISION array, dimension (LDWORK) -C The workspace array for subroutine QRFACT. -C On exit, if INFO = 0, DWORK(1) returns the optimal -C value of LDWORK. -C -C LDWORK (input) INTEGER -C The size of the array DWORK (as large as needed -C in the subroutine QRFACT). LDWORK >= 1. -C -C INFO INTEGER -C Error indicator, set to a negative value if an -C input (scalar) argument is erroneous, and to -C positive values for other possible errors in the -C subroutine QRFACT. The LAPACK Library routine -C XERBLA should be used in conjunction with negative -C INFO. INFO must be zero if the subroutine finished -C successfully. -C -C Parameters marked with "(input)" must not be changed. -C -C LMPARM EXTERNAL -C Subroutine which determines a value for the Levenberg- -C Marquardt parameter PAR such that if x solves the system -C -C J*x = b , sqrt(PAR)*D*x = 0 , -C -C in the least squares sense, where J is an m-by-n matrix, -C D is an n-by-n nonsingular diagonal matrix, and b is an -C m-vector, and if DELTA is a positive number, DXNORM is -C the Euclidean norm of D*x, then either PAR is zero and -C -C ( DXNORM - DELTA ) .LE. 0.1*DELTA , -C -C or PAR is positive and -C -C ABS( DXNORM - DELTA ) .LE. 0.1*DELTA . -C -C It is assumed that a block QR factorization, with column -C pivoting, of J is available, that is, J*P = Q*R, where P -C is a permutation matrix, Q has orthogonal columns, and -C R is an upper triangular matrix (possibly stored in a -C compressed form), with diagonal elements of nonincreasing -C magnitude for each block. On output, LMPARM also provides -C a (compressed) representation of an upper triangular -C matrix S, such that -C -C P'*(J'*J + PAR*D*D)*P = S'*S . -C -C LMPARM must be declared in an external statement in the -C calling program, and must have the following interface: -C -C SUBROUTINE LMPARM( COND, N, IPAR, LIPAR, R, LDR, IPVT, -C $ DIAG, QTB, DELTA, PAR, RANKS, X, RX, -C $ TOL, DWORK, LDWORK, INFO ) -C -C where -C -C COND CHARACTER*1 -C Specifies whether the condition of the linear -C systems involved should be estimated, as follows: -C = 'E' : use incremental condition estimation -C to find the numerical rank; -C = 'N' : do not use condition estimation, but -C check the diagonal entries for zero -C values; -C = 'U' : use the ranks already stored in RANKS -C (for R). -C -C N (input) INTEGER -C The order of the matrix R. N >= 0. -C -C IPAR (input) INTEGER array, dimension (LIPAR) -C The integer parameters describing the structure of -C the Jacobian matrix. -C -C LIPAR (input) INTEGER -C The length of the array IPAR. LIPAR >= 0. -C -C R (input/output) DOUBLE PRECISION array, dimension -C (LDR, NC), where NC is the number of columns. -C On entry, the leading N-by-NC part of this array -C must contain the (compressed) representation (Rc) -C of the upper triangular matrix R. -C On exit, the full upper triangular part of R -C (in representation Rc), is unaltered, and the -C remaining part contains (part of) the (compressed) -C representation of the transpose of the upper -C triangular matrix S. -C -C LDR (input) INTEGER -C The leading dimension of array R. -C LDR >= MAX(1,N). -C -C IPVT (input) INTEGER array, dimension (N) -C This array must define the permutation matrix P -C such that J*P = Q*R. Column j of P is column -C IPVT(j) of the identity matrix. -C -C DIAG (input) DOUBLE PRECISION array, dimension (N) -C This array must contain the diagonal elements of -C the matrix D. DIAG(I) <> 0, I = 1,...,N. -C -C QTB (input) DOUBLE PRECISION array, dimension (N) -C This array must contain the first n elements of -C the vector Q'*b. -C -C DELTA (input) DOUBLE PRECISION -C An upper bound on the Euclidean norm of D*x. -C DELTA > 0. -C -C PAR (input/output) DOUBLE PRECISION -C On entry, PAR must contain an initial estimate of -C the Levenberg-Marquardt parameter. PAR >= 0. -C On exit, it contains the final estimate of this -C parameter. -C -C RANKS (input or output) INTEGER array, dimension (r), -C where r is the number of diagonal blocks R_k in R, -C corresponding to the block column structure of J. -C On entry, if COND = 'U' and N > 0, this array must -C contain the numerical ranks of the submatrices -C R_k, k = 1:r. The number r is defined in terms of -C the entries of IPAR. -C On exit, if N > 0, this array contains the -C numerical ranks of the submatrices S_k, k = 1:r. -C -C X (output) DOUBLE PRECISION array, dimension (N) -C This array contains the least squares solution of -C the system J*x = b, sqrt(PAR)*D*x = 0. -C -C RX (output) DOUBLE PRECISION array, dimension (N) -C This array contains the matrix-vector product -C -R*P'*x. -C -C TOL (input) DOUBLE PRECISION -C If COND = 'E', the tolerance to be used for -C finding the ranks of the submatrices R_k and S_k. -C If the user sets TOL > 0, then the given value of -C TOL is used as a lower bound for the reciprocal -C condition number; a (sub)matrix whose estimated -C condition number is less than 1/TOL is considered -C to be of full rank. If the user sets TOL <= 0, -C then an implicitly computed, default tolerance, -C defined by TOLDEF = N*EPS, is used instead, -C where EPS is the machine precision (see LAPACK -C Library routine DLAMCH). -C This parameter is not relevant if COND = 'U' -C or 'N'. -C -C DWORK DOUBLE PRECISION array, dimension (LDWORK) -C The workspace array for subroutine LMPARM. -C On exit, if INFO = 0, DWORK(1) returns the optimal -C value of LDWORK. -C -C LDWORK (input) INTEGER -C The size of the array DWORK (as large as needed -C in the subroutine LMPARM). LDWORK >= 1. -C -C INFO INTEGER -C Error indicator, set to a negative value if an -C input (scalar) argument is erroneous, and to -C positive values for other possible errors in the -C subroutine LMPARM. The LAPACK Library routine -C XERBLA should be used in conjunction with negative -C INFO. INFO must be zero if the subroutine finished -C successfully. -C -C Parameters marked with "(input)" must not be changed. -C -C Input/Output Parameters -C -C M (input) INTEGER -C The number of functions. M >= 0. -C -C N (input) INTEGER -C The number of variables. M >= N >= 0. -C -C ITMAX (input) INTEGER -C The maximum number of iterations. ITMAX >= 0. -C -C FACTOR (input) DOUBLE PRECISION -C The value used in determining the initial step bound. This -C bound is set to the product of FACTOR and the Euclidean -C norm of DIAG*X if nonzero, or else to FACTOR itself. -C In most cases FACTOR should lie in the interval (.1,100). -C A generally recommended value is 100. FACTOR > 0. -C -C NPRINT (input) INTEGER -C This parameter enables controlled printing of iterates if -C it is positive. In this case, FCN is called with IFLAG = 0 -C at the beginning of the first iteration and every NPRINT -C iterations thereafter and immediately prior to return, -C with X, E, and J available for printing. Note that when -C called immediately prior to return, J normally contains -C the result returned by QRFACT and LMPARM (the compressed -C R and S factors). If NPRINT is not positive, no special -C calls of FCN with IFLAG = 0 are made. -C -C IPAR (input) INTEGER array, dimension (LIPAR) -C The integer parameters needed, for instance, for -C describing the structure of the Jacobian matrix, which -C are handed over to the routines FCN, QRFACT and LMPARM. -C The first five entries of this array are modified -C internally by a call to FCN (with IFLAG = 3), but are -C restored on exit. -C -C LIPAR (input) INTEGER -C The length of the array IPAR. LIPAR >= 5. -C -C DPAR1 (input/output) DOUBLE PRECISION array, dimension -C (LDPAR1,*) or (LDPAR1) -C A first set of real parameters needed for describing or -C solving the problem. This argument is not used by MD03BD -C routine, but it is passed to the routine FCN. -C -C LDPAR1 (input) INTEGER -C The leading dimension or the length of the array DPAR1, as -C convenient. LDPAR1 >= 0. (LDPAR1 >= 1, if leading -C dimension.) -C -C DPAR2 (input/output) DOUBLE PRECISION array, dimension -C (LDPAR2,*) or (LDPAR2) -C A second set of real parameters needed for describing or -C solving the problem. This argument is not used by MD03BD -C routine, but it is passed to the routine FCN. -C -C LDPAR2 (input) INTEGER -C The leading dimension or the length of the array DPAR2, as -C convenient. LDPAR2 >= 0. (LDPAR2 >= 1, if leading -C dimension.) -C -C X (input/output) DOUBLE PRECISION array, dimension (N) -C On entry, if XINIT = 'G', this array must contain the -C vector of initial variables x to be optimized. -C If XINIT = 'R', this array need not be set before entry, -C and random values will be used to initialize x. -C On exit, if INFO = 0, this array contains the vector of -C values that (approximately) minimize the sum of squares of -C error functions. The values returned in IWARN and -C DWORK(1:4) give details on the iterative process. -C -C DIAG (input/output) DOUBLE PRECISION array, dimension (N) -C On entry, if SCALE = 'S', this array must contain some -C positive entries that serve as multiplicative scale -C factors for the variables x. DIAG(I) > 0, I = 1,...,N. -C If SCALE = 'I', DIAG is internally set. -C On exit, this array contains the scale factors used -C (or finally used, if SCALE = 'I'). -C -C NFEV (output) INTEGER -C The number of calls to FCN with IFLAG = 1. If FCN is -C properly implemented, this includes the function -C evaluations needed for finite difference approximation -C of the Jacobian. -C -C NJEV (output) INTEGER -C The number of calls to FCN with IFLAG = 2. -C -C Tolerances -C -C FTOL DOUBLE PRECISION -C If FTOL >= 0, the tolerance which measures the relative -C error desired in the sum of squares. Termination occurs -C when both the actual and predicted relative reductions in -C the sum of squares are at most FTOL. If the user sets -C FTOL < 0, then SQRT(EPS) is used instead FTOL, where -C EPS is the machine precision (see LAPACK Library routine -C DLAMCH). -C -C XTOL DOUBLE PRECISION -C If XTOL >= 0, the tolerance which measures the relative -C error desired in the approximate solution. Termination -C occurs when the relative error between two consecutive -C iterates is at most XTOL. If the user sets XTOL < 0, -C then SQRT(EPS) is used instead XTOL. -C -C GTOL DOUBLE PRECISION -C If GTOL >= 0, the tolerance which measures the -C orthogonality desired between the function vector e and -C the columns of the Jacobian J. Termination occurs when -C the cosine of the angle between e and any column of the -C Jacobian J is at most GTOL in absolute value. If the user -C sets GTOL < 0, then EPS is used instead GTOL. -C -C TOL DOUBLE PRECISION -C If COND = 'E', the tolerance to be used for finding the -C ranks of the matrices of linear systems to be solved. If -C the user sets TOL > 0, then the given value of TOL is used -C as a lower bound for the reciprocal condition number; a -C (sub)matrix whose estimated condition number is less than -C 1/TOL is considered to be of full rank. If the user sets -C TOL <= 0, then an implicitly computed, default tolerance, -C defined by TOLDEF = N*EPS, is used instead. -C This parameter is not relevant if COND = 'N'. -C -C Workspace -C -C IWORK INTEGER array, dimension (N+r), where r is the number -C of diagonal blocks R_k in R (see description of LMPARM). -C On output, if INFO = 0, the first N entries of this array -C define a permutation matrix P such that J*P = Q*R, where -C J is the final calculated Jacobian, Q is an orthogonal -C matrix (not stored), and R is upper triangular with -C diagonal elements of nonincreasing magnitude (possibly -C for each block column of J). Column j of P is column -C IWORK(j) of the identity matrix. If INFO = 0, the entries -C N+1:N+r of this array contain the ranks of the final -C submatrices S_k (see description of LMPARM). -C -C DWORK DOUBLE PRECISION array, dimension (LDWORK) -C On exit, if INFO = 0, DWORK(1) returns the optimal value -C of LDWORK, DWORK(2) returns the residual error norm (the -C sum of squares), DWORK(3) returns the number of iterations -C performed, and DWORK(4) returns the final Levenberg -C factor. If INFO = 0, N > 0, and IWARN >= 0, the elements -C DWORK(5) to DWORK(4+M) contain the final matrix-vector -C product Z*Q'*e, and the elements DWORK(5+M) to -C DWORK(4+M+N*NC) contain the (compressed) representation of -C final upper triangular matrices R and S (if IWARN <> 4). -C -C LDWORK INTEGER -C The length of the array DWORK. -C LDWORK >= max( 4, M + max( size(J) + -C max( DW( FCN|IFLAG = 1 ), -C DW( FCN|IFLAG = 2 ), -C DW( QRFACT ) + N ), -C N*NC + N + -C max( M + DW( FCN|IFLAG = 1 ), -C N + DW( LMPARM ) ) ) ), -C where size(J) is the size of the Jacobian (provided by FCN -C in IPAR(1), for IFLAG = 3), and DW( f ) is the workspace -C needed by the routine f, where f is FCN, QRFACT, or LMPARM -C (provided by FCN in IPAR(2:5), for IFLAG = 3). -C -C Warning Indicator -C -C IWARN INTEGER -C < 0: the user set IFLAG = IWARN in the subroutine FCN; -C = 1: both actual and predicted relative reductions in -C the sum of squares are at most FTOL; -C = 2: relative error between two consecutive iterates is -C at most XTOL; -C = 3: conditions for IWARN = 1 and IWARN = 2 both hold; -C = 4: the cosine of the angle between e and any column of -C the Jacobian is at most GTOL in absolute value; -C = 5: the number of iterations has reached ITMAX without -C satisfying any convergence condition; -C = 6: FTOL is too small: no further reduction in the sum -C of squares is possible; -C = 7: XTOL is too small: no further improvement in the -C approximate solution x is possible; -C = 8: GTOL is too small: e is orthogonal to the columns of -C the Jacobian to machine precision. -C In all these cases, DWORK(1:4) are set as described above. -C -C Error Indicator -C -C INFO INTEGER -C = 0: successful exit; -C < 0: if INFO = -i, the i-th argument had an illegal -C value; -C = 1: user-defined routine FCN returned with INFO <> 0 -C for IFLAG = 1; -C = 2: user-defined routine FCN returned with INFO <> 0 -C for IFLAG = 2; -C = 3: user-defined routine QRFACT returned with INFO <> 0; -C = 4: user-defined routine LMPARM returned with INFO <> 0. -C -C METHOD -C -C If XINIT = 'R', the initial value for x is set to a vector of -C pseudo-random values uniformly distributed in (-1,1). -C -C The Levenberg-Marquardt algorithm (described in [1,3]) is used for -C optimizing the variables x. This algorithm needs the Jacobian -C matrix J, which is provided by the subroutine FCN. A trust region -C method is used. The algorithm tries to update x by the formula -C -C x = x - p, -C -C using an approximate solution of the system of linear equations -C -C (J'*J + PAR*D*D)*p = J'*e, -C -C with e the error function vector, and D a diagonal nonsingular -C matrix, where either PAR = 0 and -C -C ( norm( D*x ) - DELTA ) <= 0.1*DELTA , -C -C or PAR > 0 and -C -C ABS( norm( D*x ) - DELTA ) <= 0.1*DELTA . -C -C DELTA is the radius of the trust region. If the Gauss-Newton -C direction is not acceptable, then an iterative algorithm obtains -C improved lower and upper bounds for the Levenberg-Marquardt -C parameter PAR. Only a few iterations are generally needed for -C convergence of the algorithm. The trust region radius DELTA -C and the Levenberg factor PAR are updated based on the ratio -C between the actual and predicted reduction in the sum of squares. -C -C REFERENCES -C -C [1] More, J.J., Garbow, B.S, and Hillstrom, K.E. -C User's Guide for MINPACK-1. -C Applied Math. Division, Argonne National Laboratory, Argonne, -C Illinois, Report ANL-80-74, 1980. -C -C [2] Golub, G.H. and van Loan, C.F. -C Matrix Computations. Third Edition. -C M. D. Johns Hopkins University Press, Baltimore, pp. 520-528, -C 1996. -C -C [3] More, J.J. -C The Levenberg-Marquardt algorithm: implementation and theory. -C In Watson, G.A. (Ed.), Numerical Analysis, Lecture Notes in -C Mathematics, vol. 630, Springer-Verlag, Berlin, Heidelberg -C and New York, pp. 105-116, 1978. -C -C NUMERICAL ASPECTS -C -C The Levenberg-Marquardt algorithm described in [3] is scaling -C invariant and globally convergent to (maybe local) minima. -C The convergence rate near a local minimum is quadratic, if the -C Jacobian is computed analytically, and linear, if the Jacobian -C is computed numerically. -C -C FURTHER COMMENTS -C -C This routine is a more general version of the subroutines LMDER -C and LMDER1 from the MINPACK package [1], which enables to exploit -C the structure of the problem, and optionally use condition -C estimation. Unstructured problems could be solved as well. -C -C Template SLICOT Library implementations for FCN, QRFACT and -C LMPARM routines are: -C MD03BF, MD03BA, and MD03BB, respectively, for standard problems; -C NF01BF, NF01BS, and NF01BP, respectively, for optimizing the -C parameters of Wiener systems (structured problems). -C -C CONTRIBUTORS -C -C V. Sima, Research Institute for Informatics, Bucharest, Dec. 2001. -C -C REVISIONS -C -C V. Sima, Feb. 15, 2004. -C -C KEYWORDS -C -C Least-squares approximation, Levenberg-Marquardt algorithm, -C matrix operations, optimization. -C -C ****************************************************************** -C -C .. Parameters .. - DOUBLE PRECISION ZERO, ONE, FOUR, P1, P5, P25, P75, P0001 - PARAMETER ( ZERO = 0.0D0, ONE = 1.0D0, FOUR = 4.0D0, - $ P1 = 1.0D-1, P5 = 5.0D-1, P25 = 2.5D-1, - $ P75 = 7.5D-1, P0001 = 1.0D-4 ) -C .. Scalar Arguments .. - CHARACTER COND, SCALE, XINIT - INTEGER INFO, ITMAX, IWARN, LDPAR1, LDPAR2, LDWORK, - $ LIPAR, M, N, NFEV, NJEV, NPRINT - DOUBLE PRECISION FACTOR, FTOL, GTOL, TOL, XTOL -C .. Array Arguments .. - INTEGER IPAR(*), IWORK(*) - DOUBLE PRECISION DIAG(*), DPAR1(*), DPAR2(*), DWORK(*), X(*) -C .. Local Scalars .. - LOGICAL BADSCL, INIT, ISCAL, SSCAL - INTEGER E, IFLAG, INFOL, ITER, IW1, IW2, IW3, J, JAC, - $ JW1, JW2, JWORK, L, LDJ, LDJSAV, LFCN1, LFCN2, - $ LLMP, LQRF, NC, NFEVL, SIZEJ, WRKOPT - DOUBLE PRECISION ACTRED, DELTA, DIRDER, EPSMCH, FNORM, FNORM1, - $ FTDEF, GNORM, GTDEF, PAR, PNORM, PRERED, RATIO, - $ TEMP, TEMP1, TEMP2, TOLDEF, XNORM, XTDEF -C .. Local Arrays .. - INTEGER SEED(4) -C .. External Functions .. - DOUBLE PRECISION DLAMCH, DNRM2 - LOGICAL LSAME - EXTERNAL DLAMCH, DNRM2, LSAME -C .. External Subroutines .. - EXTERNAL DCOPY, DLARNV, FCN, LMPARM, QRFACT, XERBLA -C .. Intrinsic Functions .. - INTRINSIC ABS, DBLE, INT, MAX, MIN, MOD, SQRT -C .. -C .. Executable Statements .. -C -C Check the scalar input parameters. -C - INIT = LSAME( XINIT, 'R' ) - ISCAL = LSAME( SCALE, 'I' ) - SSCAL = LSAME( SCALE, 'S' ) - INFO = 0 - IWARN = 0 - IF( .NOT.( INIT .OR. LSAME( XINIT, 'G' ) ) ) THEN - INFO = -1 - ELSEIF( .NOT.( ISCAL .OR. SSCAL ) ) THEN - INFO = -2 - ELSEIF( .NOT.( LSAME( COND, 'E' ) .OR. LSAME( COND, 'N' ) ) ) THEN - INFO = -3 - ELSEIF( M.LT.0 ) THEN - INFO = -7 - ELSEIF( N.LT.0 .OR. N.GT.M ) THEN - INFO = -8 - ELSEIF( ITMAX.LT.0 ) THEN - INFO = -9 - ELSEIF( FACTOR.LE.ZERO ) THEN - INFO = -10 - ELSEIF( LIPAR.LT.5 ) THEN - INFO = -13 - ELSEIF( LDPAR1.LT.0 ) THEN - INFO = -15 - ELSEIF( LDPAR2.LT.0 ) THEN - INFO = -17 - ELSEIF ( LDWORK.LT.4 ) THEN - INFO = -28 - ELSEIF ( SSCAL ) THEN - BADSCL = .FALSE. -C - DO 10 J = 1, N - BADSCL = BADSCL .OR. DIAG(J).LE.ZERO - 10 CONTINUE -C - IF ( BADSCL ) - $ INFO = -19 - END IF -C -C Return if there are illegal arguments. -C - IF( INFO.NE.0 ) THEN - CALL XERBLA( 'MD03BD', -INFO ) - RETURN - ENDIF -C -C Quick return if possible. -C - NFEV = 0 - NJEV = 0 - IF ( N.EQ.0 ) THEN - DWORK(1) = FOUR - DWORK(2) = ZERO - DWORK(3) = ZERO - DWORK(4) = ZERO - RETURN - END IF -C -C Call FCN to get the size of the array J, for storing the Jacobian -C matrix, the leading dimension LDJ and the workspace required -C by FCN for IFLAG = 1 and IFLAG = 2, QRFACT and LMPARM. The -C entries DWORK(1:4) should not be modified by the special call of -C FCN below, if XINIT = 'R' and the values in DWORK(1:4) are -C explicitly desired for initialization of the random number -C generator. -C - IFLAG = 3 - IW1 = IPAR(1) - IW2 = IPAR(2) - IW3 = IPAR(3) - JW1 = IPAR(4) - JW2 = IPAR(5) -C - CALL FCN( IFLAG, M, N, IPAR, LIPAR, DPAR1, LDPAR1, DPAR2, LDPAR2, - $ X, NFEVL, DWORK, DWORK, LDJSAV, DWORK, LDWORK, INFOL ) - SIZEJ = IPAR(1) - LFCN1 = IPAR(2) - LFCN2 = IPAR(3) - LQRF = IPAR(4) - LLMP = IPAR(5) - IF ( LDJSAV.GT.0 ) THEN - NC = SIZEJ/LDJSAV - ELSE - NC = SIZEJ - END IF -C - IPAR(1) = IW1 - IPAR(2) = IW2 - IPAR(3) = IW3 - IPAR(4) = JW1 - IPAR(5) = JW2 -C -C Check the workspace length. -C - E = 1 - JAC = E + M - JW1 = JAC + SIZEJ - JW2 = JW1 + N - IW1 = JAC + N*NC - IW2 = IW1 + N - IW3 = IW2 + N - JWORK = IW2 + M -C - L = MAX( 4, M + MAX( SIZEJ + MAX( LFCN1, LFCN2, N + LQRF ), - $ N*NC + N + MAX( M + LFCN1, N + LLMP ) ) ) - IF ( LDWORK.LT.L ) THEN - INFO = -28 - CALL XERBLA( 'MD03BD', -INFO ) - RETURN - ENDIF -C -C Set default tolerances. EPSMCH is the machine precision. -C - EPSMCH = DLAMCH( 'Epsilon' ) - FTDEF = FTOL - XTDEF = XTOL - GTDEF = GTOL - TOLDEF = TOL - IF ( MIN( FTDEF, XTDEF, GTDEF, TOLDEF ).LE.ZERO ) THEN - IF ( FTDEF.LT.ZERO ) - $ FTDEF = SQRT( EPSMCH ) - IF ( XTDEF.LT.ZERO ) - $ XTDEF = SQRT( EPSMCH ) - IF ( GTDEF.LT.ZERO ) - $ GTDEF = EPSMCH - IF ( TOLDEF.LE.ZERO ) - $ TOLDEF = DBLE( N )*EPSMCH - ENDIF - WRKOPT = 1 -C -C Initialization. -C - IF ( INIT ) THEN -C -C SEED is the initial state of the random number generator. -C SEED(4) must be odd. -C - SEED(1) = MOD( INT( DWORK(1) ), 4096 ) - SEED(2) = MOD( INT( DWORK(2) ), 4096 ) - SEED(3) = MOD( INT( DWORK(3) ), 4096 ) - SEED(4) = MOD( 2*INT( DWORK(4) ) + 1, 4096 ) - CALL DLARNV( 2, SEED, N, X ) - ENDIF -C -C Initialize Levenberg-Marquardt parameter and iteration counter. -C - PAR = ZERO - ITER = 1 -C -C Evaluate the function at the starting point -C and calculate its norm. -C Workspace: need: M + SIZEJ + LFCN1; -C prefer: larger. -C - IFLAG = 1 - CALL FCN( IFLAG, M, N, IPAR, LIPAR, DPAR1, LDPAR1, DPAR2, LDPAR2, - $ X, NFEVL, DWORK(E), DWORK(JAC), LDJ, DWORK(JW1), - $ LDWORK-JW1+1, INFOL ) -C - IF ( INFOL.NE.0 ) THEN - INFO = 1 - RETURN - END IF - WRKOPT = MAX( WRKOPT, INT( DWORK(JW1) ) + JW1 - 1 ) - NFEV = 1 - FNORM = DNRM2( M, DWORK(E), 1 ) - IF ( IFLAG.LT.0 .OR. FNORM.EQ.ZERO ) - $ GO TO 90 -C -C Beginning of the outer loop. -C - 20 CONTINUE -C -C Calculate the Jacobian matrix. -C Workspace: need: M + SIZEJ + LFCN2; -C prefer: larger. -C - LDJ = LDJSAV - IFLAG = 2 - CALL FCN( IFLAG, M, N, IPAR, LIPAR, DPAR1, LDPAR1, DPAR2, - $ LDPAR2, X, NFEVL, DWORK(E), DWORK(JAC), LDJ, - $ DWORK(JW1), LDWORK-JW1+1, INFOL ) -C - IF ( INFOL.NE.0 ) THEN - INFO = 2 - RETURN - END IF - IF ( ITER.EQ.1 ) - $ WRKOPT = MAX( WRKOPT, INT( DWORK(JW1) ) + JW1 - 1 ) - IF ( NFEVL.GT.0 ) - $ NFEV = NFEV + NFEVL - NJEV = NJEV + 1 - IF ( IFLAG.LT.0 ) - $ GO TO 90 -C -C If requested, call FCN to enable printing of iterates. -C - IF ( NPRINT.GT.0 ) THEN - IFLAG = 0 - IF ( MOD( ITER-1, NPRINT ).EQ.0 ) THEN - CALL FCN( IFLAG, M, N, IPAR, LIPAR, DPAR1, LDPAR1, DPAR2, - $ LDPAR2, X, NFEV, DWORK(E), DWORK(JAC), LDJ, - $ DWORK(JW1), LDWORK-JW1+1, INFOL ) -C - IF ( IFLAG.LT.0 ) - $ GO TO 90 - END IF - END IF -C -C Compute the QR factorization of the Jacobian. -C Workspace: need: M + SIZEJ + N + LQRF; -C prefer: larger. -C - CALL QRFACT( N, IPAR, LIPAR, FNORM, DWORK(JAC), LDJ, DWORK(E), - $ DWORK(JW1), GNORM, IWORK, DWORK(JW2), - $ LDWORK-JW2+1, INFOL ) - IF ( INFOL.NE.0 ) THEN - INFO = 3 - RETURN - END IF -C -C On the first iteration and if SCALE = 'I', scale according -C to the norms of the columns of the initial Jacobian. -C - IF ( ITER.EQ.1 ) THEN - WRKOPT = MAX( WRKOPT, INT( DWORK(JW2) ) + JW2 - 1 ) - IF ( ISCAL ) THEN -C - DO 30 J = 1, N - DIAG(J) = DWORK(JW1+J-1) - IF ( DIAG(J).EQ.ZERO ) - $ DIAG(J) = ONE - 30 CONTINUE -C - END IF -C -C On the first iteration, calculate the norm of the scaled -C x and initialize the step bound DELTA. -C - DO 40 J = 1, N - DWORK(IW1+J-1) = DIAG(J)*X(J) - 40 CONTINUE -C - XNORM = DNRM2( N, DWORK(IW1), 1 ) - DELTA = FACTOR*XNORM - IF ( DELTA.EQ.ZERO ) - $ DELTA = FACTOR - ELSE -C -C Rescale if necessary. -C - IF ( ISCAL ) THEN -C - DO 50 J = 1, N - DIAG(J) = MAX( DIAG(J), DWORK(JW1+J-1) ) - 50 CONTINUE -C - END IF - END IF -C -C Test for convergence of the gradient norm. -C - IF ( GNORM.LE.GTDEF ) - $ IWARN = 4 - IF ( IWARN.NE.0 ) - $ GO TO 90 -C -C Beginning of the inner loop. -C - 60 CONTINUE -C -C Determine the Levenberg-Marquardt parameter and the -C direction p, and compute -R*P'*p. -C Workspace: need: M + N*NC + 2*N + LLMP; -C prefer: larger. -C - CALL LMPARM( COND, N, IPAR, LIPAR, DWORK(JAC), LDJ, - $ IWORK, DIAG, DWORK(E), DELTA, PAR, IWORK(N+1), - $ DWORK(IW1), DWORK(IW2), TOLDEF, DWORK(IW3), - $ LDWORK-IW3+1, INFOL ) - IF ( INFOL.NE.0 ) THEN - INFO = 4 - RETURN - END IF - IF ( ITER.EQ.1 ) - $ WRKOPT = MAX( WRKOPT, INT( DWORK(IW3) ) + IW3 - 1 ) -C - TEMP1 = DNRM2( N, DWORK(IW2), 1 )/FNORM -C -C Store the direction p and x - p. -C - DO 70 J = 0, N - 1 - DWORK(IW2+J) = DIAG(J+1)*DWORK(IW1+J) - DWORK(IW1+J) = X(J+1) - DWORK(IW1+J) - 70 CONTINUE -C -C Compute the norm of scaled p and the scaled predicted -C reduction and the scaled directional derivative. -C - PNORM = DNRM2( N, DWORK(IW2), 1 ) - TEMP2 = ( SQRT( PAR )*PNORM )/FNORM - PRERED = TEMP1**2 + TEMP2**2/P5 - DIRDER = -( TEMP1**2 + TEMP2**2 ) -C -C On the first iteration, adjust the initial step bound. -C - IF ( ITER.EQ.1 ) - $ DELTA = MIN( DELTA, PNORM ) -C -C Evaluate the function at x - p and calculate its norm. -C Workspace: need: 2*M + N*NC + N + LFCN1; -C prefer: larger. -C - IFLAG = 1 - CALL FCN( IFLAG, M, N, IPAR, LIPAR, DPAR1, LDPAR1, DPAR2, - $ LDPAR2, DWORK(IW1), NFEVL, DWORK(IW2), DWORK(JAC), - $ LDJ, DWORK(JWORK), LDWORK-JWORK+1, INFOL ) - IF ( INFOL.NE.0 ) THEN - INFO = 1 - RETURN - END IF -C - NFEV = NFEV + 1 - IF ( IFLAG.LT.0 ) - $ GO TO 90 - FNORM1 = DNRM2( M, DWORK(IW2), 1 ) -C -C Compute the scaled actual reduction. -C - ACTRED = -ONE - IF ( P1*FNORM1.LT.FNORM ) - $ ACTRED = ONE - ( FNORM1/FNORM )**2 -C -C Compute the ratio of the actual to the predicted reduction. -C - RATIO = ZERO - IF ( PRERED.NE.ZERO ) - $ RATIO = ACTRED/PRERED -C -C Update the step bound. -C - IF ( RATIO.LE.P25 ) THEN - IF ( ACTRED.GE.ZERO ) THEN - TEMP = P5 - ELSE - TEMP = P5*DIRDER/( DIRDER + P5*ACTRED ) - END IF - IF ( P1*FNORM1.GE.FNORM .OR. TEMP.LT.P1 ) - $ TEMP = P1 - DELTA = TEMP*MIN( DELTA, PNORM/P1 ) - PAR = PAR/TEMP - ELSE - IF ( PAR.EQ.ZERO .OR. RATIO.GE.P75 ) THEN - DELTA = PNORM/P5 - PAR = P5*PAR - END IF - END IF -C -C Test for successful iteration. -C - IF ( RATIO.GE.P0001 ) THEN -C -C Successful iteration. Update x, e, and their norms. -C - DO 80 J = 1, N - X(J) = DWORK(IW1+J-1) - DWORK(IW1+J-1) = DIAG(J)*X(J) - 80 CONTINUE -C - CALL DCOPY( M, DWORK(IW2), 1, DWORK(E), 1 ) - XNORM = DNRM2( N, DWORK(IW1), 1 ) - FNORM = FNORM1 - ITER = ITER + 1 - END IF -C -C Tests for convergence. -C - IF ( ABS( ACTRED ).LE.FTDEF .AND. PRERED.LE.FTDEF .AND. - $ P5*RATIO.LE.ONE ) - $ IWARN = 1 - IF ( DELTA.LE.XTDEF*XNORM ) - $ IWARN = 2 - IF ( ABS( ACTRED ).LE.FTDEF .AND. PRERED.LE.FTDEF .AND. - $ P5*RATIO.LE.ONE .AND. IWARN.EQ.2 ) - $ IWARN = 3 - IF ( IWARN.NE.0 ) - $ GO TO 90 -C -C Tests for termination and stringent tolerances. -C - IF ( ITER.GE.ITMAX ) - $ IWARN = 5 - IF ( ABS( ACTRED ).LE.EPSMCH .AND. PRERED.LE.EPSMCH .AND. - $ P5*RATIO.LE.ONE ) - $ IWARN = 6 - IF ( DELTA.LE.EPSMCH*XNORM ) - $ IWARN = 7 - IF ( GNORM.LE.EPSMCH ) - $ IWARN = 8 - IF ( IWARN.NE.0 ) - $ GO TO 90 -C -C End of the inner loop. Repeat if unsuccessful iteration. -C - IF ( RATIO.LT.P0001 ) GO TO 60 -C -C End of the outer loop. -C - GO TO 20 -C - 90 CONTINUE -C -C Termination, either normal or user imposed. -C Note that DWORK(JAC) normally contains the results returned by -C QRFACT and LMPARM (the compressed R and S factors). -C - IF ( IFLAG.LT.0 ) - $ IWARN = IFLAG - IF ( NPRINT.GT.0 ) THEN - IFLAG = 0 - CALL FCN( IFLAG, M, N, IPAR, LIPAR, DPAR1, LDPAR1, DPAR2, - $ LDPAR2, X, NFEV, DWORK(E), DWORK(JAC), LDJ, - $ DWORK(JWORK), LDWORK-JWORK+1, INFOL ) - IF ( IFLAG.LT.0 ) - $ IWARN = IFLAG - END IF -C - IF ( IWARN.GE.0 ) THEN - DO 100 J = M + N*NC, 1, -1 - DWORK(4+J) = DWORK(J) - 100 CONTINUE - END IF - DWORK(1) = WRKOPT - DWORK(2) = FNORM - DWORK(3) = ITER - DWORK(4) = PAR -C - RETURN -C *** Last line of MD03BD *** - END diff --git a/mex/sources/libslicot/MD03BF.f b/mex/sources/libslicot/MD03BF.f deleted file mode 100644 index 232ac807d..000000000 --- a/mex/sources/libslicot/MD03BF.f +++ /dev/null @@ -1,122 +0,0 @@ - SUBROUTINE MD03BF( IFLAG, M, N, IPAR, LIPAR, DPAR1, LDPAR1, DPAR2, - $ LDPAR2, X, NFEVL, E, J, LDJ, DWORK, LDWORK, - $ INFO ) -C -C SLICOT RELEASE 5.0. -C -C Copyright (c) 2002-2009 NICONET e.V. -C -C This program is free software: you can redistribute it and/or -C modify it under the terms of the GNU General Public License as -C published by the Free Software Foundation, either version 2 of -C the License, or (at your option) any later version. -C -C This program is distributed in the hope that it will be useful, -C but WITHOUT ANY WARRANTY; without even the implied warranty of -C MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the -C GNU General Public License for more details. -C -C You should have received a copy of the GNU General Public License -C along with this program. If not, see -C . -C -C This is the FCN routine for solving a standard nonlinear least -C squares problem using SLICOT Library routine MD03BD. See the -C parameter FCN in the routine MD03BD for the description of -C parameters. -C -C The example programmed in this routine is adapted from that -C accompanying the MINPACK routine LMDER. -C -C ****************************************************************** -C -C .. Parameters .. -C .. NOUT is the unit number for printing intermediate results .. - INTEGER NOUT - PARAMETER ( NOUT = 6 ) - DOUBLE PRECISION ONE - PARAMETER ( ONE = 1.0D0 ) -C .. Scalar Arguments .. - INTEGER IFLAG, INFO, LDJ, LDPAR1, LDPAR2, LDWORK, LIPAR, - $ M, N, NFEVL -C .. Array Arguments .. - INTEGER IPAR(*) - DOUBLE PRECISION DPAR1(*), DPAR2(*), DWORK(*), E(*), J(LDJ,*), - $ X(*) -C .. Local Scalars .. - INTEGER I - DOUBLE PRECISION ERR, TMP1, TMP2, TMP3, TMP4 -C .. External Functions .. - DOUBLE PRECISION DNRM2 - EXTERNAL DNRM2 -C .. DATA Statements .. - DOUBLE PRECISION Y(15) - DATA Y(1), Y(2), Y(3), Y(4), Y(5), Y(6), Y(7), Y(8), - $ Y(9), Y(10), Y(11), Y(12), Y(13), Y(14), Y(15) - $ / 1.4D-1, 1.8D-1, 2.2D-1, 2.5D-1, 2.9D-1, - $ 3.2D-1, 3.5D-1, 3.9D-1, 3.7D-1, 5.8D-1, - $ 7.3D-1, 9.6D-1, 1.34D0, 2.1D0, 4.39D0 / -C -C .. Executable Statements .. -C - INFO = 0 - IF ( IFLAG.EQ.1 ) THEN -C -C Compute the error function values. -C - DO 10 I = 1, 15 - TMP1 = I - TMP2 = 16 - I - IF ( I.GT.8 ) THEN - TMP3 = TMP2 - ELSE - TMP3 = TMP1 - END IF - E(I) = Y(I) - ( X(1) + TMP1/( X(2)*TMP2 + X(3)*TMP3 ) ) - 10 CONTINUE -C - ELSE IF ( IFLAG.EQ.2 ) THEN -C -C Compute the Jacobian. -C - DO 30 I = 1, 15 - TMP1 = I - TMP2 = 16 - I - IF ( I.GT.8 ) THEN - TMP3 = TMP2 - ELSE - TMP3 = TMP1 - END IF - TMP4 = ( X(2)*TMP2 + X(3)*TMP3 )**2 - J(I,1) = -ONE - J(I,2) = TMP1*TMP2/TMP4 - J(I,3) = TMP1*TMP3/TMP4 - 30 CONTINUE -C - NFEVL = 0 -C - ELSE IF ( IFLAG.EQ.3 ) THEN -C -C Set the parameter LDJ, the length of the array J, and the sizes -C of the workspace for FCN (IFLAG = 1 or 2), MD03BA and MD03BB. -C - LDJ = M - IPAR(1) = M*N - IPAR(2) = 0 - IPAR(3) = 0 - IPAR(4) = 4*N + 1 - IPAR(5) = 4*N -C - ELSE IF ( IFLAG.EQ.0 ) THEN -C -C Special call for printing intermediate results. -C - ERR = DNRM2( M, E, 1 ) - WRITE( 1, '('' Norm of current error = '', D15.6)') ERR -C - END IF -C - RETURN -C -C *** Last line of MD03BF *** - END diff --git a/mex/sources/libslicot/MD03BX.f b/mex/sources/libslicot/MD03BX.f deleted file mode 100644 index 7ffef61d0..000000000 --- a/mex/sources/libslicot/MD03BX.f +++ /dev/null @@ -1,255 +0,0 @@ - SUBROUTINE MD03BX( M, N, FNORM, J, LDJ, E, JNORMS, GNORM, IPVT, - $ DWORK, LDWORK, INFO ) -C -C SLICOT RELEASE 5.0. -C -C Copyright (c) 2002-2009 NICONET e.V. -C -C This program is free software: you can redistribute it and/or -C modify it under the terms of the GNU General Public License as -C published by the Free Software Foundation, either version 2 of -C the License, or (at your option) any later version. -C -C This program is distributed in the hope that it will be useful, -C but WITHOUT ANY WARRANTY; without even the implied warranty of -C MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the -C GNU General Public License for more details. -C -C You should have received a copy of the GNU General Public License -C along with this program. If not, see -C . -C -C PURPOSE -C -C To compute the QR factorization with column pivoting of an -C m-by-n matrix J (m >= n), that is, J*P = Q*R, where Q is a matrix -C with orthogonal columns, P a permutation matrix, and R an upper -C trapezoidal matrix with diagonal elements of nonincreasing -C magnitude, and to apply the transformation Q' on the error -C vector e (in-situ). The 1-norm of the scaled gradient is also -C returned. The matrix J could be the Jacobian of a nonlinear least -C squares problem. -C -C ARGUMENTS -C -C Input/Output Parameters -C -C M (input) INTEGER -C The number of rows of the Jacobian matrix J. M >= 0. -C -C N (input) INTEGER -C The number of columns of the Jacobian matrix J. -C M >= N >= 0. -C -C FNORM (input) DOUBLE PRECISION -C The Euclidean norm of the vector e. FNORM >= 0. -C -C J (input/output) DOUBLE PRECISION array, dimension (LDJ, N) -C On entry, the leading M-by-N part of this array must -C contain the Jacobian matrix J. -C On exit, the leading N-by-N upper triangular part of this -C array contains the upper triangular factor R of the -C Jacobian matrix. Note that for efficiency of the later -C calculations, the matrix R is delivered with the leading -C dimension MAX(1,N), possibly much smaller than the value -C of LDJ on entry. -C -C LDJ (input/output) INTEGER -C The leading dimension of array J. -C On entry, LDJ >= MAX(1,M). -C On exit, LDJ >= MAX(1,N). -C -C E (input/output) DOUBLE PRECISION array, dimension (M) -C On entry, this array must contain the error vector e. -C On exit, this array contains the updated vector Q'*e. -C -C JNORMS (output) DOUBLE PRECISION array, dimension (N) -C This array contains the Euclidean norms of the columns of -C the Jacobian matrix, considered in the initial order. -C -C GNORM (output) DOUBLE PRECISION -C If FNORM > 0, the 1-norm of the scaled vector -C J'*Q'*e/FNORM, with each element i further divided by -C JNORMS(i) (if JNORMS(i) is nonzero). -C If FNORM = 0, the returned value of GNORM is 0. -C -C IPVT (output) INTEGER array, dimension (N) -C This array defines the permutation matrix P such that -C J*P = Q*R. Column j of P is column IPVT(j) of the identity -C matrix. -C -C Workspace -C -C DWORK DOUBLE PRECISION array, dimension (LDWORK) -C On exit, if INFO = 0, DWORK(1) returns the optimal value -C of LDWORK. -C -C LDWORK INTEGER -C The length of the array DWORK. -C LDWORK >= 1, if N = 0 or M = 1; -C LDWORK >= 4*N+1, if N > 1. -C For optimum performance LDWORK should be larger. -C -C Error Indicator -C -C INFO INTEGER -C = 0: successful exit; -C < 0: if INFO = -i, the i-th argument had an illegal -C value. -C -C METHOD -C -C The algorithm uses QR factorization with column pivoting of the -C matrix J, J*P = Q*R, and applies the orthogonal matrix Q' to the -C vector e. -C -C CONTRIBUTORS -C -C V. Sima, Research Institute for Informatics, Bucharest, Dec. 2001. -C -C REVISIONS -C -C - -C -C KEYWORDS -C -C Elementary matrix operations, Jacobian matrix, matrix algebra, -C matrix operations. -C -C ****************************************************************** -C -C .. Parameters .. - DOUBLE PRECISION ZERO, ONE - PARAMETER ( ZERO = 0.0D0, ONE = 1.0D0 ) -C .. Scalar Arguments .. - INTEGER INFO, LDJ, LDWORK, M, N - DOUBLE PRECISION FNORM, GNORM -C .. Array Arguments .. - INTEGER IPVT(*) - DOUBLE PRECISION DWORK(*), E(*), J(*), JNORMS(*) -C .. Local Scalars .. - INTEGER I, ITAU, JWORK, L, WRKOPT - DOUBLE PRECISION SUM -C .. External Functions .. - DOUBLE PRECISION DDOT, DNRM2 - EXTERNAL DDOT, DNRM2 -C .. External Subroutines .. - EXTERNAL DGEQP3, DLACPY, DORMQR, XERBLA -C .. Intrinsic Functions .. - INTRINSIC ABS, INT, MAX -C .. -C .. Executable Statements .. -C - INFO = 0 - IF ( M.LT.0 ) THEN - INFO = -1 - ELSEIF ( N.LT.0.OR. M.LT.N ) THEN - INFO = -2 - ELSEIF ( FNORM.LT.ZERO ) THEN - INFO = -3 - ELSEIF ( LDJ.LT.MAX( 1, M ) ) THEN - INFO = -5 - ELSE - IF ( N.EQ.0 .OR. M.EQ.1 ) THEN - JWORK = 1 - ELSE - JWORK = 4*N + 1 - END IF - IF ( LDWORK.LT.JWORK ) - $ INFO = -11 - END IF -C - IF ( INFO.NE.0 ) THEN -C -C Error return. -C - CALL XERBLA( 'MD03BX', -INFO ) - RETURN - END IF -C -C Quick return if possible. -C - GNORM = ZERO - IF ( N.EQ.0 ) THEN - LDJ = 1 - DWORK(1) = ONE - RETURN - ELSEIF ( M.EQ.1 ) THEN - JNORMS(1) = ABS( J(1) ) - IF ( FNORM*J(1).NE.ZERO ) - $ GNORM = ABS( E(1)/FNORM ) - LDJ = 1 - IPVT(1) = 1 - DWORK(1) = ONE - RETURN - END IF -C -C Initialize the column pivoting indices. -C - DO 10 I = 1, N - IPVT(I) = 0 - 10 CONTINUE -C -C (Note: Comments in the code beginning "Workspace:" describe the -C minimal amount of real workspace needed at that point in the -C code, as well as the preferred amount for good performance. -C NB refers to the optimal block size for the immediately -C following subroutine, as returned by ILAENV.) -C - ITAU = 1 - JWORK = ITAU + N - WRKOPT = 1 -C -C Compute the QR factorization with pivoting of J, and apply Q' to -C the vector e. -C -C Workspace: need: 4*N + 1; -C prefer: 3*N + ( N+1 )*NB. -C - CALL DGEQP3( M, N, J, LDJ, IPVT, DWORK(ITAU), DWORK(JWORK), - $ LDWORK-JWORK+1, INFO ) - WRKOPT = MAX( WRKOPT, INT( DWORK(JWORK) ) + JWORK - 1 ) -C -C Workspace: need: N + 1; -C prefer: N + NB. -C - CALL DORMQR( 'Left', 'Transpose', M, 1, N, J, LDJ, DWORK(ITAU), E, - $ M, DWORK(JWORK), LDWORK-JWORK+1, INFO ) - WRKOPT = MAX( WRKOPT, INT( DWORK(JWORK) ) + JWORK - 1 ) -C - IF ( LDJ.GT.N ) THEN -C -C Reshape the array J to have the leading dimension N. -C This destroys the details of the orthogonal matrix Q. -C - CALL DLACPY( 'Upper', N, N, J, LDJ, J, N ) - LDJ = N - END IF -C -C Compute the norm of the scaled gradient and original column norms. -C - IF ( FNORM.NE.ZERO ) THEN -C - DO 20 I = 1, N - L = IPVT(I) - JNORMS(L) = DNRM2( I, J((I-1)*LDJ+1), 1 ) - IF ( JNORMS(L).NE.ZERO ) THEN - SUM = DDOT( I, J((I-1)*LDJ+1), 1, E, 1 )/FNORM - GNORM = MAX( GNORM, ABS( SUM/JNORMS(L) ) ) - END IF - 20 CONTINUE -C - ELSE -C - DO 30 I = 1, N - L = IPVT(I) - JNORMS(L) = DNRM2( I, J((I-1)*LDJ+1), 1 ) - 30 CONTINUE -C - END IF -C - DWORK(1) = WRKOPT - RETURN -C -C *** Last line of MD03BX *** - END diff --git a/mex/sources/libslicot/MD03BY.f b/mex/sources/libslicot/MD03BY.f deleted file mode 100644 index ec4637ce4..000000000 --- a/mex/sources/libslicot/MD03BY.f +++ /dev/null @@ -1,514 +0,0 @@ - SUBROUTINE MD03BY( COND, N, R, LDR, IPVT, DIAG, QTB, DELTA, PAR, - $ RANK, X, RX, TOL, DWORK, LDWORK, INFO ) -C -C SLICOT RELEASE 5.0. -C -C Copyright (c) 2002-2009 NICONET e.V. -C -C This program is free software: you can redistribute it and/or -C modify it under the terms of the GNU General Public License as -C published by the Free Software Foundation, either version 2 of -C the License, or (at your option) any later version. -C -C This program is distributed in the hope that it will be useful, -C but WITHOUT ANY WARRANTY; without even the implied warranty of -C MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the -C GNU General Public License for more details. -C -C You should have received a copy of the GNU General Public License -C along with this program. If not, see -C . -C -C PURPOSE -C -C To determine a value for the parameter PAR such that if x solves -C the system -C -C A*x = b , sqrt(PAR)*D*x = 0 , -C -C in the least squares sense, where A is an m-by-n matrix, D is an -C n-by-n nonsingular diagonal matrix, and b is an m-vector, and if -C DELTA is a positive number, DXNORM is the Euclidean norm of D*x, -C then either PAR is zero and -C -C ( DXNORM - DELTA ) .LE. 0.1*DELTA , -C -C or PAR is positive and -C -C ABS( DXNORM - DELTA ) .LE. 0.1*DELTA . -C -C It is assumed that a QR factorization, with column pivoting, of A -C is available, that is, A*P = Q*R, where P is a permutation matrix, -C Q has orthogonal columns, and R is an upper triangular matrix -C with diagonal elements of nonincreasing magnitude. -C The routine needs the full upper triangle of R, the permutation -C matrix P, and the first n components of Q'*b (' denotes the -C transpose). On output, MD03BY also provides an upper triangular -C matrix S such that -C -C P'*(A'*A + PAR*D*D)*P = S'*S . -C -C Matrix S is used in the solution process. -C -C ARGUMENTS -C -C Mode Parameters -C -C COND CHARACTER*1 -C Specifies whether the condition of the matrices R and S -C should be estimated, as follows: -C = 'E' : use incremental condition estimation for R and S; -C = 'N' : do not use condition estimation, but check the -C diagonal entries of R and S for zero values; -C = 'U' : use the rank already stored in RANK (for R). -C -C Input/Output Parameters -C -C N (input) INTEGER -C The order of the matrix R. N >= 0. -C -C R (input/output) DOUBLE PRECISION array, dimension (LDR, N) -C On entry, the leading N-by-N upper triangular part of this -C array must contain the upper triangular matrix R. -C On exit, the full upper triangle is unaltered, and the -C strict lower triangle contains the strict upper triangle -C (transposed) of the upper triangular matrix S. -C -C LDR INTEGER -C The leading dimension of array R. LDR >= MAX(1,N). -C -C IPVT (input) INTEGER array, dimension (N) -C This array must define the permutation matrix P such that -C A*P = Q*R. Column j of P is column IPVT(j) of the identity -C matrix. -C -C DIAG (input) DOUBLE PRECISION array, dimension (N) -C This array must contain the diagonal elements of the -C matrix D. DIAG(I) <> 0, I = 1,...,N. -C -C QTB (input) DOUBLE PRECISION array, dimension (N) -C This array must contain the first n elements of the -C vector Q'*b. -C -C DELTA (input) DOUBLE PRECISION -C An upper bound on the Euclidean norm of D*x. DELTA > 0. -C -C PAR (input/output) DOUBLE PRECISION -C On entry, PAR must contain an initial estimate of the -C Levenberg-Marquardt parameter. PAR >= 0. -C On exit, it contains the final estimate of this parameter. -C -C RANK (input or output) INTEGER -C On entry, if COND = 'U', this parameter must contain the -C (numerical) rank of the matrix R. -C On exit, this parameter contains the numerical rank of -C the matrix S. -C -C X (output) DOUBLE PRECISION array, dimension (N) -C This array contains the least squares solution of the -C system A*x = b, sqrt(PAR)*D*x = 0. -C -C RX (output) DOUBLE PRECISION array, dimension (N) -C This array contains the matrix-vector product -R*P'*x. -C -C Tolerances -C -C TOL DOUBLE PRECISION -C If COND = 'E', the tolerance to be used for finding the -C rank of the matrices R and S. If the user sets TOL > 0, -C then the given value of TOL is used as a lower bound for -C the reciprocal condition number; a (sub)matrix whose -C estimated condition number is less than 1/TOL is -C considered to be of full rank. If the user sets TOL <= 0, -C then an implicitly computed, default tolerance, defined by -C TOLDEF = N*EPS, is used instead, where EPS is the machine -C precision (see LAPACK Library routine DLAMCH). -C This parameter is not relevant if COND = 'U' or 'N'. -C -C Workspace -C -C DWORK DOUBLE PRECISION array, dimension (LDWORK) -C On exit, the first N elements of this array contain the -C diagonal elements of the upper triangular matrix S. -C -C LDWORK INTEGER -C The length of the array DWORK. -C LDWORK >= 4*N, if COND = 'E'; -C LDWORK >= 2*N, if COND <> 'E'. -C -C Error Indicator -C -C INFO INTEGER -C = 0: successful exit; -C < 0: if INFO = -i, the i-th argument had an illegal -C value. -C -C METHOD -C -C The algorithm computes the Gauss-Newton direction. A least squares -C solution is found if the Jacobian is rank deficient. If the Gauss- -C Newton direction is not acceptable, then an iterative algorithm -C obtains improved lower and upper bounds for the parameter PAR. -C Only a few iterations are generally needed for convergence of the -C algorithm. If, however, the limit of ITMAX = 10 iterations is -C reached, then the output PAR will contain the best value obtained -C so far. If the Gauss-Newton step is acceptable, it is stored in x, -C and PAR is set to zero, hence S = R. -C -C REFERENCES -C -C [1] More, J.J., Garbow, B.S, and Hillstrom, K.E. -C User's Guide for MINPACK-1. -C Applied Math. Division, Argonne National Laboratory, Argonne, -C Illinois, Report ANL-80-74, 1980. -C -C NUMERICAL ASPECTS -C 2 -C The algorithm requires 0(N ) operations and is backward stable. -C -C FURTHER COMMENTS -C -C This routine is a LAPACK-based modification of LMPAR from the -C MINPACK package [1], and with optional condition estimation. -C The option COND = 'U' is useful when dealing with several -C right-hand side vectors, but RANK should be reset. -C If COND = 'E', but the matrix S is guaranteed to be nonsingular -C and well conditioned relative to TOL, i.e., rank(R) = N, and -C min(DIAG) > 0, then its condition is not estimated. -C -C CONTRIBUTORS -C -C V. Sima, Research Institute for Informatics, Bucharest, Dec. 2001. -C -C REVISIONS -C -C V. Sima, Research Institute for Informatics, Bucharest, Mar. 2005. -C -C KEYWORDS -C -C Linear system of equations, matrix operations, plane rotations. -C -C ****************************************************************** -C -C .. Parameters .. - INTEGER ITMAX - PARAMETER ( ITMAX = 10 ) - DOUBLE PRECISION P1, P001, ZERO, SVLMAX - PARAMETER ( P1 = 1.0D-1, P001 = 1.0D-3, ZERO = 0.0D0, - $ SVLMAX = 0.0D0 ) -C .. Scalar Arguments .. - CHARACTER COND - INTEGER INFO, LDR, LDWORK, N, RANK - DOUBLE PRECISION DELTA, PAR, TOL -C .. Array Arguments .. - INTEGER IPVT(*) - DOUBLE PRECISION DIAG(*), DWORK(*), QTB(*), R(LDR,*), RX(*), X(*) -C .. Local Scalars .. - INTEGER ITER, J, L, N2 - DOUBLE PRECISION DMINO, DWARF, DXNORM, FP, GNORM, PARC, PARL, - $ PARU, TEMP, TOLDEF - LOGICAL ECOND, NCOND, SING, UCOND - CHARACTER CONDL -C .. Local Arrays .. - DOUBLE PRECISION DUM(3) -C .. External Functions .. - DOUBLE PRECISION DDOT, DLAMCH, DNRM2 - LOGICAL LSAME - EXTERNAL DDOT, DLAMCH, DNRM2, LSAME -C .. External Subroutines .. - EXTERNAL DAXPY, DCOPY, DSWAP, DTRMV, DTRSV, MB02YD, - $ MB03OD, XERBLA -C .. Intrinsic Functions .. - INTRINSIC ABS, DBLE, MAX, MIN, SQRT -C .. -C .. Executable Statements .. -C -C Check the scalar input parameters. -C - ECOND = LSAME( COND, 'E' ) - NCOND = LSAME( COND, 'N' ) - UCOND = LSAME( COND, 'U' ) - INFO = 0 - IF( .NOT.( ECOND .OR. NCOND .OR. UCOND ) ) THEN - INFO = -1 - ELSEIF( N.LT.0 ) THEN - INFO = -2 - ELSEIF ( LDR.LT.MAX( 1, N ) ) THEN - INFO = -4 - ELSEIF ( DELTA.LE.ZERO ) THEN - INFO = -8 - ELSEIF( PAR.LT.ZERO ) THEN - INFO = -9 - ELSEIF ( UCOND .AND. ( RANK.LT.0 .OR. RANK.GT.N ) ) THEN - INFO = -10 - ELSEIF ( LDWORK.LT.2*N .OR. ( ECOND .AND. LDWORK.LT.4*N ) ) THEN - INFO = -15 - ELSEIF ( N.GT.0 ) THEN - DMINO = DIAG(1) - SING = .FALSE. -C - DO 10 J = 1, N - IF ( DIAG(J).LT.DMINO ) - $ DMINO = DIAG(J) - SING = SING .OR. DIAG(J).EQ.ZERO - 10 CONTINUE -C - IF ( SING ) - $ INFO = -6 - END IF -C -C Return if there are illegal arguments. -C - IF( INFO.NE.0 ) THEN - CALL XERBLA( 'MD03BY', -INFO ) - RETURN - END IF -C -C Quick return if possible. -C - IF ( N.EQ.0 ) THEN - PAR = ZERO - RANK = 0 - RETURN - END IF -C -C DWARF is the smallest positive magnitude. -C - DWARF = DLAMCH( 'Underflow' ) - N2 = N -C -C Estimate the rank of R, if required. -C - IF ( ECOND ) THEN - N2 = 2*N - TEMP = TOL - IF ( TEMP.LE.ZERO ) THEN -C -C Use the default tolerance in rank determination. -C - TEMP = DBLE( N )*DLAMCH( 'Epsilon' ) - END IF -C -C Estimate the reciprocal condition number of R and set the rank. -C Workspace: 2*N. -C - CALL MB03OD( 'No QR', N, N, R, LDR, IPVT, TEMP, SVLMAX, DWORK, - $ RANK, DUM, DWORK, LDWORK, INFO ) -C - ELSEIF ( NCOND ) THEN - J = 1 -C - 20 CONTINUE - IF ( R(J,J).NE.ZERO ) THEN - J = J + 1 - IF ( J.LE.N ) - $ GO TO 20 - END IF -C - RANK = J - 1 - END IF -C -C Compute and store in x the Gauss-Newton direction. If the -C Jacobian is rank-deficient, obtain a least squares solution. -C The array RX is used as workspace. -C - CALL DCOPY( RANK, QTB, 1, RX, 1 ) - DUM(1) = ZERO - IF ( RANK.LT.N ) - $ CALL DCOPY( N-RANK, DUM, 0, RX(RANK+1), 1 ) - CALL DTRSV( 'Upper', 'No transpose', 'Non unit', RANK, R, LDR, - $ RX, 1 ) -C - DO 30 J = 1, N - L = IPVT(J) - X(L) = RX(J) - 30 CONTINUE -C -C Initialize the iteration counter. -C Evaluate the function at the origin, and test -C for acceptance of the Gauss-Newton direction. -C - ITER = 0 -C - DO 40 J = 1, N - DWORK(J) = DIAG(J)*X(J) - 40 CONTINUE -C - DXNORM = DNRM2( N, DWORK, 1 ) - FP = DXNORM - DELTA - IF ( FP.GT.P1*DELTA ) THEN -C -C Set an appropriate option for estimating the condition of -C the matrix S. -C - IF ( UCOND ) THEN - IF ( LDWORK.GE.4*N ) THEN - CONDL = 'E' - TOLDEF = DBLE( N )*DLAMCH( 'Epsilon' ) - ELSE - CONDL = 'N' - TOLDEF = TOL - END IF - ELSE - CONDL = COND - TOLDEF = TOL - END IF -C -C If the Jacobian is not rank deficient, the Newton -C step provides a lower bound, PARL, for the zero of -C the function. Otherwise set this bound to zero. -C - IF ( RANK.EQ.N ) THEN -C - DO 50 J = 1, N - L = IPVT(J) - RX(J) = DIAG(L)*( DWORK(L)/DXNORM ) - 50 CONTINUE -C - CALL DTRSV( 'Upper', 'Transpose', 'Non unit', N, R, LDR, - $ RX, 1 ) - TEMP = DNRM2( N, RX, 1 ) - PARL = ( ( FP/DELTA )/TEMP )/TEMP -C -C For efficiency, use CONDL = 'U', if possible. -C - IF ( .NOT.LSAME( CONDL, 'U' ) .AND. DMINO.GT.ZERO ) - $ CONDL = 'U' - ELSE - PARL = ZERO - END IF -C -C Calculate an upper bound, PARU, for the zero of the function. -C - DO 60 J = 1, N - L = IPVT(J) - RX(J) = DDOT( J, R(1,J), 1, QTB, 1 )/DIAG(L) - 60 CONTINUE -C - GNORM = DNRM2( N, RX, 1 ) - PARU = GNORM/DELTA - IF ( PARU.EQ.ZERO ) - $ PARU = DWARF/MIN( DELTA, P1 )/P001 -C -C If the input PAR lies outside of the interval (PARL,PARU), -C set PAR to the closer endpoint. -C - PAR = MAX( PAR, PARL ) - PAR = MIN( PAR, PARU ) - IF ( PAR.EQ.ZERO ) - $ PAR = GNORM/DXNORM -C -C Beginning of an iteration. -C - 70 CONTINUE - ITER = ITER + 1 -C -C Evaluate the function at the current value of PAR. -C - IF ( PAR.EQ.ZERO ) - $ PAR = MAX( DWARF, P001*PARU ) - TEMP = SQRT( PAR ) -C - DO 80 J = 1, N - RX(J) = TEMP*DIAG(J) - 80 CONTINUE -C -C Solve the system A*x = b , sqrt(PAR)*D*x = 0 , in a least -C square sense. The first N elements of DWORK contain the -C diagonal elements of the upper triangular matrix S, and -C the next N elements contain the vector z, so that x = P*z. -C The vector z is preserved if COND = 'E'. -C Workspace: 4*N, if CONDL = 'E'; -C 2*N, if CONDL <> 'E'. -C - CALL MB02YD( CONDL, N, R, LDR, IPVT, RX, QTB, RANK, X, - $ TOLDEF, DWORK, LDWORK, INFO ) -C - DO 90 J = 1, N - DWORK(N2+J) = DIAG(J)*X(J) - 90 CONTINUE -C - DXNORM = DNRM2( N, DWORK(N2+1), 1 ) - TEMP = FP - FP = DXNORM - DELTA -C -C If the function is small enough, accept the current value -C of PAR. Also test for the exceptional cases where PARL -C is zero or the number of iterations has reached ITMAX. -C - IF ( ABS( FP ).GT.P1*DELTA .AND. - $ ( PARL.NE.ZERO .OR. FP.GT.TEMP .OR. TEMP.GE.ZERO ) .AND. - $ ITER.LT.ITMAX ) THEN -C -C Compute the Newton correction. -C - DO 100 J = 1, RANK - L = IPVT(J) - RX(J) = DIAG(L)*( DWORK(N2+L)/DXNORM ) - 100 CONTINUE -C - IF ( RANK.LT.N ) - $ CALL DCOPY( N-RANK, DUM, 0, RX(RANK+1), 1 ) - CALL DSWAP( N, R, LDR+1, DWORK, 1 ) - CALL DTRSV( 'Lower', 'No transpose', 'Non Unit', RANK, - $ R, LDR, RX, 1 ) - CALL DSWAP( N, R, LDR+1, DWORK, 1 ) - TEMP = DNRM2( RANK, RX, 1 ) - PARC = ( ( FP/DELTA )/TEMP )/TEMP -C -C Depending on the sign of the function, update PARL -C or PARU. -C - IF ( FP.GT.ZERO ) THEN - PARL = MAX( PARL, PAR ) - ELSE IF ( FP.LT.ZERO ) THEN - PARU = MIN( PARU, PAR ) - END IF -C -C Compute an improved estimate for PAR. -C - PAR = MAX( PARL, PAR + PARC ) -C -C End of an iteration. -C - GO TO 70 - END IF - END IF -C -C Compute -R*P'*x = -R*z. -C - IF ( ECOND .AND. ITER.GT.0 ) THEN -C - DO 110 J = 1, N - RX(J) = -DWORK(N+J) - 110 CONTINUE -C - CALL DTRMV( 'Upper', 'NoTranspose', 'NonUnit', N, R, LDR, - $ RX, 1 ) - ELSE -C - DO 120 J = 1, N - RX(J) = ZERO - L = IPVT(J) - CALL DAXPY( J, -X(L), R(1,J), 1, RX, 1 ) - 120 CONTINUE -C - END IF -C -C Termination. If PAR = 0, set S. -C - IF ( ITER.EQ.0 ) THEN - PAR = ZERO -C - DO 130 J = 1, N - 1 - DWORK(J) = R(J,J) - CALL DCOPY( N-J, R(J,J+1), LDR, R(J+1,J), 1 ) - 130 CONTINUE -C - DWORK(N) = R(N,N) - END IF -C - RETURN -C -C *** Last line of MD03BY *** - END diff --git a/mex/sources/libslicot/NF01AD.f b/mex/sources/libslicot/NF01AD.f deleted file mode 100644 index 16af66a25..000000000 --- a/mex/sources/libslicot/NF01AD.f +++ /dev/null @@ -1,230 +0,0 @@ - SUBROUTINE NF01AD( NSMP, M, L, IPAR, LIPAR, X, LX, U, LDU, Y, LDY, - $ DWORK, LDWORK, INFO ) -C -C SLICOT RELEASE 5.0. -C -C Copyright (c) 2002-2009 NICONET e.V. -C -C This program is free software: you can redistribute it and/or -C modify it under the terms of the GNU General Public License as -C published by the Free Software Foundation, either version 2 of -C the License, or (at your option) any later version. -C -C This program is distributed in the hope that it will be useful, -C but WITHOUT ANY WARRANTY; without even the implied warranty of -C MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the -C GNU General Public License for more details. -C -C You should have received a copy of the GNU General Public License -C along with this program. If not, see -C . -C -C PURPOSE -C -C To calculate the output y of the Wiener system -C -C x(t+1) = A*x(t) + B*u(t) -C z(t) = C*x(t) + D*u(t), -C -C y(t) = f(z(t),wb(1:L)), -C -C where t = 1, 2, ..., NSMP, and f is a nonlinear function, -C evaluated by the SLICOT Library routine NF01AY. The parameter -C vector X is partitioned as X = ( wb(1), ..., wb(L), theta ), -C where wb(i), i = 1:L, correspond to the nonlinear part, theta -C corresponds to the linear part, and the notation is fully -C described below. -C -C ARGUMENTS -C -C Input/Output Parameters -C -C NSMP (input) INTEGER -C The number of training samples. NSMP >= 0. -C -C M (input) INTEGER -C The length of each input sample. M >= 0. -C -C L (input) INTEGER -C The length of each output sample. L >= 0. -C -C IPAR (input) INTEGER array, dimension (LIPAR) -C The integer parameters needed. -C IPAR(1) must contain the order of the linear part, -C referred to as N below. N >= 0. -C IPAR(2) must contain the number of neurons for the -C nonlinear part, referred to as NN below. -C NN >= 0. -C -C LIPAR (input) INTEGER -C The length of IPAR. LIPAR >= 2. -C -C X (input) DOUBLE PRECISION array, dimension (LX) -C The parameter vector, partitioned as -C X = (wb(1), ..., wb(L), theta), where the vectors -C wb(i), of length NN*(L+2)+1, are parameters for the -C static nonlinearity, which is simulated by the -C SLICOT Library routine NF01AY. See the documentation of -C NF01AY for further details. The vector theta, of length -C N*(M + L + 1) + L*M, represents the matrices A, B, C, -C D and x(1), and it can be retrieved from these matrices -C by SLICOT Library routine TB01VD and retranslated by -C TB01VY. -C -C LX (input) INTEGER -C The length of the array X. -C LX >= ( NN*(L+2)+1 )*L + N*(M + L + 1) + L*M. -C -C U (input) DOUBLE PRECISION array, dimension (LDU, M) -C The leading NSMP-by-M part of this array must contain the -C set of input samples, -C U = ( U(1,1),...,U(1,M); ...; U(NSMP,1),...,U(NSMP,M) ). -C -C LDU INTEGER -C The leading dimension of the array U. LDU >= MAX(1,NSMP). -C -C Y (output) DOUBLE PRECISION array, dimension (LDY, L) -C The leading NSMP-by-L part of this array contains the -C simulated output. -C -C LDY INTEGER -C The leading dimension of the array Y. LDY >= MAX(1,NSMP). -C -C Workspace -C -C DWORK DOUBLE PRECISION array, dimension (LDWORK) -C -C LDWORK INTEGER -C The length of the array DWORK. -C LDWORK >= NSMP*L + MAX( 2*NN, (N + L)*(N + M) + 2*N + -C MAX( N*(N + L), N + M + L ) ) -C if M > 0; -C LDWORK >= NSMP*L + MAX( 2*NN, (N + L)*N + 2*N + -C MAX( N*(N + L), L ) ), if M = 0. -C A larger value of LDWORK could improve the efficiency. -C -C Error Indicator -C -C INFO INTEGER -C = 0: successful exit; -C < 0: if INFO = -i, the i-th argument had an illegal -C value. -C METHOD -C -C BLAS routines are used for the matrix-vector multiplications and -C the routine NF01AY is called for the calculation of the nonlinear -C function. -C -C CONTRIBUTORS -C -C A. Riedel, R. Schneider, Chemnitz University of Technology, -C Mar. 2001, during a stay at University of Twente, NL. -C -C REVISIONS -C -C V. Sima, Research Institute for Informatics, Bucharest, Mar. 2001, -C Dec. 2001. -C -C KEYWORDS -C -C Nonlinear system, output normal form, simulation, state-space -C representation, Wiener system. -C -C ****************************************************************** -C -C .. Scalar Arguments .. - INTEGER INFO, L, LDU, LDWORK, LDY, LX, LIPAR, M, NSMP -C .. Array Arguments .. - INTEGER IPAR(*) - DOUBLE PRECISION DWORK(*), U(LDU,*), X(*), Y(LDY,*) -C .. Local Scalars .. - INTEGER AC, BD, IX, JW, LDAC, LTHS, N, NN, NTHS, Z -C .. External Subroutines .. - EXTERNAL NF01AY, TB01VY, TF01MX, XERBLA -C .. Intrinsic Functions .. - INTRINSIC MAX, MIN -C .. -C .. Executable Statements .. -C - INFO = 0 - IF ( NSMP.LT.0 ) THEN - INFO = -1 - ELSEIF ( M.LT.0 ) THEN - INFO = -2 - ELSEIF ( L.LT.0 ) THEN - INFO = -3 - ELSEIF ( LIPAR.LT.2 ) THEN - INFO = -5 - ELSE -C - N = IPAR(1) - NN = IPAR(2) - LDAC = N + L - NTHS = ( NN*( L + 2 ) + 1 )*L - LTHS = N*( M + L + 1 ) + L*M -C - IF ( N.LT.0 .OR. NN.LT.0 ) THEN - INFO = -4 - ELSEIF ( LX.LT.NTHS + LTHS ) THEN - INFO = -7 - ELSEIF ( LDU.LT.MAX( 1, NSMP ) ) THEN - INFO = -9 - ELSEIF ( LDY.LT.MAX( 1, NSMP ) ) THEN - INFO = -11 - ELSE - IF ( M.GT.0 ) THEN - JW = MAX( N*LDAC, N + M + L ) - ELSE - JW = MAX( N*LDAC, L ) - END IF - IF ( LDWORK.LT.NSMP*L + MAX( 2*NN, LDAC*( N + M ) + 2*N + - $ JW ) ) - $ INFO = -13 - ENDIF - ENDIF -C -C Return if there are illegal arguments. -C - IF( INFO.NE.0 ) THEN - CALL XERBLA( 'NF01AD', -INFO ) - RETURN - ENDIF -C -C Quick return if possible. -C - IF ( MIN( NSMP, L ).EQ.0 ) - $ RETURN -C -C Compute the output of the linear part. -C Workspace: need NSMP*L + (N + L)*(N + M) + N + N*(N + L + 1). -C (NSMP*L locations are reserved for the output of the linear part.) -C - Z = 1 - AC = Z + NSMP*L - BD = AC + LDAC*N - IX = BD + LDAC*M - JW = IX + N -C - CALL TB01VY( 'Apply', N, M, L, X(NTHS+1), LTHS, DWORK(AC), LDAC, - $ DWORK(BD), LDAC, DWORK(AC+N), LDAC, DWORK(BD+N), - $ LDAC, DWORK(IX), DWORK(JW), LDWORK-JW+1, INFO ) -C -C Workspace: need NSMP*L + (N + L)*(N + M) + 3*N + M + L, if M>0; -C NSMP*L + (N + L)*N + 2*N + L, if M=0; -C prefer larger. -C - CALL TF01MX( N, M, L, NSMP, DWORK(AC), LDAC, U, LDU, DWORK(IX), - $ DWORK(Z), NSMP, DWORK(JW), LDWORK-JW+1, INFO ) -C -C Simulate the static nonlinearity. -C Workspace: need NSMP*L + 2*NN; -C prefer larger. -C - JW = AC - CALL NF01AY( NSMP, L, L, IPAR(2), LIPAR-1, X, NTHS, DWORK(Z), - $ NSMP, Y, LDY, DWORK(JW), LDWORK-JW+1, INFO ) -C - RETURN -C -C *** Last line of NF01AD *** - END diff --git a/mex/sources/libslicot/NF01AY.f b/mex/sources/libslicot/NF01AY.f deleted file mode 100644 index cc9782a86..000000000 --- a/mex/sources/libslicot/NF01AY.f +++ /dev/null @@ -1,353 +0,0 @@ - SUBROUTINE NF01AY( NSMP, NZ, L, IPAR, LIPAR, WB, LWB, Z, LDZ, - $ Y, LDY, DWORK, LDWORK, INFO ) -C -C SLICOT RELEASE 5.0. -C -C Copyright (c) 2002-2009 NICONET e.V. -C -C This program is free software: you can redistribute it and/or -C modify it under the terms of the GNU General Public License as -C published by the Free Software Foundation, either version 2 of -C the License, or (at your option) any later version. -C -C This program is distributed in the hope that it will be useful, -C but WITHOUT ANY WARRANTY; without even the implied warranty of -C MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the -C GNU General Public License for more details. -C -C You should have received a copy of the GNU General Public License -C along with this program. If not, see -C . -C -C PURPOSE -C -C To calculate the output of a set of neural networks with the -C structure -C -C - tanh(w1'*z+b1) - -C / : \ -C z --- : --- sum(ws(i)*...)+ b(n+1) --- y, -C \ : / -C - tanh(wn'*z+bn) - -C -C given the input z and the parameter vectors wi, ws, and b, -C where z, w1, ..., wn are vectors of length NZ, ws is a vector -C of length n, b(1), ..., b(n+1) are scalars, and n is called the -C number of neurons in the hidden layer, or just number of neurons. -C Such a network is used for each L output variables. -C -C ARGUMENTS -C -C Input/Output Parameters -C -C NSMP (input) INTEGER -C The number of training samples. NSMP >= 0. -C -C NZ (input) INTEGER -C The length of each input sample. NZ >= 0. -C -C L (input) INTEGER -C The length of each output sample. L >= 0. -C -C IPAR (input) INTEGER array, dimension (LIPAR) -C The integer parameters needed. -C IPAR(1) must contain the number of neurons, n, per output -C variable, denoted NN in the sequel. NN >= 0. -C -C LIPAR (input) INTEGER -C The length of the vector IPAR. LIPAR >= 1. -C -C WB (input) DOUBLE PRECISION array, dimension (LWB) -C The leading (NN*(NZ+2)+1)*L part of this array must -C contain the weights and biases of the network. This vector -C is partitioned into L vectors of length NN*(NZ+2)+1, -C WB = [ wb(1), ..., wb(L) ]. Each wb(k), k = 1, ..., L, -C corresponds to one output variable, and has the structure -C wb(k) = [ w1(1), ..., w1(NZ), ..., wn(1), ..., wn(NZ), -C ws(1), ..., ws(n), b(1), ..., b(n+1) ], -C where wi(j) are the weights of the hidden layer, -C ws(i) are the weights of the linear output layer, and -C b(i) are the biases, as in the scheme above. -C -C LWB (input) INTEGER -C The length of the array WB. -C LWB >= ( NN*(NZ + 2) + 1 )*L. -C -C Z (input) DOUBLE PRECISION array, dimension (LDZ, NZ) -C The leading NSMP-by-NZ part of this array must contain the -C set of input samples, -C Z = ( Z(1,1),...,Z(1,NZ); ...; Z(NSMP,1),...,Z(NSMP,NZ) ). -C -C LDZ INTEGER -C The leading dimension of the array Z. LDZ >= MAX(1,NSMP). -C -C Y (output) DOUBLE PRECISION array, dimension (LDY, L) -C The leading NSMP-by-L part of this array contains the set -C of output samples, -C Y = ( Y(1,1),...,Y(1,L); ...; Y(NSMP,1),...,Y(NSMP,L) ). -C -C LDY INTEGER -C The leading dimension of the array Y. LDY >= MAX(1,NSMP). -C -C Workspace -C -C DWORK DOUBLE PRECISION array, dimension (LDWORK) -C -C LDWORK INTEGER -C The length of the array DWORK. LDWORK >= 2*NN. -C For better performance, LDWORK should be larger. -C -C Error Indicator -C -C INFO INTEGER -C = 0: successful exit; -C < 0: if INFO = -i, the i-th argument had an illegal -C value. -C -C METHOD -C -C BLAS routines are used to compute the matrix-vector products. -C -C CONTRIBUTORS -C -C A. Riedel, R. Schneider, Chemnitz University of Technology, -C Oct. 2000, during a stay at University of Twente, NL. -C V. Sima, Research Institute for Informatics, Bucharest, Mar. 2001. -C -C REVISIONS -C -C - -C -C KEYWORDS -C -C Input output description, neural network, nonlinear system, -C simulation, system response. -C -C ****************************************************************** -C -C .. Parameters .. - DOUBLE PRECISION ZERO, ONE, TWO - PARAMETER ( ZERO = 0.0D0, ONE = 1.0D0, TWO = 2.0D0 ) -C .. Scalar Arguments .. - INTEGER INFO, L, LDWORK, LDY, LDZ, LIPAR, LWB, NSMP, NZ -C .. Array Arguments .. - DOUBLE PRECISION DWORK(*), WB(*), Y(LDY,*), Z(LDZ,*) - INTEGER IPAR(*) -C .. Local Scalars .. - LOGICAL LAST - INTEGER I, IB, J, K, LDWB, LJ, LK, M, MF, NN, NV, WS - DOUBLE PRECISION BIGNUM, DF, SMLNUM, TMP -C .. External Functions .. - DOUBLE PRECISION DDOT, DLAMCH - EXTERNAL DDOT, DLAMCH -C .. External Subroutines .. - EXTERNAL DCOPY, DGEMM, DGEMV, DLABAD, XERBLA -C .. Intrinsic Functions .. - INTRINSIC ABS, EXP, LOG, MAX, MIN, MOD -C .. -C .. Executable Statements .. -C - INFO = 0 - NN = IPAR(1) - LDWB = NN*( NZ + 2 ) + 1 - IF ( NSMP.LT.0 ) THEN - INFO = -1 - ELSEIF ( NZ.LT.0 ) THEN - INFO = -2 - ELSEIF ( L.LT.0 ) THEN - INFO = -3 - ELSEIF ( NN.LT.0 ) THEN - INFO = -4 - ELSEIF ( LIPAR.LT.1 ) THEN - INFO = -5 - ELSEIF ( LWB.LT.LDWB*L ) THEN - INFO = -7 - ELSEIF ( LDZ.LT.MAX( 1, NSMP ) ) THEN - INFO = -9 - ELSEIF ( LDY.LT.MAX( 1, NSMP ) ) THEN - INFO = -11 - ELSEIF ( LDWORK.LT.2*NN ) THEN - INFO = -13 - ENDIF -C -C Return if there are illegal arguments. -C - IF( INFO.NE.0 ) THEN - CALL XERBLA( 'NF01AY', -INFO ) - RETURN - ENDIF -C -C Quick return if possible. -C - IF ( MIN( NSMP, L ).EQ.0 ) - $ RETURN -C -C Set parameters to avoid overflows and increase accuracy for -C extreme values. -C - SMLNUM = DLAMCH( 'Safe minimum' ) / DLAMCH( 'Precision' ) - BIGNUM = ONE / SMLNUM - CALL DLABAD( SMLNUM, BIGNUM ) - SMLNUM = LOG( SMLNUM ) - BIGNUM = LOG( BIGNUM ) -C - WS = NZ*NN + 1 - IB = WS + NN - 1 - LK = 0 - IF ( MIN( NZ, NN ).EQ.0 ) THEN - NV = 2 - ELSE - NV = ( LDWORK - NN )/NN - END IF -C - IF ( NV.GT.2 ) THEN - MF = ( NSMP/NV )*NV - LAST = MOD( NSMP, NV ).NE.0 -C -C Some BLAS 3 calculations can be used. -C - DO 70 K = 0, L - 1 - TMP = WB(IB+NN+1+LK) -C - DO 10 J = 1, NN - DWORK(J) = TWO*WB(IB+J+LK) - 10 CONTINUE -C - DO 40 I = 1, MF, NV -C -C Compute -2*[w1 w2 ... wn]'*Z', where -C Z = [z(i)';...; z(i+NV-1)']. -C - CALL DGEMM( 'Transpose', 'Transpose', NN, NV, NZ, -TWO, - $ WB(1+LK), NZ, Z(I,1), LDZ, ZERO, DWORK(NN+1), - $ NN ) - LJ = NN -C - DO 30 M = 1, NV - DO 20 J = 1, NN -C -C Compute tanh(wj'*z(i) + bj), j = 1:n. -C - LJ = LJ + 1 - DF = DWORK(LJ) - DWORK(J) - IF ( ABS( DF ).GE.BIGNUM ) THEN - IF ( DF.GT.ZERO ) THEN - DWORK(LJ) = -ONE - ELSE - DWORK(LJ) = ONE - END IF - ELSE IF ( ABS( DF ).LE.SMLNUM ) THEN - DWORK(LJ) = ZERO - ELSE - DWORK(LJ) = TWO/( ONE + EXP( DF ) ) - ONE - END IF - 20 CONTINUE -C - 30 CONTINUE -C - Y(I, K+1) = TMP - CALL DCOPY( NV-1, Y(I, K+1), 0, Y(I+1, K+1), 1 ) - CALL DGEMV( 'Transpose', NN, NV, ONE, DWORK(NN+1), NN, - $ WB(WS+LK), 1, ONE, Y(I, K+1), 1 ) - 40 CONTINUE -C - IF ( LAST ) THEN -C -C Process the last samples. -C - NV = NSMP - MF - I = MF + 1 -C -C Compute -2*[w1 w2 ... wn]'*Z', where -C Z = [z(i)';...; z(NSMP)']. -C - CALL DGEMM( 'Transpose', 'Transpose', NN, NV, NZ, -TWO, - $ WB(1+LK), NZ, Z(I,1), LDZ, ZERO, DWORK(NN+1), - $ NN ) - LJ = NN -C - DO 60 M = 1, NV - DO 50 J = 1, NN -C -C Compute tanh(wj'*z(i) + bj), j = 1:n. -C - LJ = LJ + 1 - DF = DWORK(LJ) - DWORK(J) - IF ( ABS( DF ).GE.BIGNUM ) THEN - IF ( DF.GT.ZERO ) THEN - DWORK(LJ) = -ONE - ELSE - DWORK(LJ) = ONE - END IF - ELSE IF ( ABS( DF ).LE.SMLNUM ) THEN - DWORK(LJ) = ZERO - ELSE - DWORK(LJ) = TWO/( ONE + EXP( DF ) ) - ONE - END IF - 50 CONTINUE -C - 60 CONTINUE -C - Y(I, K+1) = TMP - IF ( NV.GT.1 ) - $ CALL DCOPY( NV-1, Y(I, K+1), 0, Y(I+1, K+1), 1 ) - CALL DGEMV( 'Transpose', NN, NV, ONE, DWORK(NN+1), NN, - $ WB(WS+LK), 1, ONE, Y(I, K+1), 1 ) - END IF -C - LK = LK + LDWB - 70 CONTINUE -C - ELSE -C -C BLAS 2 calculations only can be used. -C - DO 110 K = 0, L - 1 - TMP = WB(IB+NN+1+LK) -C - DO 80 J = 1, NN - DWORK(J) = TWO*WB(IB+J+LK) - 80 CONTINUE -C - DO 100 I = 1, NSMP -C -C Compute -2*[w1 w2 ... wn]'*z(i). -C - IF ( NZ.EQ.0 ) THEN - DWORK(NN+1) = ZERO - CALL DCOPY( NN, DWORK(NN+1), 0, DWORK(NN+1), 1 ) - ELSE - CALL DGEMV( 'Transpose', NZ, NN, -TWO, WB(1+LK), NZ, - $ Z(I,1), LDZ, ZERO, DWORK(NN+1), 1 ) - END IF -C - DO 90 J = NN + 1, 2*NN -C -C Compute tanh(wj'*z(i) + bj), j = 1:n. -C - DF = DWORK(J) - DWORK(J-NN) - IF ( ABS( DF ).GE.BIGNUM ) THEN - IF ( DF.GT.ZERO ) THEN - DWORK(J) = -ONE - ELSE - DWORK(J) = ONE - END IF - ELSE IF ( ABS( DF ).LE.SMLNUM ) THEN - DWORK(J) = ZERO - ELSE - DWORK(J) = TWO/( ONE + EXP( DF ) ) - ONE - END IF - 90 CONTINUE -C - Y(I, K+1) = DDOT( NN, WB(WS+LK), 1, DWORK(NN+1), 1 ) + - $ TMP - 100 CONTINUE -C - LK = LK + LDWB - 110 CONTINUE -C - END IF - RETURN -C -C *** Last line of NF01AY *** - END diff --git a/mex/sources/libslicot/NF01BA.f b/mex/sources/libslicot/NF01BA.f deleted file mode 100644 index 98c344a37..000000000 --- a/mex/sources/libslicot/NF01BA.f +++ /dev/null @@ -1,104 +0,0 @@ - SUBROUTINE NF01BA( IFLAG, NSMP, N, IPAR, LIPAR, Z, LDZ, Y, LDY, X, - $ NFEVL, E, J, LDJ, JTE, DWORK, LDWORK, INFO ) -C -C SLICOT RELEASE 5.0. -C -C Copyright (c) 2002-2009 NICONET e.V. -C -C This program is free software: you can redistribute it and/or -C modify it under the terms of the GNU General Public License as -C published by the Free Software Foundation, either version 2 of -C the License, or (at your option) any later version. -C -C This program is distributed in the hope that it will be useful, -C but WITHOUT ANY WARRANTY; without even the implied warranty of -C MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the -C GNU General Public License for more details. -C -C You should have received a copy of the GNU General Public License -C along with this program. If not, see -C . -C -C This is the FCN routine for optimizing the parameters of the -C nonlinear part of a Wiener system (initialization phase), using -C SLICOT Library routine MD03AD. See the argument FCN in the -C routine MD03AD for the description of parameters. Note that -C NF01BA is called for each output of the Wiener system. -C -C ****************************************************************** -C -C .. Parameters .. -C .. CJTE is initialized to activate the calculation of J'*e .. -C .. NOUT is the unit number for printing intermediate results .. - CHARACTER CJTE - PARAMETER ( CJTE = 'C' ) - INTEGER NOUT - PARAMETER ( NOUT = 6 ) - DOUBLE PRECISION ZERO, ONE - PARAMETER ( ZERO = 0.0D0, ONE = 1.0D0 ) -C .. Scalar Arguments .. - INTEGER IFLAG, INFO, LDJ, LDWORK, LDY, LDZ, LIPAR, N, - $ NFEVL, NSMP -C .. Array Arguments .. - INTEGER IPAR(*) - DOUBLE PRECISION DWORK(*), E(*), J(LDJ,*), JTE(*), X(*), - $ Y(LDY,*), Z(LDZ,*) -C .. Local Scalars .. - DOUBLE PRECISION ERR -C .. External Functions .. - DOUBLE PRECISION DNRM2 - EXTERNAL DNRM2 -C .. External Subroutines .. - EXTERNAL DAXPY, NF01AY, NF01BY -C -C .. Executable Statements .. -C - INFO = 0 - IF ( IFLAG.EQ.1 ) THEN -C -C Call NF01AY to compute the output y of the Wiener system (in E) -C and then the error functions (also in E). The array Z must -C contain the output of the linear part of the Wiener system, and -C Y must contain the original output Y of the Wiener system. -C IPAR(2) must contain the number of outputs. -C Workspace: need: 2*NN, NN = IPAR(3) (number of neurons); -C prefer: larger. -C - CALL NF01AY( NSMP, IPAR(2), 1, IPAR(3), LIPAR-2, X, N, Z, LDZ, - $ E, NSMP, DWORK, LDWORK, INFO ) - CALL DAXPY( NSMP, -ONE, Y, 1, E, 1 ) - DWORK(1) = 2*IPAR(3) -C - ELSE IF ( IFLAG.EQ.2 ) THEN -C -C Call NF01BY to compute the Jacobian in a compressed form. -C IPAR(2), IPAR(3) must have the same content as for IFLAG = 1. -C Workspace: need: 0. -C - CALL NF01BY( CJTE, NSMP, IPAR(2), 1, IPAR(3), LIPAR-2, X, N, Z, - $ LDZ, E, J, LDJ, JTE, DWORK, LDWORK, INFO ) - NFEVL = 0 - DWORK(1) = ZERO -C - ELSE IF ( IFLAG.EQ.3 ) THEN -C -C Set the parameter LDJ, the length of the array J, and the sizes -C of the workspace for FCN (IFLAG = 1 or 2), and JPJ. -C - LDJ = NSMP - IPAR(1) = NSMP*N - IPAR(2) = 2*IPAR(3) - IPAR(3) = 0 - IPAR(4) = NSMP -C - ELSE IF ( IFLAG.EQ.0 ) THEN -C -C Special call for printing intermediate results. -C - ERR = DNRM2( NSMP, E, 1 ) - WRITE( NOUT, '('' Norm of current error = '', D15.6)') ERR - END IF - RETURN -C -C *** Last line of NF01BA *** - END diff --git a/mex/sources/libslicot/NF01BB.f b/mex/sources/libslicot/NF01BB.f deleted file mode 100644 index ec39f9b38..000000000 --- a/mex/sources/libslicot/NF01BB.f +++ /dev/null @@ -1,138 +0,0 @@ - SUBROUTINE NF01BB( IFLAG, NFUN, LX, IPAR, LIPAR, U, LDU, Y, LDY, - $ X, NFEVL, E, J, LDJ, JTE, DWORK, LDWORK, INFO ) -C -C SLICOT RELEASE 5.0. -C -C Copyright (c) 2002-2009 NICONET e.V. -C -C This program is free software: you can redistribute it and/or -C modify it under the terms of the GNU General Public License as -C published by the Free Software Foundation, either version 2 of -C the License, or (at your option) any later version. -C -C This program is distributed in the hope that it will be useful, -C but WITHOUT ANY WARRANTY; without even the implied warranty of -C MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the -C GNU General Public License for more details. -C -C You should have received a copy of the GNU General Public License -C along with this program. If not, see -C . -C -C This is the FCN routine for optimizing all parameters of a Wiener -C system using SLICOT Library routine MD03AD. See the argument FCN -C in the routine MD03AD for the description of parameters. -C -C ****************************************************************** -C -C .. Parameters .. -C .. CJTE is initialized to activate the calculation of J'*e .. -C .. NOUT is the unit number for printing intermediate results .. - CHARACTER CJTE - PARAMETER ( CJTE = 'C' ) - INTEGER NOUT - PARAMETER ( NOUT = 6 ) - DOUBLE PRECISION ONE - PARAMETER ( ONE = 1.0D0 ) -C .. Scalar Arguments .. - INTEGER IFLAG, INFO, LDJ, LDU, LDWORK, LDY, LIPAR, LX, - $ NFEVL, NFUN -C .. Array Arguments .. - INTEGER IPAR(*) - DOUBLE PRECISION DWORK(*), E(*), J(LDJ,*), JTE(*), U(LDU,*), - $ X(*), Y(LDY,*) -C .. Local Scalars .. - INTEGER BSN, I, JWORK, L, M, N, NN, NSMP, ST - DOUBLE PRECISION ERR -C .. External Functions .. - DOUBLE PRECISION DNRM2 - EXTERNAL DNRM2 -C .. External Subroutines .. - EXTERNAL DAXPY, NF01AD, NF01BD -C -C .. Executable Statements .. -C - L = IPAR(2) - M = IPAR(5) - N = IPAR(6) - IF ( L.EQ.0 ) THEN - NSMP = NFUN - ELSE - NSMP = NFUN/L - END IF -C - INFO = 0 - IF ( IFLAG.EQ.1 ) THEN -C -C Call NF01AD to compute the output y of the Wiener system (in E) -C and then the error functions (also in E). The array U must -C contain the input to the linear part of the Wiener system, and -C Y must contain the original output Y of the Wiener system. -C IPAR(6) must contain the number of states of the linear part, n. -C Workspace: need: NFUN + MAX( 2*NN, (N + L)*(N + M) + 2*N + -C MAX( N*(N + L), N + M + L ) ), -C if M>0, -C NFUN + MAX( 2*NN, (N + L)*N + 2*N + -C MAX( N*(N + L), L ) ), if M=0, -C where NN = IPAR(7) (number of neurons); -C prefer: larger. -C - CALL NF01AD( NSMP, M, L, IPAR(6), LIPAR-2, X, LX, U, LDU, E, - $ NSMP, DWORK, LDWORK, INFO ) -C - DO 10 I = 1, L - CALL DAXPY( NSMP, -ONE, Y(1,I), 1, E((I-1)*NSMP+1), 1 ) - 10 CONTINUE -C - DWORK(1) = NFUN + MAX( 2*IPAR(7), (N + L)*(N + M) + 2*N + - $ MAX( N*(N + L), N + M + L ) ) -C - ELSE IF ( IFLAG.EQ.2 ) THEN -C -C Call NF01BD to compute the Jacobian in a compressed form. -C Workspace: need: 2*NFUN + MAX( 2*NN, (N + L)*(N + M) + 2*N + -C MAX( N*(N + L), N + M + L )), -C if M > 0, -C 2*NFUN + MAX( 2*NN, (N + L)*N + 2*N + -C MAX( N*(N + L), L ) ), -C if M = 0; -C prefer: larger. -C - CALL NF01BD( CJTE, NSMP, M, L, IPAR(6), LIPAR-2, X, LX, U, - $ LDU, E, J, LDJ, JTE, DWORK, LDWORK, INFO ) - NFEVL = IPAR(6)*( M + L + 1 ) + L*M - DWORK(1) = 2*NFUN + MAX( 2*IPAR(7), (N + L)*(N + M) + 2*N + - $ MAX( N*(N + L), N + M + L ) ) -C - ELSE IF ( IFLAG.EQ.3 ) THEN -C -C Set the parameter LDJ, the length of the array J, and the sizes -C of the workspace for FCN (IFLAG = 1 or 2), and JTJ. -C - ST = IPAR(1) - BSN = IPAR(4) - NN = IPAR(7) -C - LDJ = NFUN - IPAR(1) = NFUN*( BSN + ST ) - IF ( M.GT.0 ) THEN - JWORK = MAX( N*( N + L ), N + M + L ) - ELSE - JWORK = MAX( N*( N + L ), L ) - END IF - IPAR(2) = LDJ + MAX( ( N + L )*( N + M ) + 2*N + JWORK, 2*NN ) - IPAR(3) = LDJ + IPAR(2) - IPAR(4) = 0 - IPAR(5) = NFUN -C - ELSE IF ( IFLAG.EQ.0 ) THEN -C -C Special call for printing intermediate results. -C - ERR = DNRM2( NFUN, E, 1 ) - WRITE( NOUT, '('' Norm of current error = '', D15.6)') ERR - END IF - RETURN -C -C *** Last line of NF01BB *** - END diff --git a/mex/sources/libslicot/NF01BD.f b/mex/sources/libslicot/NF01BD.f deleted file mode 100644 index 3f15bc2a6..000000000 --- a/mex/sources/libslicot/NF01BD.f +++ /dev/null @@ -1,381 +0,0 @@ - SUBROUTINE NF01BD( CJTE, NSMP, M, L, IPAR, LIPAR, X, LX, U, LDU, - $ E, J, LDJ, JTE, DWORK, LDWORK, INFO ) -C -C SLICOT RELEASE 5.0. -C -C Copyright (c) 2002-2009 NICONET e.V. -C -C This program is free software: you can redistribute it and/or -C modify it under the terms of the GNU General Public License as -C published by the Free Software Foundation, either version 2 of -C the License, or (at your option) any later version. -C -C This program is distributed in the hope that it will be useful, -C but WITHOUT ANY WARRANTY; without even the implied warranty of -C MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the -C GNU General Public License for more details. -C -C You should have received a copy of the GNU General Public License -C along with this program. If not, see -C . -C -C PURPOSE -C -C To calculate the Jacobian dy/dX of the Wiener system -C -C x(t+1) = A*x(t) + B*u(t) -C z(t) = C*x(t) + D*u(t), -C -C y(t,i) = sum( ws(k, i)*f(w(k, i)*z(t) + b(k,i)) ) + b(k+1,i), -C -C where t = 1, 2, ..., NSMP, -C i = 1, 2, ..., L, -C k = 1, 2, ..., NN. -C -C NN is arbitrary eligible and has to be provided in IPAR(2), and -C X = ( wb(1), ..., wb(L), theta ) is described below. -C -C Denoting y(j) = y(1:NSMP,j), the Jacobian J has the block form -C -C dy(1)/dwb(1) 0 ..... 0 dy(1)/dtheta -C 0 dy(2)/dwb(2) ..... 0 dy(2)/dtheta -C ..... ..... ..... ..... ..... -C 0 ..... 0 dy(L)/dwb(L) dy(L)/dtheta -C -C but it will be returned without the zero blocks, in the form -C -C dy(1)/dwb(1) dy(1)/dtheta -C ... -C dy(L)/dwb(L) dy(L)/dtheta. -C -C dy(i)/dwb(i) depends on f and is calculated by the routine NF01BY; -C dy(i)/dtheta is computed by a forward-difference approximation. -C -C ARGUMENTS -C -C Mode Parameters -C -C CJTE CHARACTER*1 -C Specifies whether the matrix-vector product J'*e should be -C computed or not, as follows: -C = 'C' : compute J'*e; -C = 'N' : do not compute J'*e. -C -C Input/Output Parameters -C -C NSMP (input) INTEGER -C The number of training samples. NSMP >= 0. -C -C M (input) INTEGER -C The length of each input sample. M >= 0. -C -C L (input) INTEGER -C The length of each output sample. L >= 0. -C -C IPAR (input/output) INTEGER array, dimension (LIPAR) -C On entry, the first entries of this array must contain -C the integer parameters needed; specifically, -C IPAR(1) must contain the order of the linear part, N; -C actually, N = abs(IPAR(1)), since setting -C IPAR(1) < 0 has a special meaning (see below); -C IPAR(2) must contain the number of neurons for the -C nonlinear part, NN, NN >= 0. -C On exit, if IPAR(1) < 0 on entry, then no computations are -C performed, except the needed tests on input parameters, -C but the following values are returned: -C IPAR(1) contains the length of the array J, LJ; -C LDJ contains the leading dimension of array J. -C Otherwise, IPAR(1) and LDJ are unchanged on exit. -C -C LIPAR (input) INTEGER -C The length of the array IPAR. LIPAR >= 2. -C -C X (input) DOUBLE PRECISION array, dimension (LX) -C The leading LPAR entries of this array must contain the -C set of system parameters, where -C LPAR = (NN*(L + 2) + 1)*L + N*(M + L + 1) + L*M. -C X has the form (wb(1), ..., wb(L), theta), where the -C vectors wb(i) have the structure -C (w(1,1), ..., w(1,L), ..., w(NN,1), ..., w(NN,L), -C ws(1), ..., ws(NN), b(1), ..., b(NN+1) ), -C and the vector theta represents the matrices A, B, C, D -C and x(1), and it can be retrieved from these matrices -C by SLICOT Library routine TB01VD and retranslated by -C TB01VY. -C -C LX (input) INTEGER -C The length of X. -C LX >= (NN*(L + 2) + 1)*L + N*(M + L + 1) + L*M. -C -C U (input) DOUBLE PRECISION array, dimension (LDU, M) -C The leading NSMP-by-M part of this array must contain the -C set of input samples, -C U = ( U(1,1),...,U(1,M); ...; U(NSMP,1),...,U(NSMP,M) ). -C -C LDU INTEGER -C The leading dimension of array U. LDU >= MAX(1,NSMP). -C -C E (input) DOUBLE PRECISION array, dimension (NSMP*L) -C If CJTE = 'C', this array must contain a vector e, which -C will be premultiplied with J', e = vec( Y - y ), where -C Y is set of output samples, and vec denotes the -C concatenation of the columns of a matrix. -C If CJTE = 'N', this array is not referenced. -C -C J (output) DOUBLE PRECISION array, dimension (LDJ, *) -C The leading NSMP*L-by-NCOLJ part of this array contains -C the Jacobian of the error function stored in a compressed -C form, as described above, where -C NCOLJ = NN*(L + 2) + 1 + N*(M + L + 1) + L*M. -C -C LDJ INTEGER -C The leading dimension of array J. LDJ >= MAX(1,NSMP*L). -C Note that LDJ is an input parameter, except for -C IPAR(1) < 0 on entry, when it is an output parameter. -C -C JTE (output) DOUBLE PRECISION array, dimension (LPAR) -C If CJTE = 'C', this array contains the matrix-vector -C product J'*e. -C If CJTE = 'N', this array is not referenced. -C -C Workspace -C -C DWORK DOUBLE PRECISION array, dimension (LDWORK) -C -C LDWORK INTEGER -C The length of the array DWORK. -C LDWORK >= 2*NSMP*L + MAX( 2*NN, (N + L)*(N + M) + 2*N + -C MAX( N*(N + L), N + M + L ) ) -C if M > 0; -C LDWORK >= 2*NSMP*L + MAX( 2*NN, (N + L)*N + 2*N + -C MAX( N*(N + L), L ) ), if M = 0. -C A larger value of LDWORK could improve the efficiency. -C -C Error Indicator -C -C INFO INTEGER -C = 0: successful exit; -C < 0: if INFO = -i, the i-th argument had an illegal -C value. -C -C METHOD -C -C BLAS routines are used for the matrix-vector multiplications, and -C the SLICOT Library routine TB01VY is called for the conversion of -C the output normal form parameters to an LTI-system; the routine -C NF01AD is then used for the simulation of the system with given -C parameters, and the routine NF01BY is called for the (analytically -C performed) calculation of the parts referring to the parameters -C of the static nonlinearity. -C -C CONTRIBUTORS -C -C A. Riedel, R. Schneider, Chemnitz University of Technology, -C Mar. 2001, during a stay at University of Twente, NL. -C -C REVISIONS -C -C V. Sima, Research Institute for Informatics, Bucharest, Mar. 2001, -C Dec. 2001. -C -C KEYWORDS -C -C Jacobian matrix, nonlinear system, output normal form, simulation, -C state-space representation, Wiener system. -C -C ****************************************************************** -C -C .. Parameters .. -C .. EPSFCN is related to the error in computing the functions .. -C .. For EPSFCN = 0.0D0, the square root of the machine precision -C .. is used for finite difference approximation of the derivatives. - DOUBLE PRECISION ZERO, ONE, EPSFCN - PARAMETER ( ZERO = 0.0D0, ONE = 1.0D0, EPSFCN = 0.0D0 ) -C .. Scalar Arguments .. - CHARACTER CJTE - INTEGER INFO, L, LDJ, LDU, LDWORK, LX, LIPAR, M, NSMP -C .. Array Arguments .. - INTEGER IPAR(*) - DOUBLE PRECISION DWORK(*), E(*), J(LDJ, *), JTE(*), U(LDU,*), - $ X(*) -C .. Local Scalars .. - LOGICAL WJTE - DOUBLE PRECISION EPS, H, PARSAV - INTEGER AC, BD, BSN, I, IX, IY, JW, K, KCOL, LDAC, LPAR, - $ LTHS, N, NN, NSML, NTHS, Z -C .. External Functions .. - DOUBLE PRECISION DLAMCH - LOGICAL LSAME - EXTERNAL DLAMCH, LSAME -C .. External Subroutines .. - EXTERNAL DCOPY, DGEMV, NF01AD, NF01AY, NF01BY, TB01VY, - $ TF01MX, XERBLA -C .. Intrinsic Functions .. - INTRINSIC ABS, MAX, MIN, SQRT -C .. -C .. Executable Statements .. -C - N = IPAR(1) - NN = IPAR(2) - BSN = NN*( L + 2 ) + 1 - NSML = NSMP*L - NTHS = BSN*L - LTHS = N*( M + L + 1 ) + L*M - LPAR = NTHS + LTHS - WJTE = LSAME( CJTE, 'C' ) -C -C Check the scalar input parameters. -C - INFO = 0 - IF( .NOT.( WJTE .OR. LSAME( CJTE, 'N' ) ) ) THEN - INFO = -1 - ELSEIF ( NSMP.LT.0 ) THEN - INFO = -2 - ELSEIF ( M.LT.0 ) THEN - INFO = -3 - ELSEIF ( L.LT.0 ) THEN - INFO = -4 - ELSEIF ( NN.LT.0 ) THEN - INFO = -5 - ELSEIF ( LIPAR.LT.2 ) THEN - INFO = -6 - ELSEIF ( IPAR(1).LT.0 ) THEN - IF( INFO.NE.0 ) THEN - CALL XERBLA( 'NF01BD', -INFO ) - ELSE - IPAR(1) = NSML*( ABS( N )*( M + L + 1 ) + L*M + BSN ) - LDJ = MAX( 1, NSML ) - ENDIF - RETURN - ELSEIF ( LX.LT.LPAR ) THEN - INFO = -8 - ELSEIF ( LDU.LT.MAX( 1, NSMP ) ) THEN - INFO = -10 - ELSEIF ( LDJ.LT.MAX( 1, NSML ) ) THEN - INFO = -13 - ELSE - LDAC = N + L - IF ( M.GT.0 ) THEN - JW = MAX( N*LDAC, N + M + L ) - ELSE - JW = MAX( N*LDAC, L ) - END IF - IF ( LDWORK.LT.2*NSML + MAX( 2*NN, LDAC*( N + M ) + 2*N + JW )) - $ INFO = -16 - ENDIF -C -C Return if there are illegal arguments. -C - IF( INFO.NE.0 ) THEN - CALL XERBLA( 'NF01BD', -INFO ) - RETURN - ENDIF -C -C Quick return if possible. -C - IF ( MIN( NSMP, L ).EQ.0 ) THEN - IF ( WJTE .AND. LPAR.GE.1 ) THEN - JTE(1) = ZERO - CALL DCOPY( LPAR, JTE(1), 0, JTE(1), 1 ) - END IF - RETURN - END IF -C -C Compute the output of the linear part. -C Workspace: need 2*NSMP*L + (N + L)*(N + M) + N + N*(N + L + 1). -C (2*NSMP*L locations are reserved for computing two times the -C output of the linear part.) -C - IY = 1 - Z = IY + NSML - AC = Z + NSML - BD = AC + LDAC*N - IX = BD + LDAC*M - JW = IX + N -C - CALL TB01VY( 'Apply', N, M, L, X(NTHS+1), LTHS, DWORK(AC), LDAC, - $ DWORK(BD), LDAC, DWORK(AC+N), LDAC, DWORK(BD+N), - $ LDAC, DWORK(IX), DWORK(JW), LDWORK-JW+1, INFO ) -C -C Workspace: need 2*NSMP*L + (N + L)*(N + M) + 3*N + M + L, -C if M > 0; -C 2*NSMP*L + (N + L)*N + 2*N + L, if M = 0; -C prefer larger. -C - CALL TF01MX( N, M, L, NSMP, DWORK(AC), LDAC, U, LDU, DWORK(IX), - $ DWORK(Z), NSMP, DWORK(JW), LDWORK-JW+1, INFO ) -C -C Fill the blocks dy(i)/dwb(i) and the corresponding parts of JTE, -C if needed. -C - JW = AC - IF ( WJTE ) THEN -C - DO 10 I = 0, L - 1 - CALL NF01BY( CJTE, NSMP, L, 1, IPAR(2), LIPAR-1, X(I*BSN+1), - $ BSN, DWORK(Z), NSMP, E(I*NSMP+1), - $ J(I*NSMP+1,1), LDJ, JTE(I*BSN+1), DWORK(JW), - $ LDWORK-JW+1, INFO ) - 10 CONTINUE -C - ELSE -C - DO 20 I = 0, L - 1 - CALL NF01BY( CJTE, NSMP, L, 1, IPAR(2), LIPAR-1, X(I*BSN+1), - $ BSN, DWORK(Z), NSMP, DWORK, J(I*NSMP+1,1), LDJ, - $ DWORK, DWORK(JW), LDWORK-JW+1, INFO ) - 20 CONTINUE -C - END IF -C -C Compute the output of the system with unchanged parameters. -C Workspace: need 2*NSMP*L + 2*NN; -C prefer larger. -C - CALL NF01AY( NSMP, L, L, IPAR(2), LIPAR-1, X, NTHS, DWORK(Z), - $ NSMP, DWORK(IY), NSMP, DWORK(JW), LDWORK-JW+1, - $ INFO ) -C -C Compute dy/dtheta numerically by forward-difference approximation. -C Workspace: need 2*NSMP*L + MAX( 2*NN, (N + L)*(N + M) + 2*N + -C MAX( N*(N + L), N + M + L ) ), -C if M > 0; -C 2*NSMP*L + MAX( 2*NN, (N + L)*N + 2*N + -C MAX( N*(N + L), L ) ), if M = 0; -C prefer larger. -C - JW = Z - EPS = SQRT( MAX( EPSFCN, DLAMCH( 'Epsilon' ) ) ) -C - DO 40 K = NTHS + 1, LPAR - KCOL = K - NTHS + BSN - PARSAV = X(K) - IF ( PARSAV.EQ.ZERO ) THEN - H = EPS - ELSE - H = EPS*ABS( PARSAV ) - END IF - X(K) = X(K) + H - CALL NF01AD( NSMP, M, L, IPAR, LIPAR, X, LPAR, U, LDU, - $ J(1,KCOL), NSMP, DWORK(JW), LDWORK-JW+1, - $ INFO ) - X(K) = PARSAV -C - DO 30 I = 1, NSML - J(I,KCOL) = ( J(I,KCOL) - DWORK(I) ) / H - 30 CONTINUE -C - 40 CONTINUE -C - IF ( WJTE ) THEN -C -C Compute the last part of J'e in JTE. -C - CALL DGEMV( 'Transpose', NSML, LTHS, ONE, J(1,BSN+1), LDJ, E, - $ 1, ZERO, JTE(NTHS+1), 1 ) - END IF -C - RETURN -C -C *** Last line of NF01BD *** - END diff --git a/mex/sources/libslicot/NF01BE.f b/mex/sources/libslicot/NF01BE.f deleted file mode 100644 index a9ad1dde5..000000000 --- a/mex/sources/libslicot/NF01BE.f +++ /dev/null @@ -1,105 +0,0 @@ - SUBROUTINE NF01BE( IFLAG, NSMP, N, IPAR, LIPAR, Z, LDZ, Y, LDY, X, - $ NFEVL, E, J, LDJ, DWORK, LDWORK, INFO ) -C -C SLICOT RELEASE 5.0. -C -C Copyright (c) 2002-2009 NICONET e.V. -C -C This program is free software: you can redistribute it and/or -C modify it under the terms of the GNU General Public License as -C published by the Free Software Foundation, either version 2 of -C the License, or (at your option) any later version. -C -C This program is distributed in the hope that it will be useful, -C but WITHOUT ANY WARRANTY; without even the implied warranty of -C MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the -C GNU General Public License for more details. -C -C You should have received a copy of the GNU General Public License -C along with this program. If not, see -C . -C -C This is the FCN routine for optimizing the parameters of the -C nonlinear part of a Wiener system (initialization phase), using -C SLICOT Library routine MD03BD. See the argument FCN in the -C routine MD03BD for the description of parameters. Note that -C NF01BE is called for each output of the Wiener system. -C -C ****************************************************************** -C -C .. Parameters .. -C .. CJTE is initialized to avoid the calculation of J'*e .. -C .. NOUT is the unit number for printing intermediate results .. - CHARACTER CJTE - PARAMETER ( CJTE = 'N' ) - INTEGER NOUT - PARAMETER ( NOUT = 6 ) - DOUBLE PRECISION ZERO, ONE - PARAMETER ( ZERO = 0.0D0, ONE = 1.0D0 ) -C .. Scalar Arguments .. - INTEGER IFLAG, INFO, LDJ, LDWORK, LDY, LDZ, LIPAR, N, - $ NFEVL, NSMP -C .. Array Arguments .. - INTEGER IPAR(*) - DOUBLE PRECISION DWORK(*), E(*), J(LDJ,*), X(*), Y(LDY,*), - $ Z(LDZ,*) -C .. Local Scalars .. - DOUBLE PRECISION ERR -C .. External Functions .. - DOUBLE PRECISION DNRM2 - EXTERNAL DNRM2 -C .. External Subroutines .. - EXTERNAL DAXPY, NF01AY, NF01BY -C -C .. Executable Statements .. -C - INFO = 0 - IF ( IFLAG.EQ.1 ) THEN -C -C Call NF01AY to compute the output y of the Wiener system (in E) -C and then the error functions (also in E). The array Z must -C contain the output of the linear part of the Wiener system, and -C Y must contain the original output Y of the Wiener system. -C IPAR(2) must contain the number of outputs. -C Workspace: need: 2*NN, NN = IPAR(3) (number of neurons); -C prefer: larger. -C - CALL NF01AY( NSMP, IPAR(2), 1, IPAR(3), LIPAR-2, X, N, Z, LDZ, - $ E, NSMP, DWORK, LDWORK, INFO ) - CALL DAXPY( NSMP, -ONE, Y, 1, E, 1 ) - DWORK(1) = 2*IPAR(3) -C - ELSE IF ( IFLAG.EQ.2 ) THEN -C -C Call NF01BY to compute the Jacobian in a compressed form. -C IPAR(2), IPAR(3) must have the same content as for IFLAG = 1. -C Workspace: need: 0. -C - CALL NF01BY( CJTE, NSMP, IPAR(2), 1, IPAR(3), LIPAR-2, X, N, Z, - $ LDZ, E, J, LDJ, DWORK, DWORK, LDWORK, INFO ) - NFEVL = 0 - DWORK(1) = ZERO -C - ELSE IF ( IFLAG.EQ.3 ) THEN -C -C Set the parameter LDJ, the length of the array J, and the sizes -C of the workspace for FCN (IFLAG = 1 or 2), QRFACT and LMPARM. -C - LDJ = NSMP - IPAR(1) = NSMP*N - IPAR(2) = 2*IPAR(3) - IPAR(3) = 0 - IPAR(4) = 4*N + 1 - IPAR(5) = 4*N -C - ELSE IF ( IFLAG.EQ.0 ) THEN -C -C Special call for printing intermediate results. -C - ERR = DNRM2( NSMP, E, 1 ) - WRITE( NOUT, '('' Norm of current error = '', D15.6)') ERR - END IF - RETURN -C -C *** Last line of NF01BE *** - END diff --git a/mex/sources/libslicot/NF01BF.f b/mex/sources/libslicot/NF01BF.f deleted file mode 100644 index d47b288dc..000000000 --- a/mex/sources/libslicot/NF01BF.f +++ /dev/null @@ -1,157 +0,0 @@ - SUBROUTINE NF01BF( IFLAG, NFUN, LX, IPAR, LIPAR, U, LDU, Y, LDY, - $ X, NFEVL, E, J, LDJ, DWORK, LDWORK, INFO ) -C -C SLICOT RELEASE 5.0. -C -C Copyright (c) 2002-2009 NICONET e.V. -C -C This program is free software: you can redistribute it and/or -C modify it under the terms of the GNU General Public License as -C published by the Free Software Foundation, either version 2 of -C the License, or (at your option) any later version. -C -C This program is distributed in the hope that it will be useful, -C but WITHOUT ANY WARRANTY; without even the implied warranty of -C MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the -C GNU General Public License for more details. -C -C You should have received a copy of the GNU General Public License -C along with this program. If not, see -C . -C -C This is the FCN routine for optimizing all parameters of a Wiener -C system using SLICOT Library routine MD03BD. See the argument FCN -C in the routine MD03BD for the description of parameters. -C -C ****************************************************************** -C -C .. Parameters .. -C .. CJTE is initialized to avoid the calculation of J'*e .. -C .. NOUT is the unit number for printing intermediate results .. - CHARACTER CJTE - PARAMETER ( CJTE = 'N' ) - INTEGER NOUT - PARAMETER ( NOUT = 6 ) - DOUBLE PRECISION ONE - PARAMETER ( ONE = 1.0D0 ) -C .. Scalar Arguments .. - INTEGER IFLAG, INFO, LDJ, LDU, LDWORK, LDY, LIPAR, LX, - $ NFEVL, NFUN -C .. Array Arguments .. - INTEGER IPAR(*) - DOUBLE PRECISION DWORK(*), E(*), J(LDJ,*), U(LDU,*), X(*), - $ Y(LDY,*) -C .. Local Scalars .. - LOGICAL FULL - INTEGER BSN, I, JWORK, L, M, N, NN, NSMP, ST - DOUBLE PRECISION ERR -C .. External Functions .. - DOUBLE PRECISION DNRM2 - EXTERNAL DNRM2 -C .. External Subroutines .. - EXTERNAL DAXPY, NF01AD, NF01BD -C -C .. Executable Statements .. -C - L = IPAR(2) - M = IPAR(5) - N = IPAR(6) - IF ( L.EQ.0 ) THEN - NSMP = NFUN - ELSE - NSMP = NFUN/L - END IF -C - INFO = 0 - IF ( IFLAG.EQ.1 ) THEN -C -C Call NF01AD to compute the output y of the Wiener system (in E) -C and then the error functions (also in E). The array U must -C contain the input to the linear part of the Wiener system, and -C Y must contain the original output Y of the Wiener system. -C IPAR(6) must contain the number of states of the linear part, n. -C Workspace: need: NFUN + MAX( 2*NN, (N + L)*(N + M) + 2*N + -C MAX( N*(N + L), N + M + L ) ), -C if M>0, -C NFUN + MAX( 2*NN, (N + L)*N + 2*N + -C MAX( N*(N + L), L ) ), if M=0, -C where NN = IPAR(7) (number of neurons); -C prefer: larger. -C - CALL NF01AD( NSMP, M, L, IPAR(6), LIPAR-2, X, LX, U, LDU, E, - $ NSMP, DWORK, LDWORK, INFO ) -C - DO 10 I = 1, L - CALL DAXPY( NSMP, -ONE, Y(1,I), 1, E((I-1)*NSMP+1), 1 ) - 10 CONTINUE -C - DWORK(1) = NFUN + MAX( 2*IPAR(7), (N + L)*(N + M) + 2*N + - $ MAX( N*(N + L), N + M + L ) ) -C - ELSE IF ( IFLAG.EQ.2 ) THEN -C -C Call NF01BD to compute the Jacobian in a compressed form. -C Workspace: need: 2*NFUN + MAX( 2*NN, (N + L)*(N + M) + 2*N + -C MAX( N*(N + L), N + M + L )), -C if M > 0, -C 2*NFUN + MAX( 2*NN, (N + L)*N + 2*N + -C MAX( N*(N + L), L ) ), -C if M > 0; -C prefer: larger. -C - CALL NF01BD( CJTE, NSMP, M, L, IPAR(6), LIPAR-2, X, LX, U, - $ LDU, E, J, LDJ, DWORK, DWORK, LDWORK, INFO ) - NFEVL = IPAR(6)*( M + L + 1 ) + L*M - DWORK(1) = 2*NFUN + MAX( 2*IPAR(7), (N + L)*(N + M) + 2*N + - $ MAX( N*(N + L), N + M + L ) ) -C - ELSE IF ( IFLAG.EQ.3 ) THEN -C -C Set the parameter LDJ, the length of the array J, and the sizes -C of the workspace for FCN (IFLAG = 1 or 2), QRFACT and LMPARM. -C Condition estimation (COND = 'E') is assumed in these routines. -C - ST = IPAR(1) - BSN = IPAR(4) - NN = IPAR(7) - FULL = L.LE.1 .OR. BSN.EQ.0 -C - LDJ = NFUN - IPAR(1) = LDJ*( BSN + ST ) - IF ( M.GT.0 ) THEN - JWORK = MAX( N*( N + L ), N + M + L ) - ELSE - JWORK = MAX( N*( N + L ), L ) - END IF - IPAR(2) = LDJ + MAX( (N + L)*(N + M) + 2*N + JWORK, 2*NN ) - IPAR(3) = LDJ + IPAR(2) - JWORK = 1 - IF ( FULL ) THEN - JWORK = 4*LX + 1 - ELSEIF ( BSN.GT.0 ) THEN - JWORK = BSN + MAX( 3*BSN + 1, ST ) - IF ( NSMP.GT.BSN ) THEN - JWORK = MAX( JWORK, 4*ST + 1 ) - IF ( NSMP.LT.2*BSN ) - $ JWORK = MAX( JWORK, ( NSMP - BSN )*( L - 1 ) ) - END IF - END IF - IPAR(4) = JWORK - IF ( FULL ) THEN - JWORK = 4*LX - ELSE - JWORK = ST*( LX - ST ) + 2*LX + 2*MAX( BSN, ST ) - END IF - IPAR(5) = JWORK -C - ELSE IF ( IFLAG.EQ.0 ) THEN -C -C Special call for printing intermediate results. -C - ERR = DNRM2( NFUN, E, 1 ) - WRITE( NOUT, '('' Norm of current error = '', D15.6)') ERR - END IF - RETURN -C -C *** Last line of NF01BF *** - END diff --git a/mex/sources/libslicot/NF01BP.f b/mex/sources/libslicot/NF01BP.f deleted file mode 100644 index e15e17f4e..000000000 --- a/mex/sources/libslicot/NF01BP.f +++ /dev/null @@ -1,666 +0,0 @@ - SUBROUTINE NF01BP( COND, N, IPAR, LIPAR, R, LDR, IPVT, DIAG, QTB, - $ DELTA, PAR, RANKS, X, RX, TOL, DWORK, LDWORK, - $ INFO ) -C -C SLICOT RELEASE 5.0. -C -C Copyright (c) 2002-2009 NICONET e.V. -C -C This program is free software: you can redistribute it and/or -C modify it under the terms of the GNU General Public License as -C published by the Free Software Foundation, either version 2 of -C the License, or (at your option) any later version. -C -C This program is distributed in the hope that it will be useful, -C but WITHOUT ANY WARRANTY; without even the implied warranty of -C MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the -C GNU General Public License for more details. -C -C You should have received a copy of the GNU General Public License -C along with this program. If not, see -C . -C -C PURPOSE -C -C To determine a value for the Levenberg-Marquardt parameter PAR -C such that if x solves the system -C -C J*x = b , sqrt(PAR)*D*x = 0 , -C -C in the least squares sense, where J is an m-by-n matrix, D is an -C n-by-n nonsingular diagonal matrix, and b is an m-vector, and if -C DELTA is a positive number, DXNORM is the Euclidean norm of D*x, -C then either PAR is zero and -C -C ( DXNORM - DELTA ) .LE. 0.1*DELTA , -C -C or PAR is positive and -C -C ABS( DXNORM - DELTA ) .LE. 0.1*DELTA . -C -C The matrix J is the current Jacobian matrix of a nonlinear least -C squares problem, provided in a compressed form by SLICOT Library -C routine NF01BD. It is assumed that a block QR factorization, with -C column pivoting, of J is available, that is, J*P = Q*R, where P is -C a permutation matrix, Q has orthogonal columns, and R is an upper -C triangular matrix with diagonal elements of nonincreasing -C magnitude for each block, as returned by SLICOT Library -C routine NF01BS. The routine NF01BP needs the upper triangle of R -C in compressed form, the permutation matrix P, and the first -C n components of Q'*b (' denotes the transpose). On output, -C NF01BP also provides a compressed representation of an upper -C triangular matrix S, such that -C -C P'*(J'*J + PAR*D*D)*P = S'*S . -C -C Matrix S is used in the solution process. The matrix R has the -C following structure -C -C / R_1 0 .. 0 | L_1 \ -C | 0 R_2 .. 0 | L_2 | -C | : : .. : | : | , -C | 0 0 .. R_l | L_l | -C \ 0 0 .. 0 | R_l+1 / -C -C where the submatrices R_k, k = 1:l, have the same order BSN, -C and R_k, k = 1:l+1, are square and upper triangular. This matrix -C is stored in the compressed form -C -C / R_1 | L_1 \ -C | R_2 | L_2 | -C Rc = | : | : | , -C | R_l | L_l | -C \ X | R_l+1 / -C -C where the submatrix X is irrelevant. The matrix S has the same -C structure as R, and its diagonal blocks are denoted by S_k, -C k = 1:l+1. -C -C If l <= 1, then the full upper triangle of the matrix R is stored. -C -C ARGUMENTS -C -C Mode Parameters -C -C COND CHARACTER*1 -C Specifies whether the condition of the diagonal blocks R_k -C and S_k of the matrices R and S should be estimated, -C as follows: -C = 'E' : use incremental condition estimation for each -C diagonal block of R_k and S_k to find its -C numerical rank; -C = 'N' : do not use condition estimation, but check the -C diagonal entries of R_k and S_k for zero values; -C = 'U' : use the ranks already stored in RANKS (for R). -C -C Input/Output Parameters -C -C N (input) INTEGER -C The order of the matrix R. N = BN*BSN + ST >= 0. -C (See parameter description below.) -C -C IPAR (input) INTEGER array, dimension (LIPAR) -C The integer parameters describing the structure of the -C matrix R, as follows: -C IPAR(1) must contain ST, the number of columns of the -C submatrices L_k and the order of R_l+1. ST >= 0. -C IPAR(2) must contain BN, the number of blocks, l, in the -C block diagonal part of R. BN >= 0. -C IPAR(3) must contain BSM, the number of rows of the blocks -C R_k, k = 1:l. BSM >= 0. -C IPAR(4) must contain BSN, the number of columns of the -C blocks R_k, k = 1:l. BSN >= 0. -C BSM is not used by this routine, but assumed equal to BSN. -C -C LIPAR (input) INTEGER -C The length of the array IPAR. LIPAR >= 4. -C -C R (input/output) DOUBLE PRECISION array, dimension (LDR, NC) -C where NC = N if BN <= 1, and NC = BSN+ST, if BN > 1. -C On entry, the leading N-by-NC part of this array must -C contain the (compressed) representation (Rc) of the upper -C triangular matrix R. If BN > 1, the submatrix X in Rc is -C not referenced. The zero strict lower triangles of R_k, -C k = 1:l+1, need not be set. If BN <= 1 or BSN = 0, then -C the full upper triangle of R must be stored. -C On exit, the full upper triangles of R_k, k = 1:l+1, and -C L_k, k = 1:l, are unaltered, and the strict lower -C triangles of R_k, k = 1:l+1, contain the corresponding -C strict upper triangles (transposed) of the upper -C triangular matrix S. -C If BN <= 1 or BSN = 0, then the transpose of the strict -C upper triangle of S is stored in the strict lower triangle -C of R. -C -C LDR INTEGER -C The leading dimension of array R. LDR >= MAX(1,N). -C -C IPVT (input) INTEGER array, dimension (N) -C This array must define the permutation matrix P such that -C J*P = Q*R. Column j of P is column IPVT(j) of the identity -C matrix. -C -C DIAG (input) DOUBLE PRECISION array, dimension (N) -C This array must contain the diagonal elements of the -C matrix D. DIAG(I) <> 0, I = 1,...,N. -C -C QTB (input) DOUBLE PRECISION array, dimension (N) -C This array must contain the first n elements of the -C vector Q'*b. -C -C DELTA (input) DOUBLE PRECISION -C An upper bound on the Euclidean norm of D*x. DELTA > 0. -C -C PAR (input/output) DOUBLE PRECISION -C On entry, PAR must contain an initial estimate of the -C Levenberg-Marquardt parameter. PAR >= 0. -C On exit, it contains the final estimate of this parameter. -C -C RANKS (input or output) INTEGER array, dimension (r), where -C r = BN + 1, if ST > 0, BSN > 0, and BN > 1; -C r = BN, if ST = 0 and BSN > 0; -C r = 1, if ST > 0 and ( BSN = 0 or BN <= 1 ); -C r = 0, if ST = 0 and BSN = 0. -C On entry, if COND = 'U' and N > 0, this array must contain -C the numerical ranks of the submatrices R_k, k = 1:l(+1). -C On exit, if N > 0, this array contains the numerical ranks -C of the submatrices S_k, k = 1:l(+1). -C -C X (output) DOUBLE PRECISION array, dimension (N) -C This array contains the least squares solution of the -C system J*x = b, sqrt(PAR)*D*x = 0. -C -C RX (output) DOUBLE PRECISION array, dimension (N) -C This array contains the matrix-vector product -R*P'*x. -C -C Tolerances -C -C TOL DOUBLE PRECISION -C If COND = 'E', the tolerance to be used for finding the -C ranks of the submatrices R_k and S_k. If the user sets -C TOL > 0, then the given value of TOL is used as a lower -C bound for the reciprocal condition number; a (sub)matrix -C whose estimated condition number is less than 1/TOL is -C considered to be of full rank. If the user sets TOL <= 0, -C then an implicitly computed, default tolerance, defined by -C TOLDEF = N*EPS, is used instead, where EPS is the machine -C precision (see LAPACK Library routine DLAMCH). -C This parameter is not relevant if COND = 'U' or 'N'. -C -C Workspace -C -C DWORK DOUBLE PRECISION array, dimension (LDWORK) -C On exit, the first N elements of this array contain the -C diagonal elements of the upper triangular matrix S. -C If BN > 1 and BSN > 0, the elements N+1 : N+ST*(N-ST) -C contain the submatrix (S(1:N-ST,N-ST+1:N))' of the -C matrix S. -C -C LDWORK INTEGER -C The length of the array DWORK. -C LDWORK >= 2*N, if BN <= 1 or BSN = 0 and -C COND <> 'E'; -C LDWORK >= 4*N, if BN <= 1 or BSN = 0 and -C COND = 'E'; -C LDWORK >= ST*(N-ST) + 2*N, if BN > 1 and BSN > 0 and -C COND <> 'E'; -C LDWORK >= ST*(N-ST) + 2*N + 2*MAX(BSN,ST), -C if BN > 1 and BSN > 0 and -C COND = 'E'. -C -C Error Indicator -C -C INFO INTEGER -C = 0: successful exit; -C < 0: if INFO = -i, the i-th argument had an illegal -C value. -C -C METHOD -C -C The algorithm computes the Gauss-Newton direction. An approximate -C basic least squares solution is found if the Jacobian is rank -C deficient. The computations exploit the special structure and -C storage scheme of the matrix R. If one or more of the submatrices -C R_k or S_k, k = 1:l+1, is singular, then the computed result is -C not the basic least squares solution for the whole problem, but a -C concatenation of (least squares) solutions of the individual -C subproblems involving R_k or S_k, k = 1:l+1 (with adapted right -C hand sides). -C -C If the Gauss-Newton direction is not acceptable, then an iterative -C algorithm obtains improved lower and upper bounds for the -C Levenberg-Marquardt parameter PAR. Only a few iterations are -C generally needed for convergence of the algorithm. If, however, -C the limit of ITMAX = 10 iterations is reached, then the output PAR -C will contain the best value obtained so far. If the Gauss-Newton -C step is acceptable, it is stored in x, and PAR is set to zero, -C hence S = R. -C -C REFERENCES -C -C [1] More, J.J., Garbow, B.S, and Hillstrom, K.E. -C User's Guide for MINPACK-1. -C Applied Math. Division, Argonne National Laboratory, Argonne, -C Illinois, Report ANL-80-74, 1980. -C -C NUMERICAL ASPECTS -C -C The algorithm requires 0(N*(BSN+ST)) operations and is backward -C stable, if R is nonsingular. -C -C FURTHER COMMENTS -C -C This routine is a structure-exploiting, LAPACK-based modification -C of LMPAR from the MINPACK package [1], and with optional condition -C estimation. The option COND = 'U' is useful when dealing with -C several right-hand side vectors, but RANKS array should be reset. -C If COND = 'E', but the matrix S is guaranteed to be nonsingular -C and well conditioned relative to TOL, i.e., rank(R) = N, and -C min(DIAG) > 0, then its condition is not estimated. -C -C CONTRIBUTORS -C -C V. Sima, Research Institute for Informatics, Bucharest, Dec. 2001. -C -C REVISIONS -C -C V. Sima, Feb. 2004. -C -C KEYWORDS -C -C Linear system of equations, matrix operations, plane rotations. -C -C ****************************************************************** -C -C .. Parameters .. - INTEGER ITMAX - PARAMETER ( ITMAX = 10 ) - DOUBLE PRECISION P1, P001, ZERO, ONE - PARAMETER ( P1 = 1.0D-1, P001 = 1.0D-3, ZERO = 0.0D0, - $ ONE = 1.0D0 ) -C .. Scalar Arguments .. - CHARACTER COND - INTEGER INFO, LDR, LDWORK, LIPAR, N - DOUBLE PRECISION DELTA, PAR, TOL -C .. Array Arguments .. - INTEGER IPAR(*), IPVT(*), RANKS(*) - DOUBLE PRECISION DIAG(*), DWORK(*), QTB(*), R(LDR,*), RX(*), X(*) -C .. Local Scalars .. - INTEGER BN, BSM, BSN, I, IBSN, ITER, J, JW, K, L, LDS, - $ N2, NTHS, RANK, ST - DOUBLE PRECISION DMINO, DWARF, DXNORM, FP, GNORM, PARC, PARL, - $ PARU, SUM, TEMP, TOLDEF - LOGICAL BADRK, ECOND, NCOND, SING, UCOND - CHARACTER CONDL -C .. External Functions .. - DOUBLE PRECISION DDOT, DLAMCH, DNRM2 - LOGICAL LSAME - EXTERNAL DDOT, DLAMCH, DNRM2, LSAME -C .. External Subroutines .. - EXTERNAL DCOPY, DGEMV, DTRMV, MD03BY, NF01BQ, NF01BR, - $ XERBLA -C .. Intrinsic Functions .. - INTRINSIC ABS, DBLE, MAX, MIN, SQRT -C .. -C .. Executable Statements .. -C -C Check the scalar input parameters. -C - ECOND = LSAME( COND, 'E' ) - NCOND = LSAME( COND, 'N' ) - UCOND = LSAME( COND, 'U' ) - INFO = 0 - N2 = 2*N - IF( .NOT.( ECOND .OR. NCOND .OR. UCOND ) ) THEN - INFO = -1 - ELSEIF( N.LT.0 ) THEN - INFO = -2 - ELSEIF( LIPAR.LT.4 ) THEN - INFO = -4 - ELSEIF ( LDR.LT.MAX( 1, N ) ) THEN - INFO = -6 - ELSEIF( DELTA.LE.ZERO ) THEN - INFO = -10 - ELSEIF( PAR.LT.ZERO ) THEN - INFO = -11 - ELSE - ST = IPAR(1) - BN = IPAR(2) - BSM = IPAR(3) - BSN = IPAR(4) - NTHS = BN*BSN - IF ( MIN( ST, BN, BSM, BSN ).LT.0 ) THEN - INFO = -3 - ELSEIF ( N.NE.NTHS + ST ) THEN - INFO = -2 - ELSE - IF ( N.GT.0 ) - $ DMINO = DIAG(1) - SING = .FALSE. -C - DO 10 J = 1, N - IF ( DIAG(J).LT.DMINO ) - $ DMINO = DIAG(J) - SING = SING .OR. DIAG(J).EQ.ZERO - 10 CONTINUE -C - IF ( SING ) THEN - INFO = -8 - ELSEIF ( UCOND ) THEN - BADRK = .FALSE. - IF ( BN.LE.1 .OR. BSN.EQ.0 ) THEN - IF ( N.GT.0 ) - $ BADRK = RANKS(1).LT.0 .OR. RANKS(1).GT.N - ELSE - RANK = 0 -C - DO 20 K = 1, BN - BADRK = BADRK .OR. RANKS(K).LT.0 - $ .OR. RANKS(K).GT.BSN - RANK = RANK + RANKS(K) - 20 CONTINUE -C - IF ( ST.GT.0 ) THEN - BADRK = BADRK .OR. RANKS(BN+1).LT.0 .OR. - $ RANKS(BN+1).GT.ST - RANK = RANK + RANKS(BN+1) - END IF - END IF - IF ( BADRK ) - $ INFO = -12 - ELSE - JW = N2 - IF ( BN.LE.1 .OR. BSN.EQ.0 ) THEN - IF ( ECOND ) - $ JW = 4*N - ELSE - JW = ST*NTHS + JW - IF ( ECOND ) - $ JW = 2*MAX( BSN, ST ) + JW - END IF - IF ( LDWORK.LT.JW ) - $ INFO = -17 - ENDIF - ENDIF - ENDIF -C -C Return if there are illegal arguments. -C - IF( INFO.NE.0 ) THEN - CALL XERBLA( 'NF01BP', -INFO ) - RETURN - ENDIF -C -C Quick return if possible. -C - IF ( N.EQ.0 ) THEN - PAR = ZERO - RETURN - END IF -C - IF ( BN.LE.1 .OR. BSN.EQ.0 ) THEN -C -C Special case: R is just an upper triangular matrix. -C Workspace: 4*N, if COND = 'E'; -C 2*N, if COND <> 'E'. -C - CALL MD03BY( COND, N, R, LDR, IPVT, DIAG, QTB, DELTA, PAR, - $ RANKS(1), X, RX, TOL, DWORK, LDWORK, INFO ) - RETURN - END IF -C -C General case: l > 1 and BSN > 0. -C DWARF is the smallest positive magnitude. -C - DWARF = DLAMCH( 'Underflow' ) -C -C Compute and store in x the Gauss-Newton direction. If the -C Jacobian is rank-deficient, obtain a least squares solution. -C The array RX is used as workspace. -C Workspace: 2*MAX(BSN,ST), if COND = 'E'; -C 0, if COND <> 'E'. -C - CALL DCOPY( N, QTB, 1, RX, 1 ) - CALL NF01BR( COND, 'Upper', 'No transpose', N, IPAR, LIPAR, R, - $ LDR, DWORK, DWORK, 1, RX, RANKS, TOL, DWORK, LDWORK, - $ INFO ) -C - DO 30 J = 1, N - L = IPVT(J) - X(L) = RX(J) - 30 CONTINUE -C -C Initialize the iteration counter. -C Evaluate the function at the origin, and test -C for acceptance of the Gauss-Newton direction. -C - ITER = 0 -C - DO 40 J = 1, N - DWORK(J) = DIAG(J)*X(J) - 40 CONTINUE -C - DXNORM = DNRM2( N, DWORK, 1 ) - FP = DXNORM - DELTA - IF ( FP.GT.P1*DELTA ) THEN -C -C Set an appropriate option for estimating the condition of -C the matrix S. -C - LDS = MAX( 1, ST ) - JW = N2 + ST*NTHS - IF ( UCOND ) THEN - IF ( LDWORK.GE.JW + 2*MAX( BSN, ST ) ) THEN - CONDL = 'E' - TOLDEF = DBLE( N )*DLAMCH( 'Epsilon' ) - ELSE - CONDL = 'N' - TOLDEF = TOL - END IF - ELSE - RANK = 0 -C - DO 50 K = 1, BN - RANK = RANK + RANKS(K) - 50 CONTINUE -C - IF ( ST.GT.0 ) - $ RANK = RANK + RANKS(BN+1) - CONDL = COND - TOLDEF = TOL - END IF -C -C If the Jacobian is not rank deficient, the Newton -C step provides a lower bound, PARL, for the zero of -C the function. Otherwise set this bound to zero. -C - IF ( RANK.EQ.N ) THEN -C - DO 60 J = 1, N - L = IPVT(J) - RX(J) = DIAG(L)*( DWORK(L)/DXNORM ) - 60 CONTINUE -C - CALL NF01BR( 'Use ranks', 'Upper', 'Transpose', N, IPAR, - $ LIPAR, R, LDR, DWORK, DWORK, 1, RX, RANKS, TOL, - $ DWORK, LDWORK, INFO ) - TEMP = DNRM2( N, RX, 1 ) - PARL = ( ( FP/DELTA )/TEMP )/TEMP -C -C For efficiency, use CONDL = 'U', if possible. -C - IF ( .NOT.LSAME( CONDL, 'U' ) .AND. DMINO.GT.ZERO ) - $ CONDL = 'U' - ELSE - PARL = ZERO - END IF -C - IBSN = 0 - K = 1 -C -C Calculate an upper bound, PARU, for the zero of the function. -C - DO 70 J = 1, N - IBSN = IBSN + 1 - IF ( J.LT.NTHS ) THEN - SUM = DDOT( IBSN, R(K,IBSN), 1, QTB(K), 1 ) - IF ( IBSN.EQ.BSN ) THEN - IBSN = 0 - K = K + BSN - END IF - ELSE IF ( J.EQ.NTHS ) THEN - SUM = DDOT( IBSN, R(K,IBSN), 1, QTB(K), 1 ) - ELSE - SUM = DDOT( J, R(1,IBSN), 1, QTB, 1 ) - END IF - L = IPVT(J) - RX(J) = SUM/DIAG(L) - 70 CONTINUE -C - GNORM = DNRM2( N, RX, 1 ) - PARU = GNORM/DELTA - IF ( PARU.EQ.ZERO ) - $ PARU = DWARF/MIN( DELTA, P1 )/P001 -C -C If the input PAR lies outside of the interval (PARL,PARU), -C set PAR to the closer endpoint. -C - PAR = MAX( PAR, PARL ) - PAR = MIN( PAR, PARU ) - IF ( PAR.EQ.ZERO ) - $ PAR = GNORM/DXNORM -C -C Beginning of an iteration. -C - 80 CONTINUE - ITER = ITER + 1 -C -C Evaluate the function at the current value of PAR. -C - IF ( PAR.EQ.ZERO ) - $ PAR = MAX( DWARF, P001*PARU ) - TEMP = SQRT( PAR ) -C - DO 90 J = 1, N - RX(J) = TEMP*DIAG(J) - 90 CONTINUE -C -C Solve the system J*x = b , sqrt(PAR)*D*x = 0 , in a least -C square sense. -C The first N elements of DWORK contain the diagonal elements -C of the upper triangular matrix S, and the next N elements -C contain the the vector z, so that x = P*z (see NF01BQ). -C The vector z is not preserved, to reduce the workspace. -C The elements 2*N+1 : 2*N+ST*(N-ST) contain the -C submatrix (S(1:N-ST,N-ST+1:N))' of the matrix S. -C Workspace: ST*(N-ST) + 2*N, if CONDL <> 'E'; -C ST*(N-ST) + 2*N + 2*MAX(BSN,ST), if CONDL = 'E'. -C - CALL NF01BQ( CONDL, N, IPAR, LIPAR, R, LDR, IPVT, RX, QTB, - $ RANKS, X, TOLDEF, DWORK, LDWORK, INFO ) -C - DO 100 J = 1, N - DWORK(N+J) = DIAG(J)*X(J) - 100 CONTINUE -C - DXNORM = DNRM2( N, DWORK(N+1), 1 ) - TEMP = FP - FP = DXNORM - DELTA -C -C If the function is small enough, accept the current value -C of PAR. Also test for the exceptional cases where PARL -C is zero or the number of iterations has reached ITMAX. -C - IF ( ABS( FP ).GT.P1*DELTA .AND. - $ ( PARL.NE.ZERO .OR. FP.GT.TEMP .OR. TEMP.GE.ZERO ) .AND. - $ ITER.LT.ITMAX ) THEN -C -C Compute the Newton correction. -C - DO 110 J = 1, N - L = IPVT(J) - RX(J) = DIAG(L)*( DWORK(N+L)/DXNORM ) - 110 CONTINUE -C - CALL NF01BR( 'Use ranks', 'Lower', 'Transpose', N, IPAR, - $ LIPAR, R, LDR, DWORK, DWORK(N2+1), LDS, RX, - $ RANKS, TOL, DWORK(JW), LDWORK-JW, INFO ) - TEMP = DNRM2( N, RX, 1 ) - PARC = ( ( FP/DELTA )/TEMP )/TEMP -C -C Depending on the sign of the function, update PARL -C or PARU. -C - IF ( FP.GT.ZERO ) THEN - PARL = MAX( PARL, PAR ) - ELSE IF ( FP.LT.ZERO ) THEN - PARU = MIN( PARU, PAR ) - END IF -C -C Compute an improved estimate for PAR. -C - PAR = MAX( PARL, PAR + PARC ) -C -C End of an iteration. -C - GO TO 80 - END IF - END IF -C -C Compute -R*P'*x = -R*z. -C - DO 120 J = 1, N - L = IPVT(J) - RX(J) = -X(L) - 120 CONTINUE -C - DO 130 I = 1, NTHS, BSN - CALL DTRMV( 'Upper', 'NoTranspose', 'NonUnit', BSN, R(I,1), - $ LDR, RX(I), 1 ) - 130 CONTINUE -C - IF ( ST.GT.0 ) THEN - CALL DGEMV( 'NoTranspose', NTHS, ST, ONE, R(1,BSN+1), LDR, - $ RX(NTHS+1), 1, ONE, RX, 1 ) - CALL DTRMV( 'Upper', 'NoTranspose', 'NonUnit', ST, - $ R(NTHS+1,BSN+1), LDR, RX(NTHS+1), 1 ) - END IF -C -C Termination. If PAR = 0, set S. -C - IF ( ITER.EQ.0 ) THEN - PAR = ZERO - I = 1 -C - DO 150 K = 1, BN -C - DO 140 J = 1, BSN - DWORK(I) = R(I,J) - CALL DCOPY( BSN-J+1, R(I,J), LDR, R(I,J), 1 ) - I = I + 1 - 140 CONTINUE -C - 150 CONTINUE -C - IF ( ST.GT.0 ) THEN -C - DO 160 J = BSN + 1, BSN + ST - CALL DCOPY( NTHS, R(1,J), 1, DWORK(N+J-BSN), ST ) - DWORK(I) = R(I,J) - CALL DCOPY( BSN+ST-J+1, R(I,J), LDR, R(I,J), 1 ) - I = I + 1 - 160 CONTINUE -C - END IF - ELSE -C - DO 170 K = N + 1, N + ST*NTHS - DWORK(K) = DWORK(K+N) - 170 CONTINUE -C - END IF -C - RETURN -C -C *** Last line of NF01BP *** - END diff --git a/mex/sources/libslicot/NF01BQ.f b/mex/sources/libslicot/NF01BQ.f deleted file mode 100644 index e07faaa28..000000000 --- a/mex/sources/libslicot/NF01BQ.f +++ /dev/null @@ -1,477 +0,0 @@ - SUBROUTINE NF01BQ( COND, N, IPAR, LIPAR, R, LDR, IPVT, DIAG, QTB, - $ RANKS, X, TOL, DWORK, LDWORK, INFO ) -C -C SLICOT RELEASE 5.0. -C -C Copyright (c) 2002-2009 NICONET e.V. -C -C This program is free software: you can redistribute it and/or -C modify it under the terms of the GNU General Public License as -C published by the Free Software Foundation, either version 2 of -C the License, or (at your option) any later version. -C -C This program is distributed in the hope that it will be useful, -C but WITHOUT ANY WARRANTY; without even the implied warranty of -C MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the -C GNU General Public License for more details. -C -C You should have received a copy of the GNU General Public License -C along with this program. If not, see -C . -C -C PURPOSE -C -C To determine a vector x which solves the system of linear -C equations -C -C J*x = b , D*x = 0 , -C -C in the least squares sense, where J is an m-by-n matrix, -C D is an n-by-n diagonal matrix, and b is an m-vector. The matrix J -C is the current Jacobian of a nonlinear least squares problem, -C provided in a compressed form by SLICOT Library routine NF01BD. -C It is assumed that a block QR factorization, with column pivoting, -C of J is available, that is, J*P = Q*R, where P is a permutation -C matrix, Q has orthogonal columns, and R is an upper triangular -C matrix with diagonal elements of nonincreasing magnitude for each -C block, as returned by SLICOT Library routine NF01BS. The routine -C NF01BQ needs the upper triangle of R in compressed form, the -C permutation matrix P, and the first n components of Q'*b -C (' denotes the transpose). The system J*x = b, D*x = 0, is then -C equivalent to -C -C R*z = Q'*b , P'*D*P*z = 0 , (1) -C -C where x = P*z. If this system does not have full rank, then an -C approximate least squares solution is obtained (see METHOD). -C On output, NF01BQ also provides an upper triangular matrix S -C such that -C -C P'*(J'*J + D*D)*P = S'*S . -C -C The system (1) is equivalent to S*z = c , where c contains the -C first n components of the vector obtained by applying to -C [ (Q'*b)' 0 ]' the transformations which triangularized -C [ R' P'*D*P ]', getting S. -C -C The matrix R has the following structure -C -C / R_1 0 .. 0 | L_1 \ -C | 0 R_2 .. 0 | L_2 | -C | : : .. : | : | , -C | 0 0 .. R_l | L_l | -C \ 0 0 .. 0 | R_l+1 / -C -C where the submatrices R_k, k = 1:l, have the same order BSN, -C and R_k, k = 1:l+1, are square and upper triangular. This matrix -C is stored in the compressed form -C -C / R_1 | L_1 \ -C | R_2 | L_2 | -C Rc = | : | : | , -C | R_l | L_l | -C \ X | R_l+1 / -C -C where the submatrix X is irrelevant. The matrix S has the same -C structure as R, and its diagonal blocks are denoted by S_k, -C k = 1:l+1. -C -C If l <= 1, then the full upper triangle of the matrix R is stored. -C -C ARGUMENTS -C -C Mode Parameters -C -C COND CHARACTER*1 -C Specifies whether the condition of the matrices S_k should -C be estimated, as follows: -C = 'E' : use incremental condition estimation and store -C the numerical rank of S_k in the array entry -C RANKS(k), for k = 1:l+1; -C = 'N' : do not use condition estimation, but check the -C diagonal entries of S_k for zero values; -C = 'U' : use the ranks already stored in RANKS(1:l+1). -C -C Input/Output Parameters -C -C N (input) INTEGER -C The order of the matrix R. N = BN*BSN + ST >= 0. -C (See parameter description below.) -C -C IPAR (input) INTEGER array, dimension (LIPAR) -C The integer parameters describing the structure of the -C matrix R, as follows: -C IPAR(1) must contain ST, the number of columns of the -C submatrices L_k and the order of R_l+1. ST >= 0. -C IPAR(2) must contain BN, the number of blocks, l, in the -C block diagonal part of R. BN >= 0. -C IPAR(3) must contain BSM, the number of rows of the blocks -C R_k, k = 1:l. BSM >= 0. -C IPAR(4) must contain BSN, the number of columns of the -C blocks R_k, k = 1:l. BSN >= 0. -C BSM is not used by this routine, but assumed equal to BSN. -C -C LIPAR (input) INTEGER -C The length of the array IPAR. LIPAR >= 4. -C -C R (input/output) DOUBLE PRECISION array, dimension (LDR, NC) -C where NC = N if BN <= 1, and NC = BSN+ST, if BN > 1. -C On entry, the leading N-by-NC part of this array must -C contain the (compressed) representation (Rc) of the upper -C triangular matrix R. If BN > 1, the submatrix X in Rc is -C not referenced. The zero strict lower triangles of R_k, -C k = 1:l+1, need not be set. If BN <= 1 or BSN = 0, then -C the full upper triangle of R must be stored. -C On exit, the full upper triangles of R_k, k = 1:l+1, and -C L_k, k = 1:l, are unaltered, and the strict lower -C triangles of R_k, k = 1:l+1, contain the corresponding -C strict upper triangles (transposed) of the upper -C triangular matrix S. -C If BN <= 1 or BSN = 0, then the transpose of the strict -C upper triangle of S is stored in the strict lower triangle -C of R. -C -C LDR INTEGER -C The leading dimension of the array R. LDR >= MAX(1,N). -C -C IPVT (input) INTEGER array, dimension (N) -C This array must define the permutation matrix P such that -C J*P = Q*R. Column j of P is column IPVT(j) of the identity -C matrix. -C -C DIAG (input) DOUBLE PRECISION array, dimension (N) -C This array must contain the diagonal elements of the -C matrix D. -C -C QTB (input) DOUBLE PRECISION array, dimension (N) -C This array must contain the first n elements of the -C vector Q'*b. -C -C RANKS (input or output) INTEGER array, dimension (r), where -C r = BN + 1, if ST > 0, BSN > 0, and BN > 1; -C r = BN, if ST = 0 and BSN > 0; -C r = 1, if ST > 0 and ( BSN = 0 or BN <= 1 ); -C r = 0, if ST = 0 and BSN = 0. -C On entry, if COND = 'U' and N > 0, this array must contain -C the numerical ranks of the submatrices S_k, k = 1:l(+1). -C On exit, if COND = 'E' or 'N' and N > 0, this array -C contains the numerical ranks of the submatrices S_k, -C k = 1:l(+1), estimated according to the value of COND. -C -C X (output) DOUBLE PRECISION array, dimension (N) -C This array contains the least squares solution of the -C system J*x = b, D*x = 0. -C -C Tolerances -C -C TOL DOUBLE PRECISION -C If COND = 'E', the tolerance to be used for finding the -C ranks of the submatrices S_k. If the user sets TOL > 0, -C then the given value of TOL is used as a lower bound for -C the reciprocal condition number; a (sub)matrix whose -C estimated condition number is less than 1/TOL is -C considered to be of full rank. If the user sets TOL <= 0, -C then an implicitly computed, default tolerance, defined by -C TOLDEF = N*EPS, is used instead, where EPS is the machine -C precision (see LAPACK Library routine DLAMCH). -C This parameter is not relevant if COND = 'U' or 'N'. -C -C Workspace -C -C DWORK DOUBLE PRECISION array, dimension (LDWORK) -C On exit, the first N elements of this array contain the -C diagonal elements of the upper triangular matrix S, and -C the next N elements contain the solution z. -C If BN > 1 and BSN > 0, the elements 2*N+1 : 2*N+ST*(N-ST) -C contain the submatrix (S(1:N-ST,N-ST+1:N))' of the -C matrix S. -C -C LDWORK INTEGER -C The length of the array DWORK. -C LDWORK >= 2*N, if BN <= 1 or BSN = 0 and -C COND <> 'E'; -C LDWORK >= 4*N, if BN <= 1 or BSN = 0 and -C COND = 'E'; -C LDWORK >= ST*(N-ST) + 2*N, if BN > 1 and BSN > 0 and -C COND <> 'E'; -C LDWORK >= ST*(N-ST) + 2*N + 2*MAX(BSN,ST), -C if BN > 1 and BSN > 0 and -C COND = 'E'. -C -C Error Indicator -C -C INFO INTEGER -C = 0: successful exit; -C < 0: if INFO = -i, the i-th argument had an illegal -C value. -C -C METHOD -C -C Standard plane rotations are used to annihilate the elements of -C the diagonal matrix D, updating the upper triangular matrix R -C and the first n elements of the vector Q'*b. A basic least squares -C solution is computed. The computations exploit the special -C structure and storage scheme of the matrix R. If one or more of -C the submatrices S_k, k = 1:l+1, is singular, then the computed -C result is not the basic least squares solution for the whole -C problem, but a concatenation of (least squares) solutions of the -C individual subproblems involving R_k, k = 1:l+1 (with adapted -C right hand sides). -C -C REFERENCES -C -C [1] More, J.J., Garbow, B.S, and Hillstrom, K.E. -C User's Guide for MINPACK-1. -C Applied Math. Division, Argonne National Laboratory, Argonne, -C Illinois, Report ANL-80-74, 1980. -C -C NUMERICAL ASPECTS -C -C The algorithm requires 0(N*(BSN+ST)) operations and is backward -C stable, if R is nonsingular. -C -C FURTHER COMMENTS -C -C This routine is a structure-exploiting, LAPACK-based modification -C of QRSOLV from the MINPACK package [1], and with optional -C condition estimation. -C The option COND = 'U' is useful when dealing with several -C right-hand side vectors. -C -C CONTRIBUTORS -C -C V. Sima, Research Institute for Informatics, Bucharest, Dec. 2001. -C -C REVISIONS -C -C - -C -C KEYWORDS -C -C Linear system of equations, matrix operations, plane rotations. -C -C ****************************************************************** -C -C .. Parameters .. - DOUBLE PRECISION ZERO - PARAMETER ( ZERO = 0.0D0 ) -C .. Scalar Arguments .. - CHARACTER COND - INTEGER INFO, LDR, LDWORK, LIPAR, N - DOUBLE PRECISION TOL -C .. Array Arguments .. - INTEGER IPAR(*), IPVT(*), RANKS(*) - DOUBLE PRECISION DIAG(*), DWORK(*), QTB(*), R(LDR,*), X(*) -C .. Local Scalars .. - DOUBLE PRECISION QTBPJ - INTEGER BN, BSM, BSN, I, IB, IBSN, IS, ITC, ITR, J, - $ JW, K, KF, L, NC, NTHS, ST - LOGICAL ECOND -C .. External Functions .. - LOGICAL LSAME - EXTERNAL LSAME -C .. External Subroutines .. - EXTERNAL DCOPY, DSWAP, MB02YD, MB04OW, NF01BR, XERBLA -C .. Intrinsic Functions .. - INTRINSIC MAX, MIN -C .. -C .. Executable Statements .. -C -C Check the scalar input parameters. -C - ECOND = LSAME( COND, 'E' ) - INFO = 0 - IF( .NOT.( ECOND .OR. LSAME( COND, 'N' ) .OR. - $ LSAME( COND, 'U' ) ) ) THEN - INFO = -1 - ELSEIF( N.LT.0 ) THEN - INFO = -2 - ELSEIF( LIPAR.LT.4 ) THEN - INFO = -4 - ELSE - ST = IPAR(1) - BN = IPAR(2) - BSM = IPAR(3) - BSN = IPAR(4) - NTHS = BN*BSN - IF ( MIN( ST, BN, BSM, BSN ).LT.0 ) THEN - INFO = -3 - ELSEIF ( N.NE.NTHS + ST ) THEN - INFO = -2 - ELSEIF ( LDR.LT.MAX( 1, N ) ) THEN - INFO = -6 - ELSE - JW = 2*N - IF ( BN.LE.1 .OR. BSN.EQ.0 ) THEN - IF ( ECOND ) - $ JW = 4*N - ELSE - JW = ST*NTHS + JW - IF ( ECOND ) - $ JW = 2*MAX( BSN, ST ) + JW - END IF - IF ( LDWORK.LT.JW ) - $ INFO = -14 - ENDIF - ENDIF -C -C Return if there are illegal arguments. -C - IF( INFO.NE.0 ) THEN - CALL XERBLA( 'NF01BQ', -INFO ) - RETURN - ENDIF -C -C Quick return if possible. -C - IF ( N.EQ.0 ) - $ RETURN -C - IF ( BN.LE.1 .OR. BSN.EQ.0 ) THEN -C -C Special case: R is an upper triangular matrix. -C Workspace: 4*N, if COND = 'E'; -C 2*N, if COND <> 'E'. -C - CALL MB02YD( COND, N, R, LDR, IPVT, DIAG, QTB, RANKS(1), X, - $ TOL, DWORK, LDWORK, INFO ) - RETURN - END IF -C -C General case: BN > 1 and BSN > 0. -C Copy R and Q'*b to preserve input and initialize S. -C In particular, save the diagonal elements of R in X. -C - IB = N + 1 - IS = IB + N - JW = IS + ST*NTHS - I = 1 - L = IS - NC = BSN + ST - KF = NC -C - DO 20 K = 1, BN -C - DO 10 J = 1, BSN - X(I) = R(I,J) - CALL DCOPY( BSN-J+1, R(I,J), LDR, R(I,J), 1 ) - I = I + 1 - 10 CONTINUE -C - 20 CONTINUE -C -C DWORK(IS) contains a copy of [ L_1' ... L_l' ]. -C Workspace: ST*(N-ST)+2*N; -C - DO 30 J = BSN + 1, NC - CALL DCOPY( NTHS, R(1,J), 1, DWORK(L), ST ) - X(I) = R(I,J) - CALL DCOPY( NC-J+1, R(I,J), LDR, R(I,J), 1 ) - I = I + 1 - L = L + 1 - 30 CONTINUE -C - CALL DCOPY( N, QTB, 1, DWORK(IB), 1 ) - IF ( ST.GT.0 ) THEN - ITR = NTHS + 1 - ITC = BSN + 1 - ELSE - ITR = 1 - ITC = 1 - END IF - IBSN = 0 -C -C Eliminate the diagonal matrix D using Givens rotations. -C - DO 50 J = 1, N - IBSN = IBSN + 1 - I = IBSN -C -C Prepare the row of D to be eliminated, locating the -C diagonal element using P from the QR factorization. -C - L = IPVT(J) - IF ( DIAG(L).NE.ZERO ) THEN - QTBPJ = ZERO - DWORK(J) = DIAG(L) -C - DO 40 K = J + 1, MIN( J + KF - 1, N ) - DWORK(K) = ZERO - 40 CONTINUE -C -C The transformations to eliminate the row of D modify only -C a single element of Q'*b beyond the first n, which is -C initially zero. -C - IF ( J.LT.NTHS ) THEN - CALL MB04OW( BSN-IBSN+1, ST, 1, R(J,IBSN), LDR, - $ R(ITR,ITC), LDR, DWORK(J), 1, DWORK(IB+J-1), - $ BSN, DWORK(IB+NTHS), ST, QTBPJ, 1 ) - IF ( IBSN.EQ.BSN ) - $ IBSN = 0 - ELSE IF ( J.EQ.NTHS ) THEN - CALL MB04OW( 1, ST, 1, R(J,IBSN), LDR, R(ITR,ITC), LDR, - $ DWORK(J), 1, DWORK(IB+J-1), BSN, - $ DWORK(IB+NTHS), ST, QTBPJ, 1 ) - KF = ST - ELSE - CALL MB04OW( 0, N-J+1, 1, R(J,IBSN), LDR, R(J,IBSN), LDR, - $ DWORK(J), 1, DWORK(IB+J-1), 1, - $ DWORK(IB+J-1), ST, QTBPJ, 1 ) - END IF - ELSE - IF ( J.LT.NTHS ) THEN - IF ( IBSN.EQ.BSN ) - $ IBSN = 0 - ELSE IF ( J.EQ.NTHS ) THEN - KF = ST - END IF - END IF -C -C Store the diagonal element of S. -C - DWORK(J) = R(J,I) - 50 CONTINUE -C -C Solve the triangular system for z. If the system is singular, -C then obtain an approximate least squares solution. -C Additional workspace: 2*MAX(BSN,ST), if COND = 'E'; -C 0, if COND <> 'E'. -C - CALL NF01BR( COND, 'Upper', 'NoTranspose', N, IPAR, LIPAR, R, LDR, - $ DWORK, DWORK(IS), 1, DWORK(IB), RANKS, TOL, - $ DWORK(JW), LDWORK-JW+1, INFO ) - I = 1 -C -C Restore the diagonal elements of R from X and interchange -C the upper and lower triangular parts of R. -C - DO 70 K = 1, BN -C - DO 60 J = 1, BSN - R(I,J) = X(I) - CALL DSWAP( BSN-J+1, R(I,J), LDR, R(I,J), 1 ) - I = I + 1 - 60 CONTINUE -C - 70 CONTINUE -C - DO 80 J = BSN + 1, NC - CALL DSWAP( NTHS, R(1,J), 1, DWORK(IS), ST ) - R(I,J) = X(I) - CALL DSWAP( NC-J+1, R(I,J), LDR, R(I,J), 1 ) - I = I + 1 - IS = IS + 1 - 80 CONTINUE -C -C Permute the components of z back to components of x. -C - DO 90 J = 1, N - L = IPVT(J) - X(L) = DWORK(N+J) - 90 CONTINUE -C - RETURN -C -C *** Last line of NF01BQ *** - END diff --git a/mex/sources/libslicot/NF01BR.f b/mex/sources/libslicot/NF01BR.f deleted file mode 100644 index 4a68dab2b..000000000 --- a/mex/sources/libslicot/NF01BR.f +++ /dev/null @@ -1,711 +0,0 @@ - SUBROUTINE NF01BR( COND, UPLO, TRANS, N, IPAR, LIPAR, R, LDR, - $ SDIAG, S, LDS, B, RANKS, TOL, DWORK, LDWORK, - $ INFO ) -C -C SLICOT RELEASE 5.0. -C -C Copyright (c) 2002-2009 NICONET e.V. -C -C This program is free software: you can redistribute it and/or -C modify it under the terms of the GNU General Public License as -C published by the Free Software Foundation, either version 2 of -C the License, or (at your option) any later version. -C -C This program is distributed in the hope that it will be useful, -C but WITHOUT ANY WARRANTY; without even the implied warranty of -C MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the -C GNU General Public License for more details. -C -C You should have received a copy of the GNU General Public License -C along with this program. If not, see -C . -C -C PURPOSE -C -C To solve one of the systems of linear equations -C -C R*x = b , or R'*x = b , -C -C in the least squares sense, where R is an n-by-n block upper -C triangular matrix, with the structure -C -C / R_1 0 .. 0 | L_1 \ -C | 0 R_2 .. 0 | L_2 | -C | : : .. : | : | , -C | 0 0 .. R_l | L_l | -C \ 0 0 .. 0 | R_l+1 / -C -C with the upper triangular submatrices R_k, k = 1:l+1, square, and -C the first l of the same order, BSN. The diagonal elements of each -C block R_k have nonincreasing magnitude. The matrix R is stored in -C the compressed form, as returned by SLICOT Library routine NF01BS, -C -C / R_1 | L_1 \ -C | R_2 | L_2 | -C Rc = | : | : | , -C | R_l | L_l | -C \ X | R_l+1 / -C -C where the submatrix X is irrelevant. If the matrix R does not have -C full rank, then a least squares solution is obtained. If l <= 1, -C then R is an upper triangular matrix and its full upper triangle -C is stored. -C -C Optionally, the transpose of the matrix R can be stored in the -C strict lower triangles of the submatrices R_k, k = 1:l+1, and in -C the arrays SDIAG and S, as described at the parameter UPLO below. -C -C ARGUMENTS -C -C Mode Parameters -C -C COND CHARACTER*1 -C Specifies whether the condition of submatrices R_k should -C be estimated, as follows: -C = 'E' : use incremental condition estimation and store -C the numerical rank of R_k in the array entry -C RANKS(k), for k = 1:l+1; -C = 'N' : do not use condition estimation, but check the -C diagonal entries of R_k for zero values; -C = 'U' : use the ranks already stored in RANKS(1:l+1). -C -C UPLO CHARACTER*1 -C Specifies the storage scheme for the matrix R, as follows: -C = 'U' : the upper triangular part is stored as in Rc; -C = 'L' : the lower triangular part is stored, namely, -C - the transpose of the strict upper triangle of -C R_k is stored in the strict lower triangle of -C R_k, for k = 1:l+1; -C - the diagonal elements of R_k, k = 1:l+1, are -C stored in the array SDIAG; -C - the transpose of the last block column in R -C (without R_l+1) is stored in the array S. -C -C TRANS CHARACTER*1 -C Specifies the form of the system of equations, as follows: -C = 'N': R*x = b (No transpose); -C = 'T': R'*x = b (Transpose); -C = 'C': R'*x = b (Transpose). -C -C Input/Output Parameters -C -C N (input) INTEGER -C The order of the matrix R. N = BN*BSN + ST >= 0. -C (See parameter description below.) -C -C IPAR (input) INTEGER array, dimension (LIPAR) -C The integer parameters describing the structure of the -C matrix R, as follows: -C IPAR(1) must contain ST, the number of columns of the -C submatrices L_k and the order of R_l+1. ST >= 0. -C IPAR(2) must contain BN, the number of blocks, l, in the -C block diagonal part of R. BN >= 0. -C IPAR(3) must contain BSM, the number of rows of the blocks -C R_k, k = 1:l. BSM >= 0. -C IPAR(4) must contain BSN, the number of columns of the -C blocks R_k, k = 1:l. BSN >= 0. -C BSM is not used by this routine, but assumed equal to BSN. -C -C LIPAR (input) INTEGER -C The length of the array IPAR. LIPAR >= 4. -C -C R (input) DOUBLE PRECISION array, dimension (LDR, NC) -C where NC = N if BN <= 1, and NC = BSN+ST, if BN > 1. -C If UPLO = 'U', the leading N-by-NC part of this array must -C contain the (compressed) representation (Rc) of the upper -C triangular matrix R. The submatrix X in Rc and the strict -C lower triangular parts of the diagonal blocks R_k, -C k = 1:l+1, are not referenced. If BN <= 1 or BSN = 0, then -C the full upper triangle of R must be stored. -C If UPLO = 'L', BN > 1 and BSN > 0, the leading -C (N-ST)-by-BSN part of this array must contain the -C transposes of the strict upper triangles of R_k, k = 1:l, -C stored in the strict lower triangles of R_k, and the -C strict lower triangle of R_l+1 must contain the transpose -C of the strict upper triangle of R_l+1. The submatrix X -C in Rc is not referenced. The diagonal elements of R_k, -C and, if COND = 'E', the upper triangular parts of R_k, -C k = 1:l+1, are modified internally, but are restored -C on exit. -C If UPLO = 'L' and BN <= 1 or BSN = 0, the leading N-by-N -C strict lower triangular part of this array must contain -C the transpose of the strict upper triangular part of R. -C The diagonal elements and, if COND = 'E', the upper -C triangular elements are modified internally, but are -C restored on exit. -C -C LDR INTEGER -C The leading dimension of the array R. LDR >= MAX(1,N). -C -C SDIAG (input) DOUBLE PRECISION array, dimension (N) -C If UPLO = 'L', this array must contain the diagonal -C entries of R_k, k = 1:l+1. This array is modified -C internally, but is restored on exit. -C This parameter is not referenced if UPLO = 'U'. -C -C S (input) DOUBLE PRECISION array, dimension (LDS,N-ST) -C If UPLO = 'L', BN > 1, and BSN > 0, the leading -C ST-by-(N-ST) part of this array must contain the transpose -C of the rectangular part of the last block column in R, -C that is [ L_1' L_2' ... L_l' ] . If COND = 'E', S is -C modified internally, but is restored on exit. -C This parameter is not referenced if UPLO = 'U', or -C BN <= 1, or BSN = 0. -C -C LDS INTEGER -C The leading dimension of the array S. -C LDS >= 1, if UPLO = 'U', or BN <= 1, or BSN = 0; -C LDS >= MAX(1,ST), if UPLO = 'L', BN > 1, and BSN > 0. -C -C B (input/output) DOUBLE PRECISION array, dimension (N) -C On entry, this array must contain the right hand side -C vector b. -C On exit, this array contains the (least squares) solution -C of the system R*x = b or R'*x = b. -C -C RANKS (input or output) INTEGER array, dimension (r), where -C r = BN + 1, if ST > 0, BSN > 0, and BN > 1; -C r = BN, if ST = 0 and BSN > 0; -C r = 1, if ST > 0 and ( BSN = 0 or BN <= 1 ); -C r = 0, if ST = 0 and BSN = 0. -C On entry, if COND = 'U' and N > 0, this array must contain -C the numerical ranks of the submatrices R_k, k = 1:l(+1). -C On exit, if COND = 'E' or 'N' and N > 0, this array -C contains the numerical ranks of the submatrices R_k, -C k = 1:l(+1), estimated according to the value of COND. -C -C Tolerances -C -C TOL DOUBLE PRECISION -C If COND = 'E', the tolerance to be used for finding the -C ranks of the submatrices R_k. If the user sets TOL > 0, -C then the given value of TOL is used as a lower bound for -C the reciprocal condition number; a (sub)matrix whose -C estimated condition number is less than 1/TOL is -C considered to be of full rank. If the user sets TOL <= 0, -C then an implicitly computed, default tolerance, defined by -C TOLDEF = N*EPS, is used instead, where EPS is the machine -C precision (see LAPACK Library routine DLAMCH). -C This parameter is not relevant if COND = 'U' or 'N'. -C -C Workspace -C -C DWORK DOUBLE PRECISION array, dimension (LDWORK) -C -C LDWORK INTEGER -C The length of the array DWORK. -C Denote Full = ( BN <= 1 or BSN = 0 ); -C Comp = ( BN > 1 and BSN > 0 ). -C LDWORK >= 2*N, if Full and COND = 'E'; -C LDWORK >= 2*MAX(BSN,ST), if Comp and COND = 'E'; -C LDWORK >= 0, in the remaining cases. -C -C Error Indicator -C -C INFO INTEGER -C = 0: successful exit; -C < 0: if INFO = -i, the i-th argument had an illegal -C value. -C -C METHOD -C -C Block back or forward substitution is used (depending on TRANS -C and UPLO), exploiting the special structure and storage scheme of -C the matrix R. If a submatrix R_k, k = 1:l+1, is singular, a local -C basic least squares solution is computed. Therefore, the returned -C result is not the basic least squares solution for the whole -C problem, but a concatenation of (least squares) solutions of the -C individual subproblems involving R_k, k = 1:l+1 (with adapted -C right hand sides). -C -C NUMERICAL ASPECTS -C 2 2 -C The algorithm requires 0(BN*BSN + ST + N*ST) operations and is -C backward stable, if R is nonsingular. -C -C CONTRIBUTORS -C -C V. Sima, Research Institute for Informatics, Bucharest, Dec. 2001. -C -C REVISIONS -C -C V. Sima, Research Institute for Informatics, Bucharest, Mar. 2005. -C -C KEYWORDS -C -C Linear system of equations, matrix operations, plane rotations. -C -C ****************************************************************** -C -C .. Parameters .. - DOUBLE PRECISION ZERO, ONE, SVLMAX - PARAMETER ( ZERO = 0.0D0, ONE = 1.0D0, SVLMAX = 0.0D0 ) -C .. Scalar Arguments .. - CHARACTER COND, TRANS, UPLO - INTEGER INFO, LDR, LDS, LDWORK, LIPAR, N - DOUBLE PRECISION TOL -C .. Array Arguments .. - INTEGER IPAR(*), RANKS(*) - DOUBLE PRECISION B(*), DWORK(*), R(LDR,*), S(LDS,*), SDIAG(*) -C .. Local Scalars .. - DOUBLE PRECISION TOLDEF - INTEGER BN, BSM, BSN, I, I1, J, K, L, NC, NTHS, RANK, ST - CHARACTER TRANSL, UPLOL - LOGICAL ECOND, FULL, LOWER, NCOND, TRANR -C .. Local Arrays .. - DOUBLE PRECISION DUM(3) -C .. External Functions .. - DOUBLE PRECISION DLAMCH - LOGICAL LSAME - EXTERNAL DLAMCH, LSAME -C .. External Subroutines .. - EXTERNAL DCOPY, DGEMV, DSWAP, DTRSV, MB03OD, XERBLA -C .. Intrinsic Functions .. - INTRINSIC DBLE, MAX, MIN -C .. -C .. Executable Statements .. -C -C Check the scalar input parameters. -C - ECOND = LSAME( COND, 'E' ) - NCOND = LSAME( COND, 'N' ) - LOWER = LSAME( UPLO, 'L' ) - TRANR = LSAME( TRANS, 'T' ) .OR. LSAME( TRANS, 'C' ) -C - INFO = 0 - IF( .NOT.( ECOND .OR. NCOND .OR. LSAME( COND, 'U' ) ) ) THEN - INFO = -1 - ELSEIF( .NOT.( LOWER .OR. LSAME( UPLO, 'U' ) ) ) THEN - INFO = -2 - ELSEIF( .NOT.( TRANR .OR. LSAME( TRANS, 'N' ) ) ) THEN - INFO = -3 - ELSEIF( N.LT.0 ) THEN - INFO = -4 - ELSEIF( LIPAR.LT.4 ) THEN - INFO = -6 - ELSE - ST = IPAR(1) - BN = IPAR(2) - BSM = IPAR(3) - BSN = IPAR(4) - NTHS = BN*BSN - FULL = BN.LE.1 .OR. BSN.EQ.0 - IF ( MIN( ST, BN, BSM, BSN ).LT.0 ) THEN - INFO = -5 - ELSEIF ( N.NE.NTHS + ST ) THEN - INFO = -4 - ELSEIF ( LDR.LT.MAX( 1, N ) ) THEN - INFO = -8 - ELSEIF ( LDS.LT.1 .OR. ( LOWER .AND. .NOT.FULL .AND. - $ LDS.LT.ST ) ) THEN - INFO = -11 - ELSE - IF ( ECOND ) THEN - IF ( FULL ) THEN - L = 2*N - ELSE - L = 2*MAX( BSN, ST ) - END IF - ELSE - L = 0 - END IF - IF ( LDWORK.LT.L ) - $ INFO = -16 - END IF - END IF -C -C Return if there are illegal arguments. -C - IF( INFO.NE.0 ) THEN - CALL XERBLA( 'NF01BR', -INFO ) - RETURN - END IF -C -C Quick return if possible. -C - IF ( N.EQ.0 ) - $ RETURN -C - IF ( ECOND ) THEN - TOLDEF = TOL - IF ( TOLDEF.LE.ZERO ) THEN -C -C Use the default tolerance in rank determination. -C - TOLDEF = DBLE( N )*DLAMCH( 'Epsilon' ) - END IF - END IF -C - NC = BSN + ST - IF ( FULL ) THEN -C -C Special case: l <= 1 or BSN = 0; R is just an upper triangular -C matrix. -C - IF ( LOWER ) THEN -C -C Swap the diagonal elements of R and the elements of SDIAG -C and, if COND = 'E', swap the upper and lower triangular -C parts of R, in order to find the numerical rank. -C - CALL DSWAP( N, R, LDR+1, SDIAG, 1 ) - IF ( ECOND ) THEN - UPLOL = 'U' - TRANSL = TRANS -C - DO 10 J = 1, N - CALL DSWAP( N-J+1, R(J,J), LDR, R(J,J), 1 ) - 10 CONTINUE -C - ELSE - UPLOL = UPLO - IF ( TRANR ) THEN - TRANSL = 'N' - ELSE - TRANSL = 'T' - END IF - END IF - ELSE - UPLOL = UPLO - TRANSL = TRANS - END IF -C - IF ( ECOND ) THEN -C -C Estimate the reciprocal condition number and set the rank. -C Workspace: 2*N. -C - CALL MB03OD( 'No QR', N, N, R, LDR, IPAR, TOLDEF, SVLMAX, - $ DWORK, RANK, DUM, DWORK, LDWORK, INFO ) - RANKS(1) = RANK -C - ELSEIF ( NCOND ) THEN -C -C Determine rank(R) by checking zero diagonal entries. -C - RANK = N -C - DO 20 J = 1, N - IF ( R(J,J).EQ.ZERO .AND. RANK.EQ.N ) - $ RANK = J - 1 - 20 CONTINUE -C - RANKS(1) = RANK -C - ELSE -C -C Use the stored rank. -C - RANK = RANKS(1) - END IF -C -C Solve R*x = b, or R'*x = b using back or forward substitution. -C - DUM(1) = ZERO - IF ( RANK.LT.N ) - $ CALL DCOPY( N-RANK, DUM, 0, B(RANK+1), 1 ) - CALL DTRSV( UPLOL, TRANSL, 'NonUnit', RANK, R, LDR, B, 1 ) -C - IF ( LOWER ) THEN -C -C Swap the diagonal elements of R and the elements of SDIAG -C and, if COND = 'E', swap back the upper and lower triangular -C parts of R. -C - CALL DSWAP( N, R, LDR+1, SDIAG, 1 ) - IF ( ECOND ) THEN -C - DO 30 J = 1, N - CALL DSWAP( N-J+1, R(J,J), LDR, R(J,J), 1 ) - 30 CONTINUE -C - END IF -C - END IF - RETURN - END IF -C -C General case: l > 1 and BSN > 0. -C - I = 1 - L = BN - IF ( ECOND ) THEN -C -C Estimate the reciprocal condition numbers and set the ranks. -C - IF ( LOWER ) THEN -C -C Swap the diagonal elements of R and the elements of SDIAG -C and swap the upper and lower triangular parts of R, in order -C to find the numerical rank. Swap S and the transpose of the -C rectangular part of the last block column of R. -C - DO 50 K = 1, BN - CALL DSWAP( BSN, R(I,1), LDR+1, SDIAG(I), 1 ) -C - DO 40 J = 1, BSN - CALL DSWAP( BSN-J+1, R(I,J), LDR, R(I,J), 1 ) - I = I + 1 - 40 CONTINUE -C - 50 CONTINUE -C - IF ( ST.GT.0 ) THEN - CALL DSWAP( ST, R(I,BSN+1), LDR+1, SDIAG(I), 1 ) -C - DO 60 J = BSN + 1, NC - CALL DSWAP( NTHS, R(1,J), 1, S(J-BSN,1), LDS ) - CALL DSWAP( NC-J+1, R(I,J), LDR, R(I,J), 1 ) - I = I + 1 - 60 CONTINUE -C - END IF -C - END IF -C - I1 = 1 -C -C Determine rank(R_k) using incremental condition estimation. -C Workspace 2*MAX(BSN,ST). -C - DO 70 K = 1, BN - CALL MB03OD( 'No QR', BSN, BSN, R(I1,1), LDR, IPAR, TOLDEF, - $ SVLMAX, DWORK, RANKS(K), DUM, DWORK, LDWORK, - $ INFO ) - I1 = I1 + BSN - 70 CONTINUE -C - IF ( ST.GT.0 ) THEN - L = L + 1 - CALL MB03OD( 'No QR', ST, ST, R(I1,BSN+1), LDR, IPAR, - $ TOLDEF, SVLMAX, DWORK, RANKS(L), DUM, DWORK, - $ LDWORK, INFO ) - END IF -C - ELSEIF ( NCOND ) THEN -C -C Determine rank(R_k) by checking zero diagonal entries. -C - IF ( LOWER ) THEN -C - DO 90 K = 1, BN - RANK = BSN -C - DO 80 J = 1, BSN - IF ( SDIAG(I).EQ.ZERO .AND. RANK.EQ.BSN ) - $ RANK = J - 1 - I = I + 1 - 80 CONTINUE -C - RANKS(K) = RANK - 90 CONTINUE -C - IF ( ST.GT.0 ) THEN - L = L + 1 - RANK = ST -C - DO 100 J = 1, ST - IF ( SDIAG(I).EQ.ZERO .AND. RANK.EQ.ST ) - $ RANK = J - 1 - I = I + 1 - 100 CONTINUE -C - RANKS(L) = RANK - END IF -C - ELSE -C - DO 120 K = 1, BN - RANK = BSN -C - DO 110 J = 1, BSN - IF ( R(I,J).EQ.ZERO .AND. RANK.EQ.BSN ) - $ RANK = J - 1 - I = I + 1 - 110 CONTINUE -C - RANKS(K) = RANK - 120 CONTINUE -C - IF ( ST.GT.0 ) THEN - L = L + 1 - RANK = ST -C - DO 130 J = BSN + 1, NC - IF ( R(I,J).EQ.ZERO .AND. RANK.EQ.ST ) - $ RANK = J - BSN - 1 - I = I + 1 - 130 CONTINUE -C - RANKS(L) = RANK - END IF - END IF -C - ELSE -C -C Set the number of elements of RANKS. Then use the stored ranks. -C - IF ( ST.GT.0 ) - $ L = L + 1 - END IF -C -C Solve the triangular system for x. If the system is singular, -C then obtain a basic least squares solution. -C - DUM(1) = ZERO - IF ( LOWER .AND. .NOT.ECOND ) THEN -C - IF ( .NOT.TRANR ) THEN -C -C Solve R*x = b using back substitution, with R' stored in -C the arrays R, SDIAG and S. Swap diag(R) and SDIAG. -C - I1 = NTHS + 1 - IF ( ST.GT.0 ) THEN - RANK = RANKS(L) - IF ( RANK.LT.ST ) - $ CALL DCOPY( ST-RANK, DUM, 0, B(I1+RANK), 1 ) - CALL DSWAP( ST, R(I1,BSN+1), LDR+1, SDIAG(I1), 1 ) - CALL DTRSV( 'Lower', 'Transpose', 'NonUnit', RANK, - $ R(I1,BSN+1), LDR, B(I1), 1 ) - CALL DSWAP( ST, R(I1,BSN+1), LDR+1, SDIAG(I1), 1 ) - CALL DGEMV( 'Transpose', ST, NTHS, -ONE, S, LDS, - $ B(NTHS+1), 1, ONE, B, 1 ) - END IF -C - DO 140 K = BN, 1, -1 - I1 = I1 - BSN - RANK = RANKS(K) - IF ( RANK.LT.BSN ) - $ CALL DCOPY( BSN-RANK, DUM, 0, B(I1+RANK), 1 ) - CALL DSWAP( BSN, R(I1,1), LDR+1, SDIAG(I1), 1 ) - CALL DTRSV( 'Lower', 'Transpose', 'NonUnit', RANK, - $ R(I1,1), LDR, B(I1), 1 ) - CALL DSWAP( BSN, R(I1,1), LDR+1, SDIAG(I1), 1 ) - 140 CONTINUE -C - ELSE -C -C Solve R'*x = b using forward substitution, with R' stored in -C the arrays R, SDIAG and S. Swap diag(R) and SDIAG. -C - I1 = 1 - IF ( TRANR ) THEN - TRANSL = 'N' - ELSE - TRANSL = 'T' - END IF -C - DO 150 K = 1, BN - RANK = RANKS(K) - IF ( RANK.LT.BSN ) - $ CALL DCOPY( BSN-RANK, DUM, 0, B(I1+RANK), 1 ) - CALL DSWAP( BSN, R(I1,1), LDR+1, SDIAG(I1), 1 ) - CALL DTRSV( 'Lower', TRANSL, 'NonUnit', RANK, R(I1,1), - $ LDR, B(I1), 1 ) - CALL DSWAP( BSN, R(I1,1), LDR+1, SDIAG(I1), 1 ) - I1 = I1 + BSN - 150 CONTINUE -C - IF ( ST.GT.0 ) THEN - RANK = RANKS(L) - IF ( RANK.LT.ST ) - $ CALL DCOPY( ST-RANK, DUM, 0, B(I1+RANK), 1 ) - CALL DGEMV( 'NoTranspose', ST, NTHS, -ONE, S, LDS, B, 1, - $ ONE, B(I1), 1 ) - CALL DSWAP( ST, R(I1,BSN+1), LDR+1, SDIAG(I1), 1 ) - CALL DTRSV( 'Lower', TRANSL, 'NonUnit', RANK, - $ R(I1,BSN+1), LDR, B(I1), 1 ) - CALL DSWAP( ST, R(I1,BSN+1), LDR+1, SDIAG(I1), 1 ) - END IF -C - END IF -C - ELSE -C - IF ( .NOT.TRANR ) THEN -C -C Solve R*x = b using back substitution. -C - I1 = NTHS + 1 - IF ( ST.GT.0 ) THEN - RANK = RANKS(L) - IF ( RANK.LT.ST ) - $ CALL DCOPY( ST-RANK, DUM, 0, B(I1+RANK), 1 ) - CALL DTRSV( 'Upper', TRANS, 'NonUnit', RANK, R(I1,BSN+1), - $ LDR, B(I1), 1 ) - CALL DGEMV( TRANS, NTHS, ST, -ONE, R(1,BSN+1), LDR, - $ B(NTHS+1), 1, ONE, B, 1 ) - END IF -C - DO 160 K = BN, 1, -1 - I1 = I1 - BSN - RANK = RANKS(K) - IF ( RANK.LT.BSN ) - $ CALL DCOPY( BSN-RANK, DUM, 0, B(I1+RANK), 1 ) - CALL DTRSV( 'Upper', TRANS, 'NonUnit', RANK, R(I1,1), - $ LDR, B(I1), 1 ) - 160 CONTINUE -C - ELSE -C -C Solve R'*x = b using forward substitution. -C - I1 = 1 -C - DO 170 K = 1, BN - RANK = RANKS(K) - IF ( RANK.LT.BSN ) - $ CALL DCOPY( BSN-RANK, DUM, 0, B(I1+RANK), 1 ) - CALL DTRSV( 'Upper', TRANS, 'NonUnit', RANK, R(I1,1), - $ LDR, B(I1), 1 ) - I1 = I1 + BSN - 170 CONTINUE -C - IF ( ST.GT.0 ) THEN - RANK = RANKS(L) - IF ( RANK.LT.ST ) - $ CALL DCOPY( ST-RANK, DUM, 0, B(I1+RANK), 1 ) - CALL DGEMV( TRANS, NTHS, ST, -ONE, R(1,BSN+1), LDR, B, 1, - $ ONE, B(I1), 1 ) - CALL DTRSV( 'Upper', TRANS, 'NonUnit', RANK, R(I1,BSN+1), - $ LDR, B(I1), 1 ) - END IF -C - END IF - END IF -C - IF ( ECOND .AND. LOWER ) THEN - I = 1 -C -C If COND = 'E' and UPLO = 'L', swap the diagonal elements of R -C and the elements of SDIAG and swap back the upper and lower -C triangular parts of R, including the part corresponding to S. -C - DO 190 K = 1, BN - CALL DSWAP( BSN, R(I,1), LDR+1, SDIAG(I), 1 ) -C - DO 180 J = 1, BSN - CALL DSWAP( BSN-J+1, R(I,J), LDR, R(I,J), 1 ) - I = I + 1 - 180 CONTINUE -C - 190 CONTINUE -C - IF ( ST.GT.0 ) THEN - CALL DSWAP( ST, R(I,BSN+1), LDR+1, SDIAG(I), 1 ) -C - DO 200 J = BSN + 1, NC - CALL DSWAP( NTHS, R(1,J), 1, S(J-BSN,1), LDS ) - CALL DSWAP( NC-J+1, R(I,J), LDR, R(I,J), 1 ) - I = I + 1 - 200 CONTINUE -C - END IF -C - END IF -C - RETURN -C -C *** Last line of NF01BR *** - END diff --git a/mex/sources/libslicot/NF01BS.f b/mex/sources/libslicot/NF01BS.f deleted file mode 100644 index 3d7d6e5c9..000000000 --- a/mex/sources/libslicot/NF01BS.f +++ /dev/null @@ -1,610 +0,0 @@ - SUBROUTINE NF01BS( N, IPAR, LIPAR, FNORM, J, LDJ, E, JNORMS, - $ GNORM, IPVT, DWORK, LDWORK, INFO ) -C -C SLICOT RELEASE 5.0. -C -C Copyright (c) 2002-2009 NICONET e.V. -C -C This program is free software: you can redistribute it and/or -C modify it under the terms of the GNU General Public License as -C published by the Free Software Foundation, either version 2 of -C the License, or (at your option) any later version. -C -C This program is distributed in the hope that it will be useful, -C but WITHOUT ANY WARRANTY; without even the implied warranty of -C MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the -C GNU General Public License for more details. -C -C You should have received a copy of the GNU General Public License -C along with this program. If not, see -C . -C -C PURPOSE -C -C To compute the QR factorization of the Jacobian matrix J, as -C received in compressed form from SLICOT Library routine NF01BD, -C -C / dy(1)/dwb(1) | dy(1)/ dtheta \ -C Jc = | : | : | , -C \ dy(L)/dwb(L) | dy(L)/ dtheta / -C -C and to apply the transformation Q on the error vector e (in-situ). -C The factorization is J*P = Q*R, where Q is a matrix with -C orthogonal columns, P a permutation matrix, and R an upper -C trapezoidal matrix with diagonal elements of nonincreasing -C magnitude for each block column (see below). The 1-norm of the -C scaled gradient is also returned. -C -C Actually, the Jacobian J has the block form -C -C dy(1)/dwb(1) 0 ..... 0 dy(1)/dtheta -C 0 dy(2)/dwb(2) ..... 0 dy(2)/dtheta -C ..... ..... ..... ..... ..... -C 0 ..... 0 dy(L)/dwb(L) dy(L)/dtheta -C -C but the zero blocks are omitted. The diagonal blocks have the -C same size and correspond to the nonlinear part. The last block -C column corresponds to the linear part. It is assumed that the -C Jacobian matrix has at least as many rows as columns. The linear -C or nonlinear parts can be empty. If L <= 1, the Jacobian is -C represented as a full matrix. -C -C ARGUMENTS -C -C Input/Output Parameters -C -C N (input) INTEGER -C The number of columns of the Jacobian matrix J. -C N = BN*BSN + ST >= 0. (See parameter description below.) -C -C IPAR (input) INTEGER array, dimension (LIPAR) -C The integer parameters describing the structure of the -C matrix J, as follows: -C IPAR(1) must contain ST, the number of parameters -C corresponding to the linear part. ST >= 0. -C IPAR(2) must contain BN, the number of blocks, BN = L, -C for the parameters corresponding to the nonlinear -C part. BN >= 0. -C IPAR(3) must contain BSM, the number of rows of the blocks -C J_k = dy(k)/dwb(k), k = 1:BN, if BN > 0, or the -C number of rows of the matrix J, if BN <= 1. -C BN*BSM >= N, if BN > 0; -C BSM >= N, if BN = 0. -C IPAR(4) must contain BSN, the number of columns of the -C blocks J_k, k = 1:BN. BSN >= 0. -C -C LIPAR (input) INTEGER -C The length of the array IPAR. LIPAR >= 4. -C -C FNORM (input) DOUBLE PRECISION -C The Euclidean norm of the vector e. FNORM >= 0. -C -C J (input/output) DOUBLE PRECISION array, dimension (LDJ, NC) -C where NC = N if BN <= 1, and NC = BSN+ST, if BN > 1. -C On entry, the leading NR-by-NC part of this array must -C contain the (compressed) representation (Jc) of the -C Jacobian matrix J, where NR = BSM if BN <= 1, and -C NR = BN*BSM, if BN > 1. -C On exit, the leading N-by-NC part of this array contains -C a (compressed) representation of the upper triangular -C factor R of the Jacobian matrix. The matrix R has the same -C structure as the Jacobian matrix J, but with an additional -C diagonal block. Note that for efficiency of the later -C calculations, the matrix R is delivered with the leading -C dimension MAX(1,N), possibly much smaller than the value -C of LDJ on entry. -C -C LDJ (input/output) INTEGER -C The leading dimension of array J. -C On entry, LDJ >= MAX(1,NR). -C On exit, LDJ >= MAX(1,N). -C -C E (input/output) DOUBLE PRECISION array, dimension (NR) -C On entry, this array contains the vector e, -C e = vec( Y - y ), where Y is set of output samples, and -C vec denotes the concatenation of the columns of a matrix. -C On exit, this array contains the updated vector Z*Q'*e, -C where Z is the block row permutation matrix used in the -C QR factorization of J (see METHOD). -C -C JNORMS (output) DOUBLE PRECISION array, dimension (N) -C This array contains the Euclidean norms of the columns -C of the Jacobian matrix, considered in the initial order. -C -C GNORM (output) DOUBLE PRECISION -C If FNORM > 0, the 1-norm of the scaled vector J'*e/FNORM, -C with each element i further divided by JNORMS(i) (if -C JNORMS(i) is nonzero). -C If FNORM = 0, the returned value of GNORM is 0. -C -C IPVT (output) INTEGER array, dimension (N) -C This array defines the permutation matrix P such that -C J*P = Q*R. Column j of P is column IPVT(j) of the identity -C matrix. -C -C Workspace -C -C DWORK DOUBLE PRECISION array, dimension (LDWORK) -C On exit, if INFO = 0, DWORK(1) returns the optimal value -C of LDWORK. -C -C LDWORK INTEGER -C The length of the array DWORK. -C LDWORK >= 1, if N = 0 or BN <= 1 and BSM = N = 1; -C otherwise, -C LDWORK >= 4*N+1, if BN <= 1 or BSN = 0; -C LDWORK >= JWORK, if BN > 1 and BSN > 0, where JWORK is -C given by the following procedure: -C JWORK = BSN + MAX(3*BSN+1,ST); -C JWORK = MAX(JWORK,4*ST+1), if BSM > BSN; -C JWORK = MAX(JWORK,(BSM-BSN)*(BN-1)), -C if BSN < BSM < 2*BSN. -C For optimum performance LDWORK should be larger. -C -C Error Indicator -C -C INFO INTEGER -C = 0: successful exit; -C < 0: if INFO = -i, the i-th argument had an illegal -C value. -C -C METHOD -C -C A QR factorization with column pivoting of the matrix J is -C computed, J*P = Q*R. -C -C If l = L > 1, the R factor of the QR factorization has the same -C structure as the Jacobian, but with an additional diagonal block. -C Denote -C -C / J_1 0 .. 0 | L_1 \ -C | 0 J_2 .. 0 | L_2 | -C J = | : : .. : | : | . -C | : : .. : | : | -C \ 0 0 .. J_l | L_l / -C -C The algorithm consists in two phases. In the first phase, the -C algorithm uses QR factorizations with column pivoting for each -C block J_k, k = 1:l, and applies the orthogonal matrix Q'_k to the -C corresponding part of the last block column and of e. After all -C block rows have been processed, the block rows are interchanged -C so that the zeroed submatrices in the first l block columns are -C moved to the bottom part. The same block row permutation Z is -C also applied to the vector e. At the end of the first phase, -C the structure of the processed matrix J is -C -C / R_1 0 .. 0 | L^1_1 \ -C | 0 R_2 .. 0 | L^1_2 | -C | : : .. : | : | . -C | : : .. : | : | -C | 0 0 .. R_l | L^1_l | -C | 0 0 .. 0 | L^2_1 | -C | : : .. : | : | -C \ 0 0 .. 0 | L^2_l / -C -C In the second phase, the submatrix L^2_1:l is triangularized -C using an additional QR factorization with pivoting. (The columns -C of L^1_1:l are also permuted accordingly.) Therefore, the column -C pivoting is restricted to each such local block column. -C -C If l <= 1, the matrix J is triangularized in one phase, by one -C QR factorization with pivoting. In this case, the column -C pivoting is global. -C -C CONTRIBUTORS -C -C V. Sima, Research Institute for Informatics, Bucharest, Dec. 2001. -C -C REVISIONS -C -C Feb. 22, 2004. -C -C KEYWORDS -C -C Elementary matrix operations, Jacobian matrix, matrix algebra, -C matrix operations, Wiener system. -C -C ****************************************************************** -C -C .. Parameters .. - DOUBLE PRECISION ZERO, ONE - PARAMETER ( ZERO = 0.0D0, ONE = 1.0D0 ) -C .. Scalar Arguments .. - INTEGER INFO, LDJ, LDWORK, LIPAR, N - DOUBLE PRECISION FNORM, GNORM -C .. Array Arguments .. - INTEGER IPAR(*), IPVT(*) - DOUBLE PRECISION DWORK(*), E(*), J(*), JNORMS(*) -C .. Local Scalars .. - INTEGER BN, BSM, BSN, I, IBSM, IBSN, IBSNI, ITAU, JL, - $ JLM, JWORK, K, L, M, MMN, NTHS, ST, WRKOPT - DOUBLE PRECISION SUM -C .. External Functions .. - DOUBLE PRECISION DDOT, DNRM2 - EXTERNAL DDOT, DNRM2 -C .. External Subroutines .. - EXTERNAL DCOPY, DGEQP3, DLACPY, DLAPMT, DORMQR, DSWAP, - $ MD03BX, XERBLA -C .. Intrinsic Functions .. - INTRINSIC ABS, INT, MAX, MIN -C .. -C .. Executable Statements .. -C - INFO = 0 - IF ( N.LT.0 ) THEN - INFO = -1 - ELSEIF( LIPAR.LT.4 ) THEN - INFO = -3 - ELSEIF ( FNORM.LT.ZERO ) THEN - INFO = -4 - ELSEIF ( LDJ.LT.MAX( 1, N ) ) THEN - INFO = -6 - ELSE - ST = IPAR(1) - BN = IPAR(2) - BSM = IPAR(3) - BSN = IPAR(4) - NTHS = BN*BSN - MMN = BSM - BSN - IF ( BN.GT.0 ) THEN - M = BN*BSM - ELSE - M = N - END IF - IF ( MIN( ST, BN, BSM, BSN ).LT.0 ) THEN - INFO = -2 - ELSEIF ( N.NE.NTHS + ST ) THEN - INFO = -1 - ELSEIF ( M.LT.N ) THEN - INFO = -2 - ELSEIF ( LDJ.LT.MAX( 1, M ) ) THEN - INFO = -6 - ELSE - IF ( N.EQ.0 ) THEN - JWORK = 1 - ELSEIF ( BN.LE.1 .OR. BSN.EQ.0 ) THEN - IF ( BN.LE.1 .AND. BSM.EQ.1 .AND. N.EQ.1 ) THEN - JWORK = 1 - ELSE - JWORK = 4*N + 1 - END IF - ELSE - JWORK = BSN + MAX( 3*BSN + 1, ST ) - IF ( BSM.GT.BSN ) THEN - JWORK = MAX( JWORK, 4*ST + 1 ) - IF ( BSM.LT.2*BSN ) - $ JWORK = MAX( JWORK, MMN*( BN - 1 ) ) - END IF - END IF - IF ( LDWORK.LT.JWORK ) - $ INFO = -12 - END IF - END IF -C - IF ( INFO.NE.0 ) THEN -C -C Error return. -C - CALL XERBLA( 'NF01BS', -INFO ) - RETURN - END IF -C -C Quick return if possible. -C - GNORM = ZERO - IF ( N.EQ.0 ) THEN - LDJ = 1 - DWORK(1) = ONE - RETURN - END IF -C - IF ( BN.LE.1 .OR. BSN.EQ.0 ) THEN -C -C Special case, l <= 1 or BSN = 0: the Jacobian is represented -C as a full matrix. -C (Note: Comments in the code beginning "Workspace:" describe the -C minimal amount of real workspace needed at that point in the -C code, as well as the preferred amount for good performance. -C NB refers to the optimal block size for the immediately -C following subroutine, as returned by ILAENV.) -C -C Workspace: need: 4*N + 1; -C prefer: 3*N + ( N+1 )*NB. -C - CALL MD03BX( M, N, FNORM, J, LDJ, E, JNORMS, GNORM, IPVT, - $ DWORK, LDWORK, INFO ) - RETURN - END IF -C -C General case: l > 1 and BSN > 0. -C Initialize the column pivoting indices. -C - DO 10 I = 1, N - IPVT(I) = 0 - 10 CONTINUE -C -C Compute the QR factorization with pivoting of J. -C Pivoting is done separately on each block column of J. -C - WRKOPT = 1 - IBSN = 1 - JL = LDJ*BSN + 1 - JWORK = BSN + 1 -C - DO 30 IBSM = 1, M, BSM -C -C Compute the QR factorization with pivoting of J_k, and apply Q' -C to the corresponding part of the last block-column and of e. -C Workspace: need: 4*BSN + 1; -C prefer: 3*BSN + ( BSN+1 )*NB. -C - CALL DGEQP3( BSM, BSN, J(IBSM), LDJ, IPVT(IBSN), DWORK, - $ DWORK(JWORK), LDWORK-JWORK+1, INFO ) - WRKOPT = MAX( WRKOPT, INT( DWORK(JWORK) ) + JWORK - 1 ) - IF ( IBSM.GT.1 ) THEN -C -C Adjust the column pivoting indices. -C - DO 20 I = IBSN, IBSN + BSN - 1 - IPVT(I) = IPVT(I) + IBSN - 1 - 20 CONTINUE -C - END IF -C - IF ( ST.GT.0 ) THEN -C -C Workspace: need: BSN + ST; -C prefer: BSN + ST*NB. -C - CALL DORMQR( 'Left', 'Transpose', BSM, ST, BSN, J(IBSM), - $ LDJ, DWORK, J(JL), LDJ, DWORK(JWORK), - $ LDWORK-JWORK+1, INFO ) - WRKOPT = MAX( WRKOPT, INT( DWORK(JWORK) ) + JWORK - 1 ) - END IF -C -C Workspace: need: BSN + 1; -C prefer: BSN + NB. -C - CALL DORMQR( 'Left', 'Transpose', BSM, 1, BSN, J(IBSM), LDJ, - $ DWORK, E(IBSM), BSM, DWORK(JWORK), LDWORK-JWORK+1, - $ INFO ) - JL = JL + BSM - IBSN = IBSN + BSN - 30 CONTINUE -C - IF ( MMN.GT.0 ) THEN -C -C Case BSM > BSN. -C Compute the original column norms for the first block column -C of Jc. -C Permute the rows of the first block column to move the zeroed -C submatrices to the bottom. In the same loops, reshape the -C first block column of R to have the leading dimension N. -C - L = IPVT(1) - JNORMS(L) = ABS( J(1) ) - IBSM = BSM + 1 - IBSN = BSN + 1 -C - DO 40 K = 1, BN - 1 - J(IBSN) = J(IBSM) - L = IPVT(IBSN) - JNORMS(L) = ABS( J(IBSN) ) - IBSM = IBSM + BSM - IBSN = IBSN + BSN - 40 CONTINUE -C - IBSN = IBSN + ST -C - DO 60 I = 2, BSN - IBSM = ( I - 1 )*LDJ + 1 - JL = I -C - DO 50 K = 1, BN -C - DO 45 L = 0, I - 1 - J(IBSN+L) = J(IBSM+L) - 45 CONTINUE -C - L = IPVT(JL) - JNORMS(L) = DNRM2( I, J(IBSN), 1 ) - IBSM = IBSM + BSM - IBSN = IBSN + BSN - JL = JL + BSN - 50 CONTINUE -C - IBSN = IBSN + ST - 60 CONTINUE -C -C Permute the rows of the second block column of Jc and of -C the vector e. -C - JL = LDJ*BSN - IF ( BSM.GE.2*BSN ) THEN -C -C A swap operation can be used. -C - DO 80 I = 1, ST - IBSN = BSN + 1 -C - DO 70 IBSM = BSM + 1, M, BSM - CALL DSWAP( MMN, J(JL+IBSM), 1, J(JL+IBSN), 1 ) - IBSN = IBSN + BSN - 70 CONTINUE -C - JL = JL + LDJ - 80 CONTINUE -C -C Permute the rows of e. -C - IBSN = BSN + 1 -C - DO 90 IBSM = BSM + 1, M, BSM - CALL DSWAP( MMN, E(IBSM), 1, E(IBSN), 1 ) - IBSN = IBSN + BSN - 90 CONTINUE -C - ELSE -C -C A swap operation cannot be used. -C Workspace: need: ( BSM-BSN )*( BN-1 ). -C - DO 110 I = 1, ST - IBSN = BSN + 1 - JLM = JL + IBSN - JWORK = 1 -C - DO 100 IBSM = BSM + 1, M, BSM - CALL DCOPY( MMN, J(JLM), 1, DWORK(JWORK), 1 ) -C - DO 105 K = JL, JL + BSN - 1 - J(IBSN+K) = J(IBSM+K) - 105 CONTINUE -C - JLM = JLM + BSM - IBSN = IBSN + BSN - JWORK = JWORK + MMN - 100 CONTINUE -C - CALL DCOPY( MMN*( BN-1 ), DWORK, 1, J(JL+IBSN), 1 ) - JL = JL + LDJ - 110 CONTINUE -C -C Permute the rows of e. -C - IBSN = BSN + 1 - JLM = IBSN - JWORK = 1 -C - DO 120 IBSM = BSM + 1, M, BSM - CALL DCOPY( MMN, E(JLM), 1, DWORK(JWORK), 1 ) -C - DO 115 K = 0, BSN - 1 - E(IBSN+K) = E(IBSM+K) - 115 CONTINUE -C - JLM = JLM + BSM - IBSN = IBSN + BSN - JWORK = JWORK + MMN - 120 CONTINUE -C - CALL DCOPY( MMN*( BN-1 ), DWORK, 1, E(IBSN), 1 ) - END IF -C - IF ( ST.GT.0 ) THEN -C -C Compute the QR factorization with pivoting of the submatrix -C L^2_1:l, and apply Q' to the corresponding part of e. -C -C Workspace: need: 4*ST + 1; -C prefer: 3*ST + ( ST+1 )*NB. -C - JL = ( LDJ + BN )*BSN + 1 - ITAU = 1 - JWORK = ITAU + ST - CALL DGEQP3( MMN*BN, ST, J(JL), LDJ, IPVT(NTHS+1), - $ DWORK(ITAU), DWORK(JWORK), LDWORK-JWORK+1, - $ INFO ) - WRKOPT = MAX( WRKOPT, INT( DWORK(JWORK) ) + JWORK - 1 ) -C -C Permute columns of the upper part of the second block -C column of Jc. -C - CALL DLAPMT( .TRUE., NTHS, ST, J(JL-NTHS), LDJ, - $ IPVT(NTHS+1) ) -C -C Adjust the column pivoting indices. -C - DO 130 I = NTHS + 1, N - IPVT(I) = IPVT(I) + NTHS - 130 CONTINUE -C -C Workspace: need: ST + 1; -C prefer: ST + NB. -C - CALL DORMQR( 'Left', 'Transpose', MMN*BN, 1, ST, J(JL), LDJ, - $ DWORK(ITAU), E(IBSN), LDJ, DWORK(JWORK), - $ LDWORK-JWORK+1, INFO ) - WRKOPT = MAX( WRKOPT, INT( DWORK(JWORK) ) + JWORK - 1 ) -C -C Reshape the second block column of R to have the leading -C dimension N. -C - IBSN = N*BSN + 1 - CALL DLACPY( 'Full', N, ST, J(LDJ*BSN+1), LDJ, J(IBSN), N ) -C -C Compute the original column norms for the second block -C column. -C - DO 140 I = NTHS + 1, N - L = IPVT(I) - JNORMS(L) = DNRM2( I, J(IBSN), 1 ) - IBSN = IBSN + N - 140 CONTINUE -C - END IF -C - ELSE -C -C Case BSM = BSN. -C Compute the original column norms for the first block column -C of Jc. -C - IBSN = 1 -C - DO 160 I = 1, BSN - JL = I -C - DO 150 K = 1, BN - L = IPVT(JL) - JNORMS(L) = DNRM2( I, J(IBSN), 1 ) - IBSN = IBSN + BSN - JL = JL + BSN - 150 CONTINUE -C - IBSN = IBSN + ST - 160 CONTINUE -C - DO 170 I = NTHS + 1, N - IPVT(I) = I - 170 CONTINUE -C - END IF -C -C Compute the norm of the scaled gradient. -C - IF ( FNORM.NE.ZERO ) THEN -C - DO 190 IBSN = 1, NTHS, BSN - IBSNI = IBSN -C - DO 180 I = 1, BSN - L = IPVT(IBSN+I-1) - IF ( JNORMS(L).NE.ZERO ) THEN - SUM = DDOT( I, J(IBSNI), 1, E(IBSN), 1 )/FNORM - GNORM = MAX( GNORM, ABS( SUM/JNORMS(L) ) ) - END IF - IBSNI = IBSNI + N - 180 CONTINUE -C - 190 CONTINUE -C - IBSNI = N*BSN + 1 -C - DO 200 I = NTHS + 1, N - L = IPVT(I) - IF ( JNORMS(L).NE.ZERO ) THEN - SUM = DDOT( I, J(IBSNI), 1, E, 1 )/FNORM - GNORM = MAX( GNORM, ABS( SUM/JNORMS(L) ) ) - END IF - IBSNI = IBSNI + N - 200 CONTINUE -C - END IF -C - LDJ = N - DWORK(1) = WRKOPT - RETURN -C -C *** Last line of NF01BS *** - END diff --git a/mex/sources/libslicot/NF01BU.f b/mex/sources/libslicot/NF01BU.f deleted file mode 100644 index 502959cdd..000000000 --- a/mex/sources/libslicot/NF01BU.f +++ /dev/null @@ -1,398 +0,0 @@ - SUBROUTINE NF01BU( STOR, UPLO, N, IPAR, LIPAR, DPAR, LDPAR, J, - $ LDJ, JTJ, LDJTJ, DWORK, LDWORK, INFO ) -C -C SLICOT RELEASE 5.0. -C -C Copyright (c) 2002-2009 NICONET e.V. -C -C This program is free software: you can redistribute it and/or -C modify it under the terms of the GNU General Public License as -C published by the Free Software Foundation, either version 2 of -C the License, or (at your option) any later version. -C -C This program is distributed in the hope that it will be useful, -C but WITHOUT ANY WARRANTY; without even the implied warranty of -C MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the -C GNU General Public License for more details. -C -C You should have received a copy of the GNU General Public License -C along with this program. If not, see -C . -C -C PURPOSE -C -C To compute the matrix J'*J + c*I, for the Jacobian J as received -C from SLICOT Library routine NF01BD: -C -C / dy(1)/dwb(1) | dy(1)/dtheta \ -C Jc = | : | : | . -C \ dy(L)/dwb(L) | dy(L)/dtheta / -C -C This is a compressed representation of the actual structure -C -C / J_1 0 .. 0 | L_1 \ -C | 0 J_2 .. 0 | L_2 | -C J = | : : .. : | : | . -C | : : .. : | : | -C \ 0 0 .. J_L | L_L / -C -C ARGUMENTS -C -C Mode Parameters -C -C STOR CHARACTER*1 -C Specifies the storage scheme for the symmetric -C matrix J'*J + c*I, as follows: -C = 'F' : full storage is used; -C = 'P' : packed storage is used. -C -C UPLO CHARACTER*1 -C Specifies which part of the matrix J'*J + c*I is stored, -C as follows: -C = 'U' : the upper triagular part is stored; -C = 'L' : the lower triagular part is stored. -C -C Input/Output Parameters -C -C N (input) INTEGER -C The order of the matrix J'*J + c*I. -C N = BN*BSN + ST >= 0. (See parameter description below.) -C -C IPAR (input) INTEGER array, dimension (LIPAR) -C The integer parameters describing the structure of the -C matrix J, as follows: -C IPAR(1) must contain ST, the number of parameters -C corresponding to the linear part. ST >= 0. -C IPAR(2) must contain BN, the number of blocks, BN = L, -C for the parameters corresponding to the nonlinear -C part. BN >= 0. -C IPAR(3) must contain BSM, the number of rows of the blocks -C J_k = dy(k)/dwb(k), k = 1:BN, if BN > 0, or the -C number of rows of the matrix J, if BN <= 1. -C IPAR(4) must contain BSN, the number of columns of the -C blocks J_k, k = 1:BN. BSN >= 0. -C -C LIPAR (input) INTEGER -C The length of the array IPAR. LIPAR >= 4. -C -C DPAR (input) DOUBLE PRECISION array, dimension (LDPAR) -C The real parameters needed for solving the problem. -C The entry DPAR(1) must contain the real scalar c. -C -C LDPAR (input) INTEGER -C The length of the array DPAR. LDPAR >= 1. -C -C J (input) DOUBLE PRECISION array, dimension (LDJ, NC) -C where NC = N if BN <= 1, and NC = BSN+ST, if BN > 1. -C The leading NR-by-NC part of this array must contain -C the (compressed) representation (Jc) of the Jacobian -C matrix J, where NR = BSM if BN <= 1, and NR = BN*BSM, -C if BN > 1. -C -C LDJ (input) INTEGER -C The leading dimension of array J. LDJ >= MAX(1,NR). -C -C JTJ (output) DOUBLE PRECISION array, -C dimension (LDJTJ,N), if STOR = 'F', -C dimension (N*(N+1)/2), if STOR = 'P'. -C The leading N-by-N (if STOR = 'F'), or N*(N+1)/2 (if -C STOR = 'P') part of this array contains the upper or -C lower triangle of the matrix J'*J + c*I, depending on -C UPLO = 'U', or UPLO = 'L', respectively, stored either as -C a two-dimensional, or one-dimensional array, depending -C on STOR. -C -C LDJTJ INTEGER -C The leading dimension of the array JTJ. -C LDJTJ >= MAX(1,N), if STOR = 'F'. -C LDJTJ >= 1, if STOR = 'P'. -C -C Workspace -C -C DWORK DOUBLE PRECISION array, dimension (LDWORK) -C Currently, this array is not used. -C -C LDWORK INTEGER -C The length of the array DWORK. LDWORK >= 0. -C -C Error Indicator -C -C INFO INTEGER -C = 0: successful exit; -C < 0: if INFO = -i, the i-th argument had an illegal -C value. -C -C METHOD -C -C The matrix product is computed columnn-wise, exploiting the -C symmetry. BLAS 3 routines DGEMM and DSYRK are used if STOR = 'F', -C and BLAS 2 routine DGEMV is used if STOR = 'P'. -C -C CONTRIBUTORS -C -C V. Sima, Research Institute for Informatics, Bucharest, Apr. 2001. -C -C REVISIONS -C -C V. Sima, Dec. 2001, Mar. 2002. -C -C KEYWORDS -C -C Elementary matrix operations, matrix algebra, matrix operations, -C Wiener system. -C -C ****************************************************************** -C -C .. Parameters .. - DOUBLE PRECISION ZERO, ONE - PARAMETER ( ZERO = 0.0D0, ONE = 1.0D0 ) -C .. Scalar Arguments .. - CHARACTER STOR, UPLO - INTEGER INFO, LDJ, LDJTJ, LDPAR, LDWORK, LIPAR, N -C .. Array Arguments .. - DOUBLE PRECISION DPAR(*), DWORK(*), J(LDJ,*), JTJ(*) - INTEGER IPAR(*) -C .. Local Scalars .. - LOGICAL FULL, UPPER - INTEGER BN, BSM, BSN, I1, IBSM, IBSN, II, JL, K, M, - $ NBSN, NTHS, ST - DOUBLE PRECISION C -C .. Local Arrays .. - DOUBLE PRECISION TMP(1) - INTEGER ITMP(1) -C .. External Functions .. - LOGICAL LSAME - EXTERNAL LSAME -C .. External Subroutines .. - EXTERNAL DCOPY, DGEMM, DGEMV, DLASET, DSYRK, NF01BV, - $ XERBLA -C .. Intrinsic Functions .. - INTRINSIC MAX, MIN -C .. -C .. Executable Statements .. -C - INFO = 0 -C - FULL = LSAME( STOR, 'F' ) - UPPER = LSAME( UPLO, 'U' ) -C - IF( .NOT.( FULL .OR. LSAME( STOR, 'P' ) ) ) THEN - INFO = -1 - ELSEIF ( .NOT.( UPPER .OR. LSAME( UPLO, 'L' ) ) ) THEN - INFO = -2 - ELSEIF ( N.LT.0 ) THEN - INFO = -3 - ELSEIF ( LIPAR.LT.4 ) THEN - INFO = -5 - ELSEIF ( LDPAR.LT.1 ) THEN - INFO = -7 - ELSEIF ( LDJTJ.LT.1 .OR. ( FULL .AND. LDJTJ.LT.N ) ) THEN - INFO = -11 - ELSEIF ( LDWORK.LT.0 ) THEN - INFO = -13 - ELSE - ST = IPAR(1) - BN = IPAR(2) - BSM = IPAR(3) - BSN = IPAR(4) - NTHS = BN*BSN - IF ( BN.GT.1 ) THEN - M = BN*BSM - ELSE - M = BSM - END IF - IF ( MIN( ST, BN, BSM, BSN ).LT.0 ) THEN - INFO = -4 - ELSEIF ( N.NE.NTHS + ST ) THEN - INFO = -3 - ELSEIF ( LDJ.LT.MAX( 1, M ) ) THEN - INFO = -9 - END IF - ENDIF -C -C Return if there are illegal arguments. -C - IF( INFO.NE.0 ) THEN - CALL XERBLA( 'NF01BU', -INFO ) - RETURN - ENDIF -C -C Quick return if possible. -C - IF ( N.EQ.0 ) - $ RETURN -C - C = DPAR(1) -C - IF ( BN.LE.1 .OR. BSN.EQ.0 .OR. BSM.EQ.0 ) THEN -C -C Special case, l <= 1 or BSN = 0 or BSM = 0: the Jacobian is -C represented as a full matrix. -C - ITMP(1) = M - CALL NF01BV( STOR, UPLO, N, ITMP, 1, DPAR, 1, J, LDJ, JTJ, - $ LDJTJ, DWORK, LDWORK, INFO ) - RETURN - END IF -C -C General case: l > 1, BSN > 0, BSM > 0. -C - JL = BSN + 1 -C - IF ( FULL ) THEN -C - NBSN = N*BSN -C - IF ( UPPER ) THEN -C -C Compute the leading upper triangular part (full storage). -C - CALL DLASET( UPLO, BSN, BSN, ZERO, C, JTJ, LDJTJ ) - CALL DSYRK( UPLO, 'Transpose', BSN, BSM, ONE, J, LDJ, ONE, - $ JTJ, LDJTJ ) - IBSN = BSN - I1 = NBSN + 1 -C - DO 10 IBSM = BSM + 1, M, BSM - II = I1 + IBSN - CALL DLASET( 'Full', IBSN, BSN, ZERO, ZERO, JTJ(I1), - $ LDJTJ ) - I1 = I1 + NBSN - CALL DLASET( UPLO, BSN, BSN, ZERO, C, JTJ(II), LDJTJ ) - CALL DSYRK( UPLO, 'Transpose', BSN, BSM, ONE, J(IBSM,1), - $ LDJ, ONE, JTJ(II), LDJTJ ) - IBSN = IBSN + BSN - 10 CONTINUE -C - IF ( ST.GT.0 ) THEN -C -C Compute the last block column. -C - DO 20 IBSM = 1, M, BSM - CALL DGEMM( 'Transpose', 'NoTranspose', BSN, ST, BSM, - $ ONE, J(IBSM,1), LDJ, J(IBSM,JL), LDJ, - $ ZERO, JTJ(I1), LDJTJ ) - I1 = I1 + BSN - 20 CONTINUE -C - CALL DLASET( UPLO, ST, ST, ZERO, C, JTJ(I1), LDJTJ ) - CALL DSYRK( UPLO, 'Transpose', ST, M, ONE, J(1,JL), - $ LDJ, ONE, JTJ(I1), LDJTJ ) - END IF -C - ELSE -C -C Compute the leading lower triangular part (full storage). -C - IBSN = NTHS - II = 1 -C - DO 30 IBSM = 1, M, BSM - I1 = II + BSN - CALL DLASET( UPLO, BSN, BSN, ZERO, C, JTJ(II), LDJTJ ) - CALL DSYRK( UPLO, 'Transpose', BSN, BSM, ONE, J(IBSM,1), - $ LDJ, ONE, JTJ(II), LDJTJ ) - IBSN = IBSN - BSN - CALL DLASET( 'Full', IBSN, BSN, ZERO, ZERO, JTJ(I1), - $ LDJTJ ) - II = I1 + NBSN - IF ( ST.GT.0 ) - $ CALL DGEMM( 'Transpose', 'NoTranspose', ST, BSN, BSM, - $ ONE, J(IBSM,JL), LDJ, J(IBSM,1), LDJ, - $ ZERO, JTJ(I1+IBSN), LDJTJ ) - 30 CONTINUE -C - IF ( ST.GT.0 ) THEN -C -C Compute the last diagonal block. -C - CALL DLASET( UPLO, ST, ST, ZERO, C, JTJ(II), LDJTJ ) - CALL DSYRK( UPLO, 'Transpose', ST, M, ONE, J(1,JL), - $ LDJ, ONE, JTJ(II), LDJTJ ) - END IF -C - END IF -C - ELSE -C - TMP(1) = ZERO -C - IF ( UPPER ) THEN -C -C Compute the leading upper triangular part (packed storage). -C - IBSN = 0 - I1 = 1 -C - DO 50 IBSM = 1, M, BSM -C - DO 40 K = 1, BSN - II = I1 + IBSN - CALL DCOPY( IBSN, TMP, 0, JTJ(I1), 1 ) - CALL DGEMV( 'Transpose', BSM, K, ONE, J(IBSM,1), LDJ, - $ J(IBSM,K), 1, ZERO, JTJ(II), 1 ) - I1 = II + K - JTJ(I1-1) = JTJ(I1-1) + C - 40 CONTINUE -C - IBSN = IBSN + BSN - 50 CONTINUE -C -C Compute the last block column. -C - DO 70 K = 1, ST -C - DO 60 IBSM = 1, M, BSM - CALL DGEMV( 'Transpose', BSM, BSN, ONE, J(IBSM,1), - $ LDJ, J(IBSM,BSN+K), 1, ZERO, JTJ(I1), 1 ) - I1 = I1 + BSN - 60 CONTINUE -C - CALL DGEMV( 'Transpose', M, K, ONE, J(1,JL), LDJ, - $ J(1,BSN+K), 1, ZERO, JTJ(I1), 1 ) - I1 = I1 + K - JTJ(I1-1) = JTJ(I1-1) + C - 70 CONTINUE -C - ELSE -C -C Compute the leading lower triangular part (packed storage). -C - IBSN = NTHS - II = 1 -C - DO 90 IBSM = 1, M, BSM - IBSN = IBSN - BSN -C - DO 80 K = 1, BSN - I1 = II + BSN - K + 1 - CALL DCOPY( IBSN, TMP, 0, JTJ(I1), 1 ) - CALL DGEMV( 'Transpose', BSM, BSN-K+1, ONE, J(IBSM,K), - $ LDJ, J(IBSM,K), 1, ZERO, JTJ(II), 1 ) - JTJ(II) = JTJ(II) + C - I1 = I1 + IBSN - II = I1 + ST - IF ( ST.GT.0 ) - $ CALL DGEMV( 'Transpose', BSM, ST, ONE, J(IBSM,JL), - $ LDJ, J(IBSM,K), 1, ZERO, JTJ(I1), 1 ) - 80 CONTINUE -C - 90 CONTINUE -C -C Compute the last diagonal block. -C - DO 100 K = 1, ST - CALL DGEMV( 'Transpose', M, ST-K+1, ONE, J(1,BSN+K), LDJ, - $ J(1,BSN+K), 1, ZERO, JTJ(II), 1 ) - JTJ(II) = JTJ(II) + C - II = II + ST - K + 1 - 100 CONTINUE -C - END IF -C - END IF -C - RETURN -C -C *** Last line of NF01BU *** - END diff --git a/mex/sources/libslicot/NF01BV.f b/mex/sources/libslicot/NF01BV.f deleted file mode 100644 index d596ec50a..000000000 --- a/mex/sources/libslicot/NF01BV.f +++ /dev/null @@ -1,249 +0,0 @@ - SUBROUTINE NF01BV( STOR, UPLO, N, IPAR, LIPAR, DPAR, LDPAR, J, - $ LDJ, JTJ, LDJTJ, DWORK, LDWORK, INFO ) -C -C SLICOT RELEASE 5.0. -C -C Copyright (c) 2002-2009 NICONET e.V. -C -C This program is free software: you can redistribute it and/or -C modify it under the terms of the GNU General Public License as -C published by the Free Software Foundation, either version 2 of -C the License, or (at your option) any later version. -C -C This program is distributed in the hope that it will be useful, -C but WITHOUT ANY WARRANTY; without even the implied warranty of -C MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the -C GNU General Public License for more details. -C -C You should have received a copy of the GNU General Public License -C along with this program. If not, see -C . -C -C PURPOSE -C -C To compute the matrix J'*J + c*I, for the Jacobian J as received -C from SLICOT Library routine NF01BY, for one output variable. -C -C NOTE: this routine must have the same arguments as SLICOT Library -C routine NF01BU. -C -C ARGUMENTS -C -C Mode Parameters -C -C STOR CHARACTER*1 -C Specifies the storage scheme for the symmetric -C matrix J'*J + c*I, as follows: -C = 'F' : full storage is used; -C = 'P' : packed storage is used. -C -C UPLO CHARACTER*1 -C Specifies which part of the matrix J'*J + c*I is stored, -C as follows: -C = 'U' : the upper triagular part is stored; -C = 'L' : the lower triagular part is stored. -C -C Input/Output Parameters -C -C N (input) INTEGER -C The number of columns of the Jacobian matrix J. N >= 0. -C -C IPAR (input) INTEGER array, dimension (LIPAR) -C The integer parameters describing the structure of the -C matrix J, as follows: -C IPAR(1) must contain the number of rows M of the Jacobian -C matrix J. M >= 0. -C IPAR is provided for compatibility with SLICOT Library -C routine MD03AD. -C -C LIPAR (input) INTEGER -C The length of the array IPAR. LIPAR >= 1. -C -C DPAR (input) DOUBLE PRECISION array, dimension (LDPAR) -C The real parameters needed for solving the problem. -C The entry DPAR(1) must contain the real scalar c. -C -C LDPAR (input) INTEGER -C The length of the array DPAR. LDPAR >= 1. -C -C J (input) DOUBLE PRECISION array, dimension (LDJ,N) -C The leading M-by-N part of this array must contain the -C Jacobian matrix J. -C -C LDJ INTEGER -C The leading dimension of the array J. LDJ >= MAX(1,M). -C -C JTJ (output) DOUBLE PRECISION array, -C dimension (LDJTJ,N), if STOR = 'F', -C dimension (N*(N+1)/2), if STOR = 'P'. -C The leading N-by-N (if STOR = 'F'), or N*(N+1)/2 (if -C STOR = 'P') part of this array contains the upper or -C lower triangle of the matrix J'*J + c*I, depending on -C UPLO = 'U', or UPLO = 'L', respectively, stored either as -C a two-dimensional, or one-dimensional array, depending -C on STOR. -C -C LDJTJ INTEGER -C The leading dimension of the array JTJ. -C LDJTJ >= MAX(1,N), if STOR = 'F'. -C LDJTJ >= 1, if STOR = 'P'. -C -C Workspace -C -C DWORK DOUBLE PRECISION array, dimension (LDWORK) -C Currently, this array is not used. -C -C LDWORK INTEGER -C The length of the array DWORK. LDWORK >= 0. -C -C Error Indicator -C -C INFO INTEGER -C = 0: successful exit; -C < 0: if INFO = -i, the i-th argument had an illegal -C value. -C -C METHOD -C -C The matrix product is computed columnn-wise, exploiting the -C symmetry. BLAS 3 routine DSYRK is used if STOR = 'F', and BLAS 2 -C routine DGEMV is used if STOR = 'P'. -C -C CONTRIBUTORS -C -C V. Sima, Research Institute for Informatics, Bucharest, Apr. 2001. -C -C REVISIONS -C -C V. Sima, March 2002. -C -C KEYWORDS -C -C Elementary matrix operations, matrix algebra, matrix operations, -C Wiener system. -C -C ****************************************************************** -C -C .. Parameters .. - DOUBLE PRECISION ZERO, ONE - PARAMETER ( ZERO = 0.0D0, ONE = 1.0D0 ) -C .. Scalar Arguments .. - CHARACTER STOR, UPLO - INTEGER INFO, LDJ, LDJTJ, LDPAR, LDWORK, LIPAR, N -C .. Array Arguments .. - INTEGER IPAR(*) - DOUBLE PRECISION DPAR(*), DWORK(*), J(LDJ,*), JTJ(*) -C .. Local Scalars .. - LOGICAL FULL, UPPER - INTEGER I, II, M - DOUBLE PRECISION C -C .. Local Arrays .. - DOUBLE PRECISION DUM(1) -C .. External Functions .. - LOGICAL LSAME - EXTERNAL LSAME -C .. External Subroutines .. - EXTERNAL DCOPY, DGEMV, DLASET, DSYRK, XERBLA -C .. Intrinsic Functions .. - INTRINSIC MAX -C .. -C .. Executable Statements .. -C - INFO = 0 - FULL = LSAME( STOR, 'F' ) - UPPER = LSAME( UPLO, 'U' ) -C - IF( .NOT.( FULL .OR. LSAME( STOR, 'P' ) ) ) THEN - INFO = -1 - ELSEIF ( .NOT.( UPPER .OR. LSAME( UPLO, 'L' ) ) ) THEN - INFO = -2 - ELSEIF ( N.LT.0 ) THEN - INFO = -3 - ELSEIF ( LIPAR.LT.1 ) THEN - INFO = -5 - ELSEIF ( LDPAR.LT.1 ) THEN - INFO = -7 - ELSEIF ( LDJTJ.LT.1 .OR. ( FULL .AND. LDJTJ.LT.N ) ) THEN - INFO = -11 - ELSEIF ( LDWORK.LT.0 ) THEN - INFO = -13 - ELSE - M = IPAR(1) - IF ( M.LT.0 ) THEN - INFO = -4 - ELSEIF ( LDJ.LT.MAX( 1, M ) ) THEN - INFO = -9 - ENDIF - ENDIF -C -C Return if there are illegal arguments. -C - IF( INFO.NE.0 ) THEN - CALL XERBLA( 'NF01BV', -INFO ) - RETURN - ENDIF -C -C Quick return if possible. -C - C = DPAR(1) - IF ( N.EQ.0 ) THEN - RETURN - ELSE IF ( M.EQ.0 ) THEN - IF ( FULL ) THEN - CALL DLASET( UPLO, N, N, ZERO, C, JTJ, LDJTJ ) - ELSE - DUM(1) = ZERO - CALL DCOPY( ( N*( N + 1 ) )/2, DUM, 0, JTJ, 1 ) - IF ( UPPER ) THEN - II = 0 -C - DO 10 I = 1, N - II = II + I - JTJ(II) = C - 10 CONTINUE -C - ELSE - II = 1 -C - DO 20 I = N, 1, -1 - JTJ(II) = C - II = II + I - 20 CONTINUE -C - ENDIF - ENDIF - RETURN - ENDIF -C -C Build a triangle of the matrix J'*J + c*I. -C - IF ( FULL ) THEN - CALL DLASET( UPLO, N, N, ZERO, C, JTJ, LDJTJ ) - CALL DSYRK( UPLO, 'Transpose', N, M, ONE, J, LDJ, ONE, JTJ, - $ LDJTJ ) - ELSEIF ( UPPER ) THEN - II = 0 -C - DO 30 I = 1, N - CALL DGEMV( 'Transpose', M, I, ONE, J, LDJ, J(1,I), 1, ZERO, - $ JTJ(II+1), 1 ) - II = II + I - JTJ(II) = JTJ(II) + C - 30 CONTINUE -C - ELSE - II = 1 -C - DO 40 I = N, 1, -1 - CALL DGEMV( 'Transpose', M, I, ONE, J(1,N-I+1), LDJ, - $ J(1,N-I+1), 1, ZERO, JTJ(II), 1 ) - JTJ(II) = JTJ(II) + C - II = II + I - 40 CONTINUE -C - ENDIF -C - RETURN -C -C *** Last line of NF01BV *** - END diff --git a/mex/sources/libslicot/NF01BW.f b/mex/sources/libslicot/NF01BW.f deleted file mode 100644 index 1fdac4fd9..000000000 --- a/mex/sources/libslicot/NF01BW.f +++ /dev/null @@ -1,242 +0,0 @@ - SUBROUTINE NF01BW( N, IPAR, LIPAR, DPAR, LDPAR, J, LDJ, X, INCX, - $ DWORK, LDWORK, INFO ) -C -C SLICOT RELEASE 5.0. -C -C Copyright (c) 2002-2009 NICONET e.V. -C -C This program is free software: you can redistribute it and/or -C modify it under the terms of the GNU General Public License as -C published by the Free Software Foundation, either version 2 of -C the License, or (at your option) any later version. -C -C This program is distributed in the hope that it will be useful, -C but WITHOUT ANY WARRANTY; without even the implied warranty of -C MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the -C GNU General Public License for more details. -C -C You should have received a copy of the GNU General Public License -C along with this program. If not, see -C . -C -C PURPOSE -C -C To compute the matrix-vector product x <-- (J'*J + c*I)*x, for the -C Jacobian J as received from SLICOT Library routine NF01BD: -C -C / dy(1)/dwb(1) | dy(1)/dtheta \ -C Jc = | : | : | . -C \ dy(L)/dwb(L) | dy(L)/dtheta / -C -C This is a compressed representation of the actual structure -C -C / J_1 0 .. 0 | L_1 \ -C | 0 J_2 .. 0 | L_2 | -C J = | : : .. : | : | . -C | : : .. : | : | -C \ 0 0 .. J_L | L_L / -C -C ARGUMENTS -C -C Input/Output Parameters -C -C N (input) INTEGER -C The dimension of the vector x. -C N = BN*BSN + ST >= 0. (See parameter description below.) -C -C IPAR (input) INTEGER array, dimension (LIPAR) -C The integer parameters describing the structure of the -C matrix J, as follows: -C IPAR(1) must contain ST, the number of parameters -C corresponding to the linear part. ST >= 0. -C IPAR(2) must contain BN, the number of blocks, BN = L, -C for the parameters corresponding to the nonlinear -C part. BN >= 0. -C IPAR(3) must contain BSM, the number of rows of the blocks -C J_k = dy(k)/dwb(k), k = 1:BN, if BN > 0, or the -C number of rows of the matrix J, if BN <= 1. -C IPAR(4) must contain BSN, the number of columns of the -C blocks J_k, k = 1:BN. BSN >= 0. -C -C LIPAR (input) INTEGER -C The length of the array IPAR. LIPAR >= 4. -C -C DPAR (input) DOUBLE PRECISION array, dimension (LDPAR) -C The real parameters needed for solving the problem. -C The entry DPAR(1) must contain the real scalar c. -C -C LDPAR (input) INTEGER -C The length of the array DPAR. LDPAR >= 1. -C -C J (input) DOUBLE PRECISION array, dimension (LDJ, NC) -C where NC = N if BN <= 1, and NC = BSN+ST, if BN > 1. -C The leading NR-by-NC part of this array must contain -C the (compressed) representation (Jc) of the Jacobian -C matrix J, where NR = BSM if BN <= 1, and NR = BN*BSM, -C if BN > 1. -C -C LDJ (input) INTEGER -C The leading dimension of array J. LDJ >= MAX(1,NR). -C -C X (input/output) DOUBLE PRECISION array, dimension -C (1+(N-1)*INCX) -C On entry, this incremented array must contain the -C vector x. -C On exit, this incremented array contains the value of the -C matrix-vector product (J'*J + c*I)*x. -C -C INCX (input) INTEGER -C The increment for the elements of X. INCX >= 1. -C -C Workspace -C -C DWORK DOUBLE PRECISION array, dimension (LDWORK) -C -C LDWORK INTEGER -C The length of the array DWORK. LDWORK >= NR. -C -C Error Indicator -C -C INFO INTEGER -C = 0: successful exit; -C < 0: if INFO = -i, the i-th argument had an illegal -C value. -C -C METHOD -C -C The associativity of matrix multiplications is used; the result -C is obtained as: x_out = J'*( J*x ) + c*x. -C -C CONTRIBUTORS -C -C A. Riedel, R. Schneider, Chemnitz University of Technology, -C Mar. 2001, during a stay at University of Twente, NL. -C -C REVISIONS -C -C V. Sima, Research Institute for Informatics, Bucharest, Apr. 2001, -C Mar. 2002. -C -C KEYWORDS -C -C Elementary matrix operations, matrix algebra, matrix operations, -C Wiener system. -C -C ****************************************************************** -C -C .. Parameters .. - DOUBLE PRECISION ZERO, ONE - PARAMETER ( ZERO = 0.0D0, ONE = 1.0D0 ) -C .. Scalar Arguments .. - INTEGER INCX, INFO, LDJ, LDPAR, LDWORK, LIPAR, N -C .. Array Arguments .. - DOUBLE PRECISION DPAR(*), DWORK(*), J(LDJ,*), X(*) - INTEGER IPAR(*) -C .. Local Scalars .. - INTEGER BN, BSM, BSN, IBSM, IBSN, IX, JL, M, NTHS, ST, - $ XL - DOUBLE PRECISION C -C .. External Subroutines .. - EXTERNAL DCOPY, DGEMV, DSCAL, XERBLA -C .. Intrinsic Functions .. - INTRINSIC MAX, MIN -C .. -C .. Executable Statements .. -C - INFO = 0 -C - IF ( N.LT.0 ) THEN - INFO = -1 - ELSEIF ( LIPAR.LT.4 ) THEN - INFO = -3 - ELSEIF ( LDPAR.LT.1 ) THEN - INFO = -5 - ELSEIF ( INCX.LT.1 ) THEN - INFO = -9 - ELSE - ST = IPAR(1) - BN = IPAR(2) - BSM = IPAR(3) - BSN = IPAR(4) - NTHS = BN*BSN - IF ( BN.GT.1 ) THEN - M = BN*BSM - ELSE - M = BSM - END IF - IF ( MIN( ST, BN, BSM, BSN ).LT.0 ) THEN - INFO = -2 - ELSEIF ( N.NE.NTHS + ST ) THEN - INFO = -1 - ELSEIF ( LDJ.LT.MAX( 1, M ) ) THEN - INFO = -7 - ELSEIF ( LDWORK.LT.M ) THEN - INFO = -11 - END IF - END IF -C -C Return if there are illegal arguments. -C - IF( INFO.NE.0 ) THEN - CALL XERBLA( 'NF01BW', -INFO ) - RETURN - ENDIF -C -C Quick return if possible. -C - IF ( N.EQ.0 ) - $ RETURN -C - C = DPAR(1) -C - IF ( M.EQ.0 ) THEN -C -C Special case, void Jacobian: x <-- c*x. -C - CALL DSCAL( N, C, X, INCX ) - RETURN - END IF -C - IF ( BN.LE.1 .OR. BSN.EQ.0 ) THEN -C -C Special case, l <= 1 or BSN = 0: the Jacobian is represented -C as a full matrix. Adapted code from NF01BX is included in-line. -C - CALL DGEMV( 'NoTranspose', M, N, ONE, J, LDJ, X, INCX, ZERO, - $ DWORK, 1 ) - CALL DGEMV( 'Transpose', M, N, ONE, J, LDJ, DWORK, 1, C, X, - $ INCX ) - RETURN - END IF -C -C General case: l > 1, BSN > 0, BSM > 0. -C - JL = BSN + 1 - IX = BSN*INCX - XL = BN*IX + 1 -C - IF ( ST.GT.0 ) THEN - CALL DGEMV( 'NoTranspose', M, ST, ONE, J(1,JL), LDJ, X(XL), - $ INCX, ZERO, DWORK, 1 ) - ELSE - DWORK(1) = ZERO - CALL DCOPY( M, DWORK(1), 0, DWORK, 1 ) - END IF - IBSN = 1 -C - DO 10 IBSM = 1, M, BSM - CALL DGEMV( 'NoTranspose', BSM, BSN, ONE, J(IBSM,1), LDJ, - $ X(IBSN), INCX, ONE, DWORK(IBSM), 1 ) - CALL DGEMV( 'Transpose', BSM, BSN, ONE, J(IBSM,1), LDJ, - $ DWORK(IBSM), 1, C, X(IBSN), INCX ) - IBSN = IBSN + IX - 10 CONTINUE -C - IF ( ST.GT.0 ) - $ CALL DGEMV( 'Transpose', M, ST, ONE, J(1,JL), LDJ, DWORK, 1, C, - $ X(XL), INCX ) -C - RETURN -C -C *** Last line of NF01BW *** - END diff --git a/mex/sources/libslicot/NF01BX.f b/mex/sources/libslicot/NF01BX.f deleted file mode 100644 index 73cc30c61..000000000 --- a/mex/sources/libslicot/NF01BX.f +++ /dev/null @@ -1,174 +0,0 @@ - SUBROUTINE NF01BX( N, IPAR, LIPAR, DPAR, LDPAR, J, LDJ, X, INCX, - $ DWORK, LDWORK, INFO ) -C -C SLICOT RELEASE 5.0. -C -C Copyright (c) 2002-2009 NICONET e.V. -C -C This program is free software: you can redistribute it and/or -C modify it under the terms of the GNU General Public License as -C published by the Free Software Foundation, either version 2 of -C the License, or (at your option) any later version. -C -C This program is distributed in the hope that it will be useful, -C but WITHOUT ANY WARRANTY; without even the implied warranty of -C MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the -C GNU General Public License for more details. -C -C You should have received a copy of the GNU General Public License -C along with this program. If not, see -C . -C -C PURPOSE -C -C To compute (J'*J + c*I)*x, where J is an m-by-n real matrix, c is -C a real scalar, I is the n-by-n identity matrix, and x is a real -C n-vector. -C -C NOTE: this routine must have the same arguments as SLICOT Library -C routine NF01BW. -C -C ARGUMENTS -C -C Input/Output Parameters -C -C N (input) INTEGER -C The number of columns of the Jacobian matrix J. N >= 0. -C -C IPAR (input) INTEGER array, dimension (LIPAR) -C The integer parameters describing the structure of the -C matrix J, as follows: -C IPAR(1) must contain the number of rows M of the Jacobian -C matrix J. M >= 0. -C IPAR is provided for compatibility with SLICOT Library -C routine MD03AD. -C -C LIPAR (input) INTEGER -C The length of the array IPAR. LIPAR >= 1. -C -C DPAR (input) DOUBLE PRECISION array, dimension (LDPAR) -C The real parameters needed for solving the problem. -C The entry DPAR(1) must contain the real scalar c. -C -C LDPAR (input) INTEGER -C The length of the array DPAR. LDPAR >= 1. -C -C J (input) DOUBLE PRECISION array, dimension (LDJ,N) -C The leading M-by-N part of this array must contain the -C Jacobian matrix J. -C -C LDJ INTEGER -C The leading dimension of the array J. LDJ >= MAX(1,M). -C -C X (input/output) DOUBLE PRECISION array, dimension -C (1+(N-1)*abs(INCX)) -C On entry, this incremented array must contain the -C vector x. -C On exit, this incremented array contains the value of the -C matrix-vector product (J'*J + c*I)*x. -C -C INCX (input) INTEGER -C The increment for the elements of X. INCX <> 0. -C -C Workspace -C -C DWORK DOUBLE PRECISION array, dimension (LDWORK) -C -C LDWORK INTEGER -C The length of the array DWORK. LDWORK >= M. -C -C Error Indicator -C -C INFO INTEGER -C = 0: successful exit; -C < 0: if INFO = -i, the i-th argument had an illegal -C value. -C -C METHOD -C -C The associativity of matrix multiplications is used; the result -C is obtained as: x_out = J'*( J*x ) + c*x. -C -C CONTRIBUTORS -C -C A. Riedel, R. Schneider, Chemnitz University of Technology, -C Oct. 2000, during a stay at University of Twente, NL. -C -C REVISIONS -C -C V. Sima, Research Institute for Informatics, Bucharest, Mar. 2001, -C Mar. 2002, Oct. 2004. -C -C KEYWORDS -C -C Elementary matrix operations, matrix algebra, matrix operations. -C -C ****************************************************************** -C -C .. Parameters .. - DOUBLE PRECISION ZERO, ONE - PARAMETER ( ZERO = 0.0D0, ONE = 1.0D0 ) -C .. Scalar Arguments .. - INTEGER INCX, INFO, LDJ, LDPAR, LDWORK, LIPAR, N -C .. Array Arguments .. - INTEGER IPAR(*) - DOUBLE PRECISION DPAR(*), DWORK(*), J(LDJ,*), X(*) -C .. Local Scalars .. - INTEGER M - DOUBLE PRECISION C -C .. External Subroutines .. - EXTERNAL DGEMV, DSCAL, XERBLA -C .. Intrinsic Functions .. - INTRINSIC MAX -C .. -C .. Executable Statements .. -C - INFO = 0 - IF ( N.LT.0 ) THEN - INFO = -1 - ELSEIF ( LIPAR.LT.1 ) THEN - INFO = -3 - ELSEIF ( LDPAR.LT.1 ) THEN - INFO = -5 - ELSEIF ( INCX.EQ.0 ) THEN - INFO = -9 - ELSE - M = IPAR(1) - IF ( M.LT.0 ) THEN - INFO = -2 - ELSEIF ( LDJ.LT.MAX( 1, M ) ) THEN - INFO = -7 - ELSEIF ( LDWORK.LT.M ) THEN - INFO = -11 - ENDIF - ENDIF -C - IF ( INFO.NE.0 ) THEN -C -C Error return. -C - CALL XERBLA( 'NF01BX', -INFO ) - RETURN - ENDIF -C -C Quick return if possible. -C - IF ( N.EQ.0 ) - $ RETURN -C - C = DPAR(1) - IF ( M.EQ.0 ) THEN -C -C Special case, void J: x <-- c*x. -C - CALL DSCAL( N, C, X, INCX ) - RETURN - END IF -C - CALL DGEMV( 'NoTranspose', M, N, ONE, J, LDJ, X, INCX, ZERO, - $ DWORK, 1 ) - CALL DGEMV( 'Transpose', M, N, ONE, J, LDJ, DWORK, 1, C, X, INCX ) - RETURN -C -C *** Last line of NF01BX *** - END diff --git a/mex/sources/libslicot/NF01BY.f b/mex/sources/libslicot/NF01BY.f deleted file mode 100644 index c9c0a8e33..000000000 --- a/mex/sources/libslicot/NF01BY.f +++ /dev/null @@ -1,294 +0,0 @@ - SUBROUTINE NF01BY( CJTE, NSMP, NZ, L, IPAR, LIPAR, WB, LWB, Z, - $ LDZ, E, J, LDJ, JTE, DWORK, LDWORK, INFO ) -C -C SLICOT RELEASE 5.0. -C -C Copyright (c) 2002-2009 NICONET e.V. -C -C This program is free software: you can redistribute it and/or -C modify it under the terms of the GNU General Public License as -C published by the Free Software Foundation, either version 2 of -C the License, or (at your option) any later version. -C -C This program is distributed in the hope that it will be useful, -C but WITHOUT ANY WARRANTY; without even the implied warranty of -C MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the -C GNU General Public License for more details. -C -C You should have received a copy of the GNU General Public License -C along with this program. If not, see -C . -C -C PURPOSE -C -C To compute the Jacobian of the error function for a neural network -C of the structure -C -C - tanh(w1*z+b1) - -C / : \ -C z --- : --- sum(ws(i)*...)+ b(n+1) --- y, -C \ : / -C - tanh(wn*z+bn) - -C -C for the single-output case. The Jacobian has the form -C -C d e(1) / d WB(1) ... d e(1) / d WB(NWB) -C J = : : , -C d e(NSMP) / d WB(1) ... d e(NSMP) / d WB(NWB) -C -C where e(z) is the error function, WB is the set of weights and -C biases of the network (for the considered output), and NWB is -C the number of elements of this set, NWB = IPAR(1)*(NZ+2)+1 -C (see below). -C -C In the multi-output case, this routine should be called for each -C output. -C -C NOTE: this routine must have the same arguments as SLICOT Library -C routine NF01BD. -C -C ARGUMENTS -C -C Mode Parameters -C -C CJTE CHARACTER*1 -C Specifies whether the matrix-vector product J'*e should be -C computed or not, as follows: -C = 'C' : compute J'*e; -C = 'N' : do not compute J'*e. -C -C Input/Output Parameters -C -C NSMP (input) INTEGER -C The number of training samples. NSMP >= 0. -C -C NZ (input) INTEGER -C The length of each input sample. NZ >= 0. -C -C L (input) INTEGER -C The length of each output sample. -C Currently, L must be 1. -C -C IPAR (input/output) INTEGER array, dimension (LIPAR) -C The integer parameters needed. -C On entry, the first element of this array must contain -C a value related to the number of neurons, n; specifically, -C n = abs(IPAR(1)), since setting IPAR(1) < 0 has a special -C meaning (see below). -C On exit, if IPAR(1) < 0 on entry, then no computations are -C performed, except the needed tests on input parameters, -C but the following values are returned: -C IPAR(1) contains the length of the array J, LJ; -C LDJ contains the leading dimension of array J. -C Otherwise, IPAR(1) and LDJ are unchanged on exit. -C -C LIPAR (input) INTEGER -C The length of the vector IPAR. LIPAR >= 1. -C -C WB (input) DOUBLE PRECISION array, dimension (LWB) -C The leading NWB = IPAR(1)*(NZ+2)+1 part of this array -C must contain the weights and biases of the network, -C WB = ( w(1,1), ..., w(1,NZ), ..., w(n,1), ..., w(n,NZ), -C ws(1), ..., ws(n), b(1), ..., b(n+1) ), -C where w(i,j) are the weights of the hidden layer, -C ws(i) are the weights of the linear output layer and -C b(i) are the biases. -C -C LWB (input) INTEGER -C The length of array WB. LWB >= NWB. -C -C Z (input) DOUBLE PRECISION array, dimension (LDZ, NZ) -C The leading NSMP-by-NZ part of this array must contain the -C set of input samples, -C Z = ( Z(1,1),...,Z(1,NZ); ...; Z(NSMP,1),...,Z(NSMP,NZ) ). -C -C LDZ INTEGER -C The leading dimension of array Z. LDZ >= MAX(1,NSMP). -C -C E (input) DOUBLE PRECISION array, dimension (NSMP) -C If CJTE = 'C', this array must contain the error vector e. -C If CJTE = 'N', this array is not referenced. -C -C J (output) DOUBLE PRECISION array, dimension (LDJ, NWB) -C The leading NSMP-by-NWB part of this array contains the -C Jacobian of the error function. -C -C LDJ INTEGER -C The leading dimension of array J. LDJ >= MAX(1,NSMP). -C Note that LDJ is an input parameter, except for -C IPAR(1) < 0 on entry, when it is an output parameter. -C -C JTE (output) DOUBLE PRECISION array, dimension (NWB) -C If CJTE = 'C', this array contains the matrix-vector -C product J'*e. -C If CJTE = 'N', this array is not referenced. -C -C Workspace -C -C DWORK DOUBLE PRECISION array, dimension (LDWORK) -C This argument is included for combatibility with SLICOT -C Library routine NF01BD. -C -C LDWORK INTEGER -C Normally, the length of the array DWORK. LDWORK >= 0. -C -C Error Indicator -C -C INFO INTEGER -C = 0: successful exit; -C < 0: if INFO = -i, the i-th argument had an illegal -C value. -C -C METHOD -C -C The Jacobian is computed analytically. -C -C CONTRIBUTORS -C -C A. Riedel, R. Schneider, Chemnitz University of Technology, -C Oct. 2000, during a stay at University of Twente, NL. -C V. Sima, Research Institute for Informatics, Bucharest, Mar. 2001. -C -C REVISIONS -C -C - -C -C KEYWORDS -C -C Input output description, neural network, nonlinear system, -C optimization, system response. -C -C ****************************************************************** -C -C .. Parameters .. - DOUBLE PRECISION ZERO, ONE, TWO - PARAMETER ( ZERO = 0.0D0, ONE = 1.0D0, TWO = 2.0D0 ) -C .. Scalar Arguments .. - CHARACTER CJTE - INTEGER INFO, L, LDJ, LDWORK, LDZ, LIPAR, LWB, NSMP, NZ -C .. Array Arguments .. - DOUBLE PRECISION DWORK(*), E(*), J(LDJ,*), JTE(*), WB(*), - $ Z(LDZ,*) - INTEGER IPAR(*) -C .. Local Scalars .. - LOGICAL WJTE - INTEGER BP1, DI, I, IB, K, M, NN, NWB, WS - DOUBLE PRECISION BIGNUM, SMLNUM, TMP -C .. External Functions .. - DOUBLE PRECISION DLAMCH - LOGICAL LSAME - EXTERNAL DLAMCH, LSAME -C .. External Subroutines .. - EXTERNAL DCOPY, DGEMM, DGEMV, DLABAD, XERBLA -C .. Intrinsic Functions .. - INTRINSIC ABS, EXP, LOG, MAX, MIN -C .. -C .. Executable Statements .. -C - WJTE = LSAME( CJTE, 'C' ) - INFO = 0 - NN = IPAR(1) - NWB = NN*( NZ + 2 ) + 1 - IF( .NOT.( WJTE .OR. LSAME( CJTE, 'N' ) ) ) THEN - INFO = -1 - ELSEIF ( NSMP.LT.0 ) THEN - INFO = -2 - ELSEIF ( NZ.LT.0 ) THEN - INFO = -3 - ELSEIF ( L.NE.1 ) THEN - INFO = -4 - ELSEIF ( LIPAR.LT.1 ) THEN - INFO = -6 - ELSEIF ( IPAR(1).LT.0 ) THEN - IF( INFO.NE.0 ) THEN - CALL XERBLA( 'NF01BY', -INFO ) - ELSE - IPAR(1) = NSMP*( ABS( NN )*( NZ + 2 ) + 1 ) - LDJ = NSMP - ENDIF - RETURN - ELSEIF ( LWB.LT.NWB ) THEN - INFO = -8 - ELSEIF ( LDZ.LT.MAX( 1, NSMP ) ) THEN - INFO = -10 - ELSEIF ( LDJ.LT.MAX( 1, NSMP ) ) THEN - INFO = -13 - ENDIF -C -C Return if there are illegal arguments. -C - IF( INFO.NE.0 ) THEN - CALL XERBLA( 'NF01BY', -INFO ) - RETURN - ENDIF -C -C Quick return if possible. -C - IF ( MIN( NSMP, NZ ).EQ.0 ) - $ RETURN -C -C Set parameters to avoid overflows and increase accuracy for -C extreme values. -C - SMLNUM = DLAMCH( 'Safe minimum' ) / DLAMCH( 'Precision' ) - BIGNUM = ONE / SMLNUM - CALL DLABAD( SMLNUM, BIGNUM ) - SMLNUM = LOG( SMLNUM ) - BIGNUM = LOG( BIGNUM ) -C - WS = NZ*NN + 1 - IB = WS + NN - BP1 = IB + NN -C - J(1, BP1) = ONE - CALL DCOPY( NSMP, J(1, BP1), 0, J(1, BP1), 1 ) -C - DO 10 I = 0, NN - 1 - CALL DCOPY( NSMP, WB(IB+I), 0, J(1, WS+I), 1 ) - 10 CONTINUE -C - CALL DGEMM( 'NoTranspose', 'NoTranspose', NSMP, NN, NZ, -TWO, Z, - $ LDZ, WB, NZ, -TWO, J(1, WS), LDJ ) - DI = 1 -C - DO 50 I = 0, NN - 1 -C - DO 20 K = 1, NSMP - TMP = J(K, WS+I) - IF ( ABS( TMP ).GE.BIGNUM ) THEN - IF ( TMP.GT.ZERO ) THEN - J(K, WS+I) = -ONE - ELSE - J(K, WS+I) = ONE - END IF - ELSE IF ( ABS( TMP ).LE.SMLNUM ) THEN - J(K, WS+I) = ZERO - ELSE - J(K, WS+I) = TWO/( ONE + EXP( TMP ) ) - ONE - END IF - J(K, IB+I) = WB(WS+I)*( ONE - J(K, WS+I)**2 ) - 20 CONTINUE -C - DO 40 K = 0, NZ - 1 -C - DO 30 M = 1, NSMP - J(M, DI+K) = J(M, IB+I)*Z(M, K+1) - 30 CONTINUE -C - 40 CONTINUE -C - DI = DI + NZ - 50 CONTINUE -C - IF ( WJTE ) THEN -C -C Compute J'e. -C - CALL DGEMV( 'Transpose', NSMP, NWB, ONE, J, LDJ, E, 1, ZERO, - $ JTE, 1 ) - END IF -C - RETURN -C -C *** Last line of NF01BY *** - END diff --git a/mex/sources/libslicot/SB01BD.f b/mex/sources/libslicot/SB01BD.f deleted file mode 100644 index 587581e34..000000000 --- a/mex/sources/libslicot/SB01BD.f +++ /dev/null @@ -1,776 +0,0 @@ - SUBROUTINE SB01BD( DICO, N, M, NP, ALPHA, A, LDA, B, LDB, WR, WI, - $ NFP, NAP, NUP, F, LDF, Z, LDZ, TOL, DWORK, - $ LDWORK, IWARN, INFO ) -C -C SLICOT RELEASE 5.0. -C -C Copyright (c) 2002-2009 NICONET e.V. -C -C This program is free software: you can redistribute it and/or -C modify it under the terms of the GNU General Public License as -C published by the Free Software Foundation, either version 2 of -C the License, or (at your option) any later version. -C -C This program is distributed in the hope that it will be useful, -C but WITHOUT ANY WARRANTY; without even the implied warranty of -C MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the -C GNU General Public License for more details. -C -C You should have received a copy of the GNU General Public License -C along with this program. If not, see -C . -C -C PURPOSE -C -C To determine the state feedback matrix F for a given system (A,B) -C such that the closed-loop state matrix A+B*F has specified -C eigenvalues. -C -C ARGUMENTS -C -C Mode Parameters -C -C DICO CHARACTER*1 -C Specifies the type of the original system as follows: -C = 'C': continuous-time system; -C = 'D': discrete-time system. -C -C Input/Output Parameters -C -C N (input) INTEGER -C The dimension of the state vector, i.e. the order of the -C matrix A, and also the number of rows of the matrix B and -C the number of columns of the matrix F. N >= 0. -C -C M (input) INTEGER -C The dimension of input vector, i.e. the number of columns -C of the matrix B and the number of rows of the matrix F. -C M >= 0. -C -C NP (input) INTEGER -C The number of given eigenvalues. At most N eigenvalues -C can be assigned. 0 <= NP. -C -C ALPHA (input) DOUBLE PRECISION -C Specifies the maximum admissible value, either for real -C parts, if DICO = 'C', or for moduli, if DICO = 'D', -C of the eigenvalues of A which will not be modified by -C the eigenvalue assignment algorithm. -C ALPHA >= 0 if DICO = 'D'. -C -C A (input/output) DOUBLE PRECISION array, dimension (LDA,N) -C On entry, the leading N-by-N part of this array must -C contain the state dynamics matrix A. -C On exit, the leading N-by-N part of this array contains -C the matrix Z'*(A+B*F)*Z in a real Schur form. -C The leading NFP-by-NFP diagonal block of A corresponds -C to the fixed (unmodified) eigenvalues having real parts -C less than ALPHA, if DICO = 'C', or moduli less than ALPHA, -C if DICO = 'D'. The trailing NUP-by-NUP diagonal block of A -C corresponds to the uncontrollable eigenvalues detected by -C the eigenvalue assignment algorithm. The elements under -C the first subdiagonal are set to zero. -C -C LDA INTEGER -C The leading dimension of array A. LDA >= MAX(1,N). -C -C B (input) DOUBLE PRECISION array, dimension (LDB,M) -C The leading N-by-M part of this array must contain the -C input/state matrix. -C -C LDB INTEGER -C The leading dimension of array B. LDB >= MAX(1,N). -C -C WR,WI (input/output) DOUBLE PRECISION array, dimension (NP) -C On entry, these arrays must contain the real and imaginary -C parts, respectively, of the desired eigenvalues of the -C closed-loop system state-matrix A+B*F. The eigenvalues -C can be unordered, except that complex conjugate pairs -C must appear consecutively in these arrays. -C On exit, if INFO = 0, the leading NAP elements of these -C arrays contain the real and imaginary parts, respectively, -C of the assigned eigenvalues. The trailing NP-NAP elements -C contain the unassigned eigenvalues. -C -C NFP (output) INTEGER -C The number of eigenvalues of A having real parts less than -C ALPHA, if DICO = 'C', or moduli less than ALPHA, if -C DICO = 'D'. These eigenvalues are not modified by the -C eigenvalue assignment algorithm. -C -C NAP (output) INTEGER -C The number of assigned eigenvalues. If INFO = 0 on exit, -C then NAP = N-NFP-NUP. -C -C NUP (output) INTEGER -C The number of uncontrollable eigenvalues detected by the -C eigenvalue assignment algorithm (see METHOD). -C -C F (output) DOUBLE PRECISION array, dimension (LDF,N) -C The leading M-by-N part of this array contains the state -C feedback F, which assigns NAP closed-loop eigenvalues and -C keeps unaltered N-NAP open-loop eigenvalues. -C -C LDF INTEGER -C The leading dimension of array F. LDF >= MAX(1,M). -C -C Z (output) DOUBLE PRECISION array, dimension (LDZ,N) -C The leading N-by-N part of this array contains the -C orthogonal matrix Z which reduces the closed-loop -C system state matrix A + B*F to upper real Schur form. -C -C LDZ INTEGER -C The leading dimension of array Z. LDZ >= MAX(1,N). -C -C Tolerances -C -C TOL DOUBLE PRECISION -C The absolute tolerance level below which the elements of A -C or B are considered zero (used for controllability tests). -C If the user sets TOL <= 0, then the default tolerance -C TOL = N * EPS * max(NORM(A),NORM(B)) is used, where EPS is -C the machine precision (see LAPACK Library routine DLAMCH) -C and NORM(A) denotes the 1-norm of A. -C -C Workspace -C -C DWORK DOUBLE PRECISION array, dimension (LDWORK) -C On exit, if INFO = 0, DWORK(1) returns the optimal value -C of LDWORK. -C -C LDWORK INTEGER -C The dimension of working array DWORK. -C LDWORK >= MAX( 1,5*M,5*N,2*N+4*M ). -C For optimum performance LDWORK should be larger. -C -C Warning Indicator -C -C IWARN INTEGER -C = 0: no warning; -C = K: K violations of the numerical stability condition -C NORM(F) <= 100*NORM(A)/NORM(B) occured during the -C assignment of eigenvalues. -C -C Error Indicator -C -C INFO INTEGER -C = 0: successful exit; -C < 0: if INFO = -i, the i-th argument had an illegal -C value; -C = 1: the reduction of A to a real Schur form failed; -C = 2: a failure was detected during the ordering of the -C real Schur form of A, or in the iterative process -C for reordering the eigenvalues of Z'*(A + B*F)*Z -C along the diagonal. -C = 3: the number of eigenvalues to be assigned is less -C than the number of possibly assignable eigenvalues; -C NAP eigenvalues have been properly assigned, -C but some assignable eigenvalues remain unmodified. -C = 4: an attempt is made to place a complex conjugate -C pair on the location of a real eigenvalue. This -C situation can only appear when N-NFP is odd, -C NP > N-NFP-NUP is even, and for the last real -C eigenvalue to be modified there exists no available -C real eigenvalue to be assigned. However, NAP -C eigenvalues have been already properly assigned. -C -C METHOD -C -C SB01BD is based on the factorization algorithm of [1]. -C Given the matrices A and B of dimensions N-by-N and N-by-M, -C respectively, this subroutine constructs an M-by-N matrix F such -C that A + BF has eigenvalues as follows. -C Let NFP eigenvalues of A have real parts less than ALPHA, if -C DICO = 'C', or moduli less then ALPHA, if DICO = 'D'. Then: -C 1) If the pair (A,B) is controllable, then A + B*F has -C NAP = MIN(NP,N-NFP) eigenvalues assigned from those specified -C by WR + j*WI and N-NAP unmodified eigenvalues; -C 2) If the pair (A,B) is uncontrollable, then the number of -C assigned eigenvalues NAP satifies generally the condition -C NAP <= MIN(NP,N-NFP). -C -C At the beginning of the algorithm, F = 0 and the matrix A is -C reduced to an ordered real Schur form by separating its spectrum -C in two parts. The leading NFP-by-NFP part of the Schur form of -C A corresponds to the eigenvalues which will not be modified. -C These eigenvalues have real parts less than ALPHA, if -C DICO = 'C', or moduli less than ALPHA, if DICO = 'D'. -C The performed orthogonal transformations are accumulated in Z. -C After this preliminary reduction, the algorithm proceeds -C recursively. -C -C Let F be the feedback matrix at the beginning of a typical step i. -C At each step of the algorithm one real eigenvalue or two complex -C conjugate eigenvalues are placed by a feedback Fi of rank 1 or -C rank 2, respectively. Since the feedback Fi affects only the -C last 1 or 2 columns of Z'*(A+B*F)*Z, the matrix Z'*(A+B*F+B*Fi)*Z -C therefore remains in real Schur form. The assigned eigenvalue(s) -C is (are) then moved to another diagonal position of the real -C Schur form using reordering techniques and a new block is -C transfered in the last diagonal position. The feedback matrix F -C is updated as F <-- F + Fi. The eigenvalue(s) to be assigned at -C each step is (are) chosen such that the norm of each Fi is -C minimized. -C -C If uncontrollable eigenvalues are encountered in the last diagonal -C position of the real Schur matrix Z'*(A+B*F)*Z, the algorithm -C deflates them at the bottom of the real Schur form and redefines -C accordingly the position of the "last" block. -C -C Note: Not all uncontrollable eigenvalues of the pair (A,B) are -C necessarily detected by the eigenvalue assignment algorithm. -C Undetected uncontrollable eigenvalues may exist if NFP > 0 and/or -C NP < N-NFP. -C -C REFERENCES -C -C [1] Varga A. -C A Schur method for pole assignment. -C IEEE Trans. Autom. Control, Vol. AC-26, pp. 517-519, 1981. -C -C NUMERICAL ASPECTS -C 3 -C The algorithm requires no more than 14N floating point -C operations. Although no proof of numerical stability is known, -C the algorithm has always been observed to yield reliable -C numerical results. -C -C CONTRIBUTOR -C -C A. Varga, German Aerospace Center, DLR Oberpfaffenhofen. -C February 1999. Based on the RASP routine SB01BD. -C -C REVISIONS -C -C March 30, 1999, V. Sima, Research Institute for Informatics, -C Bucharest. -C April 4, 1999. A. Varga, German Aerospace Center, -C DLR Oberpfaffenhofen. -C May 18, 2003. A. Varga, German Aerospace Center, -C DLR Oberpfaffenhofen. -C Feb. 15, 2004, V. Sima, Research Institute for Informatics, -C Bucharest. -C May 12, 2005. A. Varga, German Aerospace Center, -C DLR Oberpfaffenhofen. -C -C KEYWORDS -C -C Eigenvalues, eigenvalue assignment, feedback control, -C pole placement, state-space model. -C -C ****************************************************************** -C -C .. Parameters .. - DOUBLE PRECISION HUNDR, ONE, TWO, ZERO - PARAMETER ( HUNDR = 1.0D2, ONE = 1.0D0, TWO = 2.0D0, - $ ZERO = 0.0D0 ) -C .. Scalar Arguments .. - CHARACTER DICO - INTEGER INFO, IWARN, LDA, LDB, LDF, LDWORK, LDZ, M, N, - $ NAP, NFP, NP, NUP - DOUBLE PRECISION ALPHA, TOL -C .. Array Arguments .. - DOUBLE PRECISION A(LDA,*), B(LDB,*), DWORK(*), F(LDF,*), - $ WI(*), WR(*), Z(LDZ,*) -C .. Local Scalars .. - LOGICAL CEIG, DISCR, SIMPLB - INTEGER I, IB, IB1, IERR, IPC, J, K, KFI, KG, KW, KWI, - $ KWR, NCUR, NCUR1, NL, NLOW, NMOVES, NPC, NPR, - $ NSUP, WRKOPT - DOUBLE PRECISION ANORM, BNORM, C, P, RMAX, S, X, Y, TOLER, TOLERB -C .. Local Arrays .. - LOGICAL BWORK(1) - DOUBLE PRECISION A2(2,2) -C .. External Functions .. - LOGICAL LSAME, SELECT - DOUBLE PRECISION DLAMCH, DLANGE - EXTERNAL DLAMCH, DLANGE, LSAME, SELECT -C .. External Subroutines .. - EXTERNAL DGEES, DGEMM, DLAEXC, DLASET, DROT, DSWAP, - $ MB03QD, MB03QY, SB01BX, SB01BY, XERBLA -C .. Intrinsic Functions .. - INTRINSIC DBLE, INT, MAX -C .. -C .. Executable Statements .. -C - DISCR = LSAME( DICO, 'D' ) - IWARN = 0 - INFO = 0 -C -C Check the scalar input parameters. -C - IF( .NOT. ( LSAME( DICO, 'C' ) .OR. DISCR ) ) THEN - INFO = -1 - ELSE IF( N.LT.0 ) THEN - INFO = -2 - ELSE IF( M.LT.0 ) THEN - INFO = -3 - ELSE IF( NP.LT.0 ) THEN - INFO = -4 - ELSE IF( DISCR .AND. ( ALPHA.LT.ZERO ) ) THEN - INFO = -5 - ELSE IF( LDA.LT.MAX( 1, N ) ) THEN - INFO = -7 - ELSE IF( LDB.LT.MAX( 1, N ) ) THEN - INFO = -9 - ELSE IF( LDF.LT.MAX( 1, M ) ) THEN - INFO = -16 - ELSE IF( LDZ.LT.MAX( 1, N ) ) THEN - INFO = -18 - ELSE IF( LDWORK.LT.MAX( 1, 5*M, 5*N, 2*N + 4*M ) ) THEN - INFO = -21 - END IF - IF( INFO.NE.0 )THEN -C -C Error return. -C - CALL XERBLA( 'SB01BD', -INFO ) - RETURN - END IF -C -C Quick return if possible. -C - IF( N.EQ.0 ) THEN - NFP = 0 - NAP = 0 - NUP = 0 - DWORK(1) = ONE - RETURN - END IF -C -C Compute the norms of A and B, and set default tolerances -C if necessary. -C - ANORM = DLANGE( '1-norm', N, N, A, LDA, DWORK ) - BNORM = DLANGE( '1-norm', N, M, B, LDB, DWORK ) - IF( TOL.LE.ZERO ) THEN - X = DLAMCH( 'Epsilon' ) - TOLER = DBLE( N ) * MAX( ANORM, BNORM ) * X - TOLERB = DBLE( N ) * BNORM * X - ELSE - TOLER = TOL - TOLERB = TOL - END IF -C -C Allocate working storage. -C - KWR = 1 - KWI = KWR + N - KW = KWI + N -C -C Reduce A to real Schur form using an orthogonal similarity -C transformation A <- Z'*A*Z and accumulate the transformation in Z. -C -C Workspace: need 5*N; -C prefer larger. -C - CALL DGEES( 'Vectors', 'No ordering', SELECT, N, A, LDA, NCUR, - $ DWORK(KWR), DWORK(KWI), Z, LDZ, DWORK(KW), - $ LDWORK-KW+1, BWORK, INFO ) - WRKOPT = KW - 1 + INT( DWORK( KW ) ) - IF( INFO.NE.0 ) THEN - INFO = 1 - RETURN - END IF -C -C Reduce A to an ordered real Schur form using an orthogonal -C similarity transformation A <- Z'*A*Z and accumulate the -C transformations in Z. The separation of the spectrum of A is -C performed such that the leading NFP-by-NFP submatrix of A -C corresponds to the "good" eigenvalues which will not be -C modified. The bottom (N-NFP)-by-(N-NFP) diagonal block of A -C corresponds to the "bad" eigenvalues to be modified. -C -C Workspace needed: N. -C - CALL MB03QD( DICO, 'Stable', 'Update', N, 1, N, ALPHA, - $ A, LDA, Z, LDZ, NFP, DWORK, INFO ) - IF( INFO.NE.0 ) - $ RETURN -C -C Set F = 0. -C - CALL DLASET( 'Full', M, N, ZERO, ZERO, F, LDF ) -C -C Return if B is negligible (uncontrollable system). -C - IF( BNORM.LE.TOLERB ) THEN - NAP = 0 - NUP = N - DWORK(1) = WRKOPT - RETURN - END IF -C -C Compute the bound for the numerical stability condition. -C - RMAX = HUNDR * ANORM / BNORM -C -C Perform eigenvalue assignment if there exist "bad" eigenvalues. -C - NAP = 0 - NUP = 0 - IF( NFP .LT. N ) THEN - KG = 1 - KFI = KG + 2*M - KW = KFI + 2*M -C -C Set the limits for the bottom diagonal block. -C - NLOW = NFP + 1 - NSUP = N -C -C Separate and count real and complex eigenvalues to be assigned. -C - NPR = 0 - DO 10 I = 1, NP - IF( WI(I) .EQ. ZERO ) THEN - NPR = NPR + 1 - K = I - NPR - IF( K .GT. 0 ) THEN - S = WR(I) - DO 5 J = NPR + K - 1, NPR, -1 - WR(J+1) = WR(J) - WI(J+1) = WI(J) - 5 CONTINUE - WR(NPR) = S - WI(NPR) = ZERO - END IF - END IF - 10 CONTINUE - NPC = NP - NPR -C -C The first NPR elements of WR and WI contain the real -C eigenvalues, the last NPC elements contain the complex -C eigenvalues. Set the pointer to complex eigenvalues. -C - IPC = NPR + 1 -C -C Main loop for assigning one or two eigenvalues. -C -C Terminate if all eigenvalues were assigned, or if there -C are no more eigenvalues to be assigned, or if a non-fatal -C error condition was set. -C -C WHILE (NLOW <= NSUP and INFO = 0) DO -C - 20 IF( NLOW.LE.NSUP .AND. INFO.EQ.0 ) THEN -C -C Determine the dimension of the last block. -C - IB = 1 - IF( NLOW.LT.NSUP ) THEN - IF( A(NSUP,NSUP-1).NE.ZERO ) IB = 2 - END IF -C -C Compute G, the current last IB rows of Z'*B. -C - NL = NSUP - IB + 1 - CALL DGEMM( 'Transpose', 'NoTranspose', IB, M, N, ONE, - $ Z(1,NL), LDZ, B, LDB, ZERO, DWORK(KG), IB ) -C -C Check the controllability for a simple block. -C - IF( DLANGE( '1', IB, M, DWORK(KG), IB, DWORK(KW) ) - $ .LE. TOLERB ) THEN -C -C Deflate the uncontrollable block and resume the -C main loop. -C - NSUP = NSUP - IB - NUP = NUP + IB - GO TO 20 - END IF -C -C Test for termination with INFO = 3. -C - IF( NAP.EQ.NP) THEN - INFO = 3 -C -C Test for compatibility. Terminate if an attempt occurs -C to place a complex conjugate pair on a 1x1 block. -C - ELSE IF( IB.EQ.1 .AND. NPR.EQ.0 .AND. NLOW.EQ.NSUP ) THEN - INFO = 4 - ELSE -C -C Set the simple block flag. -C - SIMPLB = .TRUE. -C -C Form a 2-by-2 block if necessary from two 1-by-1 blocks. -C Consider special case IB = 1, NPR = 1 and -C NPR+NPC > NSUP-NLOW+1 to avoid incompatibility. -C - IF( ( IB.EQ.1 .AND. NPR.EQ.0 ) .OR. - $ ( IB.EQ.1 .AND. NPR.EQ.1 .AND. NSUP.GT.NLOW .AND. - $ NPR+NPC.GT.NSUP-NLOW+1 ) ) THEN - IF( NSUP.GT.2 ) THEN - IF( A(NSUP-1,NSUP-2) .NE. ZERO ) THEN -C -C Interchange with the adjacent 2x2 block. -C -C Workspace needed: N. -C - CALL DLAEXC( .TRUE., N, A, LDA, Z, LDZ, NSUP-2, - $ 2, 1, DWORK(KW), INFO ) - IF( INFO .NE. 0 ) THEN - INFO = 2 - RETURN - END IF - ELSE -C -C Form a non-simple block by extending the last -C block with a 1x1 block. -C - SIMPLB = .FALSE. - END IF - ELSE - SIMPLB = .FALSE. - END IF - IB = 2 - END IF - NL = NSUP - IB + 1 -C -C Compute G, the current last IB rows of Z'*B. -C - CALL DGEMM( 'Transpose', 'NoTranspose', IB, M, N, ONE, - $ Z(1,NL), LDZ, B, LDB, ZERO, DWORK(KG), IB ) -C -C Check the controllability for the current block. -C - IF( DLANGE( '1', IB, M, DWORK(KG), IB, DWORK(KW) ) - $ .LE. TOLERB ) THEN -C -C Deflate the uncontrollable block and resume the -C main loop. -C - NSUP = NSUP - IB - NUP = NUP + IB - GO TO 20 - END IF -C - IF( NAP+IB .GT. NP ) THEN -C -C No sufficient eigenvalues to be assigned. -C - INFO = 3 - ELSE - IF( IB .EQ. 1 ) THEN -C -C A 1-by-1 block. -C -C Assign the real eigenvalue nearest to A(NSUP,NSUP). -C - X = A(NSUP,NSUP) - CALL SB01BX( .TRUE., NPR, X, X, WR, X, S, P ) - NPR = NPR - 1 - CEIG = .FALSE. - ELSE -C -C A 2-by-2 block. -C - IF( SIMPLB ) THEN -C -C Simple 2-by-2 block with complex eigenvalues. -C Compute the eigenvalues of the last block. -C - CALL MB03QY( N, NL, A, LDA, Z, LDZ, X, Y, INFO ) - IF( NPC .GT. 1 ) THEN - CALL SB01BX( .FALSE., NPC, X, Y, - $ WR(IPC), WI(IPC), S, P ) - NPC = NPC - 2 - CEIG = .TRUE. - ELSE -C -C Choose the nearest two real eigenvalues. -C - CALL SB01BX( .TRUE., NPR, X, X, WR, X, S, P ) - CALL SB01BX( .TRUE., NPR-1, X, X, WR, X, - $ Y, P ) - P = S * Y - S = S + Y - NPR = NPR - 2 - CEIG = .FALSE. - END IF - ELSE -C -C Non-simple 2x2 block with real eigenvalues. -C Choose the nearest pair of complex eigenvalues. -C - X = ( A(NL,NL) + A(NSUP,NSUP) )/TWO - CALL SB01BX( .FALSE., NPC, X, ZERO, WR(IPC), - $ WI(IPC), S, P ) - NPC = NPC - 2 - END IF - END IF -C -C Form the IBxIB matrix A2 from the current diagonal -C block. -C - A2(1,1) = A(NL,NL) - IF( IB .GT. 1 ) THEN - A2(1,2) = A(NL,NSUP) - A2(2,1) = A(NSUP,NL) - A2(2,2) = A(NSUP,NSUP) - END IF -C -C Determine the M-by-IB feedback matrix FI which -C assigns the chosen IB eigenvalues for the pair (A2,G). -C -C Workspace needed: 5*M. -C - CALL SB01BY( IB, M, S, P, A2, DWORK(KG), DWORK(KFI), - $ TOLER, DWORK(KW), IERR ) - IF( IERR .NE. 0 ) THEN - IF( IB.EQ.1 .OR. SIMPLB ) THEN -C -C The simple 1x1 block is uncontrollable. -C - NSUP = NSUP - IB - IF( CEIG ) THEN - NPC = NPC + IB - ELSE - NPR = NPR + IB - END IF - NUP = NUP + IB - ELSE -C -C The non-simple 2x2 block is uncontrollable. -C Eliminate its uncontrollable part by using -C the information in elements FI(1,1) and F(1,2). -C - C = DWORK(KFI) - S = DWORK(KFI+IB) -C -C Apply the transformation to A and accumulate it -C in Z. -C - CALL DROT( N-NL+1, A(NL,NL), LDA, - $ A(NSUP,NL), LDA, C, S ) - CALL DROT( N, A(1,NL), 1, A(1,NSUP), 1, C, S ) - CALL DROT( N, Z(1,NL), 1, Z(1,NSUP), 1, C, S ) -C -C Annihilate the subdiagonal element of the last -C block, redefine the upper limit for the bottom -C block and resume the main loop. -C - A(NSUP,NL) = ZERO - NSUP = NL - NUP = NUP + 1 - NPC = NPC + 2 - END IF - ELSE -C -C Successful assignment of IB eigenvalues. -C -C Update the feedback matrix F <-- F + [0 FI]*Z'. -C - CALL DGEMM( 'NoTranspose', 'Transpose', M, N, - $ IB, ONE, DWORK(KFI), M, Z(1,NL), - $ LDZ, ONE, F, LDF ) -C -C Check for possible numerical instability. -C - IF( DLANGE( '1', M, IB, DWORK(KFI), M, DWORK(KW) ) - $ .GT. RMAX ) IWARN = IWARN + 1 -C -C Update the state matrix A <-- A + Z'*B*[0 FI]. -C Workspace needed: 2*N+4*M. -C - CALL DGEMM( 'NoTranspose', 'NoTranspose', N, IB, - $ M, ONE, B, LDB, DWORK(KFI), M, ZERO, - $ DWORK(KW), N ) - CALL DGEMM( 'Transpose', 'NoTranspose', NSUP, - $ IB, N, ONE, Z, LDZ, DWORK(KW), N, - $ ONE, A(1,NL), LDA ) -C -C Try to split the 2x2 block. -C - IF( IB .EQ. 2 ) - $ CALL MB03QY( N, NL, A, LDA, Z, LDZ, X, Y, - $ INFO ) - NAP = NAP + IB - IF( NLOW+IB.LE.NSUP ) THEN -C -C Move the last block(s) to the leading -C position(s) of the bottom block. -C - NCUR1 = NSUP - IB - NMOVES = 1 - IF( IB.EQ.2 .AND. A(NSUP,NSUP-1).EQ.ZERO ) THEN - IB = 1 - NMOVES = 2 - END IF -C -C WHILE (NMOVES > 0) DO - 30 IF( NMOVES .GT. 0 ) THEN - NCUR = NCUR1 -C -C WHILE (NCUR >= NLOW) DO - 40 IF( NCUR .GE. NLOW ) THEN -C -C Loop for the last block positioning. -C - IB1 = 1 - IF( NCUR.GT.NLOW ) THEN - IF( A(NCUR,NCUR-1).NE.ZERO ) IB1 = 2 - END IF - CALL DLAEXC( .TRUE., N, A, LDA, Z, LDZ, - $ NCUR-IB1+1, IB1, IB, - $ DWORK(KW), INFO ) - IF( INFO .NE. 0 ) THEN - INFO = 2 - RETURN - END IF - NCUR = NCUR - IB1 - GO TO 40 - END IF -C -C END WHILE 40 -C - NMOVES = NMOVES - 1 - NCUR1 = NCUR1 + 1 - NLOW = NLOW + IB - GO TO 30 - END IF -C -C END WHILE 30 -C - ELSE - NLOW = NLOW + IB - END IF - END IF - END IF - END IF - IF( INFO.EQ.0 ) GO TO 20 -C -C END WHILE 20 -C - END IF -C - WRKOPT = MAX( WRKOPT, 5*M, 2*N + 4*M ) - END IF -C -C Annihilate the elements below the first subdiagonal of A. -C - IF( N .GT. 2) - $ CALL DLASET( 'L', N-2, N-2, ZERO, ZERO, A(3,1), LDA ) - IF( NAP .GT. 0 ) THEN -C -C Move the assigned eigenvalues in the first NAP positions of -C WR and WI. -C - K = IPC - NPR - 1 - IF( K .GT. 0 ) CALL DSWAP( K, WR(NPR+1), 1, WR, 1 ) - J = NAP - K - IF( J .GT. 0 ) THEN - CALL DSWAP( J, WR(IPC+NPC), 1, WR(K+1), 1 ) - CALL DSWAP( J, WI(IPC+NPC), 1, WI(K+1), 1 ) - END IF - END IF -C - DWORK(1) = WRKOPT -C - RETURN -C *** Last line of SB01BD *** - END diff --git a/mex/sources/libslicot/SB01BX.f b/mex/sources/libslicot/SB01BX.f deleted file mode 100644 index 86812da08..000000000 --- a/mex/sources/libslicot/SB01BX.f +++ /dev/null @@ -1,150 +0,0 @@ - SUBROUTINE SB01BX( REIG, N, XR, XI, WR, WI, S, P ) -C -C SLICOT RELEASE 5.0. -C -C Copyright (c) 2002-2009 NICONET e.V. -C -C This program is free software: you can redistribute it and/or -C modify it under the terms of the GNU General Public License as -C published by the Free Software Foundation, either version 2 of -C the License, or (at your option) any later version. -C -C This program is distributed in the hope that it will be useful, -C but WITHOUT ANY WARRANTY; without even the implied warranty of -C MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the -C GNU General Public License for more details. -C -C You should have received a copy of the GNU General Public License -C along with this program. If not, see -C . -C -C PURPOSE -C -C To choose a real eigenvalue or a pair of complex conjugate -C eigenvalues at "minimal" distance to a given real or complex -C value. -C -C ARGUMENTS -C -C Mode Parameters -C -C REIG LOGICAL -C Specifies the type of eigenvalues as follows: -C = .TRUE., a real eigenvalue is to be selected; -C = .FALSE., a pair of complex eigenvalues is to be -C selected. -C -C Input/Output Parameters -C -C N (input) INTEGER -C The number of eigenvalues contained in the arrays WR -C and WI. N >= 1. -C -C XR,XI (input) DOUBLE PRECISION -C If REIG = .TRUE., XR must contain the real value and XI -C is assumed zero and therefore not referenced. -C If REIG = .FALSE., XR must contain the real part and XI -C the imaginary part, respectively, of the complex value. -C -C WR,WI (input/output) DOUBLE PRECISION array, dimension (N) -C On entry, if REIG = .TRUE., WR must contain the real -C eigenvalues from which an eigenvalue at minimal distance -C to XR is to be selected. In this case, WI is considered -C zero and therefore not referenced. -C On entry, if REIG = .FALSE., WR and WI must contain the -C real and imaginary parts, respectively, of the eigenvalues -C from which a pair of complex conjugate eigenvalues at -C minimal "distance" to XR + jXI is to be selected. -C The eigenvalues of each pair of complex conjugate -C eigenvalues must appear consecutively. -C On exit, the elements of these arrays are reordered such -C that the selected eigenvalue(s) is (are) found in the -C last element(s) of these arrays. -C -C S,P (output) DOUBLE PRECISION -C If REIG = .TRUE., S (and also P) contains the value of -C the selected real eigenvalue. -C If REIG = .FALSE., S and P contain the sum and product, -C respectively, of the selected complex conjugate pair of -C eigenvalues. -C -C FURTHER COMMENTS -C -C For efficiency reasons, |x| + |y| is used for a complex number -C x + jy, instead of its modulus. -C -C CONTRIBUTOR -C -C A. Varga, German Aerospace Center, DLR Oberpfaffenhofen. -C February 1999. Based on the RASP routine PMDIST. -C -C REVISIONS -C -C March 30, 1999, V. Sima, Research Institute for Informatics, -C Bucharest. -C Feb. 15, 2004, V. Sima, Research Institute for Informatics, -C Bucharest. -C -C ****************************************************************** -C -C .. Scalar Arguments .. - LOGICAL REIG - INTEGER N - DOUBLE PRECISION P, S, XI ,XR -C .. Array Arguments .. - DOUBLE PRECISION WI(*), WR(*) -C .. Local Scalars .. - INTEGER I, J, K - DOUBLE PRECISION X, Y -C .. Intrinsic Functions .. - INTRINSIC ABS -C .. Executable Statements .. -C - J = 1 - IF( REIG ) THEN - Y = ABS( WR(1)-XR ) - DO 10 I = 2, N - X = ABS( WR(I)-XR ) - IF( X .LT. Y ) THEN - Y = X - J = I - END IF - 10 CONTINUE - S = WR(J) - K = N - J - IF( K .GT. 0 ) THEN - DO 20 I = J, J + K - 1 - WR(I) = WR(I+1) - 20 CONTINUE - WR(N) = S - END IF - P = S - ELSE - Y = ABS( WR(1)-XR ) + ABS( WI(1)-XI ) - DO 30 I = 3, N, 2 - X = ABS( WR(I)-XR ) + ABS( WI(I)-XI ) - IF( X .LT. Y ) THEN - Y = X - J = I - END IF - 30 CONTINUE - X = WR(J) - Y = WI(J) - K = N - J - 1 - IF( K .GT. 0 ) THEN - DO 40 I = J, J + K - 1 - WR(I) = WR(I+2) - WI(I) = WI(I+2) - 40 CONTINUE - WR(N-1) = X - WI(N-1) = Y - WR(N) = X - WI(N) = -Y - END IF - S = X + X - P = X * X + Y * Y - END IF -C - RETURN -C *** End of SB01BX *** - END diff --git a/mex/sources/libslicot/SB01BY.f b/mex/sources/libslicot/SB01BY.f deleted file mode 100644 index 58b480138..000000000 --- a/mex/sources/libslicot/SB01BY.f +++ /dev/null @@ -1,332 +0,0 @@ - SUBROUTINE SB01BY( N, M, S, P, A, B, F, TOL, DWORK, INFO ) -C -C SLICOT RELEASE 5.0. -C -C Copyright (c) 2002-2009 NICONET e.V. -C -C This program is free software: you can redistribute it and/or -C modify it under the terms of the GNU General Public License as -C published by the Free Software Foundation, either version 2 of -C the License, or (at your option) any later version. -C -C This program is distributed in the hope that it will be useful, -C but WITHOUT ANY WARRANTY; without even the implied warranty of -C MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the -C GNU General Public License for more details. -C -C You should have received a copy of the GNU General Public License -C along with this program. If not, see -C . -C -C PURPOSE -C -C To solve an N-by-N pole placement problem for the simple cases -C N = 1 or N = 2: given the N-by-N matrix A and N-by-M matrix B, -C construct an M-by-N matrix F such that A + B*F has prescribed -C eigenvalues. These eigenvalues are specified by their sum S and -C product P (if N = 2). The resulting F has minimum Frobenius norm. -C -C ARGUMENTS -C -C Input/Output Parameters -C -C N (input) INTEGER -C The order of the matrix A and also the number of rows of -C the matrix B and the number of columns of the matrix F. -C N is either 1, if a single real eigenvalue is prescribed -C or 2, if a complex conjugate pair or a set of two real -C eigenvalues are prescribed. -C -C M (input) INTEGER -C The number of columns of the matrix B and also the number -C of rows of the matrix F. M >= 1. -C -C S (input) DOUBLE PRECISION -C The sum of the prescribed eigenvalues if N = 2 or the -C value of prescribed eigenvalue if N = 1. -C -C P (input) DOUBLE PRECISION -C The product of the prescribed eigenvalues if N = 2. -C Not referenced if N = 1. -C -C A (input/output) DOUBLE PRECISION array, dimension (N,N) -C On entry, this array must contain the N-by-N state -C dynamics matrix whose eigenvalues have to be moved to -C prescribed locations. -C On exit, this array contains no useful information. -C -C B (input/output) DOUBLE PRECISION array, dimension (N,M) -C On entry, this array must contain the N-by-M input/state -C matrix B. -C On exit, this array contains no useful information. -C -C F (output) DOUBLE PRECISION array, dimension (M,N) -C The state feedback matrix F which assigns one pole or two -C poles of the closed-loop matrix A + B*F. -C If N = 2 and the pair (A,B) is not controllable -C (INFO = 1), then F(1,1) and F(1,2) contain the elements of -C an orthogonal rotation which can be used to remove the -C uncontrollable part of the pair (A,B). -C -C Tolerances -C -C TOL DOUBLE PRECISION -C The absolute tolerance level below which the elements of A -C and B are considered zero (used for controllability test). -C -C Workspace -C -C DWORK DOUBLE PRECISION array, dimension (M) -C -C Error Indicator -C -C INFO INTEGER -C = 0: successful exit; -C = 1: if uncontrollability of the pair (A,B) is detected. -C -C CONTRIBUTOR -C -C A. Varga, German Aerospace Center, -C DLR Oberpfaffenhofen, July 1998. -C Based on the RASP routine SB01BY. -C -C REVISIONS -C -C Nov. 1998, V. Sima, Research Institute for Informatics, Bucharest. -C Dec. 1998, V. Sima, Katholieke Univ. Leuven, Leuven. -C May 2003, A. Varga, German Aerospace Center. -C -C KEYWORDS -C -C Eigenvalue, eigenvalue assignment, feedback control, pole -C placement, state-space model. -C -C ****************************************************************** -C -C .. Parameters .. - DOUBLE PRECISION FOUR, ONE, THREE, TWO, ZERO - PARAMETER ( FOUR = 4.0D0, ONE = 1.0D0, THREE = 3.0D0, - $ TWO = 2.0D0, ZERO = 0.0D0 ) -C .. Scalar Arguments .. - INTEGER INFO, M, N - DOUBLE PRECISION P, S, TOL -C .. Array Arguments .. - DOUBLE PRECISION A(N,*), B(N,*), DWORK(*), F(M,*) -C .. Local Scalars .. - INTEGER IR, J - DOUBLE PRECISION ABSR, B1, B2, B21, C, C0, C1, C11, C12, C21, - $ C22, C3, C4, CS, CU, CV, DC0, DC2, DC3, DIFFR, - $ R, RN, S12, S21, SIG, SN, SU, SV, TAU1, TAU2, - $ WI, WI1, WR, WR1, X, Y, Z -C .. External Functions .. - DOUBLE PRECISION DLAMC3, DLAMCH - EXTERNAL DLAMC3, DLAMCH -C .. External Subroutines .. - EXTERNAL DLANV2, DLARFG, DLASET, DLASV2, DLATZM, DROT -C .. Intrinsic Functions .. - INTRINSIC ABS, MIN -C .. Executable Statements .. -C -C For efficiency reasons, the parameters are not checked. -C - INFO = 0 - IF( N.EQ.1 ) THEN -C -C The case N = 1. -C - IF( M.GT.1 ) - $ CALL DLARFG( M, B(1,1), B(1,2), N, TAU1 ) - B1 = B(1,1) - IF( ABS( B1 ).LE.TOL ) THEN -C -C The pair (A,B) is uncontrollable. -C - INFO = 1 - RETURN - END IF -C - F(1,1) = ( S - A(1,1) )/B1 - IF( M.GT.1 ) THEN - CALL DLASET( 'Full', M-1, 1, ZERO, ZERO, F(2,1), M ) - CALL DLATZM( 'Left', M, N, B(1,2), N, TAU1, F(1,1), F(2,1), - $ M, DWORK ) - END IF - RETURN - END IF -C -C In the sequel N = 2. -C -C Compute the singular value decomposition of B in the form -C -C ( V 0 ) ( B1 0 ) -C B = U*( G1 0 )*( )*H2*H1 , G1 = ( ), -C ( 0 I ) ( 0 B2 ) -C -C ( CU SU ) ( CV SV ) -C where U = ( ) and V = ( ) are orthogonal -C (-SU CU ) (-SV CV ) -C -C rotations and H1 and H2 are elementary Householder reflectors. -C ABS(B1) and ABS(B2) are the singular values of matrix B, -C with ABS(B1) >= ABS(B2). -C -C Reduce first B to the lower bidiagonal form ( B1 0 ... 0 ). -C ( B21 B2 ... 0 ) - IF( M.EQ.1 ) THEN -C -C Initialization for the case M = 1; no reduction required. -C - B1 = B(1,1) - B21 = B(2,1) - B2 = ZERO - ELSE -C -C Postmultiply B with elementary Householder reflectors H1 -C and H2. -C - CALL DLARFG( M, B(1,1), B(1,2), N, TAU1 ) - CALL DLATZM( 'Right', N-1, M, B(1,2), N, TAU1, B(2,1), B(2,2), - $ N, DWORK ) - B1 = B(1,1) - B21 = B(2,1) - IF( M.GT.2 ) - $ CALL DLARFG( M-1, B(2,2), B(2,3), N, TAU2 ) - B2 = B(2,2) - END IF -C -C Reduce B to a diagonal form by premultiplying and postmultiplying -C it with orthogonal rotations U and V, respectively, and order the -C diagonal elements to have decreasing magnitudes. -C Note: B2 has been set to zero if M = 1. Thus in the following -C computations the case M = 1 need not to be distinguished. -C Note also that LAPACK routine DLASV2 assumes an upper triangular -C matrix, so the results should be adapted. -C - CALL DLASV2( B1, B21, B2, X, Y, SU, CU, SV, CV ) - SU = -SU - B1 = Y - B2 = X -C -C Compute A1 = U'*A*U. -C - CALL DROT( 2, A(2,1), 2, A(1,1), 2, CU, SU ) - CALL DROT( 2, A(1,2), 1, A(1,1), 1, CU, SU ) -C -C Compute the rank of B and check the controllability of the -C pair (A,B). -C - IR = 0 - IF( ABS( B2 ).GT.TOL ) IR = IR + 1 - IF( ABS( B1 ).GT.TOL ) IR = IR + 1 - IF( IR.EQ.0 .OR. ( IR.EQ.1 .AND. ABS( A(2,1) ).LE.TOL ) ) THEN - F(1,1) = CU - F(1,2) = -SU -C -C The pair (A,B) is uncontrollable. -C - INFO = 1 - RETURN - END IF -C -C Compute F1 which assigns N poles for the reduced pair (A1,G1). -C - X = DLAMC3( B1, B2 ) - IF( X.EQ.B1 ) THEN -C -C Rank one G1. -C - F(1,1) = ( S - ( A(1,1) + A(2,2) ) )/B1 - F(1,2) = -( A(2,2)*( A(2,2) - S ) + A(2,1)*A(1,2) + P )/ - $ A(2,1)/B1 - IF( M.GT.1 ) THEN - F(2,1) = ZERO - F(2,2) = ZERO - END IF - ELSE -C -C Rank two G1. -C - Z = ( S - ( A(1,1) + A(2,2) ) )/( B1*B1 + B2*B2 ) - F(1,1) = B1*Z - F(2,2) = B2*Z -C -C Compute an approximation for the minimum norm parameter -C selection. -C - X = A(1,1) + B1*F(1,1) - C = X*( S - X ) - P - IF( C.GE.ZERO ) THEN - SIG = ONE - ELSE - SIG = -ONE - END IF - S12 = B1/B2 - S21 = B2/B1 - C11 = ZERO - C12 = ONE - C21 = SIG*S12*C - C22 = A(1,2) - SIG*S12*A(2,1) - CALL DLANV2( C11, C12, C21, C22, WR, WI, WR1, WI1, CS, SN ) - IF( ABS( WR - A(1,2) ).GT.ABS( WR1 - A(1,2) ) ) THEN - R = WR1 - ELSE - R = WR - END IF -C -C Perform Newton iteration to solve the equation for minimum. -C - C0 = -C*C - C1 = C*A(2,1) - C4 = S21*S21 - C3 = -C4*A(1,2) - DC0 = C1 - DC2 = THREE*C3 - DC3 = FOUR*C4 -C - DO 10 J = 1, 10 - X = C0 + R*( C1 + R*R*( C3 + R*C4 ) ) - Y = DC0 + R*R*( DC2 + R*DC3 ) - IF( Y.EQ.ZERO ) GO TO 20 - RN = R - X/Y - ABSR = ABS( R ) - DIFFR = ABS( R - RN ) - Z = DLAMC3( ABSR, DIFFR ) - IF( Z.EQ.ABSR ) - $ GO TO 20 - R = RN - 10 CONTINUE -C - 20 CONTINUE - IF( R.EQ.ZERO ) R = DLAMCH( 'Epsilon' ) - F(1,2) = ( R - A(1,2) )/B1 - F(2,1) = ( C/R - A(2,1) )/B2 - END IF -C -C Back-transform F1. Compute first F1*U'. -C - CALL DROT( MIN( M, 2 ), F(1,1), 1, F(1,2), 1, CU, SU ) - IF( M.EQ.1 ) - $ RETURN -C -C Compute V'*F1. -C - CALL DROT( 2, F(2,1), M, F(1,1), M, CV, SV ) -C -C ( F1 ) -C Form F = ( ) . -C ( 0 ) -C - IF( M.GT.N ) - $ CALL DLASET( 'Full', M-N, N, ZERO, ZERO, F(N+1,1), M ) -C -C Compute H1*H2*F. -C - IF( M.GT.2 ) - $ CALL DLATZM( 'Left', M-1, N, B(2,3), N, TAU2, F(2,1), F(3,1), - $ M, DWORK ) - CALL DLATZM( 'Left', M, N, B(1,2), N, TAU1, F(1,1), F(2,1), M, - $ DWORK ) -C - RETURN -C *** Last line of SB01BY *** - END diff --git a/mex/sources/libslicot/SB01DD.f b/mex/sources/libslicot/SB01DD.f deleted file mode 100644 index 15ab1b8e9..000000000 --- a/mex/sources/libslicot/SB01DD.f +++ /dev/null @@ -1,643 +0,0 @@ - SUBROUTINE SB01DD( N, M, INDCON, A, LDA, B, LDB, NBLK, WR, WI, - $ Z, LDZ, Y, COUNT, G, LDG, TOL, IWORK, DWORK, - $ LDWORK, INFO ) -C -C SLICOT RELEASE 5.0. -C -C Copyright (c) 2002-2009 NICONET e.V. -C -C This program is free software: you can redistribute it and/or -C modify it under the terms of the GNU General Public License as -C published by the Free Software Foundation, either version 2 of -C the License, or (at your option) any later version. -C -C This program is distributed in the hope that it will be useful, -C but WITHOUT ANY WARRANTY; without even the implied warranty of -C MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the -C GNU General Public License for more details. -C -C You should have received a copy of the GNU General Public License -C along with this program. If not, see -C . -C -C PURPOSE -C -C To compute for a controllable matrix pair ( A, B ) a matrix G -C such that the matrix A - B*G has the desired eigenstructure, -C specified by desired eigenvalues and free eigenvector elements. -C -C The pair ( A, B ) should be given in orthogonal canonical form -C as returned by the SLICOT Library routine AB01ND. -C -C ARGUMENTS -C -C Input/Output Parameters -C -C N (input) INTEGER -C The order of the matrix A and the number of rows of the -C matrix B. N >= 0. -C -C M (input) INTEGER -C The number of columns of the matrix B. M >= 0. -C -C INDCON (input) INTEGER -C The controllability index of the pair ( A, B ). -C 0 <= INDCON <= N. -C -C A (input/output) DOUBLE PRECISION array, dimension (LDA,N) -C On entry, the leading N-by-N part of this array must -C contain the N-by-N matrix A in orthogonal canonical form, -C as returned by SLICOT Library routine AB01ND. -C On exit, the leading N-by-N part of this array contains -C the real Schur form of the matrix A - B*G. -C The elements below the real Schur form of A are set to -C zero. -C -C LDA INTEGER -C The leading dimension of the array A. LDA >= max(1,N). -C -C B (input/output) DOUBLE PRECISION array, dimension (LDB,M) -C On entry, the leading N-by-M part of this array must -C contain the N-by-M matrix B in orthogonal canonical form, -C as returned by SLICOT Library routine AB01ND. -C On exit, the leading N-by-M part of this array contains -C the transformed matrix B. -C -C LDB INTEGER -C The leading dimension of the array B. LDB >= max(1,N). -C -C NBLK (input) INTEGER array, dimension (N) -C The leading INDCON elements of this array must contain the -C orders of the diagonal blocks in the orthogonal canonical -C form of A, as returned by SLICOT Library routine AB01ND. -C The values of these elements must satisfy the following -C conditions: -C NBLK(1) >= NBLK(2) >= ... >= NBLK(INDCON), -C NBLK(1) + NBLK(2) + ... + NBLK(INDCON) = N. -C -C WR (input) DOUBLE PRECISION array, dimension (N) -C WI (input) DOUBLE PRECISION array, dimension (N) -C These arrays must contain the real and imaginary parts, -C respectively, of the desired poles of the closed-loop -C system, i.e., the eigenvalues of A - B*G. The poles can be -C unordered, except that complex conjugate pairs of poles -C must appear consecutively. -C The elements of WI for complex eigenvalues are modified -C internally, but restored on exit. -C -C Z (input/output) DOUBLE PRECISION array, dimension (LDZ,N) -C On entry, the leading N-by-N part of this array must -C contain the orthogonal matrix Z generated by SLICOT -C Library routine AB01ND in the reduction of ( A, B ) to -C orthogonal canonical form. -C On exit, the leading N-by-N part of this array contains -C the orthogonal transformation matrix which reduces A - B*G -C to real Schur form. -C -C LDZ INTEGER -C The leading dimension of the array Z. LDZ >= max(1,N). -C -C Y (input) DOUBLE PRECISION array, dimension (M*N) -C Y contains elements which are used as free parameters -C in the eigenstructure design. The values of these -C parameters are often set by an external optimization -C procedure. -C -C COUNT (output) INTEGER -C The actual number of elements in Y used as free -C eigenvector and feedback matrix elements in the -C eigenstructure design. -C -C G (output) DOUBLE PRECISION array, dimension (LDG,N) -C The leading M-by-N part of this array contains the -C feedback matrix which assigns the desired eigenstructure -C of A - B*G. -C -C LDG INTEGER -C The leading dimension of the array G. LDG >= max(1,M). -C -C Tolerances -C -C TOL DOUBLE PRECISION -C The tolerance to be used in rank determination when -C transforming (A, B). If the user sets TOL > 0, then -C the given value of TOL is used as a lower bound for the -C reciprocal condition number (see the description of the -C argument RCOND in the SLICOT routine MB03OD); a -C (sub)matrix whose estimated condition number is less than -C 1/TOL is considered to be of full rank. If the user sets -C TOL <= 0, then an implicitly computed, default tolerance, -C defined by TOLDEF = N*N*EPS, is used instead, where -C EPS is the machine precision (see LAPACK Library routine -C DLAMCH). -C -C Workspace -C -C IWORK INTEGER array, dimension (M) -C -C DWORK DOUBLE PRECISION array, dimension (LDWORK) -C On exit, if INFO = 0, DWORK(1) returns the optimal value -C of LDWORK. -C -C LDWORK INTEGER -C The length of the array DWORK. -C LDWORK >= MAX(M*N,M*M+2*N+4*M+1). -C For optimum performance LDWORK should be larger. -C -C Error Indicator -C -C INFO INTEGER -C = 0: successful exit; -C < 0: if INFO = -i, the i-th argument had an illegal -C value; -C = 1: if the pair ( A, B ) is not controllable or the free -C parameters are not set appropriately. -C -C METHOD -C -C The routine implements the method proposed in [1], [2]. -C -C REFERENCES -C -C [1] Petkov, P.Hr., Konstantinov, M.M., Gu, D.W. and -C Postlethwaite, I. -C Optimal pole assignment design of linear multi-input systems. -C Report 96-11, Department of Engineering, Leicester University, -C 1996. -C -C [2] Petkov, P.Hr., Christov, N.D. and Konstantinov, M.M. -C A computational algorithm for pole assignment of linear multi -C input systems. IEEE Trans. Automatic Control, vol. AC-31, -C pp. 1044-1047, 1986. -C -C NUMERICAL ASPECTS -C -C The method implemented is backward stable. -C -C FURTHER COMMENTS -C -C The eigenvalues of the real Schur form matrix As, returned in the -C array A, are very close to the desired eigenvalues WR+WI*i. -C However, the eigenvalues of the closed-loop matrix A - B*G, -C computed by the QR algorithm using the matrices A and B, given on -C entry, may be far from WR+WI*i, although the relative error -C norm( Z'*(A - B*G)*Z - As )/norm( As ) -C is close to machine accuracy. This may happen when the eigenvalue -C problem for the matrix A - B*G is ill-conditioned. -C -C CONTRIBUTORS -C -C P.Hr. Petkov, Technical University of Sofia, Oct. 1998. -C V. Sima, Katholieke Universiteit Leuven, Jan. 1999, SLICOT Library -C version. -C -C REVISIONS -C -C V. Sima, Research Institute for Informatics, Bucharest, Mar. 2005. -C -C KEYWORDS -C -C Closed loop spectrum, closed loop systems, eigenvalue assignment, -C orthogonal canonical form, orthogonal transformation, pole -C placement, Schur form. -C -C ****************************************************************** -C -C .. Parameters .. - DOUBLE PRECISION ZERO, ONE - PARAMETER ( ZERO = 0.0D0, ONE = 1.0D0 ) -C -C .. Scalar Arguments .. - INTEGER COUNT, INDCON, INFO, LDA, LDB, LDG, LDWORK, - $ LDZ, M, N - DOUBLE PRECISION TOL -C .. -C .. Array Arguments .. - INTEGER IWORK( * ), NBLK( * ) - DOUBLE PRECISION A( LDA, * ), B( LDB, * ), DWORK( * ), - $ G( LDG, * ), WI( * ), WR( * ), Y( * ), - $ Z( LDZ, * ) -C .. -C .. Local Scalars .. - LOGICAL COMPLX - INTEGER I, IA, INDCN1, INDCN2, INDCRT, IP, IRMX, IWRK, - $ K, KK, KMR, L, LP1, M1, MAXWRK, MI, MP1, MR, - $ MR1, NBLKCR, NC, NI, NJ, NP1, NR, NR1, RANK - DOUBLE PRECISION P, Q, R, S, SVLMAX, TOLDEF -C .. -C .. Local Arrays .. - DOUBLE PRECISION SVAL( 3 ) -C .. -C .. External Functions .. - DOUBLE PRECISION DASUM, DLAMCH, DLANGE, DLAPY2 - EXTERNAL DASUM, DLAMCH, DLANGE, DLAPY2 -C .. -C .. External Subroutines .. - EXTERNAL DAXPY, DCOPY, DGEMM, DGEMV, DLACPY, DLARF, - $ DLARFG, DLARTG, DLASET, DROT, DSCAL, MB02QD, - $ XERBLA -C .. -C .. Intrinsic Functions .. - INTRINSIC DBLE, INT, MAX, MIN -C .. -C .. Executable Statements .. -C -C Test the input arguments. -C - INFO = 0 - NR = 0 - IWRK = MAX( M*N, M*M + 2*N + 4*M + 1 ) - DO 10 I = 1, MIN( INDCON, N ) - NR = NR + NBLK( I ) - IF( I.GT.1 ) THEN - IF( NBLK( I-1 ).LT.NBLK( I ) ) - $ INFO = -8 - END IF - 10 CONTINUE - IF( N.LT.0 ) THEN - INFO = -1 - ELSE IF( M.LT.0 ) THEN - INFO = -2 - ELSE IF( INDCON.LT.0 .OR. INDCON.GT.N ) THEN - INFO = -3 - ELSE IF( LDA.LT.MAX( 1, N ) ) THEN - INFO = -5 - ELSE IF( LDB.LT.MAX( 1, N ) ) THEN - INFO = -7 - ELSE IF( NR.NE.N ) THEN - INFO = -8 - ELSE IF( LDZ.LT.MAX( 1, N ) ) THEN - INFO = -12 - ELSE IF( LDG.LT.MAX( 1, M ) ) THEN - INFO = -16 - ELSE IF( LDWORK.LT.IWRK ) THEN - INFO = -20 - END IF -C - IF( INFO.NE.0 ) THEN - CALL XERBLA( 'SB01DD', -INFO ) - RETURN - END IF -C -C Quick return if possible. -C - IF( MIN( M, N, INDCON ).EQ.0 ) THEN - COUNT = 0 - DWORK( 1 ) = ONE - RETURN - END IF -C - MAXWRK = IWRK - TOLDEF = TOL - IF ( TOLDEF.LE.ZERO ) THEN -C -C Use the default tolerance, based on machine precision. -C - TOLDEF = DBLE( N*N )*DLAMCH( 'EPSILON' ) - END IF -C - IRMX = 2*N + 1 - IWRK = IRMX + M*M - M1 = NBLK( 1 ) - COUNT = 1 - INDCRT = INDCON - NBLKCR = NBLK( INDCRT ) -C -C Compute the Frobenius norm of [ B A ] (used for rank estimation), -C taking into account the structure. -C - NR = M1 - NC = 1 - SVLMAX = DLANGE( 'Frobenius', M1, M, B, LDB, DWORK ) -C - DO 20 I = 1, INDCRT - 1 - NR = NR + NBLK( I+1 ) - SVLMAX = DLAPY2( SVLMAX, - $ DLANGE( 'Frobenius', NR, NBLK( I ), - $ A( 1, NC ), LDA, DWORK ) ) - NC = NC + NBLK( I ) - 20 CONTINUE -C - SVLMAX = DLAPY2( SVLMAX, - $ DLANGE( 'Frobenius', N, NBLKCR, A( 1, NC ), LDA, - $ DWORK ) ) - L = 1 - MR = NBLKCR - NR = N - MR + 1 - 30 CONTINUE -C WHILE( INDCRT.GT.1 )LOOP - IF( INDCRT.GT.1 ) THEN -C -C Assign next eigenvalue/eigenvector. -C - LP1 = L + M1 - INDCN1 = INDCRT - 1 - MR1 = NBLK( INDCN1 ) - NR1 = NR - MR1 - COMPLX = WI(L).NE.ZERO - CALL DCOPY( MR, Y( COUNT ), 1, DWORK( NR ), 1 ) - COUNT = COUNT + MR - NC = 1 - IF( COMPLX ) THEN - CALL DCOPY( MR, Y( COUNT ), 1, DWORK( N+NR ), 1 ) - COUNT = COUNT + MR - WI( L+1 ) = WI( L )*WI( L+1 ) - NC = 2 - END IF -C -C Compute and transform eiegenvector. -C - DO 50 IP = 1, INDCRT - IF( IP.NE.INDCRT ) THEN - CALL DLACPY( 'Full', MR, MR1, A( NR, NR1 ), LDA, - $ DWORK( IRMX ), M ) - IF( IP.EQ.1 ) THEN - MP1 = MR - NP1 = NR + MP1 - ELSE - MP1 = MR + 1 - NP1 = NR + MP1 - S = DASUM( MP1, DWORK( NR ), 1 ) - IF( COMPLX ) S = S + DASUM( MP1, DWORK( N+NR ), 1 ) - IF( S.NE.ZERO ) THEN -C -C Scale eigenvector elements. -C - CALL DSCAL( MP1, ONE/S, DWORK( NR ), 1 ) - IF( COMPLX ) THEN - CALL DSCAL( MP1, ONE/S, DWORK( N+NR ), 1 ) - IF( NP1.LE.N ) - $ DWORK( N+NP1 ) = DWORK( N+NP1 ) / S - END IF - END IF - END IF -C -C Compute the right-hand side of the eigenvector equations. -C - CALL DCOPY( MR, DWORK( NR ), 1, DWORK( NR1 ), 1 ) - CALL DSCAL( MR, WR( L ), DWORK( NR1 ), 1 ) - CALL DGEMV( 'No transpose', MR, MP1, -ONE, A( NR, NR ), - $ LDA, DWORK( NR ), 1, ONE, DWORK( NR1 ), 1 ) - IF( COMPLX ) THEN - CALL DAXPY( MR, WI( L+1 ), DWORK( N+NR ), 1, - $ DWORK( NR1 ), 1 ) - CALL DCOPY( MR, DWORK( NR ), 1, DWORK( N+NR1 ), 1 ) - CALL DAXPY( MR, WR( L+1 ), DWORK( N+NR ), 1, - $ DWORK( N+NR1 ), 1 ) - CALL DGEMV( 'No transpose', MR, MP1, -ONE, - $ A( NR, NR ), LDA, DWORK( N+NR ), 1, ONE, - $ DWORK( N+NR1 ), 1 ) - IF( NP1.LE.N ) - $ CALL DAXPY( MR, -DWORK( N+NP1 ), A( NR, NP1 ), 1, - $ DWORK( N+NR1 ), 1 ) - END IF -C -C Solve linear equations for eigenvector elements. -C - CALL MB02QD( 'FreeElements', 'NoPermuting', MR, MR1, NC, - $ TOLDEF, SVLMAX, DWORK( IRMX ), M, - $ DWORK( NR1 ), N, Y( COUNT ), IWORK, RANK, - $ SVAL, DWORK( IWRK ), LDWORK-IWRK+1, INFO ) - MAXWRK = MAX( MAXWRK, INT( DWORK( IWRK ) ) + IWRK - 1 ) - IF( RANK.LT.MR ) GO TO 80 -C - COUNT = COUNT + ( MR1 - MR )*NC - NJ = NR1 - ELSE - NJ = NR - END IF - NI = NR + MR - 1 - IF( IP.EQ.1 ) THEN - KMR = MR - 1 - ELSE - KMR = MR - IF( IP.EQ.2 ) THEN - NI = NI + NBLKCR - ELSE - NI = NI + NBLK( INDCRT-IP+2 ) + 1 - IF( COMPLX ) NI = MIN( NI+1, N ) - END IF - END IF -C - DO 40 KK = 1, KMR - K = NR + MR - KK - IF( IP.EQ.1 ) K = N - KK - CALL DLARTG( DWORK( K ), DWORK( K+1 ), P, Q, R ) - DWORK( K ) = R - DWORK( K+1 ) = ZERO -C -C Transform A. -C - CALL DROT( N-NJ+1, A( K, NJ ), LDA, A( K+1, NJ ), LDA, - $ P, Q ) - CALL DROT( NI, A( 1, K ), 1, A( 1, K+1 ), 1, P, Q ) -C - IF( K.LT.LP1 ) THEN -C -C Transform B. -C - CALL DROT( M, B( K, 1 ), LDB, B( K+1, 1 ), LDB, P, Q ) - END IF -C -C Accumulate transformations. -C - CALL DROT( N, Z( 1, K ), 1, Z( 1, K+1 ), 1, P, Q ) -C - IF( COMPLX ) THEN - CALL DROT( 1, DWORK( N+K ), 1, DWORK( N+K+1 ), 1, P, - $ Q ) - K = K + 1 - IF( K.LT.N ) THEN - CALL DLARTG( DWORK( N+K ), DWORK( N+K+1 ), P, Q, - $ R ) - DWORK( N+K ) = R - DWORK( N+K+1 ) = ZERO -C -C Transform A. -C - CALL DROT( N-NJ+1, A( K, NJ ), LDA, A( K+1, NJ ), - $ LDA, P, Q ) - CALL DROT( NI, A( 1, K ), 1, A( 1, K+1 ), 1, P, Q ) -C - IF( K.LE.LP1 ) THEN -C -C Transform B. -C - CALL DROT( M, B( K, 1 ), LDB, B( K+1, 1 ), LDB, - $ P, Q ) - END IF -C -C Accumulate transformations. -C - CALL DROT( N, Z( 1, K ), 1, Z( 1, K+1 ), 1, P, Q ) -C - END IF - END IF - 40 CONTINUE -C - IF( IP.NE.INDCRT ) THEN - MR = MR1 - NR = NR1 - IF( IP.NE.INDCN1 ) THEN - INDCN2 = INDCRT - IP - 1 - MR1 = NBLK( INDCN2 ) - NR1 = NR1 - MR1 - END IF - END IF - 50 CONTINUE -C - IF( .NOT.COMPLX ) THEN -C -C Find one column of G. -C - CALL DLACPY( 'Full', M1, M, B( L+1, 1 ), LDB, DWORK( IRMX ), - $ M ) - CALL DCOPY( M1, A( L+1, L ), 1, G( 1, L ), 1 ) - ELSE -C -C Find two columns of G. -C - IF( LP1.LT.N ) THEN - LP1 = LP1 + 1 - K = L + 2 - ELSE - K = L + 1 - END IF - CALL DLACPY( 'Full', M1, M, B( K, 1 ), LDB, DWORK( IRMX ), - $ M ) - CALL DLACPY( 'Full', M1, 2, A( K, L ), LDA, G( 1, L ), LDG ) - IF( K.EQ.L+1 ) THEN - G( 1, L ) = G( 1, L ) - - $ ( DWORK( N+L+1 ) / DWORK( L ) )*WI( L+1 ) - G( 1, L+1 ) = G( 1, L+1 ) - WR(L+1) + - $ ( DWORK( N+L ) / DWORK( L ) )*WI( L+1 ) - END IF - END IF -C - CALL MB02QD( 'FreeElements', 'NoPermuting', M1, M, NC, TOLDEF, - $ SVLMAX, DWORK( IRMX ), M, G( 1, L ), LDG, - $ Y( COUNT ), IWORK, RANK, SVAL, DWORK( IWRK ), - $ LDWORK-IWRK+1, INFO ) - MAXWRK = MAX( MAXWRK, INT( DWORK( IWRK ) ) + IWRK - 1 ) - IF( RANK.LT.M1 ) GO TO 80 -C - COUNT = COUNT + ( M - M1 )*NC - CALL DGEMM( 'No transpose', 'No transpose', LP1, NC, M, -ONE, - $ B, LDB, G( 1, L ), LDG, ONE, A( 1, L ), LDA ) - L = L + 1 - NBLKCR = NBLKCR - 1 - IF( NBLKCR.EQ.0 ) THEN - INDCRT = INDCRT - 1 - NBLKCR = NBLK( INDCRT ) - END IF - IF( COMPLX ) THEN - WI( L ) = -WI( L-1 ) - L = L + 1 - NBLKCR = NBLKCR - 1 - IF( NBLKCR.EQ.0 ) THEN - INDCRT = INDCRT - 1 - IF( INDCRT.GT.0 ) NBLKCR = NBLK( INDCRT ) - END IF - END IF - MR = NBLKCR - NR = N - MR + 1 - GO TO 30 - END IF -C END WHILE 30 -C - IF( L.LE.N ) THEN -C -C Find the remaining columns of G. -C -C QR decomposition of the free eigenvectors. -C - DO 60 I = 1, MR - 1 - IA = L + I - 1 - MI = MR - I + 1 - CALL DCOPY( MI, Y( COUNT ), 1, DWORK( 1 ), 1 ) - COUNT = COUNT + MI - CALL DLARFG( MI, DWORK( 1 ), DWORK( 2 ), 1, R ) - DWORK( 1 ) = ONE -C -C Transform A. -C - CALL DLARF( 'Left', MI, MR, DWORK( 1 ), 1, R, A( IA, L ), - $ LDA, DWORK( N+1 ) ) - CALL DLARF( 'Right', N, MI, DWORK( 1 ), 1, R, A( 1, IA ), - $ LDA, DWORK( N+1 ) ) -C -C Transform B. -C - CALL DLARF( 'Left', MI, M, DWORK( 1 ), 1, R, B( IA, 1 ), - $ LDB, DWORK( N+1 ) ) -C -C Accumulate transformations. -C - CALL DLARF( 'Right', N, MI, DWORK( 1 ), 1, R, Z( 1, IA ), - $ LDZ, DWORK( N+1 ) ) - 60 CONTINUE -C - I = 0 -C REPEAT - 70 CONTINUE - I = I + 1 - IA = L + I - 1 - IF( WI( IA ).EQ.ZERO ) THEN - CALL DCOPY( MR, A( IA, L ), LDA, G( I, L ), LDG ) - CALL DAXPY( MR-I, -ONE, Y( COUNT ), 1, G( I, L+I ), LDG ) - COUNT = COUNT + MR - I - G( I, IA ) = G( I, IA ) - WR( IA ) - ELSE - CALL DLACPY( 'Full', 2, MR, A( IA, L ), LDA, G( I, L ), - $ LDG ) - CALL DAXPY( MR-I-1, -ONE, Y( COUNT ), 2, G( I, L+I+1 ), - $ LDG ) - CALL DAXPY( MR-I-1, -ONE, Y( COUNT+1 ), 2, - $ G( I+1, L+I+1 ), LDG ) - COUNT = COUNT + 2*( MR - I - 1 ) - G( I, IA ) = G(I, IA ) - WR( IA ) - G( I, IA+1 ) = G(I, IA+1 ) - WI( IA ) - G( I+1, IA ) = G(I+1, IA ) - WI( IA+1 ) - G( I+1, IA+1 ) = G(I+1, IA+1 ) - WR( IA+1 ) - I = I + 1 - END IF - IF( I.LT.MR ) GO TO 70 -C UNTIL I.GE.MR -C - CALL DLACPY( 'Full', MR, M, B( L, 1 ), LDB, DWORK( IRMX ), M ) - CALL MB02QD( 'FreeElements', 'NoPermuting', MR, M, MR, TOLDEF, - $ SVLMAX, DWORK( IRMX ), M, G( 1, L ), LDG, - $ Y( COUNT ), IWORK, RANK, SVAL, DWORK( IWRK ), - $ LDWORK-IWRK+1, INFO ) - MAXWRK = MAX( MAXWRK, INT( DWORK( IWRK ) ) + IWRK - 1 ) - IF( RANK.LT.MR ) GO TO 80 -C - COUNT = COUNT + ( M - MR )*MR - CALL DGEMM( 'No transpose', 'No transpose', N, MR, M, -ONE, B, - $ LDB, G( 1, L ), LDG, ONE, A( 1, L ), LDA ) - END IF -C -C Transform G: -C G := G * Z'. -C - CALL DGEMM( 'No transpose', 'Transpose', M, N, N, ONE, G, LDG, - $ Z, LDZ, ZERO, DWORK( 1 ), M ) - CALL DLACPY( 'Full', M, N, DWORK( 1 ), M, G, LDG ) - COUNT = COUNT - 1 -C - IF( N.GT.2) THEN -C -C Set the elements of A below the Hessenberg part to zero. -C - CALL DLASET( 'Lower', N-2, N-2, ZERO, ZERO, A( 3, 1 ), LDA ) - END IF - DWORK( 1 ) = MAXWRK - RETURN -C -C Exit with INFO = 1 if the pair ( A, B ) is not controllable or -C the free parameters are not set appropriately. -C - 80 INFO = 1 - RETURN -C *** Last line of SB01DD *** - END diff --git a/mex/sources/libslicot/SB01FY.f b/mex/sources/libslicot/SB01FY.f deleted file mode 100644 index 20a716ba1..000000000 --- a/mex/sources/libslicot/SB01FY.f +++ /dev/null @@ -1,315 +0,0 @@ - SUBROUTINE SB01FY( DISCR, N, M, A, LDA, B, LDB, F, LDF, V, LDV, - $ INFO ) -C -C SLICOT RELEASE 5.0. -C -C Copyright (c) 2002-2009 NICONET e.V. -C -C This program is free software: you can redistribute it and/or -C modify it under the terms of the GNU General Public License as -C published by the Free Software Foundation, either version 2 of -C the License, or (at your option) any later version. -C -C This program is distributed in the hope that it will be useful, -C but WITHOUT ANY WARRANTY; without even the implied warranty of -C MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the -C GNU General Public License for more details. -C -C You should have received a copy of the GNU General Public License -C along with this program. If not, see -C . -C -C PURPOSE -C -C To compute the inner denominator of a right-coprime factorization -C of a system of order N, where N is either 1 or 2. Specifically, -C given the N-by-N unstable system state matrix A and the N-by-M -C system input matrix B, an M-by-N state-feedback matrix F and -C an M-by-M matrix V are constructed, such that the system -C (A + B*F, B*V, F, V) is inner. -C -C ARGUMENTS -C -C Mode Parameters -C -C DISCR LOGICAL -C Specifies the type of system as follows: -C = .FALSE.: continuous-time system; -C = .TRUE. : discrete-time system. -C -C Input/Output Parameters -C -C N (input) INTEGER -C The order of the matrix A and also the number of rows of -C the matrix B and the number of columns of the matrix F. -C N is either 1 or 2. -C -C M (input) INTEGER -C The number of columns of the matrices B and V, and also -C the number of rows of the matrix F. M >= 0. -C -C A (input) DOUBLE PRECISION array, dimension (LDA,N) -C The leading N-by-N part of this array must contain the -C system state matrix A whose eigenvalues must have positive -C real parts if DISCR = .FALSE. or moduli greater than unity -C if DISCR = .TRUE.. -C -C LDA INTEGER -C The leading dimension of array A. LDA >= N. -C -C B (input) DOUBLE PRECISION array, dimension (LDB,M) -C The leading N-by-M part of this array must contain the -C system input matrix B. -C -C LDB INTEGER -C The leading dimension of array B. LDB >= N. -C -C F (output) DOUBLE PRECISION array, dimension (LDF,N) -C The leading M-by-N part of this array contains the state- -C feedback matrix F which assigns one eigenvalue (if N = 1) -C or two eigenvalues (if N = 2) of the matrix A + B*F in -C symmetric positions with respect to the imaginary axis -C (if DISCR = .FALSE.) or the unit circle (if -C DISCR = .TRUE.). -C -C LDF INTEGER -C The leading dimension of array F. LDF >= MAX(1,M). -C -C V (output) DOUBLE PRECISION array, dimension (LDV,M) -C The leading M-by-M upper triangular part of this array -C contains the input/output matrix V of the resulting inner -C system in upper triangular form. -C If DISCR = .FALSE., the resulting V is an identity matrix. -C -C LDV INTEGER -C The leading dimension of array V. LDF >= MAX(1,M). -C -C Error Indicator -C -C INFO INTEGER -C = 0: successful exit; -C = 1: if uncontrollability of the pair (A,B) is detected; -C = 2: if A is stable or at the stability limit; -C = 3: if N = 2 and A has a pair of real eigenvalues. -C -C CONTRIBUTOR -C -C A. Varga, German Aerospace Center, -C DLR Oberpfaffenhofen, July 1998. -C Based on the RASP routine RCFID2. -C -C REVISIONS -C -C Nov. 1998, V. Sima, Research Institute for Informatics, Bucharest. -C Dec. 1998, V. Sima, Katholieke Univ. Leuven, Leuven. -C Feb. 1999, A. Varga, DLR Oberpfaffenhofen. -C -C KEYWORDS -C -C Coprime factorization, eigenvalue, eigenvalue assignment, -C feedback control, pole placement, state-space model. -C -C ****************************************************************** -C -C .. Parameters .. - DOUBLE PRECISION ONE, TWO, ZERO - PARAMETER ( ONE = 1.0D0, TWO = 2.0D0, ZERO = 0.0D0 ) -C .. Scalar Arguments .. - LOGICAL DISCR - INTEGER INFO, LDA, LDB, LDF, LDV, M, N -C .. Array Arguments .. - DOUBLE PRECISION A(LDA,*), B(LDB,*), F(LDF,*), V(LDV,*) -C .. Local Scalars .. - INTEGER I - DOUBLE PRECISION CS, R11, R12, R22, SCALE, SN, TEMP -C .. Local Arrays .. - DOUBLE PRECISION AT(2,2), DUMMY(2,2), U(2,2) -C .. External Functions .. - DOUBLE PRECISION DLAPY2, DLAPY3 - EXTERNAL DLAPY2, DLAPY3 -C .. External Subroutines .. - EXTERNAL DLARFG, DLASET, DLATZM, DROTG, DTRTRI, MA02AD, - $ MB04OX, SB03OY -C .. Intrinsic Functions .. - INTRINSIC ABS, SQRT -C .. Executable Statements .. -C -C For efficiency reasons, the parameters are not checked. -C - INFO = 0 -C -C Compute an N-by-N upper triangular R such that R'*R = B*B' and -C find an upper triangular matrix U in the equation -C -C A'*U'*U + U'*U*A = R'*R if DISCR = .FALSE. or -C A'*U'*U*A - U'*U = R'*R if DISCR = .TRUE. . -C - CALL MA02AD( 'Full', N, M, B, LDB, F, LDF ) -C - IF( N.EQ.1 ) THEN -C -C The N = 1 case. -C - IF( M.GT.1 ) - $ CALL DLARFG( M, F(1,1), F(2,1), 1, TEMP ) - R11 = ABS( F(1,1) ) -C -C Make sure A is unstable or divergent and find U. -C - IF( DISCR ) THEN - TEMP = ABS( A(1,1) ) - IF( TEMP.LE.ONE ) THEN - INFO = 2 - RETURN - ELSE - TEMP = R11 / SQRT( ( TEMP - ONE )*( TEMP + ONE ) ) - END IF - ELSE - IF( A(1,1).LE.ZERO ) THEN - INFO = 2 - RETURN - ELSE - TEMP = R11 / SQRT( ABS( TWO*A(1,1) ) ) - END IF - END IF - U(1,1) = TEMP - SCALE = ONE - ELSE -C -C The N = 2 case. -C - IF( M.GT.1 ) THEN - CALL DLARFG( M, F(1,1), F(2,1), 1, TEMP ) - CALL DLATZM( 'Left', M, N-1, F(2,1), 1, TEMP, F(1,2), - $ F(2,2), LDF, V ) - END IF - R11 = F(1,1) - R12 = F(1,2) - IF( M.GT.2 ) - $ CALL DLARFG( M-1, F(2,2), F(3,2), 1, TEMP ) - IF( M.EQ.1 ) THEN - R22 = ZERO - ELSE - R22 = F(2,2) - END IF - AT(1,1) = A(1,1) - AT(1,2) = A(2,1) - AT(2,1) = A(1,2) - AT(2,2) = A(2,2) - U(1,1) = R11 - U(1,2) = R12 - U(2,2) = R22 - CALL SB03OY( DISCR, .FALSE., -1, AT, 2, U, 2, DUMMY, 2, - $ SCALE, INFO ) - IF( INFO.NE.0 ) THEN - IF( INFO.NE.4 ) THEN - INFO = 2 - ELSE - INFO = 3 - END IF - RETURN - END IF - END IF -C -C Check the controllability of the pair (A,B). -C -C Warning. Only an exact controllability check is performed. -C If the pair (A,B) is nearly uncontrollable, then -C the computed results may be inaccurate. -C - DO 10 I = 1, N - IF( U(I,I).EQ.ZERO ) THEN - INFO = 1 - RETURN - END IF - 10 CONTINUE -C -C Set V = I. -C - CALL DLASET( 'Upper', M, M, ZERO, ONE, V, LDV ) -C - IF( DISCR ) THEN -C -C Compute an upper triangular matrix V such that -C -1 -C V*V' = (I+B'*inv(U'*U)*B) . -C -C First compute F = B'*inv(U) and the Cholesky factorization -C of I + F*F'. -C - DO 20 I = 1, M - F(I,1) = B(1,I)/U(1,1)*SCALE - 20 CONTINUE - IF( N.EQ.2 ) THEN - DO 30 I = 1, M - F(I,2) = ( B(2,I) - F(I,1)*U(1,2) )/U(2,2)*SCALE - 30 CONTINUE - CALL MB04OX( M, V, LDV, F(1,2), 1 ) - END IF - CALL MB04OX( M, V, LDV, F(1,1), 1 ) - CALL DTRTRI( 'Upper', 'NonUnit', M, V, LDV, INFO ) - END IF -C -C Compute the feedback matrix F as: -C -C 1) If DISCR = .FALSE. -C -C F = -B'*inv(U'*U); -C -C 2) If DISCR = .TRUE. -C -1 -C F = -B'*(U'*U+B*B') *A. -C - IF( N.EQ.1 ) THEN - IF( DISCR ) THEN - TEMP = -A(1,1) - R11 = DLAPY2( U(1,1), R11 ) - DO 40 I = 1, M - F(I,1) = ( ( B(1,I)/R11 )/R11 )*TEMP - 40 CONTINUE - ELSE - R11 = U(1,1) - DO 50 I = 1, M - F(I,1) = -( ( B(1,I)/R11 )/R11 ) - 50 CONTINUE - END IF - ELSE -C -C Set R = U if DISCR = .FALSE. or compute the Cholesky -C factorization of R'*R = U'*U+B*B' if DISCR = .TRUE.. -C - IF( DISCR ) THEN - TEMP = U(1,1) - CALL DROTG( R11, TEMP, CS, SN ) - TEMP = -SN*R12 + CS*U(1,2) - R12 = CS*R12 + SN*U(1,2) - R22 = DLAPY3( R22, TEMP, U(2,2) ) - ELSE - R11 = U(1,1) - R12 = U(1,2) - R22 = U(2,2) - END IF -C -C Compute F = -B'*inv(R'*R). -C - DO 60 I = 1, M - F(I,1) = -B(1,I)/R11 - F(I,2) = -( B(2,I) + F(I,1)*R12 )/R22 - F(I,2) = F(I,2)/R22 - F(I,1) = ( F(I,1) - F(I,2)*R12 )/R11 - 60 CONTINUE - IF( DISCR ) THEN -C -C Compute F <-- F*A. -C - DO 70 I = 1, M - TEMP = F(I,1)*A(1,1) + F(I,2)*A(2,1) - F(I,2) = F(I,1)*A(1,2) + F(I,2)*A(2,2) - F(I,1) = TEMP - 70 CONTINUE - END IF - END IF -C - RETURN -C *** Last line of SB01FY *** - END diff --git a/mex/sources/libslicot/SB01MD.f b/mex/sources/libslicot/SB01MD.f deleted file mode 100644 index cc6abc4d8..000000000 --- a/mex/sources/libslicot/SB01MD.f +++ /dev/null @@ -1,397 +0,0 @@ - SUBROUTINE SB01MD( NCONT, N, A, LDA, B, WR, WI, Z, LDZ, G, DWORK, - $ INFO ) -C -C SLICOT RELEASE 5.0. -C -C Copyright (c) 2002-2009 NICONET e.V. -C -C This program is free software: you can redistribute it and/or -C modify it under the terms of the GNU General Public License as -C published by the Free Software Foundation, either version 2 of -C the License, or (at your option) any later version. -C -C This program is distributed in the hope that it will be useful, -C but WITHOUT ANY WARRANTY; without even the implied warranty of -C MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the -C GNU General Public License for more details. -C -C You should have received a copy of the GNU General Public License -C along with this program. If not, see -C . -C -C PURPOSE -C -C To determine the one-dimensional state feedback matrix G of the -C linear time-invariant single-input system -C -C dX/dt = A * X + B * U, -C -C where A is an NCONT-by-NCONT matrix and B is an NCONT element -C vector such that the closed-loop system -C -C dX/dt = (A - B * G) * X -C -C has desired poles. The system must be preliminarily reduced -C to orthogonal canonical form using the SLICOT Library routine -C AB01MD. -C -C ARGUMENTS -C -C Input/Output Parameters -C -C NCONT (input) INTEGER -C The order of the matrix A as produced by SLICOT Library -C routine AB01MD. NCONT >= 0. -C -C N (input) INTEGER -C The order of the matrix Z. N >= NCONT. -C -C A (input/output) DOUBLE PRECISION array, dimension -C (LDA,NCONT) -C On entry, the leading NCONT-by-NCONT part of this array -C must contain the canonical form of the state dynamics -C matrix A as produced by SLICOT Library routine AB01MD. -C On exit, the leading NCONT-by-NCONT part of this array -C contains the upper quasi-triangular form S of the closed- -C loop system matrix (A - B * G), that is triangular except -C for possible 2-by-2 diagonal blocks. -C (To reconstruct the closed-loop system matrix see -C FURTHER COMMENTS below.) -C -C LDA INTEGER -C The leading dimension of array A. LDA >= MAX(1,NCONT). -C -C B (input/output) DOUBLE PRECISION array, dimension (NCONT) -C On entry, this array must contain the canonical form of -C the input/state vector B as produced by SLICOT Library -C routine AB01MD. -C On exit, this array contains the transformed vector Z * B -C of the closed-loop system. -C -C WR (input) DOUBLE PRECISION array, dimension (NCONT) -C WI (input) DOUBLE PRECISION array, dimension (NCONT) -C These arrays must contain the real and imaginary parts, -C respectively, of the desired poles of the closed-loop -C system. The poles can be unordered, except that complex -C conjugate pairs of poles must appear consecutively. -C -C Z (input/output) DOUBLE PRECISION array, dimension (LDZ,N) -C On entry, the leading N-by-N part of this array must -C contain the orthogonal transformation matrix as produced -C by SLICOT Library routine AB01MD, which reduces the system -C to canonical form. -C On exit, the leading NCONT-by-NCONT part of this array -C contains the orthogonal matrix Z which reduces the closed- -C loop system matrix (A - B * G) to upper quasi-triangular -C form. -C -C LDZ INTEGER -C The leading dimension of array Z. LDZ >= MAX(1,N). -C -C G (output) DOUBLE PRECISION array, dimension (NCONT) -C This array contains the one-dimensional state feedback -C matrix G of the original system. -C -C Workspace -C -C DWORK DOUBLE PRECISION array, dimension (3*NCONT) -C -C Error Indicator -C -C INFO INTEGER -C = 0: successful exit; -C < 0: if INFO = -i, the i-th argument had an illegal -C value. -C -C METHOD -C -C The method is based on the orthogonal reduction of the closed-loop -C system matrix (A - B * G) to upper quasi-triangular form S whose -C 1-by-1 and 2-by-2 diagonal blocks correspond to the desired poles. -C That is, S = Z'*(A - B * G)*Z, where Z is an orthogonal matrix. -C -C REFERENCES -C -C [1] Petkov, P. Hr. -C A Computational Algorithm for Pole Assignment of Linear -C Single Input Systems. -C Internal Report 81/2, Control Systems Research Group, School -C of Electronic Engineering and Computer Science, Kingston -C Polytechnic, 1981. -C -C NUMERICAL ASPECTS -C 3 -C The algorithm requires 0(NCONT ) operations and is backward -C stable. -C -C FURTHER COMMENTS -C -C If required, the closed-loop system matrix (A - B * G) can be -C formed from the matrix product Z * S * Z' (where S and Z are the -C matrices output in arrays A and Z respectively). -C -C CONTRIBUTORS -C -C Release 3.0: V. Sima, Katholieke Univ. Leuven, Belgium, Aug. 1997. -C Supersedes Release 2.0 routine SB01AD by Control Systems Research -C Group, Kingston Polytechnic, United Kingdom, May 1981. -C -C REVISIONS -C -C - -C -C KEYWORDS -C -C Closed loop spectrum, closed loop systems, eigenvalue assignment, -C orthogonal canonical form, orthogonal transformation, pole -C placement, Schur form. -C -C ****************************************************************** -C -C .. Parameters .. - DOUBLE PRECISION ZERO, ONE - PARAMETER ( ZERO = 0.0D0, ONE = 1.0D0 ) -C .. Scalar Arguments .. - INTEGER INFO, LDA, LDZ, N, NCONT -C .. Array Arguments .. - DOUBLE PRECISION A(LDA,*), B(*), DWORK(*), G(*), WI(*), WR(*), - $ Z(LDZ,*) -C .. Local Scalars .. - LOGICAL COMPL - INTEGER I, IM1, K, L, LL, LP1, NCONT2, NI, NJ, NL - DOUBLE PRECISION B1, P, Q, R, S, T -C .. External Functions .. - DOUBLE PRECISION DDOT - EXTERNAL DDOT -C .. External Subroutines .. - EXTERNAL DAXPY, DCOPY, DGEMV, DLARTG, DLASET, DROT, - $ DSCAL, XERBLA -C .. Intrinsic Functions .. - INTRINSIC ABS, MAX, MIN -C .. Executable Statements .. -C - INFO = 0 -C -C Test the input scalar arguments. -C - IF( NCONT.LT.0 ) THEN - INFO = -1 - ELSE IF( N.LT.NCONT ) THEN - INFO = -2 - ELSE IF( LDA.LT.MAX( 1, NCONT ) ) THEN - INFO = -4 - ELSE IF( LDZ.LT.MAX( 1, N ) ) THEN - INFO = -9 - END IF -C - IF ( INFO.NE.0 ) THEN -C -C Error return -C - CALL XERBLA( 'SB01MD', -INFO ) - RETURN - END IF -C -C Quick return if possible. -C - IF ( NCONT.EQ.0 .OR. N.EQ.0 ) - $ RETURN -C -C Return if the system is not complete controllable. -C - IF ( B(1).EQ.ZERO ) - $ RETURN -C - IF ( NCONT.EQ.1 ) THEN -C -C 1-by-1 case. -C - P = A(1,1) - WR(1) - A(1,1) = WR(1) - G(1) = P/B(1) - Z(1,1) = ONE - RETURN - END IF -C -C General case. Save the contents of WI in DWORK. -C - NCONT2 = 2*NCONT - CALL DCOPY( NCONT, WI, 1, DWORK(NCONT2+1), 1 ) -C - B1 = B(1) - B(1) = ONE - L = 0 - LL = 0 - 20 CONTINUE - L = L + 1 - LL = LL + 1 - COMPL = DWORK(NCONT2+L).NE.ZERO - IF ( L.NE.NCONT ) THEN - LP1 = L + 1 - NL = NCONT - L - IF ( LL.NE.2 ) THEN - IF ( COMPL ) THEN -C -C Compute complex eigenvector. -C - DWORK(NCONT) = ONE - DWORK(NCONT2) = ONE - P = WR(L) - T = DWORK(NCONT2+L) - Q = T*DWORK(NCONT2+LP1) - DWORK(NCONT2+L) = ONE - DWORK(NCONT2+LP1) = Q -C - DO 40 I = NCONT, LP1, -1 - IM1 = I - 1 - DWORK(IM1) = ( P*DWORK(I) + Q*DWORK(NCONT+I) - - $ DDOT( NCONT-IM1, A(I,I), LDA, DWORK(I), 1 ) ) - $ /A(I,IM1) - DWORK(NCONT+IM1) = ( P*DWORK(NCONT+I) + DWORK(I) - - $ DDOT( NCONT-IM1, A(I,I), LDA, DWORK(NCONT+I), 1 ) ) - $ /A(I,IM1) - 40 CONTINUE -C - ELSE -C -C Compute real eigenvector. -C - DWORK(NCONT) = ONE - P = WR(L) -C - DO 60 I = NCONT, LP1, -1 - IM1 = I - 1 - DWORK(IM1) = ( P*DWORK(I) - - $ DDOT( NCONT-IM1, A(I,I), LDA, DWORK(I), 1 ) ) - $ /A(I,IM1) - 60 CONTINUE -C - END IF - END IF -C -C Transform eigenvector. -C - DO 80 K = NCONT - 1, L, -1 - IF ( LL.NE.2 ) THEN - R = DWORK(K) - S = DWORK(K+1) - ELSE - R = DWORK(NCONT+K) - S = DWORK(NCONT+K+1) - END IF - CALL DLARTG( R, S, P, Q, T ) - DWORK(K) = T - IF ( LL.NE.2 ) THEN - NJ = MAX( K-1, L ) - ELSE - DWORK(NCONT+K) = T - NJ = L - 1 - END IF -C -C Transform A. -C - CALL DROT( NCONT-NJ+1, A(K,NJ), LDA, A(K+1,NJ), LDA, P, Q ) -C - IF ( COMPL .AND. LL.EQ.1 ) THEN - NI = NCONT - ELSE - NI = MIN( K+2, NCONT ) - END IF - CALL DROT( NI, A(1,K), 1, A(1,K+1), 1, P, Q ) -C - IF ( K.EQ.L ) THEN -C -C Transform B. -C - T = B(K) - B(K) = P*T - B(K+1) = -Q*T - END IF -C -C Accumulate transformations. -C - CALL DROT( NCONT, Z(1,K), 1, Z(1,K+1), 1, P, Q ) -C - IF ( COMPL .AND. LL.NE.2 ) THEN - T = DWORK(NCONT+K) - DWORK(NCONT+K) = P*T + Q*DWORK(NCONT+K+1) - DWORK(NCONT+K+1) = P*DWORK(NCONT+K+1) - Q*T - END IF - 80 CONTINUE -C - END IF -C - IF ( .NOT.COMPL ) THEN -C -C Find one element of G. -C - K = L - R = B(L) - IF ( L.NE.NCONT ) THEN - IF ( ABS( B(LP1) ).GT.ABS( B(L) ) ) THEN - K = LP1 - R = B(LP1) - END IF - END IF - P = A(K,L) - IF ( K.EQ.L ) P = P - WR(L) - P = P/R -C - CALL DAXPY( LP1, -P, B, 1, A(1,L), 1 ) -C - G(L) = P/B1 - IF ( L.NE.NCONT ) THEN - LL = 0 - GO TO 20 - END IF - ELSE IF ( LL.EQ.1 ) THEN - GO TO 20 - ELSE -C -C Find two elements of G. -C - K = L - R = B(L) - IF ( L.NE.NCONT ) THEN - IF ( ABS( B(LP1)).GT.ABS( B(L) ) ) THEN - K = LP1 - R = B(LP1) - END IF - END IF - P = A(K,L-1) - Q = A(K,L) - IF ( K.EQ.L ) THEN - P = P - ( DWORK(NCONT+L)/DWORK(L-1) )*DWORK(NCONT2+L) - Q = Q - WR(L) + - $ ( DWORK(NCONT+L-1)/DWORK(L-1) )*DWORK(NCONT2+L) - END IF - P = P/R - Q = Q/R -C - CALL DAXPY( LP1, -P, B, 1, A(1,L-1), 1 ) - CALL DAXPY( LP1, -Q, B, 1, A(1,L), 1 ) -C - G(L-1) = P/B1 - G(L) = Q/B1 - IF ( L.NE.NCONT ) THEN - LL = 0 - GO TO 20 - END IF - END IF -C -C Transform G. -C - CALL DGEMV( 'No transpose', NCONT, NCONT, ONE, Z, LDZ, G, 1, - $ ZERO, DWORK, 1 ) - CALL DCOPY( NCONT, DWORK, 1, G, 1 ) - CALL DSCAL( NCONT, B1, B, 1 ) -C -C Annihilate A after the first subdiagonal. -C - IF ( NCONT.GT.2 ) - $ CALL DLASET( 'Lower', NCONT-2, NCONT-2, ZERO, ZERO, A(3,1), - $ LDA ) -C - RETURN -C *** Last line of SB01MD *** - END diff --git a/mex/sources/libslicot/SB02CX.f b/mex/sources/libslicot/SB02CX.f deleted file mode 100644 index d84f72178..000000000 --- a/mex/sources/libslicot/SB02CX.f +++ /dev/null @@ -1,94 +0,0 @@ - LOGICAL FUNCTION SB02CX( REIG, IEIG ) -C -C SLICOT RELEASE 5.0. -C -C Copyright (c) 2002-2009 NICONET e.V. -C -C This program is free software: you can redistribute it and/or -C modify it under the terms of the GNU General Public License as -C published by the Free Software Foundation, either version 2 of -C the License, or (at your option) any later version. -C -C This program is distributed in the hope that it will be useful, -C but WITHOUT ANY WARRANTY; without even the implied warranty of -C MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the -C GNU General Public License for more details. -C -C You should have received a copy of the GNU General Public License -C along with this program. If not, see -C . -C -C PURPOSE -C -C To select the purely imaginary eigenvalues in computing the -C H-infinity norm of a system. -C -C ARGUMENTS -C -C Input/Output Parameters -C -C REIG (input) DOUBLE PRECISION -C The real part of the current eigenvalue considered. -C -C IEIG (input) DOUBLE PRECISION -C The imaginary part of the current eigenvalue considered. -C -C METHOD -C -C The function value SB02CX is set to .TRUE. for a purely imaginary -C eigenvalue and to .FALSE., otherwise. -C -C REFERENCES -C -C None. -C -C NUMERICAL ASPECTS -C -C None. -C -C CONTRIBUTOR -C -C P. Hr. Petkov, Technical University of Sofia, May, 1999. -C -C REVISIONS -C -C P. Hr. Petkov, Technical University of Sofia, Oct. 2000. -C -C KEYWORDS -C -C H-infinity norm, robust control. -C -C ****************************************************************** -C -C .. Parameters .. - DOUBLE PRECISION HUNDRD - PARAMETER ( HUNDRD = 100.0D+0 ) -C .. -C .. Scalar Arguments .. - DOUBLE PRECISION IEIG, REIG -C .. -C .. Local Scalars .. - DOUBLE PRECISION EPS, TOL -C .. -C .. External Functions .. - DOUBLE PRECISION DLAMCH - EXTERNAL DLAMCH -C .. -C .. Intrinsic Functions .. - INTRINSIC ABS -C .. -C .. Executable Statements .. -C -C Get the machine precision. -C - EPS = DLAMCH( 'Epsilon' ) -C -C Set the tolerance in the determination of the purely -C imaginary eigenvalues. -C - TOL = HUNDRD*EPS - SB02CX = ABS( REIG ).LT.TOL -C - RETURN -C *** Last line of SB02CX *** - END diff --git a/mex/sources/libslicot/SB02MD.f b/mex/sources/libslicot/SB02MD.f deleted file mode 100644 index 4e517d346..000000000 --- a/mex/sources/libslicot/SB02MD.f +++ /dev/null @@ -1,559 +0,0 @@ - SUBROUTINE SB02MD( DICO, HINV, UPLO, SCAL, SORT, N, A, LDA, G, - $ LDG, Q, LDQ, RCOND, WR, WI, S, LDS, U, LDU, - $ IWORK, DWORK, LDWORK, BWORK, INFO ) -C -C SLICOT RELEASE 5.0. -C -C Copyright (c) 2002-2009 NICONET e.V. -C -C This program is free software: you can redistribute it and/or -C modify it under the terms of the GNU General Public License as -C published by the Free Software Foundation, either version 2 of -C the License, or (at your option) any later version. -C -C This program is distributed in the hope that it will be useful, -C but WITHOUT ANY WARRANTY; without even the implied warranty of -C MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the -C GNU General Public License for more details. -C -C You should have received a copy of the GNU General Public License -C along with this program. If not, see -C . -C -C PURPOSE -C -C To solve for X either the continuous-time algebraic Riccati -C equation -C -1 -C Q + A'*X + X*A - X*B*R B'*X = 0 (1) -C -C or the discrete-time algebraic Riccati equation -C -1 -C X = A'*X*A - A'*X*B*(R + B'*X*B) B'*X*A + Q (2) -C -C where A, B, Q and R are N-by-N, N-by-M, N-by-N and M-by-M matrices -C respectively, with Q symmetric and R symmetric nonsingular; X is -C an N-by-N symmetric matrix. -C -1 -C The matrix G = B*R B' must be provided on input, instead of B and -C R, that is, for instance, the continuous-time equation -C -C Q + A'*X + X*A - X*G*X = 0 (3) -C -C is solved, where G is an N-by-N symmetric matrix. SLICOT Library -C routine SB02MT should be used to compute G, given B and R. SB02MT -C also enables to solve Riccati equations corresponding to optimal -C problems with coupling terms. -C -C The routine also returns the computed values of the closed-loop -C spectrum of the optimal system, i.e., the stable eigenvalues -C lambda(1),...,lambda(N) of the corresponding Hamiltonian or -C symplectic matrix associated to the optimal problem. -C -C ARGUMENTS -C -C Mode Parameters -C -C DICO CHARACTER*1 -C Specifies the type of Riccati equation to be solved as -C follows: -C = 'C': Equation (3), continuous-time case; -C = 'D': Equation (2), discrete-time case. -C -C HINV CHARACTER*1 -C If DICO = 'D', specifies which symplectic matrix is to be -C constructed, as follows: -C = 'D': The matrix H in (5) (see METHOD) is constructed; -C = 'I': The inverse of the matrix H in (5) is constructed. -C HINV is not used if DICO = 'C'. -C -C UPLO CHARACTER*1 -C Specifies which triangle of the matrices G and Q is -C stored, as follows: -C = 'U': Upper triangle is stored; -C = 'L': Lower triangle is stored. -C -C SCAL CHARACTER*1 -C Specifies whether or not a scaling strategy should be -C used, as follows: -C = 'G': General scaling should be used; -C = 'N': No scaling should be used. -C -C SORT CHARACTER*1 -C Specifies which eigenvalues should be obtained in the top -C of the Schur form, as follows: -C = 'S': Stable eigenvalues come first; -C = 'U': Unstable eigenvalues come first. -C -C Input/Output Parameters -C -C N (input) INTEGER -C The order of the matrices A, Q, G and X. N >= 0. -C -C A (input/output) DOUBLE PRECISION array, dimension (LDA,N) -C On entry, the leading N-by-N part of this array must -C contain the coefficient matrix A of the equation. -C On exit, if DICO = 'D', and INFO = 0 or INFO > 1, the -C -1 -C leading N-by-N part of this array contains the matrix A . -C Otherwise, the array A is unchanged on exit. -C -C LDA INTEGER -C The leading dimension of array A. LDA >= MAX(1,N). -C -C G (input) DOUBLE PRECISION array, dimension (LDG,N) -C The leading N-by-N upper triangular part (if UPLO = 'U') -C or lower triangular part (if UPLO = 'L') of this array -C must contain the upper triangular part or lower triangular -C part, respectively, of the symmetric matrix G. The stricly -C lower triangular part (if UPLO = 'U') or stricly upper -C triangular part (if UPLO = 'L') is not referenced. -C -C LDG INTEGER -C The leading dimension of array G. LDG >= MAX(1,N). -C -C Q (input/output) DOUBLE PRECISION array, dimension (LDQ,N) -C On entry, the leading N-by-N upper triangular part (if -C UPLO = 'U') or lower triangular part (if UPLO = 'L') of -C this array must contain the upper triangular part or lower -C triangular part, respectively, of the symmetric matrix Q. -C The stricly lower triangular part (if UPLO = 'U') or -C stricly upper triangular part (if UPLO = 'L') is not used. -C On exit, if INFO = 0, the leading N-by-N part of this -C array contains the solution matrix X of the problem. -C -C LDQ INTEGER -C The leading dimension of array N. LDQ >= MAX(1,N). -C -C RCOND (output) DOUBLE PRECISION -C An estimate of the reciprocal of the condition number (in -C the 1-norm) of the N-th order system of algebraic -C equations from which the solution matrix X is obtained. -C -C WR (output) DOUBLE PRECISION array, dimension (2*N) -C WI (output) DOUBLE PRECISION array, dimension (2*N) -C If INFO = 0 or INFO = 5, these arrays contain the real and -C imaginary parts, respectively, of the eigenvalues of the -C 2N-by-2N matrix S, ordered as specified by SORT (except -C for the case HINV = 'D', when the order is opposite to -C that specified by SORT). The leading N elements of these -C arrays contain the closed-loop spectrum of the system -C -1 -C matrix A - B*R *B'*X, if DICO = 'C', or of the matrix -C -1 -C A - B*(R + B'*X*B) B'*X*A, if DICO = 'D'. Specifically, -C lambda(k) = WR(k) + j*WI(k), for k = 1,2,...,N. -C -C S (output) DOUBLE PRECISION array, dimension (LDS,2*N) -C If INFO = 0 or INFO = 5, the leading 2N-by-2N part of this -C array contains the ordered real Schur form S of the -C Hamiltonian or symplectic matrix H. That is, -C -C (S S ) -C ( 11 12) -C S = ( ), -C (0 S ) -C ( 22) -C -C where S , S and S are N-by-N matrices. -C 11 12 22 -C -C LDS INTEGER -C The leading dimension of array S. LDS >= MAX(1,2*N). -C -C U (output) DOUBLE PRECISION array, dimension (LDU,2*N) -C If INFO = 0 or INFO = 5, the leading 2N-by-2N part of this -C array contains the transformation matrix U which reduces -C the Hamiltonian or symplectic matrix H to the ordered real -C Schur form S. That is, -C -C (U U ) -C ( 11 12) -C U = ( ), -C (U U ) -C ( 21 22) -C -C where U , U , U and U are N-by-N matrices. -C 11 12 21 22 -C -C LDU INTEGER -C The leading dimension of array U. LDU >= MAX(1,2*N). -C -C Workspace -C -C IWORK INTEGER array, dimension (2*N) -C -C DWORK DOUBLE PRECISION array, dimension (LDWORK) -C On exit, if INFO = 0, DWORK(1) returns the optimal value -C of LDWORK and DWORK(2) returns the scaling factor used -C (set to 1 if SCAL = 'N'), also set if INFO = 5; -C if DICO = 'D', DWORK(3) returns the reciprocal condition -C number of the given matrix A. -C -C LDWORK INTEGER -C The length of the array DWORK. -C LDWORK >= MAX(2,6*N) if DICO = 'C'; -C LDWORK >= MAX(3,6*N) if DICO = 'D'. -C For optimum performance LDWORK should be larger. -C -C BWORK LOGICAL array, dimension (2*N) -C -C Error Indicator -C -C INFO INTEGER -C = 0: successful exit; -C < 0: if INFO = -i, the i-th argument had an illegal -C value; -C = 1: if matrix A is (numerically) singular in discrete- -C time case; -C = 2: if the Hamiltonian or symplectic matrix H cannot be -C reduced to real Schur form; -C = 3: if the real Schur form of the Hamiltonian or -C symplectic matrix H cannot be appropriately ordered; -C = 4: if the Hamiltonian or symplectic matrix H has less -C than N stable eigenvalues; -C = 5: if the N-th order system of linear algebraic -C equations, from which the solution matrix X would -C be obtained, is singular to working precision. -C -C METHOD -C -C The method used is the Schur vector approach proposed by Laub. -C It is assumed that [A,B] is a stabilizable pair (where for (3) B -C is any matrix such that B*B' = G with rank(B) = rank(G)), and -C [E,A] is a detectable pair, where E is any matrix such that -C E*E' = Q with rank(E) = rank(Q). Under these assumptions, any of -C the algebraic Riccati equations (1)-(3) is known to have a unique -C non-negative definite solution. See [2]. -C Now consider the 2N-by-2N Hamiltonian or symplectic matrix -C -C ( A -G ) -C H = ( ), (4) -C (-Q -A'), -C -C for continuous-time equation, and -C -1 -1 -C ( A A *G ) -C H = ( -1 -1 ), (5) -C (Q*A A' + Q*A *G) -C -1 -C for discrete-time equation, respectively, where G = B*R *B'. -C The assumptions guarantee that H in (4) has no pure imaginary -C eigenvalues, and H in (5) has no eigenvalues on the unit circle. -C If Y is an N-by-N matrix then there exists an orthogonal matrix U -C such that U'*Y*U is an upper quasi-triangular matrix. Moreover, U -C can be chosen so that the 2-by-2 and 1-by-1 diagonal blocks -C (corresponding to the complex conjugate eigenvalues and real -C eigenvalues respectively) appear in any desired order. This is the -C ordered real Schur form. Thus, we can find an orthogonal -C similarity transformation U which puts (4) or (5) in ordered real -C Schur form -C -C U'*H*U = S = (S(1,1) S(1,2)) -C ( 0 S(2,2)) -C -C where S(i,j) is an N-by-N matrix and the eigenvalues of S(1,1) -C have negative real parts in case of (4), or moduli greater than -C one in case of (5). If U is conformably partitioned into four -C N-by-N blocks -C -C U = (U(1,1) U(1,2)) -C (U(2,1) U(2,2)) -C -C with respect to the assumptions we then have -C (a) U(1,1) is invertible and X = U(2,1)*inv(U(1,1)) solves (1), -C (2), or (3) with X = X' and non-negative definite; -C (b) the eigenvalues of S(1,1) (if DICO = 'C') or S(2,2) (if -C DICO = 'D') are equal to the eigenvalues of optimal system -C (the 'closed-loop' spectrum). -C -C [A,B] is stabilizable if there exists a matrix F such that (A-BF) -C is stable. [E,A] is detectable if [A',E'] is stabilizable. -C -C REFERENCES -C -C [1] Laub, A.J. -C A Schur Method for Solving Algebraic Riccati equations. -C IEEE Trans. Auto. Contr., AC-24, pp. 913-921, 1979. -C -C [2] Wonham, W.M. -C On a matrix Riccati equation of stochastic control. -C SIAM J. Contr., 6, pp. 681-697, 1968. -C -C [3] Sima, V. -C Algorithms for Linear-Quadratic Optimization. -C Pure and Applied Mathematics: A Series of Monographs and -C Textbooks, vol. 200, Marcel Dekker, Inc., New York, 1996. -C -C NUMERICAL ASPECTS -C 3 -C The algorithm requires 0(N ) operations. -C -C FURTHER COMMENTS -C -C To obtain a stabilizing solution of the algebraic Riccati -C equation for DICO = 'D', set SORT = 'U', if HINV = 'D', or set -C SORT = 'S', if HINV = 'I'. -C -C The routine can also compute the anti-stabilizing solutions of -C the algebraic Riccati equations, by specifying -C SORT = 'U' if DICO = 'D' and HINV = 'I', or DICO = 'C', or -C SORT = 'S' if DICO = 'D' and HINV = 'D'. -C -C Usually, the combinations HINV = 'D' and SORT = 'U', or HINV = 'I' -C and SORT = 'U', will be faster then the other combinations [3]. -C -C CONTRIBUTOR -C -C Release 3.0: V. Sima, Katholieke Univ. Leuven, Belgium, Aug. 1997. -C Supersedes Release 2.0 routine SB02AD by Control Systems Research -C Group, Kingston Polytechnic, United Kingdom, March 1982. -C -C REVISIONS -C -C V. Sima, Research Institute for Informatics, Bucharest, Dec. 2002. -C -C KEYWORDS -C -C Algebraic Riccati equation, closed loop system, continuous-time -C system, discrete-time system, optimal regulator, Schur form. -C -C ****************************************************************** -C -C .. Parameters .. - DOUBLE PRECISION ZERO, HALF, ONE - PARAMETER ( ZERO = 0.0D0, HALF = 0.5D0, ONE = 1.0D0 ) -C .. Scalar Arguments .. - CHARACTER DICO, HINV, SCAL, SORT, UPLO - INTEGER INFO, LDA, LDG, LDQ, LDS, LDU, LDWORK, N - DOUBLE PRECISION RCOND -C .. Array Arguments .. - LOGICAL BWORK(*) - INTEGER IWORK(*) - DOUBLE PRECISION A(LDA,*), DWORK(*), G(LDG,*), Q(LDQ,*), - $ S(LDS,*), U(LDU,*), WR(*), WI(*) -C .. Local Scalars .. - LOGICAL DISCR, LHINV, LSCAL, LSORT, LUPLO - INTEGER I, IERR, ISCL, N2, NP1, NROT - DOUBLE PRECISION GNORM, QNORM, RCONDA, UNORM, WRKOPT -C .. External Functions .. - LOGICAL LSAME, SB02MR, SB02MS, SB02MV, SB02MW - DOUBLE PRECISION DLAMCH, DLANGE, DLANSY - EXTERNAL DLAMCH, DLANGE, DLANSY, LSAME, SB02MR, SB02MS, - $ SB02MV, SB02MW -C .. External Subroutines .. - EXTERNAL DAXPY, DCOPY, DGECON, DGEES, DGETRF, DGETRS, - $ DLACPY, DLASCL, DLASET, DSCAL, DSWAP, SB02MU, - $ XERBLA -C .. Intrinsic Functions .. - INTRINSIC INT, MAX -C .. Executable Statements .. -C - INFO = 0 - N2 = N + N - NP1 = N + 1 - DISCR = LSAME( DICO, 'D' ) - LSCAL = LSAME( SCAL, 'G' ) - LSORT = LSAME( SORT, 'S' ) - LUPLO = LSAME( UPLO, 'U' ) - IF ( DISCR ) LHINV = LSAME( HINV, 'D' ) -C -C Test the input scalar arguments. -C - IF( .NOT.DISCR .AND. .NOT.LSAME( DICO, 'C' ) ) THEN - INFO = -1 - ELSE IF( DISCR ) THEN - IF( .NOT.LHINV .AND. .NOT.LSAME( HINV, 'I' ) ) - $ INFO = -2 - END IF - IF( .NOT.LUPLO .AND. .NOT.LSAME( UPLO, 'L' ) ) THEN - INFO = -3 - ELSE IF( .NOT.LSCAL .AND. .NOT.LSAME( SCAL, 'N' ) ) THEN - INFO = -4 - ELSE IF( .NOT.LSORT .AND. .NOT.LSAME( SORT, 'U' ) ) THEN - INFO = -5 - ELSE IF( N.LT.0 ) THEN - INFO = -6 - ELSE IF( LDA.LT.MAX( 1, N ) ) THEN - INFO = -8 - ELSE IF( LDG.LT.MAX( 1, N ) ) THEN - INFO = -10 - ELSE IF( LDQ.LT.MAX( 1, N ) ) THEN - INFO = -12 - ELSE IF( LDS.LT.MAX( 1, N2 ) ) THEN - INFO = -17 - ELSE IF( LDU.LT.MAX( 1, N2 ) ) THEN - INFO = -19 - ELSE IF( ( .NOT.DISCR .AND. LDWORK.LT.MAX( 2, 6*N ) ) .OR. - $ ( DISCR .AND. LDWORK.LT.MAX( 3, 6*N ) ) ) THEN - INFO = -22 - END IF -C - IF ( INFO.NE.0 ) THEN -C -C Error return. -C - CALL XERBLA( 'SB02MD', -INFO ) - RETURN - END IF -C -C Quick return if possible. -C - IF ( N.EQ.0 ) THEN - RCOND = ONE - DWORK(1) = ONE - DWORK(2) = ONE - IF ( DISCR ) DWORK(3) = ONE - RETURN - END IF -C - IF ( LSCAL ) THEN -C -C Compute the norms of the matrices Q and G. -C - QNORM = DLANSY( '1-norm', UPLO, N, Q, LDQ, DWORK ) - GNORM = DLANSY( '1-norm', UPLO, N, G, LDG, DWORK ) - END IF -C -C Initialise the Hamiltonian or symplectic matrix associated with -C the problem. -C Workspace: need 1 if DICO = 'C'; -C max(2,4*N) if DICO = 'D'; -C prefer larger if DICO = 'D'. -C - CALL SB02MU( DICO, HINV, UPLO, N, A, LDA, G, LDG, Q, LDQ, S, LDS, - $ IWORK, DWORK, LDWORK, INFO ) - IF ( INFO.NE.0 ) THEN - INFO = 1 - RETURN - END IF -C - WRKOPT = DWORK(1) - IF ( DISCR ) RCONDA = DWORK(2) -C - ISCL = 0 - IF ( LSCAL ) THEN -C -C Scale the Hamiltonian or symplectic matrix. -C - IF( QNORM.GT.GNORM .AND. GNORM.GT.ZERO ) THEN - CALL DLASCL( 'G', 0, 0, QNORM, GNORM, N, N, S(NP1,1), N2, - $ IERR ) - CALL DLASCL( 'G', 0, 0, GNORM, QNORM, N, N, S(1,NP1), N2, - $ IERR ) - ISCL = 1 - END IF - END IF -C -C Find the ordered Schur factorization of S, S = U*H*U'. -C Workspace: need 6*N; -C prefer larger. -C - IF ( .NOT.DISCR ) THEN - IF ( LSORT ) THEN - CALL DGEES( 'Vectors', 'Sorted', SB02MV, N2, S, LDS, NROT, - $ WR, WI, U, LDU, DWORK, LDWORK, BWORK, INFO ) - ELSE - CALL DGEES( 'Vectors', 'Sorted', SB02MR, N2, S, LDS, NROT, - $ WR, WI, U, LDU, DWORK, LDWORK, BWORK, INFO ) - END IF - ELSE - IF ( LSORT ) THEN - CALL DGEES( 'Vectors', 'Sorted', SB02MW, N2, S, LDS, NROT, - $ WR, WI, U, LDU, DWORK, LDWORK, BWORK, INFO ) - ELSE - CALL DGEES( 'Vectors', 'Sorted', SB02MS, N2, S, LDS, NROT, - $ WR, WI, U, LDU, DWORK, LDWORK, BWORK, INFO ) - END IF - IF ( LHINV ) THEN - CALL DSWAP( N, WR, 1, WR(NP1), 1 ) - CALL DSWAP( N, WI, 1, WI(NP1), 1 ) - END IF - END IF - IF ( INFO.GT.N2 ) THEN - INFO = 3 - ELSE IF ( INFO.GT.0 ) THEN - INFO = 2 - ELSE IF ( NROT.NE.N ) THEN - INFO = 4 - END IF - IF ( INFO.NE.0 ) - $ RETURN -C - WRKOPT = MAX( WRKOPT, DWORK(1) ) -C -C Check if U(1,1) is singular. Use the (2,1) block of S as a -C workspace for factoring U(1,1). -C - UNORM = DLANGE( '1-norm', N, N, U, LDU, DWORK ) -C - CALL DLACPY( 'Full', N, N, U, LDU, S(NP1,1), LDS ) - CALL DGETRF( N, N, S(NP1,1), LDS, IWORK, INFO ) -C - IF ( INFO.GT.0 ) THEN -C -C Singular matrix. Set INFO and RCOND for error return. -C - INFO = 5 - RCOND = ZERO - GO TO 100 - END IF -C -C Estimate the reciprocal condition of U(1,1). -C Workspace: 6*N. -C - CALL DGECON( '1-norm', N, S(NP1,1), LDS, UNORM, RCOND, - $ DWORK, IWORK(NP1), INFO ) -C - IF ( RCOND.LT.DLAMCH( 'Epsilon' ) ) THEN -C -C Nearly singular matrix. Set INFO for error return. -C - INFO = 5 - RETURN - END IF -C -C Transpose U(2,1) in Q and compute the solution. -C - DO 60 I = 1, N - CALL DCOPY( N, U(NP1,I), 1, Q(I,1), LDQ ) - 60 CONTINUE -C - CALL DGETRS( 'Transpose', N, N, S(NP1,1), LDS, IWORK, Q, LDQ, - $ INFO ) -C -C Set S(2,1) to zero. -C - CALL DLASET( 'Full', N, N, ZERO, ZERO, S(NP1,1), LDS ) -C -C Make sure the solution matrix X is symmetric. -C - DO 80 I = 1, N - 1 - CALL DAXPY( N-I, ONE, Q(I,I+1), LDQ, Q(I+1,I), 1 ) - CALL DSCAL( N-I, HALF, Q(I+1,I), 1 ) - CALL DCOPY( N-I, Q(I+1,I), 1, Q(I,I+1), LDQ ) - 80 CONTINUE -C - IF( LSCAL ) THEN -C -C Undo scaling for the solution matrix. -C - IF( ISCL.EQ.1 ) - $ CALL DLASCL( 'G', 0, 0, GNORM, QNORM, N, N, Q, LDQ, IERR ) - END IF -C -C Set the optimal workspace, the scaling factor, and reciprocal -C condition number (if any). -C - DWORK(1) = WRKOPT - 100 CONTINUE - IF( ISCL.EQ.1 ) THEN - DWORK(2) = QNORM / GNORM - ELSE - DWORK(2) = ONE - END IF - IF ( DISCR ) DWORK(3) = RCONDA -C - RETURN -C *** Last line of SB02MD *** - END diff --git a/mex/sources/libslicot/SB02MR.f b/mex/sources/libslicot/SB02MR.f deleted file mode 100644 index f306a1b93..000000000 --- a/mex/sources/libslicot/SB02MR.f +++ /dev/null @@ -1,75 +0,0 @@ - LOGICAL FUNCTION SB02MR( REIG, IEIG ) -C -C SLICOT RELEASE 5.0. -C -C Copyright (c) 2002-2009 NICONET e.V. -C -C This program is free software: you can redistribute it and/or -C modify it under the terms of the GNU General Public License as -C published by the Free Software Foundation, either version 2 of -C the License, or (at your option) any later version. -C -C This program is distributed in the hope that it will be useful, -C but WITHOUT ANY WARRANTY; without even the implied warranty of -C MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the -C GNU General Public License for more details. -C -C You should have received a copy of the GNU General Public License -C along with this program. If not, see -C . -C -C PURPOSE -C -C To select the unstable eigenvalues for solving the continuous-time -C algebraic Riccati equation. -C -C ARGUMENTS -C -C Input/Output Parameters -C -C REIG (input) DOUBLE PRECISION -C The real part of the current eigenvalue considered. -C -C IEIG (input) DOUBLE PRECISION -C The imaginary part of the current eigenvalue considered. -C -C METHOD -C -C The function value SB02MR is set to .TRUE. for an unstable -C eigenvalue and to .FALSE., otherwise. -C -C REFERENCES -C -C None. -C -C NUMERICAL ASPECTS -C -C None. -C -C CONTRIBUTOR -C -C V. Sima, Katholieke Univ. Leuven, Belgium, Aug. 1997. -C -C REVISIONS -C -C - -C -C KEYWORDS -C -C Algebraic Riccati equation, closed loop system, continuous-time -C system, optimal regulator, Schur form. -C -C ****************************************************************** -C -C .. Parameters .. - DOUBLE PRECISION ZERO - PARAMETER ( ZERO = 0.0D0 ) -C .. Scalar Arguments .. - DOUBLE PRECISION IEIG, REIG -C .. Executable Statements .. -C - SB02MR = REIG.GE.ZERO -C - RETURN -C *** Last line of SB02MR *** - END diff --git a/mex/sources/libslicot/SB02MS.f b/mex/sources/libslicot/SB02MS.f deleted file mode 100644 index 1e8481eb7..000000000 --- a/mex/sources/libslicot/SB02MS.f +++ /dev/null @@ -1,79 +0,0 @@ - LOGICAL FUNCTION SB02MS( REIG, IEIG ) -C -C SLICOT RELEASE 5.0. -C -C Copyright (c) 2002-2009 NICONET e.V. -C -C This program is free software: you can redistribute it and/or -C modify it under the terms of the GNU General Public License as -C published by the Free Software Foundation, either version 2 of -C the License, or (at your option) any later version. -C -C This program is distributed in the hope that it will be useful, -C but WITHOUT ANY WARRANTY; without even the implied warranty of -C MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the -C GNU General Public License for more details. -C -C You should have received a copy of the GNU General Public License -C along with this program. If not, see -C . -C -C PURPOSE -C -C To select the unstable eigenvalues for solving the discrete-time -C algebraic Riccati equation. -C -C ARGUMENTS -C -C Input/Output Parameters -C -C REIG (input) DOUBLE PRECISION -C The real part of the current eigenvalue considered. -C -C IEIG (input) DOUBLE PRECISION -C The imaginary part of the current eigenvalue considered. -C -C METHOD -C -C The function value SB02MS is set to .TRUE. for an unstable -C eigenvalue (i.e., with modulus greater than or equal to one) and -C to .FALSE., otherwise. -C -C REFERENCES -C -C None. -C -C NUMERICAL ASPECTS -C -C None. -C -C CONTRIBUTOR -C -C V. Sima, Katholieke Univ. Leuven, Belgium, Aug. 1997. -C -C REVISIONS -C -C - -C -C KEYWORDS -C -C Algebraic Riccati equation, closed loop system, discrete-time -C system, optimal regulator, Schur form. -C -C ****************************************************************** -C -C .. Parameters .. - DOUBLE PRECISION ONE - PARAMETER ( ONE = 1.0D0 ) -C .. Scalar Arguments .. - DOUBLE PRECISION IEIG, REIG -C .. External Functions .. - DOUBLE PRECISION DLAPY2 - EXTERNAL DLAPY2 -C .. Executable Statements .. -C - SB02MS = DLAPY2( REIG, IEIG ).GE.ONE -C - RETURN -C *** Last line of SB02MS *** - END diff --git a/mex/sources/libslicot/SB02MT.f b/mex/sources/libslicot/SB02MT.f deleted file mode 100644 index 7106bd971..000000000 --- a/mex/sources/libslicot/SB02MT.f +++ /dev/null @@ -1,581 +0,0 @@ - SUBROUTINE SB02MT( JOBG, JOBL, FACT, UPLO, N, M, A, LDA, B, LDB, - $ Q, LDQ, R, LDR, L, LDL, IPIV, OUFACT, G, LDG, - $ IWORK, DWORK, LDWORK, INFO ) -C -C SLICOT RELEASE 5.0. -C -C Copyright (c) 2002-2009 NICONET e.V. -C -C This program is free software: you can redistribute it and/or -C modify it under the terms of the GNU General Public License as -C published by the Free Software Foundation, either version 2 of -C the License, or (at your option) any later version. -C -C This program is distributed in the hope that it will be useful, -C but WITHOUT ANY WARRANTY; without even the implied warranty of -C MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the -C GNU General Public License for more details. -C -C You should have received a copy of the GNU General Public License -C along with this program. If not, see -C . -C -C PURPOSE -C -C To compute the following matrices -C -C -1 -C G = B*R *B', -C -C - -1 -C A = A - B*R *L', -C -C - -1 -C Q = Q - L*R *L', -C -C where A, B, Q, R, L, and G are N-by-N, N-by-M, N-by-N, M-by-M, -C N-by-M, and N-by-N matrices, respectively, with Q, R and G -C symmetric matrices. -C -C When R is well-conditioned with respect to inversion, standard -C algorithms for solving linear-quadratic optimization problems will -C then also solve optimization problems with coupling weighting -C matrix L. Moreover, a gain in efficiency is possible using matrix -C G in the deflating subspace algorithms (see SLICOT Library routine -C SB02OD). -C -C ARGUMENTS -C -C Mode Parameters -C -C JOBG CHARACTER*1 -C Specifies whether or not the matrix G is to be computed, -C as follows: -C = 'G': Compute G; -C = 'N': Do not compute G. -C -C JOBL CHARACTER*1 -C Specifies whether or not the matrix L is zero, as follows: -C = 'Z': L is zero; -C = 'N': L is nonzero. -C -C FACT CHARACTER*1 -C Specifies how the matrix R is given (factored or not), as -C follows: -C = 'N': Array R contains the matrix R; -C = 'C': Array R contains the Cholesky factor of R; -C = 'U': Array R contains the symmetric indefinite UdU' or -C LdL' factorization of R. -C -C UPLO CHARACTER*1 -C Specifies which triangle of the matrices R and Q (if -C JOBL = 'N') is stored, as follows: -C = 'U': Upper triangle is stored; -C = 'L': Lower triangle is stored. -C -C Input/Output Parameters -C -C N (input) INTEGER -C The order of the matrices A, Q, and G, and the number of -C rows of the matrices B and L. N >= 0. -C -C M (input) INTEGER -C The order of the matrix R, and the number of columns of -C the matrices B and L. M >= 0. -C -C A (input/output) DOUBLE PRECISION array, dimension (LDA,N) -C On entry, if JOBL = 'N', the leading N-by-N part of this -C array must contain the matrix A. -C On exit, if JOBL = 'N', and INFO = 0, the leading N-by-N -C - -1 -C part of this array contains the matrix A = A - B*R L'. -C If JOBL = 'Z', this array is not referenced. -C -C LDA INTEGER -C The leading dimension of array A. -C LDA >= MAX(1,N) if JOBL = 'N'; -C LDA >= 1 if JOBL = 'Z'. -C -C B (input/output) DOUBLE PRECISION array, dimension (LDB,M) -C On entry, the leading N-by-M part of this array must -C contain the matrix B. -C On exit, if OUFACT = 1, and INFO = 0, the leading N-by-M -C -1 -C part of this array contains the matrix B*chol(R) . -C On exit, B is unchanged if OUFACT = 2 (hence also when -C FACT = 'U'). -C -C LDB INTEGER -C The leading dimension of array B. LDB >= MAX(1,N). -C -C Q (input/output) DOUBLE PRECISION array, dimension (LDQ,N) -C On entry, if JOBL = 'N', the leading N-by-N upper -C triangular part (if UPLO = 'U') or lower triangular part -C (if UPLO = 'L') of this array must contain the upper -C triangular part or lower triangular part, respectively, of -C the symmetric matrix Q. The stricly lower triangular part -C (if UPLO = 'U') or stricly upper triangular part (if -C UPLO = 'L') is not referenced. -C On exit, if JOBL = 'N' and INFO = 0, the leading N-by-N -C upper triangular part (if UPLO = 'U') or lower triangular -C part (if UPLO = 'L') of this array contains the upper -C triangular part or lower triangular part, respectively, of -C - -1 -C the symmetric matrix Q = Q - L*R *L'. -C If JOBL = 'Z', this array is not referenced. -C -C LDQ INTEGER -C The leading dimension of array Q. -C LDQ >= MAX(1,N) if JOBL = 'N'; -C LDQ >= 1 if JOBL = 'Z'. -C -C R (input/output) DOUBLE PRECISION array, dimension (LDR,M) -C On entry, if FACT = 'N', the leading M-by-M upper -C triangular part (if UPLO = 'U') or lower triangular part -C (if UPLO = 'L') of this array must contain the upper -C triangular part or lower triangular part, respectively, -C of the symmetric input weighting matrix R. -C On entry, if FACT = 'C', the leading M-by-M upper -C triangular part (if UPLO = 'U') or lower triangular part -C (if UPLO = 'L') of this array must contain the Cholesky -C factor of the positive definite input weighting matrix R -C (as produced by LAPACK routine DPOTRF). -C On entry, if FACT = 'U', the leading M-by-M upper -C triangular part (if UPLO = 'U') or lower triangular part -C (if UPLO = 'L') of this array must contain the factors of -C the UdU' or LdL' factorization, respectively, of the -C symmetric indefinite input weighting matrix R (as produced -C by LAPACK routine DSYTRF). -C If FACT = 'N', the stricly lower triangular part (if UPLO -C = 'U') or stricly upper triangular part (if UPLO = 'L') of -C this array is used as workspace. -C On exit, if OUFACT = 1, and INFO = 0 (or INFO = M+1), -C the leading M-by-M upper triangular part (if UPLO = 'U') -C or lower triangular part (if UPLO = 'L') of this array -C contains the Cholesky factor of the given input weighting -C matrix. -C On exit, if OUFACT = 2, and INFO = 0 (or INFO = M+1), -C the leading M-by-M upper triangular part (if UPLO = 'U') -C or lower triangular part (if UPLO = 'L') of this array -C contains the factors of the UdU' or LdL' factorization, -C respectively, of the given input weighting matrix. -C On exit R is unchanged if FACT = 'C' or 'U'. -C -C LDR INTEGER -C The leading dimension of array R. LDR >= MAX(1,M). -C -C L (input/output) DOUBLE PRECISION array, dimension (LDL,M) -C On entry, if JOBL = 'N', the leading N-by-M part of this -C array must contain the matrix L. -C On exit, if JOBL = 'N', OUFACT = 1, and INFO = 0, the -C leading N-by-M part of this array contains the matrix -C -1 -C L*chol(R) . -C On exit, L is unchanged if OUFACT = 2 (hence also when -C FACT = 'U'). -C L is not referenced if JOBL = 'Z'. -C -C LDL INTEGER -C The leading dimension of array L. -C LDL >= MAX(1,N) if JOBL = 'N'; -C LDL >= 1 if JOBL = 'Z'. -C -C IPIV (input/output) INTEGER array, dimension (M) -C On entry, if FACT = 'U', this array must contain details -C of the interchanges performed and the block structure of -C the d factor in the UdU' or LdL' factorization of matrix R -C (as produced by LAPACK routine DSYTRF). -C On exit, if OUFACT = 2, this array contains details of -C the interchanges performed and the block structure of the -C d factor in the UdU' or LdL' factorization of matrix R, -C as produced by LAPACK routine DSYTRF. -C This array is not referenced if FACT = 'C'. -C -C OUFACT (output) INTEGER -C Information about the factorization finally used. -C OUFACT = 1: Cholesky factorization of R has been used; -C OUFACT = 2: UdU' (if UPLO = 'U') or LdL' (if UPLO = 'L') -C factorization of R has been used. -C -C G (output) DOUBLE PRECISION array, dimension (LDG,N) -C If JOBG = 'G', and INFO = 0, the leading N-by-N upper -C triangular part (if UPLO = 'U') or lower triangular part -C (if UPLO = 'L') of this array contains the upper -C triangular part (if UPLO = 'U') or lower triangular part -C -1 -C (if UPLO = 'L'), respectively, of the matrix G = B*R B'. -C If JOBG = 'N', this array is not referenced. -C -C LDG INTEGER -C The leading dimension of array G. -C LDG >= MAX(1,N) if JOBG = 'G', -C LDG >= 1 if JOBG = 'N'. -C -C Workspace -C -C IWORK INTEGER array, dimension (M) -C -C DWORK DOUBLE PRECISION array, dimension (LDWORK) -C On exit, if INFO = 0, DWORK(1) returns the optimal value -C of LDWORK; if FACT = 'N', DWORK(2) contains the reciprocal -C condition number of the given matrix R. -C -C LDWORK INTEGER -C The length of the array DWORK. -C LDWORK >= 1 if FACT = 'C'; -C LDWORK >= MAX(2,3*M,N*M) if FACT = 'N'; -C LDWORK >= MAX(1,N*M) if FACT = 'U'. -C For optimum performance LDWORK should be larger than 3*M, -C if FACT = 'N'. -C The N*M workspace is not needed for FACT = 'N', if matrix -C R is positive definite. -C -C Error Indicator -C -C INFO INTEGER -C = 0: successful exit; -C < 0: if INFO = -i, the i-th argument had an illegal -C value; -C = i: if the i-th element (1 <= i <= M) of the d factor is -C exactly zero; the UdU' (or LdL') factorization has -C been completed, but the block diagonal matrix d is -C exactly singular; -C = M+1: if the matrix R is numerically singular. -C -C METHOD -C - - -C The matrices G, and/or A and Q are evaluated using the given or -C computed symmetric factorization of R. -C -C NUMERICAL ASPECTS -C -C The routine should not be used when R is ill-conditioned. -C -C CONTRIBUTOR -C -C Release 3.0: V. Sima, Katholieke Univ. Leuven, Belgium, Sep. 1997. -C -C REVISIONS -C -C - -C -C KEYWORDS -C -C Algebraic Riccati equation, closed loop system, continuous-time -C system, discrete-time system, optimal regulator, Schur form. -C -C ****************************************************************** -C -C .. Parameters .. - DOUBLE PRECISION ZERO, ONE - PARAMETER ( ZERO = 0.0D0, ONE = 1.0D0 ) -C .. Scalar Arguments .. - CHARACTER FACT, JOBG, JOBL, UPLO - INTEGER INFO, LDA, LDB, LDG, LDL, LDQ, LDR, LDWORK, M, - $ N, OUFACT -C .. Array Arguments .. - INTEGER IPIV(*), IWORK(*) - DOUBLE PRECISION A(LDA,*), B(LDB,*), DWORK(*), G(LDG,*), - $ L(LDL,*), Q(LDQ,*), R(LDR,*) -C .. Local Scalars .. - LOGICAL LFACTA, LFACTC, LFACTU, LJOBG, LJOBL, LUPLOU - CHARACTER TRANS - INTEGER I, J, WRKOPT - DOUBLE PRECISION EPS, RCOND, RNORM -C .. External Functions .. - LOGICAL LSAME - DOUBLE PRECISION DLAMCH, DLANSY - EXTERNAL DLAMCH, DLANSY, LSAME -C .. External Subroutines .. - EXTERNAL DCOPY, DGEMM, DGEMV, DPOCON, DPOTRF, DSYCON, - $ DSYRK, DSYTRF, DSYTRS, DTRSM, XERBLA -C .. Intrinsic Functions .. - INTRINSIC INT, MAX -C .. Executable Statements .. -C - INFO = 0 - LJOBG = LSAME( JOBG, 'G' ) - LJOBL = LSAME( JOBL, 'N' ) - LFACTC = LSAME( FACT, 'C' ) - LFACTU = LSAME( FACT, 'U' ) - LUPLOU = LSAME( UPLO, 'U' ) - LFACTA = LFACTC.OR.LFACTU -C -C Test the input scalar arguments. -C - IF( .NOT.LJOBG .AND. .NOT.LSAME( JOBG, 'N' ) ) THEN - INFO = -1 - ELSE IF( .NOT.LJOBL .AND. .NOT.LSAME( JOBL, 'Z' ) ) THEN - INFO = -2 - ELSE IF( .NOT.LFACTA .AND. .NOT.LSAME( FACT, 'N' ) ) THEN - INFO = -3 - ELSE IF( .NOT.LUPLOU .AND. .NOT.LSAME( UPLO, 'L' ) ) THEN - INFO = -4 - ELSE IF( N.LT.0 ) THEN - INFO = -5 - ELSE IF( M.LT.0 ) THEN - INFO = -6 - ELSE IF( ( LDA.LT.1 ) .OR. ( LJOBL .AND. LDA.LT.N ) ) THEN - INFO = -8 - ELSE IF( LDB.LT.MAX( 1, N ) ) THEN - INFO = -10 - ELSE IF( ( LDQ.LT.1 ) .OR. ( LJOBL .AND. LDQ.LT.N ) ) THEN - INFO = -12 - ELSE IF( LDR.LT.MAX( 1, M ) ) THEN - INFO = -14 - ELSE IF( ( LDL.LT.1 ) .OR. ( LJOBL .AND. LDL.LT.N ) ) THEN - INFO = -16 - ELSE IF( ( LDG.LT.1 ) .OR. ( LJOBG .AND. LDG.LT.N ) ) THEN - INFO = -20 - ELSE IF( ( LFACTC .AND. LDWORK.LT.1 ) .OR. - $ ( LFACTU .AND. LDWORK.LT.MAX( 1, N*M ) ) .OR. - $ ( .NOT.LFACTA .AND. LDWORK.LT.MAX( 2, N*M, 3*M ) ) ) THEN - INFO = -23 - END IF -C - IF ( INFO.NE.0 ) THEN -C -C Error return. -C - CALL XERBLA( 'SB02MT', -INFO ) - RETURN - END IF -C - IF ( LFACTC ) THEN - OUFACT = 1 - ELSE IF ( LFACTU ) THEN - OUFACT = 2 - END IF -C -C Quick return if possible. -C - IF ( N.EQ.0 .OR. M.EQ.0 .OR. .NOT.( LJOBL.OR.LJOBG ) ) THEN - DWORK(1) = ONE - IF ( .NOT.LFACTA ) DWORK(2) = ONE - RETURN - END IF -C -C (Note: Comments in the code beginning "Workspace:" describe the -C minimal amount of workspace needed at that point in the code, -C as well as the preferred amount for good performance. -C NB refers to the optimal block size for the immediately -C following subroutine, as returned by ILAENV.) -C - WRKOPT = 1 -C -C Set relative machine precision. -C - EPS = DLAMCH( 'Epsilon' ) -C - IF ( .NOT.LFACTA ) THEN -C -C Compute the norm of the matrix R, which is not factored. -C Then save the given triangle of R in the other strict triangle -C and the diagonal in the workspace, and try Cholesky -C factorization. -C Workspace: need M. -C - RNORM = DLANSY( '1-norm', UPLO, M, R, LDR, DWORK ) - CALL DCOPY( M, R, LDR+1, DWORK, 1 ) - IF( LUPLOU ) THEN -C - DO 20 J = 2, M - CALL DCOPY( J-1, R(1,J), 1, R(J,1), LDR ) - 20 CONTINUE -C - ELSE -C - DO 40 J = 2, M - CALL DCOPY( J-1, R(J,1), LDR, R(1,J), 1 ) - 40 CONTINUE -C - END IF - CALL DPOTRF( UPLO, M, R, LDR, INFO ) - IF( INFO.EQ.0 ) THEN -C -C Compute the reciprocal of the condition number of R. -C Workspace: need 3*M. -C - CALL DPOCON( UPLO, M, R, LDR, RNORM, RCOND, DWORK, IWORK, - $ INFO ) -C -C Return if the matrix is singular to working precision. -C - OUFACT = 1 - DWORK(2) = RCOND - IF( RCOND.LT.EPS ) THEN - INFO = M + 1 - RETURN - END IF - WRKOPT = MAX( WRKOPT, 3*M ) - ELSE -C -C Use UdU' or LdL' factorization, first restoring the saved -C triangle. -C - CALL DCOPY( M, DWORK, 1, R, LDR+1 ) - IF( LUPLOU ) THEN -C - DO 60 J = 2, M - CALL DCOPY( J-1, R(J,1), LDR, R(1,J), 1 ) - 60 CONTINUE -C - ELSE -C - DO 80 J = 2, M - CALL DCOPY( J-1, R(1,J), 1, R(J,1), LDR ) - 80 CONTINUE -C - END IF -C -C Compute the UdU' or LdL' factorization. -C Workspace: need 1, -C prefer M*NB. -C - CALL DSYTRF( UPLO, M, R, LDR, IPIV, DWORK, LDWORK, INFO ) - OUFACT = 2 - IF( INFO.GT.0 ) THEN - DWORK(2) = ONE - RETURN - END IF - WRKOPT = MAX( WRKOPT, INT( DWORK(1) ) ) -C -C Compute the reciprocal of the condition number of R. -C Workspace: need 2*M. -C - CALL DSYCON( UPLO, M, R, LDR, IPIV, RNORM, RCOND, DWORK, - $ IWORK, INFO ) -C -C Return if the matrix is singular to working precision. -C - DWORK(2) = RCOND - IF( RCOND.LT.EPS ) THEN - INFO = M + 1 - RETURN - END IF - END IF - END IF -C - IF (OUFACT.EQ.1 ) THEN -C -C Solve positive definite linear system(s). -C - IF ( LUPLOU ) THEN - TRANS = 'N' - ELSE - TRANS = 'T' - END IF -C -C Solve the system X*U = B, overwriting B with X. -C - CALL DTRSM( 'Right', UPLO, TRANS, 'Non-unit', N, M, - $ ONE, R, LDR, B, LDB ) -C - IF ( LJOBG ) THEN -C -1 -C Compute the matrix G = B*R *B', multiplying X*X' in G. -C - CALL DSYRK( UPLO, 'No transpose', N, M, ONE, B, LDB, ZERO, - $ G, LDG ) - END IF -C - IF( LJOBL ) THEN -C -C Update matrices A and Q. -C -C Solve the system Y*U = L, overwriting L with Y. -C - CALL DTRSM( 'Right', UPLO, TRANS, 'Non-unit', N, M, - $ ONE, R, LDR, L, LDL ) -C -C Compute A <- A - X*Y'. -C - CALL DGEMM( 'No transpose', 'Transpose', N, N, M, -ONE, B, - $ LDB, L, LDL, ONE, A, LDA ) -C -C Compute Q <- Q - Y*Y'. -C - CALL DSYRK( UPLO, 'No transpose', N, M, -ONE, L, LDL, ONE, - $ Q, LDQ ) - END IF - ELSE -C -C Solve indefinite linear system(s). -C -C Solve the system UdU'*X = B' (or LdL'*X = B'). -C Workspace: need N*M. -C - DO 100 J = 1, M - CALL DCOPY( N, B(1,J), 1, DWORK(J), M ) - 100 CONTINUE -C - CALL DSYTRS( UPLO, M, N, R, LDR, IPIV, DWORK, M, INFO ) -C - IF ( LJOBG ) THEN -C -1 -C Compute a triangle of the matrix G = B*R *B' = B*X. -C - IF ( LUPLOU ) THEN - I = 1 -C - DO 120 J = 1, N - CALL DGEMV( 'No transpose', J, M, ONE, B, LDB, - $ DWORK(I), 1, ZERO, G(1,J), 1 ) - I = I + M - 120 CONTINUE -C - ELSE -C - DO 140 J = 1, N - CALL DGEMV( 'Transpose', M, J, ONE, DWORK, M, B(J,1), - $ LDB, ZERO, G(J,1), LDG ) - 140 CONTINUE -C - END IF - END IF -C - IF( LJOBL ) THEN -C -C Update matrices A and Q. -C -C Solve the system UdU'*Y = L' (or LdL'*Y = L'). -C - DO 160 J = 1, M - CALL DCOPY( N, L(1,J), 1, DWORK(J), M ) - 160 CONTINUE -C - CALL DSYTRS( UPLO, M, N, R, LDR, IPIV, DWORK, M, INFO ) -C -C A <- A - B*Y. -C - CALL DGEMM( 'No transpose', 'No transpose', N, N, M, -ONE, - $ B, LDB, DWORK, M, ONE, A, LDA ) -C - -1 -C Compute a triangle of the matrix Q = Q - L*R *L' = Q - L*Y. -C - IF ( LUPLOU ) THEN - I = 1 -C - DO 180 J = 1, N - CALL DGEMV( 'No transpose', J, M, -ONE, L, LDL, - $ DWORK(I), 1, ONE, Q(1,J), 1 ) - I = I + M - 180 CONTINUE -C - ELSE -C - DO 200 J = 1, N - CALL DGEMV( 'Transpose', M, J, -ONE, DWORK, M, L(J,1), - $ LDL, ONE, Q(J,1), LDQ ) - 200 CONTINUE -C - END IF - END IF - END IF -C - DWORK(1) = WRKOPT - IF ( .NOT.LFACTA ) DWORK(2) = RCOND -C -C *** Last line of SB02MT *** - RETURN - END diff --git a/mex/sources/libslicot/SB02MU.f b/mex/sources/libslicot/SB02MU.f deleted file mode 100644 index 567a22476..000000000 --- a/mex/sources/libslicot/SB02MU.f +++ /dev/null @@ -1,486 +0,0 @@ - SUBROUTINE SB02MU( DICO, HINV, UPLO, N, A, LDA, G, LDG, Q, LDQ, S, - $ LDS, IWORK, DWORK, LDWORK, INFO ) -C -C SLICOT RELEASE 5.0. -C -C Copyright (c) 2002-2009 NICONET e.V. -C -C This program is free software: you can redistribute it and/or -C modify it under the terms of the GNU General Public License as -C published by the Free Software Foundation, either version 2 of -C the License, or (at your option) any later version. -C -C This program is distributed in the hope that it will be useful, -C but WITHOUT ANY WARRANTY; without even the implied warranty of -C MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the -C GNU General Public License for more details. -C -C You should have received a copy of the GNU General Public License -C along with this program. If not, see -C . -C -C PURPOSE -C -C To construct the 2n-by-2n Hamiltonian or symplectic matrix S -C associated to the linear-quadratic optimization problem, used to -C solve the continuous- or discrete-time algebraic Riccati equation, -C respectively. -C -C For a continuous-time problem, S is defined by -C -C ( A -G ) -C S = ( ), (1) -C ( -Q -A') -C -C and for a discrete-time problem by -C -C -1 -1 -C ( A A *G ) -C S = ( -1 -1 ), (2) -C ( QA A' + Q*A *G ) -C -C or -C -C -T -T -C ( A + G*A *Q -G*A ) -C S = ( -T -T ), (3) -C ( -A *Q A ) -C -C where A, G, and Q are N-by-N matrices, with G and Q symmetric. -C Matrix A must be nonsingular in the discrete-time case. -C -C ARGUMENTS -C -C Mode Parameters -C -C DICO CHARACTER*1 -C Specifies the type of the system as follows: -C = 'C': Continuous-time system; -C = 'D': Discrete-time system. -C -C HINV CHARACTER*1 -C If DICO = 'D', specifies which of the matrices (2) or (3) -C is constructed, as follows: -C = 'D': The matrix S in (2) is constructed; -C = 'I': The (inverse) matrix S in (3) is constructed. -C HINV is not referenced if DICO = 'C'. -C -C UPLO CHARACTER*1 -C Specifies which triangle of the matrices G and Q is -C stored, as follows: -C = 'U': Upper triangle is stored; -C = 'L': Lower triangle is stored. -C -C Input/Output Parameters -C -C N (input) INTEGER -C The order of the matrices A, G, and Q. N >= 0. -C -C A (input/output) DOUBLE PRECISION array, dimension (LDA,N) -C On entry, the leading N-by-N part of this array must -C contain the matrix A. -C On exit, if DICO = 'D', and INFO = 0, the leading N-by-N -C -1 -C part of this array contains the matrix A . -C Otherwise, the array A is unchanged on exit. -C -C LDA INTEGER -C The leading dimension of array A. LDA >= MAX(1,N). -C -C G (input) DOUBLE PRECISION array, dimension (LDG,N) -C The leading N-by-N upper triangular part (if UPLO = 'U') -C or lower triangular part (if UPLO = 'L') of this array -C must contain the upper triangular part or lower triangular -C part, respectively, of the symmetric matrix G. The stricly -C lower triangular part (if UPLO = 'U') or stricly upper -C triangular part (if UPLO = 'L') is not referenced. -C -C LDG INTEGER -C The leading dimension of array G. LDG >= MAX(1,N). -C -C Q (input) DOUBLE PRECISION array, dimension (LDQ,N) -C The leading N-by-N upper triangular part (if UPLO = 'U') -C or lower triangular part (if UPLO = 'L') of this array -C must contain the upper triangular part or lower triangular -C part, respectively, of the symmetric matrix Q. The stricly -C lower triangular part (if UPLO = 'U') or stricly upper -C triangular part (if UPLO = 'L') is not referenced. -C -C LDQ INTEGER -C The leading dimension of array Q. LDQ >= MAX(1,N). -C -C S (output) DOUBLE PRECISION array, dimension (LDS,2*N) -C If INFO = 0, the leading 2N-by-2N part of this array -C contains the Hamiltonian or symplectic matrix of the -C problem. -C -C LDS INTEGER -C The leading dimension of array S. LDS >= MAX(1,2*N). -C -C Workspace -C -C IWORK INTEGER array, dimension (2*N) -C -C DWORK DOUBLE PRECISION array, dimension (LDWORK) -C On exit, if INFO = 0, DWORK(1) returns the optimal value -C of LDWORK; if DICO = 'D', DWORK(2) returns the reciprocal -C condition number of the given matrix A. -C -C LDWORK INTEGER -C The length of the array DWORK. -C LDWORK >= 1 if DICO = 'C'; -C LDWORK >= MAX(2,4*N) if DICO = 'D'. -C For optimum performance LDWORK should be larger, if -C DICO = 'D'. -C -C Error Indicator -C -C INFO INTEGER -C = 0: successful exit; -C < 0: if INFO = -i, the i-th argument had an illegal -C value; -C = i: if the leading i-by-i (1 <= i <= N) upper triangular -C submatrix of A is singular in discrete-time case; -C = N+1: if matrix A is numerically singular in discrete- -C time case. -C -C METHOD -C -C For a continuous-time problem, the 2n-by-2n Hamiltonian matrix (1) -C is constructed. -C For a discrete-time problem, the 2n-by-2n symplectic matrix (2) or -C (3) - the inverse of the matrix in (2) - is constructed. -C -C NUMERICAL ASPECTS -C -C The discrete-time case needs the inverse of the matrix A, hence -C the routine should not be used when A is ill-conditioned. -C 3 -C The algorithm requires 0(n ) floating point operations in the -C discrete-time case. -C -C CONTRIBUTOR -C -C Release 3.0: V. Sima, Katholieke Univ. Leuven, Belgium, Aug. 1997. -C -C REVISIONS -C -C V. Sima, Research Institute for Informatics, Bucharest, Feb. 2004. -C -C KEYWORDS -C -C Algebraic Riccati equation, closed loop system, continuous-time -C system, discrete-time system, optimal regulator, Schur form. -C -C ****************************************************************** -C -C .. Parameters .. - DOUBLE PRECISION ZERO, ONE - PARAMETER ( ZERO = 0.0D0, ONE = 1.0D0 ) -C .. Scalar Arguments .. - CHARACTER DICO, HINV, UPLO - INTEGER INFO, LDA, LDG, LDQ, LDS, LDWORK, N -C .. Array Arguments .. - INTEGER IWORK(*) - DOUBLE PRECISION A(LDA,*), DWORK(*), G(LDG,*), Q(LDQ,*), - $ S(LDS,*) -C .. Local Scalars .. - LOGICAL DISCR, LHINV, LUPLO - INTEGER I, J, MAXWRK, N2, NJ, NP1 - DOUBLE PRECISION ANORM, RCOND -C .. External Functions .. - LOGICAL LSAME - INTEGER ILAENV - DOUBLE PRECISION DLAMCH, DLANGE - EXTERNAL DLAMCH, DLANGE, ILAENV, LSAME -C .. External Subroutines .. - EXTERNAL DCOPY, DGECON, DGEMM, DGETRF, DGETRI, DGETRS, - $ DLACPY, DSWAP, XERBLA -C .. Intrinsic Functions .. - INTRINSIC MAX -C .. Executable Statements .. -C - INFO = 0 - N2 = N + N - DISCR = LSAME( DICO, 'D' ) - LUPLO = LSAME( UPLO, 'U' ) - IF( DISCR ) THEN - LHINV = LSAME( HINV, 'D' ) - ELSE - LHINV = .FALSE. - END IF -C -C Test the input scalar arguments. -C - IF( .NOT.DISCR .AND. .NOT.LSAME( DICO, 'C' ) ) THEN - INFO = -1 - ELSE IF( DISCR ) THEN - IF( .NOT.LHINV .AND. .NOT.LSAME( HINV, 'I' ) ) - $ INFO = -2 - END IF - IF( .NOT.LUPLO .AND. .NOT.LSAME( UPLO, 'L' ) ) THEN - INFO = -3 - ELSE IF( N.LT.0 ) THEN - INFO = -4 - ELSE IF( LDA.LT.MAX( 1, N ) ) THEN - INFO = -6 - ELSE IF( LDG.LT.MAX( 1, N ) ) THEN - INFO = -8 - ELSE IF( LDQ.LT.MAX( 1, N ) ) THEN - INFO = -10 - ELSE IF( LDS.LT.MAX( 1, N2 ) ) THEN - INFO = -12 - ELSE IF( ( LDWORK.LT.1 ) .OR. - $ ( DISCR .AND. LDWORK.LT.MAX( 2, 4*N ) ) ) THEN - INFO = -15 - END IF -C - IF ( INFO.NE.0 ) THEN -C -C Error return. -C - CALL XERBLA( 'SB02MU', -INFO ) - RETURN - END IF -C -C Quick return if possible. -C - IF ( N.EQ.0 ) THEN - DWORK(1) = ONE - IF ( DISCR ) DWORK(2) = ONE - RETURN - END IF -C -C The code tries to exploit data locality as much as possible. -C - IF ( .NOT.LHINV ) THEN - CALL DLACPY( 'Full', N, N, A, LDA, S, LDS ) -C -C Construct Hamiltonian matrix in the continuous-time case, or -C prepare symplectic matrix in (3) in the discrete-time case: -C -C Construct full Q in S(N+1:2*N,1:N) and change the sign, and -C construct full G in S(1:N,N+1:2*N) and change the sign. -C - DO 200 J = 1, N - NJ = N + J - IF ( LUPLO ) THEN -C - DO 20 I = 1, J - S(N+I,J) = -Q(I,J) - 20 CONTINUE -C - DO 40 I = J + 1, N - S(N+I,J) = -Q(J,I) - 40 CONTINUE -C - DO 60 I = 1, J - S(I,NJ) = -G(I,J) - 60 CONTINUE -C - DO 80 I = J + 1, N - S(I,NJ) = -G(J,I) - 80 CONTINUE -C - ELSE -C - DO 100 I = 1, J - 1 - S(N+I,J) = -Q(J,I) - 100 CONTINUE -C - DO 120 I = J, N - S(N+I,J) = -Q(I,J) - 120 CONTINUE -C - DO 140 I = 1, J - 1 - S(I,NJ) = -G(J,I) - 140 CONTINUE -C - DO 180 I = J, N - S(I,NJ) = -G(I,J) - 180 CONTINUE -C - END IF - 200 CONTINUE -C - IF ( .NOT.DISCR ) THEN -C - DO 240 J = 1, N - NJ = N + J -C - DO 220 I = 1, N - S(N+I,NJ) = -A(J,I) - 220 CONTINUE -C - 240 CONTINUE -C - DWORK(1) = ONE - END IF - END IF -C - IF ( DISCR ) THEN -C -C Construct the symplectic matrix (2) or (3) in the discrete-time -C case. -C -C Compute workspace. -C (Note: Comments in the code beginning "Workspace:" describe the -C minimal amount of workspace needed at that point in the code, -C as well as the preferred amount for good performance. -C NB refers to the optimal block size for the immediately -C following subroutine, as returned by ILAENV.) -C - MAXWRK = MAX( 4*N, - $ N*ILAENV( 1, 'DGETRI', ' ', N, -1, -1, -1 ) ) - NP1 = N + 1 -C - IF ( LHINV ) THEN -C -C Put A' in S(N+1:2*N,N+1:2*N). -C - DO 260 I = 1, N - CALL DCOPY( N, A(I, 1), LDA, S(NP1,N+I), 1 ) - 260 CONTINUE -C - END IF -C -C Compute the norm of the matrix A. -C - ANORM = DLANGE( '1-norm', N, N, A, LDA, DWORK ) -C -C Compute the LU factorization of A. -C - CALL DGETRF( N, N, A, LDA, IWORK, INFO ) -C -C Return if INFO is non-zero. -C - IF( INFO.GT.0 ) THEN - DWORK(2) = ZERO - RETURN - END IF -C -C Compute the reciprocal of the condition number of A. -C Workspace: need 4*N. -C - CALL DGECON( '1-norm', N, A, LDA, ANORM, RCOND, DWORK, - $ IWORK(NP1), INFO ) -C -C Return if the matrix is singular to working precision. -C - IF( RCOND.LT.DLAMCH( 'Epsilon' ) ) THEN - INFO = N + 1 - DWORK(2) = RCOND - RETURN - END IF -C - IF ( LHINV ) THEN -C -C Compute S in (2). -C -C Construct full Q in S(N+1:2*N,1:N). -C - IF ( LUPLO ) THEN - DO 270 J = 1, N - 1 - CALL DCOPY( J, Q(1,J), 1, S(NP1,J), 1 ) - CALL DCOPY( N-J, Q(J,J+1), LDQ, S(NP1+J,J), 1 ) - 270 CONTINUE - CALL DCOPY( N, Q(1,N), 1, S(NP1,N), 1 ) - ELSE - CALL DCOPY( N, Q(1,1), 1, S(NP1,1), 1 ) - DO 280 J = 2, N - CALL DCOPY( J-1, Q(J,1), LDQ, S(NP1,J), 1 ) - CALL DCOPY( N-J+1, Q(J,J), 1, S(N+J,J), 1 ) - 280 CONTINUE - END IF -C -C Compute the solution matrix X of the system X*A = Q by -C -1 -C solving A'*X' = Q and transposing the result to get Q*A . -C - CALL DGETRS( 'Transpose', N, N, A, LDA, IWORK, S(NP1,1), - $ LDS, INFO ) -C - DO 300 J = 1, N - 1 - CALL DSWAP( N-J, S(NP1+J,J), 1, S(N+J,J+1), LDS ) - 300 CONTINUE -C -C Construct full G in S(1:N,N+1:2*N). -C - IF ( LUPLO ) THEN - DO 310 J = 1, N - 1 - CALL DCOPY( J, G(1,J), 1, S(1,N+J), 1 ) - CALL DCOPY( N-J, G(J,J+1), LDG, S(J+1,N+J), 1 ) - 310 CONTINUE - CALL DCOPY( N, G(1,N), 1, S(1,N2), 1 ) - ELSE - CALL DCOPY( N, G(1,1), 1, S(1,NP1), 1 ) - DO 320 J = 2, N - CALL DCOPY( J-1, G(J,1), LDG, S(1,N+J), 1 ) - CALL DCOPY( N-J+1, G(J,J), 1, S(J,N+J), 1 ) - 320 CONTINUE - END IF -C -1 -C Compute A' + Q*A *G in S(N+1:2N,N+1:2N). -C - CALL DGEMM( 'No transpose', 'No transpose', N, N, N, ONE, - $ S(NP1,1), LDS, S(1,NP1), LDS, ONE, S(NP1,NP1), - $ LDS ) -C -C Compute the solution matrix Y of the system A*Y = G. -C - CALL DGETRS( 'No transpose', N, N, A, LDA, IWORK, S(1,NP1), - $ LDS, INFO ) -C -C Compute the inverse of A in situ. -C Workspace: need N; prefer N*NB. -C - CALL DGETRI( N, A, LDA, IWORK, DWORK, LDWORK, INFO ) -C -1 -C Copy A in S(1:N,1:N). -C - CALL DLACPY( 'Full', N, N, A, LDA, S, LDS ) -C - ELSE -C -C Compute S in (3) using the already prepared part. -C -C Compute the solution matrix X' of the system A*X' = -G -C -T -C and transpose the result to obtain X = -G*A . -C - CALL DGETRS( 'No transpose', N, N, A, LDA, IWORK, S(1,NP1), - $ LDS, INFO ) -C - DO 340 J = 1, N - 1 - CALL DSWAP( N-J, S(J+1,N+J), 1, S(J,NP1+J), LDS ) - 340 CONTINUE -C -T -C Compute A + G*A *Q in S(1:N,1:N). -C - CALL DGEMM( 'No transpose', 'No transpose', N, N, N, ONE, - $ S(1,NP1), LDS, S(NP1, 1), LDS, ONE, S, LDS ) -C -C Compute the solution matrix Y of the system A'*Y = -Q. -C - CALL DGETRS( 'Transpose', N, N, A, LDA, IWORK, S(NP1,1), - $ LDS, INFO ) -C -C Compute the inverse of A in situ. -C Workspace: need N; prefer N*NB. -C - CALL DGETRI( N, A, LDA, IWORK, DWORK, LDWORK, INFO ) -C -T -C Copy A in S(N+1:2N,N+1:2N). -C - DO 360 J = 1, N - CALL DCOPY( N, A(J,1), LDA, S(NP1,N+J), 1 ) - 360 CONTINUE -C - END IF - DWORK(1) = MAXWRK - DWORK(2) = RCOND - END IF -C -C *** Last line of SB02MU *** - RETURN - END diff --git a/mex/sources/libslicot/SB02MV.f b/mex/sources/libslicot/SB02MV.f deleted file mode 100644 index 5dc8e2452..000000000 --- a/mex/sources/libslicot/SB02MV.f +++ /dev/null @@ -1,75 +0,0 @@ - LOGICAL FUNCTION SB02MV( REIG, IEIG ) -C -C SLICOT RELEASE 5.0. -C -C Copyright (c) 2002-2009 NICONET e.V. -C -C This program is free software: you can redistribute it and/or -C modify it under the terms of the GNU General Public License as -C published by the Free Software Foundation, either version 2 of -C the License, or (at your option) any later version. -C -C This program is distributed in the hope that it will be useful, -C but WITHOUT ANY WARRANTY; without even the implied warranty of -C MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the -C GNU General Public License for more details. -C -C You should have received a copy of the GNU General Public License -C along with this program. If not, see -C . -C -C PURPOSE -C -C To select the stable eigenvalues for solving the continuous-time -C algebraic Riccati equation. -C -C ARGUMENTS -C -C Input/Output Parameters -C -C REIG (input) DOUBLE PRECISION -C The real part of the current eigenvalue considered. -C -C IEIG (input) DOUBLE PRECISION -C The imaginary part of the current eigenvalue considered. -C -C METHOD -C -C The function value SB02MV is set to .TRUE. for a stable eigenvalue -C and to .FALSE., otherwise. -C -C REFERENCES -C -C None. -C -C NUMERICAL ASPECTS -C -C None. -C -C CONTRIBUTOR -C -C V. Sima, Katholieke Univ. Leuven, Belgium, Aug. 1997. -C -C REVISIONS -C -C - -C -C KEYWORDS -C -C Algebraic Riccati equation, closed loop system, continuous-time -C system, optimal regulator, Schur form. -C -C ****************************************************************** -C -C .. Parameters .. - DOUBLE PRECISION ZERO - PARAMETER ( ZERO = 0.0D0 ) -C .. Scalar Arguments .. - DOUBLE PRECISION IEIG, REIG -C .. Executable Statements .. -C - SB02MV = REIG.LT.ZERO -C - RETURN -C *** Last line of SB02MV *** - END diff --git a/mex/sources/libslicot/SB02MW.f b/mex/sources/libslicot/SB02MW.f deleted file mode 100644 index eb54ebae9..000000000 --- a/mex/sources/libslicot/SB02MW.f +++ /dev/null @@ -1,79 +0,0 @@ - LOGICAL FUNCTION SB02MW( REIG, IEIG ) -C -C SLICOT RELEASE 5.0. -C -C Copyright (c) 2002-2009 NICONET e.V. -C -C This program is free software: you can redistribute it and/or -C modify it under the terms of the GNU General Public License as -C published by the Free Software Foundation, either version 2 of -C the License, or (at your option) any later version. -C -C This program is distributed in the hope that it will be useful, -C but WITHOUT ANY WARRANTY; without even the implied warranty of -C MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the -C GNU General Public License for more details. -C -C You should have received a copy of the GNU General Public License -C along with this program. If not, see -C . -C -C PURPOSE -C -C To select the stable eigenvalues for solving the discrete-time -C algebraic Riccati equation. -C -C ARGUMENTS -C -C Input/Output Parameters -C -C REIG (input) DOUBLE PRECISION -C The real part of the current eigenvalue considered. -C -C IEIG (input) DOUBLE PRECISION -C The imaginary part of the current eigenvalue considered. -C -C METHOD -C -C The function value SB02MW is set to .TRUE. for a stable -C eigenvalue (i.e., with modulus less than one) and to .FALSE., -C otherwise. -C -C REFERENCES -C -C None. -C -C NUMERICAL ASPECTS -C -C None. -C -C CONTRIBUTOR -C -C V. Sima, Katholieke Univ. Leuven, Belgium, Aug. 1997. -C -C REVISIONS -C -C - -C -C KEYWORDS -C -C Algebraic Riccati equation, closed loop system, discrete-time -C system, optimal regulator, Schur form. -C -C ****************************************************************** -C -C .. Parameters .. - DOUBLE PRECISION ONE - PARAMETER ( ONE = 1.0D0 ) -C .. Scalar Arguments .. - DOUBLE PRECISION IEIG, REIG -C .. External Functions .. - DOUBLE PRECISION DLAPY2 - EXTERNAL DLAPY2 -C .. Executable Statements .. -C - SB02MW = DLAPY2( REIG, IEIG ).LT.ONE -C - RETURN -C *** Last line of SB02MW *** - END diff --git a/mex/sources/libslicot/SB02ND.f b/mex/sources/libslicot/SB02ND.f deleted file mode 100644 index 1f446c023..000000000 --- a/mex/sources/libslicot/SB02ND.f +++ /dev/null @@ -1,755 +0,0 @@ - SUBROUTINE SB02ND( DICO, FACT, UPLO, JOBL, N, M, P, A, LDA, B, - $ LDB, R, LDR, IPIV, L, LDL, X, LDX, RNORM, F, - $ LDF, OUFACT, IWORK, DWORK, LDWORK, INFO ) -C -C SLICOT RELEASE 5.0. -C -C Copyright (c) 2002-2009 NICONET e.V. -C -C This program is free software: you can redistribute it and/or -C modify it under the terms of the GNU General Public License as -C published by the Free Software Foundation, either version 2 of -C the License, or (at your option) any later version. -C -C This program is distributed in the hope that it will be useful, -C but WITHOUT ANY WARRANTY; without even the implied warranty of -C MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the -C GNU General Public License for more details. -C -C You should have received a copy of the GNU General Public License -C along with this program. If not, see -C . -C -C PURPOSE -C -C To compute the optimal feedback matrix F for the problem of -C optimal control given by -C -C -1 -C F = (R + B'XB) (B'XA + L') (1) -C -C in the discrete-time case and -C -C -1 -C F = R (B'X + L') (2) -C -C in the continuous-time case, where A, B and L are N-by-N, N-by-M -C and N-by-M matrices respectively; R and X are M-by-M and N-by-N -C symmetric matrices respectively. -C -C Optionally, matrix R may be specified in a factored form, and L -C may be zero. -C -C ARGUMENTS -C -C Mode Parameters -C -C DICO CHARACTER*1 -C Specifies the equation from which F is to be determined, -C as follows: -C = 'D': Equation (1), discrete-time case; -C = 'C': Equation (2), continuous-time case. -C -C FACT CHARACTER*1 -C Specifies how the matrix R is given (factored or not), as -C follows: -C = 'N': Array R contains the matrix R; -C = 'D': Array R contains a P-by-M matrix D, where R = D'D; -C = 'C': Array R contains the Cholesky factor of R; -C = 'U': Array R contains the symmetric indefinite UdU' or -C LdL' factorization of R. This option is not -C available for DICO = 'D'. -C -C UPLO CHARACTER*1 -C Specifies which triangle of the possibly factored matrix R -C (or R + B'XB, on exit) is or should be stored, as follows: -C = 'U': Upper triangle is stored; -C = 'L': Lower triangle is stored. -C -C JOBL CHARACTER*1 -C Specifies whether or not the matrix L is zero, as follows: -C = 'Z': L is zero; -C = 'N': L is nonzero. -C -C Input/Output Parameters -C -C N (input) INTEGER -C The order of the matrices A and X. N >= 0. -C -C M (input) INTEGER -C The number of system inputs. M >= 0. -C -C P (input) INTEGER -C The number of system outputs. P >= 0. -C This parameter must be specified only for FACT = 'D'. -C -C A (input) DOUBLE PRECISION array, dimension (LDA,N) -C If DICO = 'D', the leading N-by-N part of this array must -C contain the state matrix A of the system. -C If DICO = 'C', this array is not referenced. -C -C LDA INTEGER -C The leading dimension of array A. -C LDA >= MAX(1,N) if DICO = 'D'; -C LDA >= 1 if DICO = 'C'. -C -C B (input) DOUBLE PRECISION array, dimension (LDB,M) -C The leading N-by-M part of this array must contain the -C input matrix B of the system. -C If DICO = 'D' and FACT = 'D' or 'C', the contents of this -C array is destroyed. -C Otherwise, B is unchanged on exit. -C -C LDB INTEGER -C The leading dimension of array B. LDB >= MAX(1,N). -C -C R (input/output) DOUBLE PRECISION array, dimension (LDR,M) -C On entry, if FACT = 'N', the leading M-by-M upper -C triangular part (if UPLO = 'U') or lower triangular part -C (if UPLO = 'L') of this array must contain the upper -C triangular part or lower triangular part, respectively, -C of the symmetric input weighting matrix R. -C On entry, if FACT = 'D', the leading P-by-M part of this -C array must contain the direct transmission matrix D of the -C system. -C On entry, if FACT = 'C', the leading M-by-M upper -C triangular part (if UPLO = 'U') or lower triangular part -C (if UPLO = 'L') of this array must contain the Cholesky -C factor of the positive definite input weighting matrix R -C (as produced by LAPACK routine DPOTRF). -C On entry, if DICO = 'C' and FACT = 'U', the leading M-by-M -C upper triangular part (if UPLO = 'U') or lower triangular -C part (if UPLO = 'L') of this array must contain the -C factors of the UdU' or LdL' factorization, respectively, -C of the symmetric indefinite input weighting matrix R (as -C produced by LAPACK routine DSYTRF). -C The stricly lower triangular part (if UPLO = 'U') or -C stricly upper triangular part (if UPLO = 'L') of this -C array is used as workspace. -C On exit, if OUFACT(1) = 1, and INFO = 0 (or INFO = M+1), -C the leading M-by-M upper triangular part (if UPLO = 'U') -C or lower triangular part (if UPLO = 'L') of this array -C contains the Cholesky factor of the given input weighting -C matrix (for DICO = 'C'), or that of the matrix R + B'XB -C (for DICO = 'D'). -C On exit, if OUFACT(1) = 2, and INFO = 0 (or INFO = M+1), -C the leading M-by-M upper triangular part (if UPLO = 'U') -C or lower triangular part (if UPLO = 'L') of this array -C contains the factors of the UdU' or LdL' factorization, -C respectively, of the given input weighting matrix -C (for DICO = 'C'), or that of the matrix R + B'XB -C (for DICO = 'D'). -C On exit R is unchanged if FACT = 'U'. -C -C LDR INTEGER. -C The leading dimension of the array R. -C LDR >= MAX(1,M) if FACT <> 'D'; -C LDR >= MAX(1,M,P) if FACT = 'D'. -C -C IPIV (input/output) INTEGER array, dimension (M) -C On entry, if FACT = 'U', this array must contain details -C of the interchanges performed and the block structure of -C the d factor in the UdU' or LdL' factorization of matrix R -C (as produced by LAPACK routine DSYTRF). -C On exit, if OUFACT(1) = 2, this array contains details of -C the interchanges performed and the block structure of the -C d factor in the UdU' or LdL' factorization of matrix R (or -C D'D) or R + B'XB (or D'D + B'XB), as produced by LAPACK -C routine DSYTRF. -C This array is not referenced for DICO = 'D' or FACT = 'D', -C or 'C'. -C -C L (input) DOUBLE PRECISION array, dimension (LDL,M) -C If JOBL = 'N', the leading N-by-M part of this array must -C contain the cross weighting matrix L. -C If JOBL = 'Z', this array is not referenced. -C -C LDL INTEGER -C The leading dimension of array L. -C LDL >= MAX(1,N) if JOBL = 'N'; -C LDL >= 1 if JOBL = 'Z'. -C -C X (input/output) DOUBLE PRECISION array, dimension (LDX,N) -C On entry, the leading N-by-N part of this array must -C contain the solution matrix X of the algebraic Riccati -C equation as produced by SLICOT Library routines SB02MD or -C SB02OD. Matrix X is assumed non-negative definite. -C On exit, if DICO = 'D', FACT = 'D' or 'C', OUFACT(2) = 1, -C and INFO = 0, the N-by-N upper triangular part of this -C array contains the Cholesky factor of the given matrix X, -C which is found to be positive definite. -C On exit, if DICO = 'D', FACT = 'D' or 'C', OUFACT(2) = 2, -C and INFO = 0, the leading N-by-N part of this array -C contains the matrix of orthonormal eigenvectors of X. -C On exit X is unchanged if DICO = 'C' or FACT = 'N'. -C -C LDX INTEGER -C The leading dimension of array X. LDX >= MAX(1,N). -C -C RNORM (input) DOUBLE PRECISION -C If FACT = 'U', this parameter must contain the 1-norm of -C the original matrix R (before factoring it). -C Otherwise, this parameter is not used. -C -C F (output) DOUBLE PRECISION array, dimension (LDF,N) -C The leading M-by-N part of this array contains the -C optimal feedback matrix F. -C -C LDF INTEGER -C The leading dimension of array F. LDF >= MAX(1,M). -C -C OUFACT (output) INTEGER array, dimension (2) -C Information about the factorization finally used. -C OUFACT(1) = 1: Cholesky factorization of R (or R + B'XB) -C has been used; -C OUFACT(1) = 2: UdU' (if UPLO = 'U') or LdL' (if UPLO = -C 'L') factorization of R (or R + B'XB) -C has been used; -C OUFACT(2) = 1: Cholesky factorization of X has been used; -C OUFACT(2) = 2: Spectral factorization of X has been used. -C The value of OUFACT(2) is not set for DICO = 'C' or for -C DICO = 'D' and FACT = 'N'. -C -C Workspace -C -C IWORK INTEGER array, dimension (M) -C -C DWORK DOUBLE PRECISION array, dimension (LDWORK) -C On exit, if INFO = 0, DWORK(1) returns the optimal value -C of LDWORK, and DWORK(2) contains the reciprocal condition -C number of the matrix R (for DICO = 'C') or of R + B'XB -C (for DICO = 'D'). -C If on exit INFO = 0, and OUFACT(2) = 2, then DWORK(3),..., -C DWORK(N+2) contain the eigenvalues of X, in ascending -C order. -C -C LDWORK INTEGER -C Dimension of working array DWORK. -C LDWORK >= max(2,3*M) if FACT = 'N'; -C LDWORK >= max(2,2*M) if FACT = 'U'; -C LDWORK >= max(2,3*M) if FACT = 'C', DICO = 'C'; -C LDWORK >= N+3*M+2 if FACT = 'C', DICO = 'D'; -C LDWORK >= max(2,min(P,M)+M) if FACT = 'D', DICO = 'C'; -C LDWORK >= max(N+3*M+2,4*N+1) if FACT = 'D', DICO = 'D'. -C For optimum performance LDWORK should be larger. -C -C Error Indicator -C -C INFO INTEGER -C = 0: successful exit; -C < 0: if INFO = -i, the i-th argument had an illegal -C value; -C = i: if the i-th element of the d factor is exactly zero; -C the UdU' (or LdL') factorization has been completed, -C but the block diagonal matrix d is exactly singular; -C = M+1: if the matrix R (if DICO = 'C'), or R + B'XB -C (if DICO = 'D') is numerically singular (to working -C precision); -C = M+2: if one or more of the eigenvalues of X has not -C converged. -C -C METHOD -C -C The optimal feedback matrix F is obtained as the solution to the -C system of linear equations -C -C (R + B'XB) * F = B'XA + L' -C -C in the discrete-time case and -C -C R * F = B'X + L' -C -C in the continuous-time case, with R replaced by D'D if FACT = 'D'. -C The factored form of R, specified by FACT <> 'N', is taken into -C account. If FACT = 'N', Cholesky factorization is tried first, but -C if the coefficient matrix is not positive definite, then UdU' (or -C LdL') factorization is used. The discrete-time case involves -C updating of a triangular factorization of R (or D'D); Cholesky or -C symmetric spectral factorization of X is employed to avoid -C squaring of the condition number of the matrix. When D is given, -C its QR factorization is determined, and the triangular factor is -C used as described above. -C -C NUMERICAL ASPECTS -C -C The algorithm consists of numerically stable steps. -C 3 2 -C For DICO = 'C', it requires O(m + mn ) floating point operations -C 2 -C if FACT = 'N' and O(mn ) floating point operations, otherwise. -C For DICO = 'D', the operation counts are similar, but additional -C 3 -C O(n ) floating point operations may be needed in the worst case. -C -C CONTRIBUTORS -C -C Release 3.0: V. Sima, Katholieke Univ. Leuven, Belgium, Sep. 1997. -C Supersedes Release 2.0 routine SB02BD by M. Vanbegin, and -C P. Van Dooren, Philips Research Laboratory, Brussels, Belgium. -C -C REVISIONS -C -C - -C -C KEYWORDS -C -C Algebraic Riccati equation, closed loop system, continuous-time -C system, discrete-time system, matrix algebra, optimal control, -C optimal regulator. -C -C ****************************************************************** -C -C .. Parameters .. - DOUBLE PRECISION ZERO, ONE - PARAMETER ( ZERO = 0.0D0, ONE = 1.0D0 ) -C .. Scalar Arguments .. - CHARACTER DICO, FACT, JOBL, UPLO - INTEGER INFO, LDA, LDB, LDF, LDL, LDR, LDWORK, LDX, M, - $ N, P - DOUBLE PRECISION RNORM -C .. Array Arguments .. - INTEGER IPIV(*), IWORK(*), OUFACT(2) - DOUBLE PRECISION A(LDA,*), B(LDB,*), DWORK(*), F(LDF,*), - $ L(LDL,*), R(LDR,*), X(LDX,*) -C .. Local Scalars .. - LOGICAL DISCR, LFACTA, LFACTC, LFACTD, LFACTU, LUPLOU, - $ WITHL - INTEGER I, IFAIL, ITAU, J, JW, JWORK, JZ, WRKOPT - DOUBLE PRECISION EPS, RCOND, RNORMP, TEMP -C .. Local Arrays .. - DOUBLE PRECISION DUMMY(1) -C .. External Functions .. - LOGICAL LSAME - DOUBLE PRECISION DLAMCH, DLANSY - EXTERNAL DLAMCH, DLANSY, LSAME -C .. External Subroutines .. - EXTERNAL DCOPY, DGEMM, DGEMV, DGEQRF, DLASET, DPOCON, - $ DPOTRF, DPOTRS, DSCAL, DSYCON, DSYEV, DSYTRF, - $ DSYTRS, DTRCON, DTRMM, MB04KD, XERBLA -C .. Intrinsic Functions .. - INTRINSIC ABS, INT, MAX, MIN, SQRT -C .. Executable Statements .. -C - INFO = 0 - DISCR = LSAME( DICO, 'D' ) - LFACTC = LSAME( FACT, 'C' ) - LFACTD = LSAME( FACT, 'D' ) - LFACTU = LSAME( FACT, 'U' ) - LUPLOU = LSAME( UPLO, 'U' ) - WITHL = LSAME( JOBL, 'N' ) - LFACTA = LFACTC.OR.LFACTD.OR.LFACTU -C -C Test the input scalar arguments. -C - IF( .NOT.DISCR .AND. .NOT.LSAME( DICO, 'C' ) ) THEN - INFO = -1 - ELSE IF( ( .NOT.LFACTA .AND. .NOT.LSAME( FACT, 'N' ) ) .OR. - $ ( DISCR .AND. LFACTU ) ) THEN - INFO = -2 - ELSE IF( .NOT.LUPLOU .AND. .NOT.LSAME( UPLO, 'L' ) ) THEN - INFO = -3 - ELSE IF( .NOT.WITHL .AND. .NOT.LSAME( JOBL, 'Z' ) ) THEN - INFO = -4 - ELSE IF( N.LT.0 ) THEN - INFO = -5 - ELSE IF( M.LT.0 ) THEN - INFO = -6 - ELSE IF( P.LT.0 ) THEN - INFO = -7 - ELSE IF( ( .NOT.DISCR .AND. LDA.LT.1 ) .OR. - $ ( DISCR .AND. LDA.LT.MAX( 1, N ) ) ) THEN - INFO = -9 - ELSE IF( LDB.LT.MAX( 1, N ) ) THEN - INFO = -11 - ELSE IF( ( LDR.LT.MAX( 1, M ) ) .OR. - $ ( LFACTD .AND. LDR.LT.MAX( 1, P ) ) ) THEN - INFO = -13 - ELSE IF( ( .NOT.WITHL .AND. LDL.LT.1 ) .OR. - $ ( WITHL .AND. LDL.LT.MAX( 1, N ) ) ) THEN - INFO = -16 - ELSE IF( LDX.LT.MAX( 1, N ) ) THEN - INFO = -18 - ELSE IF( LFACTU ) THEN - IF( RNORM.LT.ZERO ) - $ INFO = -19 - END IF - IF( LDF.LT.MAX( 1, M ) ) THEN - INFO = -21 - ELSE IF( ( ( .NOT.LFACTA .OR. ( LFACTC .AND. .NOT.DISCR ) ) - $ .AND. LDWORK.LT.MAX( 2, 3*M ) ) .OR. - $ ( LFACTU .AND. LDWORK.LT.MAX( 2, 2*M ) ) .OR. - $ ( DISCR .AND. LFACTC .AND. LDWORK.LT.N + 3*M + 2 ) .OR. - $(.NOT.DISCR .AND. LFACTD .AND. LDWORK.LT.MAX( 2, MIN(P,M) + M ) ) - $ .OR. - $ ( DISCR .AND. LFACTD .AND. LDWORK.LT.MAX( N + 3*M + 2, - $ 4*N + 1 ) ) ) THEN - INFO = -25 - END IF -C - IF ( INFO.NE.0 ) THEN -C -C Error return. -C - CALL XERBLA( 'SB02ND', -INFO ) - RETURN - END IF -C -C Quick return if possible. -C - IF ( N.EQ.0 .OR. M.EQ.0 .OR. ( LFACTD .AND. P.EQ.0 ) ) THEN - DWORK(1) = ONE - DWORK(2) = ONE - RETURN - END IF -C - WRKOPT = 1 - EPS = DLAMCH( 'Epsilon' ) -C -C Determine the right-hand side of the matrix equation. -C Compute B'X in F. -C -C (Note: Comments in the code beginning "Workspace:" describe the -C minimal amount of real workspace needed at that point in the -C code, as well as the preferred amount for good performance. -C NB refers to the optimal block size for the immediately -C following subroutine, as returned by ILAENV.) -C - CALL DGEMM( 'Transpose', 'No transpose', M, N, N, ONE, B, LDB, X, - $ LDX, ZERO, F, LDF ) -C - IF ( .NOT.LFACTA ) THEN - IF ( DISCR ) THEN -C -C Discrete-time case with R not factored. Compute R + B'XB. -C - IF ( LUPLOU ) THEN -C - DO 10 J = 1, M - CALL DGEMV( 'No transpose', J, N, ONE, F, LDF, B(1,J), - $ 1, ONE, R(1,J), 1 ) - 10 CONTINUE -C - ELSE -C - DO 20 J = 1, M - CALL DGEMV( 'Transpose', N, J, ONE, B, LDB, F(J,1), - $ LDF, ONE, R(J,1), LDR ) - 20 CONTINUE -C - END IF - END IF -C -C Compute the 1-norm of the matrix R or R + B'XB. -C Workspace: need M. -C - RNORMP = DLANSY( '1-norm', UPLO, M, R, LDR, DWORK ) - WRKOPT = MAX( WRKOPT, M ) - END IF -C - IF ( DISCR ) THEN -C -C For discrete-time case, postmultiply B'X by A. -C Workspace: need N. -C - DO 30 I = 1, M - CALL DCOPY( N, F(I,1), LDF, DWORK, 1 ) - CALL DGEMV( 'Transpose', N, N, ONE, A, LDA, DWORK, 1, ZERO, - $ F(I,1), LDF ) - 30 CONTINUE -C - WRKOPT = MAX( WRKOPT, N ) - END IF -C - IF( WITHL ) THEN -C -C Add L'. -C - DO 50 I = 1, M -C - DO 40 J = 1, N - F(I,J) = F(I,J) + L(J,I) - 40 CONTINUE -C - 50 CONTINUE -C - END IF -C -C Solve the matrix equation. -C - IF ( LFACTA ) THEN -C -C Case 1: Matrix R is given in a factored form. -C - IF ( LFACTD ) THEN -C -C Use QR factorization of D. -C Workspace: need min(P,M) + M, -C prefer min(P,M) + M*NB. -C - ITAU = 1 - JWORK = ITAU + MIN( P, M ) - CALL DGEQRF( P, M, R, LDR, DWORK(ITAU), DWORK(JWORK), - $ LDWORK-JWORK+1, IFAIL ) - WRKOPT = MAX( WRKOPT, INT( DWORK(JWORK) )+JWORK-1 ) -C -C Make positive the diagonal elements of the triangular -C factor. Construct the strictly lower triangle, if requested. -C - DO 70 I = 1, M - IF ( R(I,I).LT.ZERO ) THEN -C - DO 60 J = I, M - R(I,J) = -R(I,J) - 60 CONTINUE -C - END IF - IF ( .NOT.LUPLOU ) - $ CALL DCOPY( I-1, R(1,I), 1, R(I,1), LDR ) - 70 CONTINUE -C - IF ( P.LT.M ) THEN - CALL DLASET( 'Full', M-P, M, ZERO, ZERO, R(P+1,1), LDR ) - IF ( .NOT.DISCR ) THEN - DWORK(2) = ZERO - INFO = M + 1 - RETURN - END IF - END IF - END IF -C - JW = 1 - IF ( DISCR ) THEN -C -C Discrete-time case. Update the factorization for B'XB. -C Try first the Cholesky factorization of X, saving the -C diagonal of X, in order to recover it, if X is not positive -C definite. In the later case, use spectral factorization. -C Workspace: need N. -C Define JW = 1 for Cholesky factorization of X, -C JW = N+3 for spectral factorization of X. -C - CALL DCOPY( N, X, LDX+1, DWORK, 1 ) - CALL DPOTRF( 'Upper', N, X, LDX, IFAIL ) - IF ( IFAIL.EQ.0 ) THEN -C -C Use Cholesky factorization of X to compute chol(X)*B. -C - OUFACT(2) = 1 - CALL DTRMM( 'Left', 'Upper', 'No transpose', 'Non unit', - $ N, M, ONE, X, LDX, B, LDB ) - ELSE -C -C Use spectral factorization of X, X = UVU'. -C Workspace: need 4*N+1, -C prefer N*(NB+2)+N+2. -C - JW = N + 3 - OUFACT(2) = 2 - CALL DCOPY( N, DWORK, 1, X, LDX+1 ) - CALL DSYEV( 'Vectors', 'Lower', N, X, LDX, DWORK(3), - $ DWORK(JW), LDWORK-JW+1, IFAIL ) - IF ( IFAIL.GT.0 ) THEN - INFO = M + 2 - RETURN - END IF - WRKOPT = MAX( WRKOPT, INT( DWORK(JW) )+JW-1 ) - TEMP = ABS( DWORK(N+2) )*EPS -C -C Count the negligible eigenvalues and compute sqrt(V)U'B. -C Workspace: need 2*N+2. -C - JZ = 0 -C - 80 CONTINUE - IF ( ABS( DWORK(JZ+3) ).LE.TEMP ) THEN - JZ = JZ + 1 - IF ( JZ.LT.N) GO TO 80 - END IF -C - DO 90 J = 1, M - CALL DCOPY( N, B(1,J), 1, DWORK(JW), 1 ) - CALL DGEMV( 'Transpose', N, N, ONE, X, LDX, DWORK(JW), - $ 1, ZERO, B(1,J), 1 ) - 90 CONTINUE -C - DO 100 I = JZ + 1, N - CALL DSCAL( M, SQRT( ABS( DWORK(I+2) ) ), B(I,1), LDB - $ ) - 100 CONTINUE -C - IF ( JZ.GT.0 ) - $ CALL DLASET( 'Full', JZ, M, ZERO, ZERO, B, LDB ) - END IF -C -C Update the triangular factorization. -C - IF ( .NOT.LUPLOU ) THEN -C -C For efficiency, use the transposed of the lower triangle. -C - DO 110 I = 2, M - CALL DCOPY( I-1, R(I,1), LDR, R(1,I), 1 ) - 110 CONTINUE -C - END IF -C -C Workspace: need JW+2*M-1. -C - CALL MB04KD( 'Full', M, 0, N, R, LDR, B, LDB, DUMMY, N, - $ DUMMY, M, DWORK(JW), DWORK(JW+N) ) - WRKOPT = MAX( WRKOPT, JW + 2*M - 1 ) -C -C Make positive the diagonal elements of the triangular -C factor. -C - DO 130 I = 1, M - IF ( R(I,I).LT.ZERO ) THEN -C - DO 120 J = I, M - R(I,J) = -R(I,J) - 120 CONTINUE -C - END IF - 130 CONTINUE -C - IF ( .NOT.LUPLOU ) THEN -C -C Construct the lower triangle. -C - DO 140 I = 2, M - CALL DCOPY( I-1, R(1,I), 1, R(I,1), LDR ) - 140 CONTINUE -C - END IF - END IF -C -C Compute the condition number of the coefficient matrix. -C - IF ( .NOT.LFACTU ) THEN -C -C Workspace: need JW+3*M-1. -C - CALL DTRCON( '1-norm', UPLO, 'Non unit', M, R, LDR, RCOND, - $ DWORK(JW), IWORK, IFAIL ) - OUFACT(1) = 1 - WRKOPT = MAX( WRKOPT, JW + 3*M - 1 ) - ELSE -C -C Workspace: need 2*M. -C - CALL DSYCON( UPLO, M, R, LDR, IPIV, RNORM, RCOND, DWORK, - $ IWORK, INFO ) - OUFACT(1) = 2 - WRKOPT = MAX( WRKOPT, 2*M ) - END IF - DWORK(2) = RCOND - IF( RCOND.LT.EPS ) THEN - INFO = M + 1 - RETURN - END IF -C - ELSE -C -C Case 2: Matrix R is given in an unfactored form. -C -C Save the given triangle of R or R + B'XB in the other -C strict triangle and the diagonal in the workspace, and try -C Cholesky factorization. -C Workspace: need M. -C - CALL DCOPY( M, R, LDR+1, DWORK, 1 ) - IF( LUPLOU ) THEN -C - DO 150 J = 2, M - CALL DCOPY( J-1, R(1,J), 1, R(J,1), LDR ) - 150 CONTINUE -C - ELSE -C - DO 160 J = 2, M - CALL DCOPY( J-1, R(J,1), LDR, R(1,J), 1 ) - 160 CONTINUE -C - END IF - CALL DPOTRF( UPLO, M, R, LDR, INFO ) - OUFACT(1) = 1 - IF( INFO.EQ.0 ) THEN -C -C Compute the reciprocal of the condition number of R. -C Workspace: need 3*M. -C - CALL DPOCON( UPLO, M, R, LDR, RNORMP, RCOND, DWORK, IWORK, - $ INFO ) -C -C Return if the matrix is singular to working precision. -C - DWORK(2) = RCOND - IF( RCOND.LT.EPS ) THEN - INFO = M + 1 - RETURN - END IF - WRKOPT = MAX( WRKOPT, 3*M ) - ELSE -C -C Use UdU' or LdL' factorization, first restoring the saved -C triangle. -C - CALL DCOPY( M, DWORK, 1, R, LDR+1 ) - IF( LUPLOU ) THEN -C - DO 170 J = 2, M - CALL DCOPY( J-1, R(J,1), LDR, R(1,J), 1 ) - 170 CONTINUE -C - ELSE -C - DO 180 J = 2, M - CALL DCOPY( J-1, R(1,J), 1, R(J,1), LDR ) - 180 CONTINUE -C - END IF -C -C Workspace: need 1, -C prefer M*NB. -C - CALL DSYTRF( UPLO, M, R, LDR, IPIV, DWORK, LDWORK, INFO ) - OUFACT(1) = 2 - IF( INFO.GT.0 ) - $ RETURN - WRKOPT = MAX( WRKOPT, INT( DWORK(1) ) ) -C -C Compute the reciprocal of the condition number of R. -C Workspace: need 2*M. -C - CALL DSYCON( UPLO, M, R, LDR, IPIV, RNORMP, RCOND, DWORK, - $ IWORK, INFO ) -C -C Return if the matrix is singular to working precision. -C - DWORK(2) = RCOND - IF( RCOND.LT.EPS ) THEN - INFO = M + 1 - RETURN - END IF - END IF - END IF -C - IF (OUFACT(1).EQ.1 ) THEN -C -C Solve the positive definite linear system. -C - CALL DPOTRS( UPLO, M, N, R, LDR, F, LDF, INFO ) - ELSE -C -C Solve the indefinite linear system. -C - CALL DSYTRS( UPLO, M, N, R, LDR, IPIV, F, LDF, INFO ) - END IF -C -C Set the optimal workspace. -C - DWORK(1) = WRKOPT -C - RETURN -C *** Last line of SB02ND *** - END diff --git a/mex/sources/libslicot/SB02OD.f b/mex/sources/libslicot/SB02OD.f deleted file mode 100644 index 7408ba397..000000000 --- a/mex/sources/libslicot/SB02OD.f +++ /dev/null @@ -1,856 +0,0 @@ - SUBROUTINE SB02OD( DICO, JOBB, FACT, UPLO, JOBL, SORT, N, M, P, A, - $ LDA, B, LDB, Q, LDQ, R, LDR, L, LDL, RCOND, X, - $ LDX, ALFAR, ALFAI, BETA, S, LDS, T, LDT, U, - $ LDU, TOL, IWORK, DWORK, LDWORK, BWORK, INFO ) -C -C SLICOT RELEASE 5.0. -C -C Copyright (c) 2002-2009 NICONET e.V. -C -C This program is free software: you can redistribute it and/or -C modify it under the terms of the GNU General Public License as -C published by the Free Software Foundation, either version 2 of -C the License, or (at your option) any later version. -C -C This program is distributed in the hope that it will be useful, -C but WITHOUT ANY WARRANTY; without even the implied warranty of -C MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the -C GNU General Public License for more details. -C -C You should have received a copy of the GNU General Public License -C along with this program. If not, see -C . -C -C PURPOSE -C -C To solve for X either the continuous-time algebraic Riccati -C equation -C -1 -C Q + A'X + XA - (L+XB)R (L+XB)' = 0 (1) -C -C or the discrete-time algebraic Riccati equation -C -1 -C X = A'XA - (L+A'XB)(R + B'XB) (L+A'XB)' + Q (2) -C -C where A, B, Q, R, and L are N-by-N, N-by-M, N-by-N, M-by-M and -C N-by-M matrices, respectively, such that Q = C'C, R = D'D and -C L = C'D; X is an N-by-N symmetric matrix. -C The routine also returns the computed values of the closed-loop -C spectrum of the system, i.e., the stable eigenvalues lambda(1), -C ..., lambda(N) of the corresponding Hamiltonian or symplectic -C pencil, in the continuous-time case or discrete-time case, -C respectively. -C -1 -C Optionally, matrix G = BR B' may be given instead of B and R. -C Other options include the case with Q and/or R given in a -C factored form, Q = C'C, R = D'D, and with L a zero matrix. -C -C The routine uses the method of deflating subspaces, based on -C reordering the eigenvalues in a generalized Schur matrix pair. -C A standard eigenproblem is solved in the continuous-time case -C if G is given. -C -C ARGUMENTS -C -C Mode Parameters -C -C DICO CHARACTER*1 -C Specifies the type of Riccati equation to be solved as -C follows: -C = 'C': Equation (1), continuous-time case; -C = 'D': Equation (2), discrete-time case. -C -C JOBB CHARACTER*1 -C Specifies whether or not the matrix G is given, instead -C of the matrices B and R, as follows: -C = 'B': B and R are given; -C = 'G': G is given. -C -C FACT CHARACTER*1 -C Specifies whether or not the matrices Q and/or R (if -C JOBB = 'B') are factored, as follows: -C = 'N': Not factored, Q and R are given; -C = 'C': C is given, and Q = C'C; -C = 'D': D is given, and R = D'D; -C = 'B': Both factors C and D are given, Q = C'C, R = D'D. -C -C UPLO CHARACTER*1 -C If JOBB = 'G', or FACT = 'N', specifies which triangle of -C the matrices G and Q (if FACT = 'N'), or Q and R (if -C JOBB = 'B'), is stored, as follows: -C = 'U': Upper triangle is stored; -C = 'L': Lower triangle is stored. -C -C JOBL CHARACTER*1 -C Specifies whether or not the matrix L is zero, as follows: -C = 'Z': L is zero; -C = 'N': L is nonzero. -C JOBL is not used if JOBB = 'G' and JOBL = 'Z' is assumed. -C SLICOT Library routine SB02MT should be called just before -C SB02OD, for obtaining the results when JOBB = 'G' and -C JOBL = 'N'. -C -C SORT CHARACTER*1 -C Specifies which eigenvalues should be obtained in the top -C of the generalized Schur form, as follows: -C = 'S': Stable eigenvalues come first; -C = 'U': Unstable eigenvalues come first. -C -C Input/Output Parameters -C -C N (input) INTEGER -C The actual state dimension, i.e. the order of the matrices -C A, Q, and X, and the number of rows of the matrices B -C and L. N >= 0. -C -C M (input) INTEGER -C The number of system inputs. If JOBB = 'B', M is the -C order of the matrix R, and the number of columns of the -C matrix B. M >= 0. -C M is not used if JOBB = 'G'. -C -C P (input) INTEGER -C The number of system outputs. If FACT = 'C' or 'D' or 'B', -C P is the number of rows of the matrices C and/or D. -C P >= 0. -C Otherwise, P is not used. -C -C A (input) DOUBLE PRECISION array, dimension (LDA,N) -C The leading N-by-N part of this array must contain the -C state matrix A of the system. -C -C LDA INTEGER -C The leading dimension of array A. LDA >= MAX(1,N). -C -C B (input) DOUBLE PRECISION array, dimension (LDB,*) -C If JOBB = 'B', the leading N-by-M part of this array must -C contain the input matrix B of the system. -C If JOBB = 'G', the leading N-by-N upper triangular part -C (if UPLO = 'U') or lower triangular part (if UPLO = 'L') -C of this array must contain the upper triangular part or -C lower triangular part, respectively, of the matrix -C -1 -C G = BR B'. The stricly lower triangular part (if -C UPLO = 'U') or stricly upper triangular part (if -C UPLO = 'L') is not referenced. -C -C LDB INTEGER -C The leading dimension of array B. LDB >= MAX(1,N). -C -C Q (input) DOUBLE PRECISION array, dimension (LDQ,N) -C If FACT = 'N' or 'D', the leading N-by-N upper triangular -C part (if UPLO = 'U') or lower triangular part (if UPLO = -C 'L') of this array must contain the upper triangular part -C or lower triangular part, respectively, of the symmetric -C state weighting matrix Q. The stricly lower triangular -C part (if UPLO = 'U') or stricly upper triangular part (if -C UPLO = 'L') is not referenced. -C If JOBB = 'B', the triangular part of this array defined -C by UPLO is modified internally, but is restored on exit. -C If FACT = 'C' or 'B', the leading P-by-N part of this -C array must contain the output matrix C of the system. -C If JOBB = 'B', this part is modified internally, but is -C restored on exit. -C -C LDQ INTEGER -C The leading dimension of array Q. -C LDQ >= MAX(1,N) if FACT = 'N' or 'D', -C LDQ >= MAX(1,P) if FACT = 'C' or 'B'. -C -C R (input) DOUBLE PRECISION array, dimension (LDR,M) -C If FACT = 'N' or 'C', the leading M-by-M upper triangular -C part (if UPLO = 'U') or lower triangular part (if UPLO = -C 'L') of this array must contain the upper triangular part -C or lower triangular part, respectively, of the symmetric -C input weighting matrix R. The stricly lower triangular -C part (if UPLO = 'U') or stricly upper triangular part (if -C UPLO = 'L') is not referenced. -C The triangular part of this array defined by UPLO is -C modified internally, but is restored on exit. -C If FACT = 'D' or 'B', the leading P-by-M part of this -C array must contain the direct transmission matrix D of the -C system. This part is modified internally, but is restored -C on exit. -C If JOBB = 'G', this array is not referenced. -C -C LDR INTEGER -C The leading dimension of array R. -C LDR >= MAX(1,M) if JOBB = 'B' and FACT = 'N' or 'C'; -C LDR >= MAX(1,P) if JOBB = 'B' and FACT = 'D' or 'B'; -C LDR >= 1 if JOBB = 'G'. -C -C L (input) DOUBLE PRECISION array, dimension (LDL,M) -C If JOBL = 'N' (and JOBB = 'B'), the leading N-by-M part of -C this array must contain the cross weighting matrix L. -C This part is modified internally, but is restored on exit. -C If JOBL = 'Z' or JOBB = 'G', this array is not referenced. -C -C LDL INTEGER -C The leading dimension of array L. -C LDL >= MAX(1,N) if JOBL = 'N' and JOBB = 'B'; -C LDL >= 1 if JOBL = 'Z' or JOBB = 'G'. -C -C RCOND (output) DOUBLE PRECISION -C An estimate of the reciprocal of the condition number (in -C the 1-norm) of the N-th order system of algebraic -C equations from which the solution matrix X is obtained. -C -C X (output) DOUBLE PRECISION array, dimension (LDX,N) -C The leading N-by-N part of this array contains the -C solution matrix X of the problem. -C -C LDX INTEGER -C The leading dimension of array X. LDX >= MAX(1,N). -C -C ALFAR (output) DOUBLE PRECISION array, dimension (2*N) -C ALFAI (output) DOUBLE PRECISION array, dimension (2*N) -C BETA (output) DOUBLE PRECISION array, dimension (2*N) -C The generalized eigenvalues of the 2N-by-2N matrix pair, -C ordered as specified by SORT (if INFO = 0). For instance, -C if SORT = 'S', the leading N elements of these arrays -C contain the closed-loop spectrum of the system matrix -C A - BF, where F is the optimal feedback matrix computed -C based on the solution matrix X. Specifically, -C lambda(k) = [ALFAR(k)+j*ALFAI(k)]/BETA(k) for -C k = 1,2,...,N. -C If DICO = 'C' and JOBB = 'G', the elements of BETA are -C set to 1. -C -C S (output) DOUBLE PRECISION array, dimension (LDS,*) -C The leading 2N-by-2N part of this array contains the -C ordered real Schur form S of the first matrix in the -C reduced matrix pencil associated to the optimal problem, -C or of the corresponding Hamiltonian matrix, if DICO = 'C' -C and JOBB = 'G'. That is, -C -C (S S ) -C ( 11 12) -C S = ( ), -C (0 S ) -C ( 22) -C -C where S , S and S are N-by-N matrices. -C 11 12 22 -C Array S must have 2*N+M columns if JOBB = 'B', and 2*N -C columns, otherwise. -C -C LDS INTEGER -C The leading dimension of array S. -C LDS >= MAX(1,2*N+M) if JOBB = 'B', -C LDS >= MAX(1,2*N) if JOBB = 'G'. -C -C T (output) DOUBLE PRECISION array, dimension (LDT,2*N) -C If DICO = 'D' or JOBB = 'B', the leading 2N-by-2N part of -C this array contains the ordered upper triangular form T of -C the second matrix in the reduced matrix pencil associated -C to the optimal problem. That is, -C -C (T T ) -C ( 11 12) -C T = ( ), -C (0 T ) -C ( 22) -C -C where T , T and T are N-by-N matrices. -C 11 12 22 -C If DICO = 'C' and JOBB = 'G' this array is not referenced. -C -C LDT INTEGER -C The leading dimension of array T. -C LDT >= MAX(1,2*N+M) if JOBB = 'B', -C LDT >= MAX(1,2*N) if JOBB = 'G' and DICO = 'D', -C LDT >= 1 if JOBB = 'G' and DICO = 'C'. -C -C U (output) DOUBLE PRECISION array, dimension (LDU,2*N) -C The leading 2N-by-2N part of this array contains the right -C transformation matrix U which reduces the 2N-by-2N matrix -C pencil to the ordered generalized real Schur form (S,T), -C or the Hamiltonian matrix to the ordered real Schur -C form S, if DICO = 'C' and JOBB = 'G'. That is, -C -C (U U ) -C ( 11 12) -C U = ( ), -C (U U ) -C ( 21 22) -C -C where U , U , U and U are N-by-N matrices. -C 11 12 21 22 -C -C LDU INTEGER -C The leading dimension of array U. LDU >= MAX(1,2*N). -C -C Tolerances -C -C TOL DOUBLE PRECISION -C The tolerance to be used to test for near singularity of -C the original matrix pencil, specifically of the triangular -C factor obtained during the reduction process. If the user -C sets TOL > 0, then the given value of TOL is used as a -C lower bound for the reciprocal condition number of that -C matrix; a matrix whose estimated condition number is less -C than 1/TOL is considered to be nonsingular. If the user -C sets TOL <= 0, then a default tolerance, defined by -C TOLDEF = EPS, is used instead, where EPS is the machine -C precision (see LAPACK Library routine DLAMCH). -C This parameter is not referenced if JOBB = 'G'. -C -C Workspace -C -C IWORK INTEGER array, dimension (LIWORK) -C LIWORK >= MAX(1,M,2*N) if JOBB = 'B', -C LIWORK >= MAX(1,2*N) if JOBB = 'G'. -C -C DWORK DOUBLE PRECISION array, dimension (LDWORK) -C On exit, if INFO = 0, DWORK(1) returns the optimal value -C of LDWORK. If JOBB = 'B' and N > 0, DWORK(2) returns the -C reciprocal of the condition number of the M-by-M lower -C triangular matrix obtained after compressing the matrix -C pencil of order 2N+M to obtain a pencil of order 2N. -C If INFO = 0 or INFO = 6, DWORK(3) returns the scaling -C factor used internally, which should multiply the -C submatrix Y2 to recover X from the first N columns of U -C (see METHOD). -C -C LDWORK INTEGER -C The length of the array DWORK. -C LDWORK >= MAX(3,6*N), if JOBB = 'G', -C DICO = 'C'; -C LDWORK >= MAX(7*(2*N+1)+16,16*N), if JOBB = 'G', -C DICO = 'D'; -C LDWORK >= MAX(7*(2*N+1)+16,16*N,2*N+M,3*M), if JOBB = 'B'. -C For optimum performance LDWORK should be larger. -C -C BWORK LOGICAL array, dimension (2*N) -C -C Error Indicator -C -C INFO INTEGER -C = 0: successful exit; -C < 0: if INFO = -i, the i-th argument had an illegal -C value; -C = 1: if the computed extended matrix pencil is singular, -C possibly due to rounding errors; -C = 2: if the QZ (or QR) algorithm failed; -C = 3: if reordering of the (generalized) eigenvalues -C failed; -C = 4: if after reordering, roundoff changed values of -C some complex eigenvalues so that leading eigenvalues -C in the (generalized) Schur form no longer satisfy -C the stability condition; this could also be caused -C due to scaling; -C = 5: if the computed dimension of the solution does not -C equal N; -C = 6: if a singular matrix was encountered during the -C computation of the solution matrix X. -C -C METHOD -C -C The routine uses a variant of the method of deflating subspaces -C proposed by van Dooren [1]. See also [2], [3]. -C It is assumed that (A,B) is stabilizable and (C,A) is detectable. -C Under these assumptions the algebraic Riccati equation is known to -C have a unique non-negative definite solution. -C The first step in the method of deflating subspaces is to form the -C extended Hamiltonian matrices, dimension 2N + M given by -C -C discrete-time continuous-time -C -C |A 0 B| |I 0 0| |A 0 B| |I 0 0| -C |Q -I L| - z |0 -A' 0|, |Q A' L| - s |0 -I 0|. -C |L' 0 R| |0 -B' 0| |L' B' R| |0 0 0| -C -C Next, these pencils are compressed to a form (see [1]) -C -C lambda x A - B . -C f f -C -C This generalized eigenvalue problem is then solved using the QZ -C algorithm and the stable deflating subspace Ys is determined. -C If [Y1'|Y2']' is a basis for Ys, then the required solution is -C -1 -C X = Y2 x Y1 . -C A standard eigenvalue problem is solved using the QR algorithm in -C the continuous-time case when G is given (DICO = 'C', JOBB = 'G'). -C -C REFERENCES -C -C [1] Van Dooren, P. -C A Generalized Eigenvalue Approach for Solving Riccati -C Equations. -C SIAM J. Sci. Stat. Comp., 2, pp. 121-135, 1981. -C -C [2] Mehrmann, V. -C The Autonomous Linear Quadratic Control Problem. Theory and -C Numerical Solution. -C Lect. Notes in Control and Information Sciences, vol. 163, -C Springer-Verlag, Berlin, 1991. -C -C [3] Sima, V. -C Algorithms for Linear-Quadratic Optimization. -C Pure and Applied Mathematics: A Series of Monographs and -C Textbooks, vol. 200, Marcel Dekker, Inc., New York, 1996. -C -C NUMERICAL ASPECTS -C -C This routine is particularly suited for systems where the matrix R -C is ill-conditioned. Internal scaling is used. -C -C FURTHER COMMENTS -C -C To obtain a stabilizing solution of the algebraic Riccati -C equations set SORT = 'S'. -C -C The routine can also compute the anti-stabilizing solutions of -C the algebraic Riccati equations, by specifying SORT = 'U'. -C -C CONTRIBUTOR -C -C Release 3.0: V. Sima, Katholieke Univ. Leuven, Belgium, Sep. 1997. -C Supersedes Release 2.0 routine SB02CD by T.G.J. Beelen, Philips, -C Eindhoven, Holland. -C -C REVISIONS -C -C V. Sima, Katholieke Univ. Leuven, Belgium, May 1999, June 2002, -C December 2002, January 2005. -C -C KEYWORDS -C -C Algebraic Riccati equation, closed loop system, continuous-time -C system, discrete-time system, optimal regulator, Schur form. -C -C ****************************************************************** -C -C .. Parameters .. - DOUBLE PRECISION ZERO, HALF, ONE, THREE - PARAMETER ( ZERO = 0.0D0, HALF = 0.5D0, ONE = 1.0D0, - $ THREE = 3.0D0 ) -C .. Scalar Arguments .. - CHARACTER DICO, FACT, JOBB, JOBL, SORT, UPLO - INTEGER INFO, LDA, LDB, LDL, LDQ, LDR, LDS, LDT, LDU, - $ LDWORK, LDX, M, N, P - DOUBLE PRECISION RCOND, TOL -C .. Array Arguments .. - LOGICAL BWORK(*) - INTEGER IWORK(*) - DOUBLE PRECISION A(LDA,*), ALFAI(*), ALFAR(*), B(LDB,*), BETA(*), - $ DWORK(*), L(LDL,*), Q(LDQ,*), R(LDR,*), - $ S(LDS,*), T(LDT,*), U(LDU,*), X(LDX,*) -C .. Local Scalars .. - CHARACTER QTYPE, RTYPE - LOGICAL DISCR, LFACB, LFACN, LFACQ, LFACR, LJOBB, LJOBL, - $ LJOBLN, LSCAL, LSCL, LSORT, LUPLO - INTEGER I, INFO1, J, LDW, MP, NDIM, NN, NNM, NP, NP1, - $ WRKOPT - DOUBLE PRECISION QSCAL, RCONDL, RNORM, RSCAL, SCALE, UNORM -C .. Local Arrays .. - DOUBLE PRECISION DUM(1) -C .. External Functions .. - LOGICAL LSAME, SB02MR, SB02MV, SB02OU, SB02OV, SB02OW - DOUBLE PRECISION DLAMCH, DLANGE, DLANSY - EXTERNAL DLAMCH, DLANGE, DLANSY, LSAME, SB02MR, SB02MV, - $ SB02OU, SB02OV, SB02OW -C .. External Subroutines .. - EXTERNAL DAXPY, DCOPY, DGECON, DGEES, DGETRF, DGETRS, - $ DGGES, DLACPY, DLASCL, DLASET, DSCAL, DSWAP, - $ SB02OY, XERBLA -C .. Intrinsic Functions .. - INTRINSIC INT, MAX, MIN, SQRT -C .. Executable Statements .. -C - INFO = 0 - DISCR = LSAME( DICO, 'D' ) - LJOBB = LSAME( JOBB, 'B' ) - LFACN = LSAME( FACT, 'N' ) - LFACQ = LSAME( FACT, 'C' ) - LFACR = LSAME( FACT, 'D' ) - LFACB = LSAME( FACT, 'B' ) - LUPLO = LSAME( UPLO, 'U' ) - LSORT = LSAME( SORT, 'S' ) -C - NN = 2*N - IF ( LJOBB ) THEN - LJOBL = LSAME( JOBL, 'Z' ) - LJOBLN = LSAME( JOBL, 'N' ) - NNM = NN + M - LDW = MAX( NNM, 3*M ) - ELSE - NNM = NN - LDW = 1 - END IF - NP1 = N + 1 -C -C Test the input scalar arguments. -C - IF( .NOT.DISCR .AND. .NOT.LSAME( DICO, 'C' ) ) THEN - INFO = -1 - ELSE IF( .NOT.LJOBB .AND. .NOT.LSAME( JOBB, 'G' ) ) THEN - INFO = -2 - ELSE IF( .NOT.LFACQ .AND. .NOT.LFACR .AND. .NOT.LFACB - $ .AND. .NOT.LFACN ) THEN - INFO = -3 - ELSE IF( .NOT.LJOBB .OR. LFACN ) THEN - IF( .NOT.LUPLO .AND. .NOT.LSAME( UPLO, 'L' ) ) - $ INFO = -4 - END IF - IF( INFO.EQ.0 .AND. LJOBB ) THEN - IF( .NOT.LJOBL .AND. .NOT.LJOBLN ) - $ INFO = -5 - END IF - IF( INFO.EQ.0 ) THEN - IF( .NOT.LSORT .AND. .NOT.LSAME( SORT, 'U' ) ) THEN - INFO = -6 - ELSE IF( N.LT.0 ) THEN - INFO = -7 - ELSE IF( LJOBB ) THEN - IF( M.LT.0 ) - $ INFO = -8 - END IF - END IF - IF( INFO.EQ.0 .AND. .NOT.LFACN ) THEN - IF( P.LT.0 ) - $ INFO = -9 - END IF - IF( INFO.EQ.0 ) THEN - IF( LDA.LT.MAX( 1, N ) ) THEN - INFO = -11 - ELSE IF( LDB.LT.MAX( 1, N ) ) THEN - INFO = -13 - ELSE IF( ( ( LFACN.OR.LFACR ) .AND. LDQ.LT.MAX( 1, N ) ) .OR. - $ ( ( LFACQ.OR.LFACB ) .AND. LDQ.LT.MAX( 1, P ) ) ) THEN - INFO = -15 - ELSE IF( LDR.LT.1 ) THEN - INFO = -17 - ELSE IF( LDL.LT.1 ) THEN - INFO = -19 - ELSE IF( LJOBB ) THEN - IF ( ( LFACN.OR.LFACQ ) .AND. LDR.LT.M .OR. - $ ( LFACR.OR.LFACB ) .AND. LDR.LT.P ) THEN - INFO = -17 - ELSE IF( LJOBLN .AND. LDL.LT.N ) THEN - INFO = -19 - END IF - END IF - END IF - IF( INFO.EQ.0 ) THEN - IF( LDX.LT.MAX( 1, N ) ) THEN - INFO = -22 - ELSE IF( LDS.LT.MAX( 1, NNM ) ) THEN - INFO = -27 - ELSE IF( LDT.LT.1 ) THEN - INFO = -29 - ELSE IF( LDU.LT.MAX( 1, NN ) ) THEN - INFO = -31 - ELSE IF( LDWORK.LT.MAX( 3, 6*N ) ) THEN - INFO = -35 - ELSE IF( DISCR .OR. LJOBB ) THEN - IF( LDT.LT.NNM ) THEN - INFO = -29 - ELSE IF( LDWORK.LT.MAX( 14*N + 23, 16*N, LDW ) ) THEN - INFO = -35 - END IF - END IF - END IF -C - IF ( INFO.NE.0 ) THEN -C -C Error return. -C - CALL XERBLA( 'SB02OD', -INFO ) - RETURN - END IF -C -C Quick return if possible. -C - IF ( N.EQ.0 ) THEN - RCOND = ONE - DWORK(1) = THREE - DWORK(3) = ONE - RETURN - END IF -C -C Always scale the matrix pencil. -C - LSCAL = .TRUE. -C -C Start computations. -C -C (Note: Comments in the code beginning "Workspace:" describe the -C minimal amount of real workspace needed at that point in the -C code, as well as the preferred amount for good performance. -C NB refers to the optimal block size for the immediately -C following subroutine, as returned by ILAENV.) -C - IF ( LSCAL .AND. LJOBB ) THEN -C -C Scale the matrices Q, R, and L so that -C norm(Q) + norm(R) + norm(L) = 1, -C using the 1-norm. If Q and/or R are factored, the norms of -C the factors are used. -C Workspace: need max(N,M), if FACT = 'N'; -C N, if FACT = 'D'; -C M, if FACT = 'C'. -C - IF ( LFACN .OR. LFACR ) THEN - SCALE = DLANSY( '1-norm', UPLO, N, Q, LDQ, DWORK ) - QTYPE = UPLO - NP = N - ELSE - SCALE = DLANGE( '1-norm', P, N, Q, LDQ, DWORK ) - QTYPE = 'G' - NP = P - END IF -C - IF ( LFACN .OR. LFACQ ) THEN - RNORM = DLANSY( '1-norm', UPLO, M, R, LDR, DWORK ) - RTYPE = UPLO - MP = M - ELSE - RNORM = DLANGE( '1-norm', P, M, R, LDR, DWORK ) - RTYPE = 'G' - MP = P - END IF - SCALE = SCALE + RNORM -C - IF ( LJOBLN ) - $ SCALE = SCALE + DLANGE( '1-norm', N, M, L, LDL, DWORK ) - IF ( SCALE.EQ.ZERO ) - $ SCALE = ONE -C - IF ( LFACN .OR. LFACR ) THEN - QSCAL = SCALE - ELSE - QSCAL = SQRT( SCALE ) - END IF -C - IF ( LFACN .OR. LFACQ ) THEN - RSCAL = SCALE - ELSE - RSCAL = SQRT( SCALE ) - END IF -C - CALL DLASCL( QTYPE, 0, 0, QSCAL, ONE, NP, N, Q, LDQ, INFO1 ) - CALL DLASCL( RTYPE, 0, 0, RSCAL, ONE, MP, M, R, LDR, INFO1 ) - IF ( LJOBLN ) - $ CALL DLASCL( 'G', 0, 0, SCALE, ONE, N, M, L, LDL, INFO1 ) - END IF -C -C Construct the extended matrix pair. -C -C Workspace: need 1, if JOBB = 'G', -C max(1,2*N+M,3*M), if JOBB = 'B'; -C prefer larger. -C - CALL SB02OY( 'Optimal control', DICO, JOBB, FACT, UPLO, JOBL, - $ 'Identity E', N, M, P, A, LDA, B, LDB, Q, LDQ, R, - $ LDR, L, LDL, U, 1, S, LDS, T, LDT, TOL, IWORK, DWORK, - $ LDWORK, INFO ) -C - IF ( LSCAL .AND. LJOBB ) THEN -C -C Undo scaling of the data arrays. -C - CALL DLASCL( QTYPE, 0, 0, ONE, QSCAL, NP, N, Q, LDQ, INFO1 ) - CALL DLASCL( RTYPE, 0, 0, ONE, RSCAL, MP, M, R, LDR, INFO1 ) - IF ( LJOBLN ) - $ CALL DLASCL( 'G', 0, 0, ONE, SCALE, N, M, L, LDL, INFO1 ) - END IF -C - IF ( INFO.NE.0 ) - $ RETURN - WRKOPT = DWORK(1) - IF ( LJOBB ) RCONDL = DWORK(2) -C - IF ( LSCAL .AND. .NOT.LJOBB ) THEN -C -C This part of the code is used when G is given (JOBB = 'G'). -C A standard eigenproblem is solved in the continuous-time case. -C Scale the Hamiltonian matrix S, if DICO = 'C', or the -C symplectic pencil (S,T), if DICO = 'D', using the square roots -C of the norms of the matrices Q and G. -C Workspace: need N. -C - IF ( LFACN .OR. LFACR ) THEN - SCALE = SQRT( DLANSY( '1-norm', UPLO, N, Q, LDQ, DWORK ) ) - ELSE - SCALE = DLANGE( '1-norm', P, N, Q, LDQ, DWORK ) - END IF - RNORM = SQRT( DLANSY( '1-norm', UPLO, N, B, LDB, DWORK ) ) -C - LSCL = MIN( SCALE, RNORM ).GT.ZERO .AND. SCALE.NE.RNORM -C - IF( LSCL ) THEN - IF( DISCR ) THEN - CALL DLASCL( 'G', 0, 0, SCALE, RNORM, N, N, S(NP1,1), - $ LDS, INFO1 ) - CALL DLASCL( 'G', 0, 0, RNORM, SCALE, N, N, T(1,NP1), - $ LDT, INFO1 ) - ELSE - CALL DLASCL( 'G', 0, 0, SCALE, -RNORM, N, N, S(NP1,1), - $ LDS, INFO1 ) - CALL DLASCL( 'G', 0, 0, RNORM, SCALE, N, N, S(1,NP1), - $ LDS, INFO1 ) - CALL DLASCL( 'G', 0, 0, ONE, -ONE, N, N, S(NP1,NP1), - $ LDS, INFO1 ) - END IF - ELSE - IF( .NOT.DISCR ) THEN - CALL DLASCL( 'G', 0, 0, ONE, -ONE, N, NN, S(NP1,1), LDS, - $ INFO1 ) - END IF - END IF - ELSE - LSCL = .FALSE. - END IF -C -C Workspace: need max(7*(2*N+1)+16,16*N), -C if JOBB = 'B' or DICO = 'D'; -C 6*N, if JOBB = 'G' and DICO = 'C'; -C prefer larger. -C - IF ( DISCR ) THEN - IF ( LSORT ) THEN -C -C The natural tendency of the QZ algorithm to get the largest -C eigenvalues in the leading part of the matrix pair is -C exploited, by computing the unstable eigenvalues of the -C permuted matrix pair. -C - CALL DGGES( 'No vectors', 'Vectors', 'Sort', SB02OV, NN, T, - $ LDT, S, LDS, NDIM, ALFAR, ALFAI, BETA, U, LDU, - $ U, LDU, DWORK, LDWORK, BWORK, INFO1 ) - CALL DSWAP( N, ALFAR(NP1), 1, ALFAR, 1 ) - CALL DSWAP( N, ALFAI(NP1), 1, ALFAI, 1 ) - CALL DSWAP( N, BETA (NP1), 1, BETA, 1 ) - ELSE - CALL DGGES( 'No vectors', 'Vectors', 'Sort', SB02OV, NN, S, - $ LDS, T, LDT, NDIM, ALFAR, ALFAI, BETA, U, LDU, - $ U, LDU, DWORK, LDWORK, BWORK, INFO1 ) - END IF - ELSE - IF ( LJOBB ) THEN - IF ( LSORT ) THEN - CALL DGGES( 'No vectors', 'Vectors', 'Sort', SB02OW, NN, - $ S, LDS, T, LDT, NDIM, ALFAR, ALFAI, BETA, U, - $ LDU, U, LDU, DWORK, LDWORK, BWORK, INFO1 ) - ELSE - CALL DGGES( 'No vectors', 'Vectors', 'Sort', SB02OU, NN, - $ S, LDS, T, LDT, NDIM, ALFAR, ALFAI, BETA, U, - $ LDU, U, LDU, DWORK, LDWORK, BWORK, INFO1 ) - END IF - ELSE - IF ( LSORT ) THEN - CALL DGEES( 'Vectors', 'Sort', SB02MV, NN, S, LDS, NDIM, - $ ALFAR, ALFAI, U, LDU, DWORK, LDWORK, BWORK, - $ INFO1 ) - ELSE - CALL DGEES( 'Vectors', 'Sort', SB02MR, NN, S, LDS, NDIM, - $ ALFAR, ALFAI, U, LDU, DWORK, LDWORK, BWORK, - $ INFO1 ) - END IF - DUM(1) = ONE - CALL DCOPY( NN, DUM, 0, BETA, 1 ) - END IF - END IF - IF ( INFO1.GT.0 .AND. INFO1.LE.NN+1 ) THEN - INFO = 2 - ELSE IF ( INFO1.EQ.NN+2 ) THEN - INFO = 4 - ELSE IF ( INFO1.EQ.NN+3 ) THEN - INFO = 3 - ELSE IF ( NDIM.NE.N ) THEN - INFO = 5 - END IF - IF ( INFO.NE.0 ) - $ RETURN - WRKOPT = MAX( WRKOPT, INT( DWORK(1) ) ) -C -C Select submatrices U1 and U2 out of the array U which define the -C solution X = U2 x inv(U1). -C Since X = X' we may obtain X as the solution of the system of -C linear equations U1' x X = U2', where -C U1 = U(1:n, 1:n), -C U2 = U(n+1:2n, 1:n). -C Use the (2,1) block of S as a workspace for factoring U1. -C - DO 20 J = 1, N - CALL DCOPY( N, U(NP1,J), 1, X(J,1), LDX ) - 20 CONTINUE -C - CALL DLACPY( 'Full', N, N, U, LDU, S(NP1,1), LDS ) -C -C Check if U1 is singular. -C - UNORM = DLANGE( '1-norm', N, N, S(NP1,1), LDS, DWORK ) -C -C Solve the system U1' x X = U2'. -C - CALL DGETRF( N, N, S(NP1,1), LDS, IWORK, INFO1 ) - IF ( INFO1.NE.0 ) THEN - INFO = 6 - DWORK(3) = ONE - IF ( LSCAL ) THEN - IF ( LJOBB ) THEN - DWORK(3) = SCALE - ELSE IF ( LSCL ) THEN - DWORK(3) = SCALE / RNORM - END IF - END IF - RETURN - ELSE -C -C Estimate the reciprocal condition of U1. -C Workspace: need 3*N. -C - CALL DGECON( '1-norm', N, S(NP1,1), LDS, UNORM, RCOND, DWORK, - $ IWORK(NP1), INFO ) -C - IF ( RCOND.LT.DLAMCH( 'Epsilon' ) ) THEN -C -C Nearly singular matrix. Set INFO for error return. -C - INFO = 6 - RETURN - END IF - WRKOPT = MAX( WRKOPT, 3*N ) - CALL DGETRS( 'Transpose', N, N, S(NP1,1), LDS, IWORK, X, LDX, - $ INFO1 ) -C -C Set S(2,1) to zero. -C - CALL DLASET( 'Full', N, N, ZERO, ZERO, S(NP1,1), LDS ) -C - IF ( LSCAL ) THEN -C -C Prepare to undo scaling for the solution X. -C - IF ( .NOT.LJOBB ) THEN - IF ( LSCL ) THEN - SCALE = SCALE / RNORM - ELSE - SCALE = ONE - END IF - END IF - DWORK(3) = SCALE - SCALE = HALF*SCALE - ELSE - DWORK(3) = ONE - SCALE = HALF - END IF -C -C Make sure the solution matrix X is symmetric. -C - DO 40 I = 1, N - CALL DAXPY( N-I+1, ONE, X(I,I), LDX, X(I,I), 1 ) - CALL DSCAL( N-I+1, SCALE, X(I,I), 1 ) - CALL DCOPY( N-I+1, X(I,I), 1, X(I,I), LDX ) - 40 CONTINUE - END IF -C - DWORK(1) = WRKOPT - IF ( LJOBB ) DWORK(2) = RCONDL -C - RETURN -C *** Last line of SB02OD *** - END diff --git a/mex/sources/libslicot/SB02OU.f b/mex/sources/libslicot/SB02OU.f deleted file mode 100644 index 530d202f6..000000000 --- a/mex/sources/libslicot/SB02OU.f +++ /dev/null @@ -1,83 +0,0 @@ - LOGICAL FUNCTION SB02OU( ALPHAR, ALPHAI, BETA ) -C -C SLICOT RELEASE 5.0. -C -C Copyright (c) 2002-2009 NICONET e.V. -C -C This program is free software: you can redistribute it and/or -C modify it under the terms of the GNU General Public License as -C published by the Free Software Foundation, either version 2 of -C the License, or (at your option) any later version. -C -C This program is distributed in the hope that it will be useful, -C but WITHOUT ANY WARRANTY; without even the implied warranty of -C MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the -C GNU General Public License for more details. -C -C You should have received a copy of the GNU General Public License -C along with this program. If not, see -C . -C -C PURPOSE -C -C To select the unstable generalized eigenvalues for solving the -C continuous-time algebraic Riccati equation. -C -C ARGUMENTS -C -C Input/Output Parameters -C -C ALPHAR (input) DOUBLE PRECISION -C The real part of the numerator of the current eigenvalue -C considered. -C -C ALPHAI (input) DOUBLE PRECISION -C The imaginary part of the numerator of the current -C eigenvalue considered. -C -C BETA (input) DOUBLE PRECISION -C The (real) denominator of the current eigenvalue -C considered. It is assumed that BETA <> 0 (regular case). -C -C METHOD -C -C The function value SB02OU is set to .TRUE. for an unstable -C eigenvalue and to .FALSE., otherwise. -C -C REFERENCES -C -C None. -C -C NUMERICAL ASPECTS -C -C None. -C -C CONTRIBUTOR -C -C Release 3.0: V. Sima, Katholieke Univ. Leuven, Belgium, Sep. 1997. -C Supersedes Release 2.0 routine SB02CW by P. Van Dooren, Philips -C Research Laboratory, Brussels, Belgium. -C -C REVISIONS -C -C - -C -C KEYWORDS -C -C Algebraic Riccati equation, closed loop system, continuous-time -C system, optimal regulator, Schur form. -C -C ****************************************************************** -C - DOUBLE PRECISION ZERO - PARAMETER ( ZERO = 0.0D0 ) -C .. Scalar Arguments .. - DOUBLE PRECISION ALPHAR, ALPHAI, BETA -C .. Executable Statements .. -C - SB02OU = ( ALPHAR.LT.ZERO .AND. BETA.LT.ZERO ) .OR. - $ ( ALPHAR.GT.ZERO .AND. BETA.GT.ZERO ) -C - RETURN -C *** Last line of SB02OU *** - END diff --git a/mex/sources/libslicot/SB02OV.f b/mex/sources/libslicot/SB02OV.f deleted file mode 100644 index db114ae96..000000000 --- a/mex/sources/libslicot/SB02OV.f +++ /dev/null @@ -1,88 +0,0 @@ - LOGICAL FUNCTION SB02OV( ALPHAR, ALPHAI, BETA ) -C -C SLICOT RELEASE 5.0. -C -C Copyright (c) 2002-2009 NICONET e.V. -C -C This program is free software: you can redistribute it and/or -C modify it under the terms of the GNU General Public License as -C published by the Free Software Foundation, either version 2 of -C the License, or (at your option) any later version. -C -C This program is distributed in the hope that it will be useful, -C but WITHOUT ANY WARRANTY; without even the implied warranty of -C MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the -C GNU General Public License for more details. -C -C You should have received a copy of the GNU General Public License -C along with this program. If not, see -C . -C -C PURPOSE -C -C To select the unstable generalized eigenvalues for solving the -C discrete-time algebraic Riccati equation. -C -C ARGUMENTS -C -C Input/Output Parameters -C -C ALPHAR (input) DOUBLE PRECISION -C The real part of the numerator of the current eigenvalue -C considered. -C -C ALPHAI (input) DOUBLE PRECISION -C The imaginary part of the numerator of the current -C eigenvalue considered. -C -C BETA (input) DOUBLE PRECISION -C The (real) denominator of the current eigenvalue -C considered. -C -C METHOD -C -C The function value SB02OV is set to .TRUE. for an unstable -C eigenvalue (i.e., with modulus greater than or equal to one) and -C to .FALSE., otherwise. -C -C REFERENCES -C -C None. -C -C NUMERICAL ASPECTS -C -C None. -C -C CONTRIBUTOR -C -C Release 3.0: V. Sima, Katholieke Univ. Leuven, Belgium, Sep. 1997. -C Supersedes Release 2.0 routine SB02CX by P. Van Dooren, Philips -C Research Laboratory, Brussels, Belgium. -C -C REVISIONS -C -C - -C -C KEYWORDS -C -C Algebraic Riccati equation, closed loop system, continuous-time -C system, optimal regulator, Schur form. -C -C ****************************************************************** -C - DOUBLE PRECISION ONE - PARAMETER ( ONE = 1.0D0 ) -C .. Scalar Arguments .. - DOUBLE PRECISION ALPHAR, ALPHAI, BETA -C .. External Functions .. - DOUBLE PRECISION DLAPY2 - EXTERNAL DLAPY2 -C .. Intrinsic Functions .. - INTRINSIC ABS -C .. Executable Statements .. -C - SB02OV = DLAPY2( ALPHAR, ALPHAI ).GE.ABS( BETA ) -C - RETURN -C *** Last line of SB02OV *** - END diff --git a/mex/sources/libslicot/SB02OW.f b/mex/sources/libslicot/SB02OW.f deleted file mode 100644 index 11de0b233..000000000 --- a/mex/sources/libslicot/SB02OW.f +++ /dev/null @@ -1,83 +0,0 @@ - LOGICAL FUNCTION SB02OW( ALPHAR, ALPHAI, BETA ) -C -C SLICOT RELEASE 5.0. -C -C Copyright (c) 2002-2009 NICONET e.V. -C -C This program is free software: you can redistribute it and/or -C modify it under the terms of the GNU General Public License as -C published by the Free Software Foundation, either version 2 of -C the License, or (at your option) any later version. -C -C This program is distributed in the hope that it will be useful, -C but WITHOUT ANY WARRANTY; without even the implied warranty of -C MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the -C GNU General Public License for more details. -C -C You should have received a copy of the GNU General Public License -C along with this program. If not, see -C . -C -C PURPOSE -C -C To select the stable generalized eigenvalues for solving the -C continuous-time algebraic Riccati equation. -C -C ARGUMENTS -C -C Input/Output Parameters -C -C ALPHAR (input) DOUBLE PRECISION -C The real part of the numerator of the current eigenvalue -C considered. -C -C ALPHAI (input) DOUBLE PRECISION -C The imaginary part of the numerator of the current -C eigenvalue considered. -C -C BETA (input) DOUBLE PRECISION -C The (real) denominator of the current eigenvalue -C considered. It is assumed that BETA <> 0 (regular case). -C -C METHOD -C -C The function value SB02OW is set to .TRUE. for a stable eigenvalue -C and to .FALSE., otherwise. -C -C REFERENCES -C -C None. -C -C NUMERICAL ASPECTS -C -C None. -C -C CONTRIBUTOR -C -C Release 3.0: V. Sima, Katholieke Univ. Leuven, Belgium, Sep. 1997. -C Supersedes Release 2.0 routine SB02CW by P. Van Dooren, Philips -C Research Laboratory, Brussels, Belgium. -C -C REVISIONS -C -C - -C -C KEYWORDS -C -C Algebraic Riccati equation, closed loop system, continuous-time -C system, optimal regulator, Schur form. -C -C ****************************************************************** -C - DOUBLE PRECISION ZERO - PARAMETER ( ZERO = 0.0D0 ) -C .. Scalar Arguments .. - DOUBLE PRECISION ALPHAR, ALPHAI, BETA -C .. Executable Statements .. -C - SB02OW = ( ALPHAR.LT.ZERO .AND. BETA.GT.ZERO ) .OR. - $ ( ALPHAR.GT.ZERO .AND. BETA.LT.ZERO ) -C - RETURN -C *** Last line of SB02OW *** - END diff --git a/mex/sources/libslicot/SB02OX.f b/mex/sources/libslicot/SB02OX.f deleted file mode 100644 index b3f90b53b..000000000 --- a/mex/sources/libslicot/SB02OX.f +++ /dev/null @@ -1,87 +0,0 @@ - LOGICAL FUNCTION SB02OX( ALPHAR, ALPHAI, BETA ) -C -C SLICOT RELEASE 5.0. -C -C Copyright (c) 2002-2009 NICONET e.V. -C -C This program is free software: you can redistribute it and/or -C modify it under the terms of the GNU General Public License as -C published by the Free Software Foundation, either version 2 of -C the License, or (at your option) any later version. -C -C This program is distributed in the hope that it will be useful, -C but WITHOUT ANY WARRANTY; without even the implied warranty of -C MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the -C GNU General Public License for more details. -C -C You should have received a copy of the GNU General Public License -C along with this program. If not, see -C . -C -C PURPOSE -C -C To select the stable generalized eigenvalues for solving the -C discrete-time algebraic Riccati equation. -C -C ARGUMENTS -C -C Input/Output Parameters -C -C ALPHAR (input) DOUBLE PRECISION -C The real part of the numerator of the current eigenvalue -C considered. -C -C ALPHAI (input) DOUBLE PRECISION -C The imaginary part of the numerator of the current -C eigenvalue considered. -C -C BETA (input) DOUBLE PRECISION -C The (real) denominator of the current eigenvalue -C considered. -C -C METHOD -C -C The function value SB02OX is set to .TRUE. for a stable eigenvalue -C (i.e., with modulus less than one) and to .FALSE., otherwise. -C -C REFERENCES -C -C None. -C -C NUMERICAL ASPECTS -C -C None. -C -C CONTRIBUTOR -C -C Release 3.0: V. Sima, Katholieke Univ. Leuven, Belgium, Sep. 1997. -C Supersedes Release 2.0 routine SB02CX by P. Van Dooren, Philips -C Research Laboratory, Brussels, Belgium. -C -C REVISIONS -C -C - -C -C KEYWORDS -C -C Algebraic Riccati equation, closed loop system, continuous-time -C system, optimal regulator, Schur form. -C -C ****************************************************************** -C - DOUBLE PRECISION ONE - PARAMETER ( ONE = 1.0D0 ) -C .. Scalar Arguments .. - DOUBLE PRECISION ALPHAR, ALPHAI, BETA -C .. External Functions .. - DOUBLE PRECISION DLAPY2 - EXTERNAL DLAPY2 -C .. Intrinsic Functions .. - INTRINSIC ABS -C .. Executable Statements .. -C - SB02OX = DLAPY2( ALPHAR, ALPHAI ).LT.ABS( BETA ) -C - RETURN -C *** Last line of SB02OX *** - END diff --git a/mex/sources/libslicot/SB02OY.f b/mex/sources/libslicot/SB02OY.f deleted file mode 100644 index 367befee2..000000000 --- a/mex/sources/libslicot/SB02OY.f +++ /dev/null @@ -1,791 +0,0 @@ - SUBROUTINE SB02OY( TYPE, DICO, JOBB, FACT, UPLO, JOBL, JOBE, N, M, - $ P, A, LDA, B, LDB, Q, LDQ, R, LDR, L, LDL, E, - $ LDE, AF, LDAF, BF, LDBF, TOL, IWORK, DWORK, - $ LDWORK, INFO ) -C -C SLICOT RELEASE 5.0. -C -C Copyright (c) 2002-2009 NICONET e.V. -C -C This program is free software: you can redistribute it and/or -C modify it under the terms of the GNU General Public License as -C published by the Free Software Foundation, either version 2 of -C the License, or (at your option) any later version. -C -C This program is distributed in the hope that it will be useful, -C but WITHOUT ANY WARRANTY; without even the implied warranty of -C MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the -C GNU General Public License for more details. -C -C You should have received a copy of the GNU General Public License -C along with this program. If not, see -C . -C -C PURPOSE -C -C To construct the extended matrix pairs for the computation of the -C solution of the algebraic matrix Riccati equations arising in the -C problems of optimal control, both discrete and continuous-time, -C and of spectral factorization, both discrete and continuous-time. -C These matrix pairs, of dimension 2N + M, are given by -C -C discrete-time continuous-time -C -C |A 0 B| |E 0 0| |A 0 B| |E 0 0| -C |Q -E' L| - z |0 -A' 0|, |Q A' L| - s |0 -E' 0|. (1) -C |L' 0 R| |0 -B' 0| |L' B' R| |0 0 0| -C -C After construction, these pencils are compressed to a form -C (see [1]) -C -C lambda x A - B , -C f f -C -C where A and B are 2N-by-2N matrices. -C f f -C -1 -C Optionally, matrix G = BR B' may be given instead of B and R; -C then, for L = 0, 2N-by-2N matrix pairs are directly constructed as -C -C discrete-time continuous-time -C -C |A 0 | |E G | |A -G | |E 0 | -C | | - z | |, | | - s | |. (2) -C |Q -E'| |0 -A'| |Q A'| |0 -E'| -C -C Similar pairs are obtained for non-zero L, if SLICOT Library -C routine SB02MT is called before SB02OY. -C Other options include the case with E identity matrix, L a zero -C matrix, or Q and/or R given in a factored form, Q = C'C, R = D'D. -C For spectral factorization problems, there are minor differences -C (e.g., B is replaced by C'). -C The second matrix in (2) is not constructed in the continuous-time -C case if E is specified as being an identity matrix. -C -C ARGUMENTS -C -C Mode Parameters -C -C TYPE CHARACTER*1 -C Specifies the type of problem to be addressed as follows: -C = 'O': Optimal control problem; -C = 'S': Spectral factorization problem. -C -C DICO CHARACTER*1 -C Specifies the type of linear system considered as follows: -C = 'C': Continuous-time system; -C = 'D': Discrete-time system. -C -C JOBB CHARACTER*1 -C Specifies whether or not the matrix G is given, instead -C of the matrices B and R, as follows: -C = 'B': B and R are given; -C = 'G': G is given. -C For JOBB = 'G', a 2N-by-2N matrix pair is directly -C obtained assuming L = 0 (see the description of JOBL). -C -C FACT CHARACTER*1 -C Specifies whether or not the matrices Q and/or R (if -C JOBB = 'B') are factored, as follows: -C = 'N': Not factored, Q and R are given; -C = 'C': C is given, and Q = C'C; -C = 'D': D is given, and R = D'D (if TYPE = 'O'), or -C R = D + D' (if TYPE = 'S'); -C = 'B': Both factors C and D are given, Q = C'C, R = D'D -C (or R = D + D'). -C -C UPLO CHARACTER*1 -C If JOBB = 'G', or FACT = 'N', specifies which triangle of -C the matrices G and Q (if FACT = 'N'), or Q and R (if -C JOBB = 'B'), is stored, as follows: -C = 'U': Upper triangle is stored; -C = 'L': Lower triangle is stored. -C -C JOBL CHARACTER*1 -C Specifies whether or not the matrix L is zero, as follows: -C = 'Z': L is zero; -C = 'N': L is nonzero. -C JOBL is not used if JOBB = 'G' and JOBL = 'Z' is assumed. -C Using SLICOT Library routine SB02MT to compute the -C corresponding A and Q in this case, before calling SB02OY, -C enables to obtain 2N-by-2N matrix pairs directly. -C -C JOBE CHARACTER*1 -C Specifies whether or not the matrix E is identity, as -C follows: -C = 'I': E is the identity matrix; -C = 'N': E is a general matrix. -C -C Input/Output Parameters -C -C N (input) INTEGER -C The order of the matrices A, Q, and E, and the number -C of rows of the matrices B and L. N >= 0. -C -C M (input) INTEGER -C If JOBB = 'B', M is the order of the matrix R, and the -C number of columns of the matrix B. M >= 0. -C M is not used if JOBB = 'G'. -C -C P (input) INTEGER -C If FACT = 'C' or 'D' or 'B', or if TYPE = 'S', P is the -C number of rows of the matrix C and/or D, respectively. -C P >= 0, and if JOBB = 'B' and TYPE = 'S', then P = M. -C Otherwise, P is not used. -C -C A (input) DOUBLE PRECISION array, dimension (LDA,N) -C The leading N-by-N part of this array must contain the -C state matrix A of the system. -C -C LDA INTEGER -C The leading dimension of array A. LDA >= MAX(1,N). -C -C B (input) DOUBLE PRECISION array, dimension (LDB,*) -C If JOBB = 'B', the leading N-by-M part of this array must -C contain the input matrix B of the system. -C If JOBB = 'G', the leading N-by-N upper triangular part -C (if UPLO = 'U') or lower triangular part (if UPLO = 'L') -C of this array must contain the upper triangular part or -C lower triangular part, respectively, of the matrix -C -1 -C G = BR B'. The stricly lower triangular part (if -C UPLO = 'U') or stricly upper triangular part (if -C UPLO = 'L') is not referenced. -C -C LDB INTEGER -C The leading dimension of array B. LDB >= MAX(1,N). -C -C Q (input) DOUBLE PRECISION array, dimension (LDQ,N) -C If FACT = 'N' or 'D', the leading N-by-N upper triangular -C part (if UPLO = 'U') or lower triangular part (if UPLO = -C 'L') of this array must contain the upper triangular part -C or lower triangular part, respectively, of the symmetric -C output weighting matrix Q. The stricly lower triangular -C part (if UPLO = 'U') or stricly upper triangular part (if -C UPLO = 'L') is not referenced. -C If FACT = 'C' or 'B', the leading P-by-N part of this -C array must contain the output matrix C of the system. -C -C LDQ INTEGER -C The leading dimension of array Q. -C LDQ >= MAX(1,N) if FACT = 'N' or 'D', -C LDQ >= MAX(1,P) if FACT = 'C' or 'B'. -C -C R (input) DOUBLE PRECISION array, dimension (LDR,M) -C If FACT = 'N' or 'C', the leading M-by-M upper triangular -C part (if UPLO = 'U') or lower triangular part (if UPLO = -C 'L') of this array must contain the upper triangular part -C or lower triangular part, respectively, of the symmetric -C input weighting matrix R. The stricly lower triangular -C part (if UPLO = 'U') or stricly upper triangular part (if -C UPLO = 'L') is not referenced. -C If FACT = 'D' or 'B', the leading P-by-M part of this -C array must contain the direct transmission matrix D of the -C system. -C If JOBB = 'G', this array is not referenced. -C -C LDR INTEGER -C The leading dimension of array R. -C LDR >= MAX(1,M) if JOBB = 'B' and FACT = 'N' or 'C'; -C LDR >= MAX(1,P) if JOBB = 'B' and FACT = 'D' or 'B'; -C LDR >= 1 if JOBB = 'G'. -C -C L (input) DOUBLE PRECISION array, dimension (LDL,M) -C If JOBL = 'N' (and JOBB = 'B'), the leading N-by-M part of -C this array must contain the cross weighting matrix L. -C If JOBL = 'Z' or JOBB = 'G', this array is not referenced. -C -C LDL INTEGER -C The leading dimension of array L. -C LDL >= MAX(1,N) if JOBL = 'N'; -C LDL >= 1 if JOBL = 'Z' or JOBB = 'G'. -C -C E (input) DOUBLE PRECISION array, dimension (LDE,N) -C If JOBE = 'N', the leading N-by-N part of this array must -C contain the matrix E of the descriptor system. -C If JOBE = 'I', E is taken as identity and this array is -C not referenced. -C -C LDE INTEGER -C The leading dimension of array E. -C LDE >= MAX(1,N) if JOBE = 'N'; -C LDE >= 1 if JOBE = 'I'. -C -C AF (output) DOUBLE PRECISION array, dimension (LDAF,*) -C The leading 2N-by-2N part of this array contains the -C matrix A in the matrix pencil. -C f -C Array AF must have 2*N+M columns if JOBB = 'B', and 2*N -C columns, otherwise. -C -C LDAF INTEGER -C The leading dimension of array AF. -C LDAF >= MAX(1,2*N+M) if JOBB = 'B', -C LDAF >= MAX(1,2*N) if JOBB = 'G'. -C -C BF (output) DOUBLE PRECISION array, dimension (LDBF,2*N) -C If DICO = 'D' or JOBB = 'B' or JOBE = 'N', the leading -C 2N-by-2N part of this array contains the matrix B in the -C f -C matrix pencil. -C The last M zero columns are never constructed. -C If DICO = 'C' and JOBB = 'G' and JOBE = 'I', this array -C is not referenced. -C -C LDBF INTEGER -C The leading dimension of array BF. -C LDBF >= MAX(1,2*N+M) if JOBB = 'B', -C LDBF >= MAX(1,2*N) if JOBB = 'G' and ( DICO = 'D' or -C JOBE = 'N' ), -C LDBF >= 1 if JOBB = 'G' and ( DICO = 'C' and -C JOBE = 'I' ). -C -C Tolerances -C -C TOL DOUBLE PRECISION -C The tolerance to be used to test for near singularity of -C the original matrix pencil, specifically of the triangular -C factor obtained during the reduction process. If the user -C sets TOL > 0, then the given value of TOL is used as a -C lower bound for the reciprocal condition number of that -C matrix; a matrix whose estimated condition number is less -C than 1/TOL is considered to be nonsingular. If the user -C sets TOL <= 0, then a default tolerance, defined by -C TOLDEF = EPS, is used instead, where EPS is the machine -C precision (see LAPACK Library routine DLAMCH). -C This parameter is not referenced if JOBB = 'G'. -C -C Workspace -C -C IWORK INTEGER array, dimension (LIWORK) -C LIWORK >= M if JOBB = 'B', -C LIWORK >= 1 if JOBB = 'G'. -C -C DWORK DOUBLE PRECISION array, dimension (LDWORK) -C On exit, if INFO = 0, DWORK(1) returns the optimal value -C of LDWORK. If JOBB = 'B', DWORK(2) returns the reciprocal -C of the condition number of the M-by-M lower triangular -C matrix obtained after compression. -C -C LDWORK INTEGER -C The length of the array DWORK. -C LDWORK >= 1 if JOBB = 'G', -C LDWORK >= MAX(1,2*N + M,3*M) if JOBB = 'B'. -C For optimum performance LDWORK should be larger. -C -C Error Indicator -C -C INFO INTEGER -C = 0: successful exit; -C < 0: if INFO = -i, the i-th argument had an illegal -C value; -C = 1: if the computed extended matrix pencil is singular, -C possibly due to rounding errors. -C -C METHOD -C -C The extended matrix pairs are constructed, taking various options -C into account. If JOBB = 'B', the problem order is reduced from -C 2N+M to 2N (see [1]). -C -C REFERENCES -C -C [1] Van Dooren, P. -C A Generalized Eigenvalue Approach for Solving Riccati -C Equations. -C SIAM J. Sci. Stat. Comp., 2, pp. 121-135, 1981. -C -C [2] Mehrmann, V. -C The Autonomous Linear Quadratic Control Problem. Theory and -C Numerical Solution. -C Lect. Notes in Control and Information Sciences, vol. 163, -C Springer-Verlag, Berlin, 1991. -C -C [3] Sima, V. -C Algorithms for Linear-Quadratic Optimization. -C Pure and Applied Mathematics: A Series of Monographs and -C Textbooks, vol. 200, Marcel Dekker, Inc., New York, 1996. -C -C NUMERICAL ASPECTS -C -C The algorithm is backward stable. -C -C CONTRIBUTORS -C -C Release 3.0: V. Sima, Katholieke Univ. Leuven, Belgium, Sep. 1997. -C Supersedes Release 2.0 routine SB02CY by T.G.J. Beelen, Philips, -C Eindhoven, Holland, M. Vanbegin, and P. Van Dooren, Philips -C Research Laboratory, Brussels, Belgium. -C -C REVISIONS -C -C V. Sima, Research Institute for Informatics, Bucharest, Dec. 2002. -C -C KEYWORDS -C -C Algebraic Riccati equation, closed loop system, continuous-time -C system, discrete-time system, optimal regulator, Schur form. -C -C ****************************************************************** -C - DOUBLE PRECISION ZERO, ONE - PARAMETER ( ZERO = 0.0D0, ONE = 1.0D0 ) -C .. Scalar Arguments .. - CHARACTER DICO, FACT, JOBB, JOBE, JOBL, TYPE, UPLO - INTEGER INFO, LDA, LDAF, LDB, LDBF, LDE, LDL, LDQ, LDR, - $ LDWORK, M, N, P - DOUBLE PRECISION TOL -C .. Array Arguments .. - INTEGER IWORK(*) - DOUBLE PRECISION A(LDA,*), AF(LDAF,*), B(LDB,*), BF(LDBF,*), - $ DWORK(*), E(LDE,*), L(LDL,*), Q(LDQ,*), R(LDR,*) -C .. Local Scalars .. - LOGICAL DISCR, LFACB, LFACN, LFACQ, LFACR, LJOBB, LJOBE, - $ LJOBL, LUPLO, OPTC - INTEGER I, ITAU, J, JWORK, N2, N2P1, NM, NNM, NP1, - $ WRKOPT - DOUBLE PRECISION RCOND, TOLDEF -C .. External Functions .. - LOGICAL LSAME - DOUBLE PRECISION DLAMCH - EXTERNAL DLAMCH, LSAME -C .. External Subroutines .. - EXTERNAL DCOPY, DGEQLF, DLACPY, DLASET, DORMQL, DSYRK, - $ DTRCON, XERBLA -C .. Intrinsic Functions .. - INTRINSIC INT, MAX -C .. Executable Statements .. -C - INFO = 0 - OPTC = LSAME( TYPE, 'O' ) - DISCR = LSAME( DICO, 'D' ) - LJOBB = LSAME( JOBB, 'B' ) - LFACN = LSAME( FACT, 'N' ) - LFACQ = LSAME( FACT, 'C' ) - LFACR = LSAME( FACT, 'D' ) - LFACB = LSAME( FACT, 'B' ) - LUPLO = LSAME( UPLO, 'U' ) - LJOBE = LSAME( JOBE, 'I' ) - N2 = N + N - IF ( LJOBB ) THEN - LJOBL = LSAME( JOBL, 'Z' ) - NM = N + M - NNM = N2 + M - ELSE - NM = N - NNM = N2 - END IF - NP1 = N + 1 - N2P1 = N2 + 1 -C -C Test the input scalar arguments. -C - IF( .NOT.OPTC .AND. .NOT.LSAME( TYPE, 'S' ) ) THEN - INFO = -1 - ELSE IF( .NOT.DISCR .AND. .NOT.LSAME( DICO, 'C' ) ) THEN - INFO = -2 - ELSE IF( .NOT.LJOBB .AND. .NOT.LSAME( JOBB, 'G' ) ) THEN - INFO = -3 - ELSE IF( .NOT.LFACQ .AND. .NOT.LFACR .AND. .NOT.LFACB - $ .AND. .NOT.LFACN ) THEN - INFO = -4 - ELSE IF( .NOT.LJOBB .OR. LFACN ) THEN - IF( .NOT.LUPLO .AND. .NOT.LSAME( UPLO, 'L' ) ) - $ INFO = -5 - ELSE IF( LJOBB ) THEN - IF( .NOT.LJOBL .AND. .NOT.LSAME( JOBL, 'N' ) ) - $ INFO = -6 - ELSE IF( .NOT.LJOBE .AND. .NOT.LSAME( JOBE, 'N' ) ) THEN - INFO = -7 - ELSE IF( N.LT.0 ) THEN - INFO = -8 - ELSE IF( LJOBB ) THEN - IF( M.LT.0 ) - $ INFO = -9 - ELSE IF( .NOT.LFACN .OR. .NOT.OPTC ) THEN - IF( P.LT.0 ) THEN - INFO = -10 - ELSE IF( LJOBB ) THEN - IF( .NOT.OPTC .AND. P.NE.M ) - $ INFO = -10 - END IF - ELSE IF( LDA.LT.MAX( 1, N ) ) THEN - INFO = -12 - ELSE IF( LDB.LT.MAX( 1, N ) ) THEN - INFO = -14 - ELSE IF( ( ( LFACN.OR.LFACR ) .AND. LDQ.LT.MAX( 1, N ) ) .OR. - $ ( ( LFACQ.OR.LFACB ) .AND. LDQ.LT.MAX( 1, P ) ) ) THEN - INFO = -16 - ELSE IF( LDR.LT.1 ) THEN - INFO = -18 - ELSE IF( LJOBB ) THEN - IF ( ( LFACN.OR.LFACQ ) .AND. LDR.LT.M .OR. - $ ( LFACR.OR.LFACB ) .AND. LDR.LT.P ) THEN - INFO = -18 - ELSE IF( ( .NOT.LJOBL .AND. LDL.LT.MAX( 1, N ) ) .OR. - $ ( LJOBL .AND. LDL.LT.1 ) ) THEN - INFO = -20 - END IF - END IF - IF( ( .NOT.LJOBE .AND. LDE.LT.MAX( 1, N ) ) .OR. - $ ( LJOBE .AND. LDE.LT.1 ) ) THEN - INFO = -22 - ELSE IF( LDAF.LT.MAX( 1, NNM ) ) THEN - INFO = -24 - ELSE IF( ( ( LJOBB .OR. DISCR .OR. .NOT.LJOBE ) .AND. - $ LDBF.LT.NNM ) .OR. ( LDBF.LT.1 ) ) THEN - INFO = -26 - ELSE IF( ( LJOBB .AND. LDWORK.LT.MAX( NNM, 3*M ) ) .OR. - $ LDWORK.LT.1 ) THEN - INFO = -30 - END IF -C - IF ( INFO.NE.0 ) THEN -C -C Error return. -C - CALL XERBLA( 'SB02OY', -INFO ) - RETURN - END IF -C -C Quick return if possible. -C - DWORK(1) = ONE - IF ( N.EQ.0 ) - $ RETURN -C -C Construct the extended matrices in AF and BF, by block-columns. -C - CALL DLACPY( 'Full', N, N, A, LDA, AF, LDAF ) -C - IF ( .NOT.LFACQ .AND. .NOT.LFACB ) THEN - CALL DLACPY( UPLO, N, N, Q, LDQ, AF(NP1,1), LDAF ) - IF ( LUPLO ) THEN -C -C Construct the lower triangle of Q. -C - DO 20 J = 1, N - 1 - CALL DCOPY( N-J, Q(J,J+1), LDQ, AF(NP1+J,J), 1 ) - 20 CONTINUE -C - ELSE -C -C Construct the upper triangle of Q. -C - DO 40 J = 2, N - CALL DCOPY( J-1, Q(J,1), LDQ, AF(NP1,J), 1 ) - 40 CONTINUE -C - END IF - ELSE - CALL DSYRK( 'Upper', 'Transpose', N, P, ONE, Q, LDQ, ZERO, - $ AF(NP1,1), LDAF ) -C - DO 60 J = 2, N - CALL DCOPY( J-1, AF(NP1,J), 1, AF(N+J,1), LDAF ) - 60 CONTINUE -C - END IF -C - IF ( LJOBB ) THEN - IF ( LJOBL ) THEN - CALL DLASET( 'Full', M, N, ZERO, ZERO, AF(N2P1,1), LDAF ) - ELSE -C - DO 80 I = 1, N - CALL DCOPY( M, L(I,1), LDL, AF(N2P1,I), 1 ) - 80 CONTINUE -C - END IF - END IF -C - IF ( DISCR.OR.LJOBB ) THEN - CALL DLASET( 'Full', N, N, ZERO, ZERO, AF(1,NP1), LDAF ) - ELSE - IF ( LUPLO ) THEN -C -C Construct (1,2) block of AF using the upper triangle of G. -C - DO 140 J = 1, N -C - DO 100 I = 1, J - AF(I,N+J)= -B(I,J) - 100 CONTINUE -C - DO 120 I = J + 1, N - AF(I,N+J)= -B(J,I) - 120 CONTINUE -C - 140 CONTINUE -C - ELSE -C -C Construct (1,2) block of AF using the lower triangle of G. -C - DO 200 J = 1, N -C - DO 160 I = 1, J - 1 - AF(I,N+J)= -B(J,I) - 160 CONTINUE -C - DO 180 I = J, N - AF(I,N+J)= -B(I,J) - 180 CONTINUE -C - 200 CONTINUE -C - END IF - END IF -C - IF ( DISCR ) THEN - IF ( LJOBE ) THEN - CALL DLASET( 'Full', NM, N, ZERO, -ONE, AF(NP1,NP1), LDAF ) - ELSE -C - DO 240 J = 1, N -C - DO 220 I = 1, N - AF(N+I,N+J)= -E(J,I) - 220 CONTINUE -C - 240 CONTINUE -C - IF ( LJOBB ) - $ CALL DLASET( 'Full', M, N, ZERO, ZERO, AF(N2P1,NP1), - $ LDAF ) - END IF - ELSE -C - DO 280 J = 1, N -C - DO 260 I = 1, N - AF(N+I,N+J)= A(J,I) - 260 CONTINUE -C - 280 CONTINUE -C - IF ( LJOBB ) THEN - IF ( OPTC ) THEN -C - DO 300 J = 1, N - CALL DCOPY ( M, B(J,1), LDB, AF(N2P1,N+J), 1 ) - 300 CONTINUE -C - ELSE - CALL DLACPY( 'Full', P, N, Q, LDQ, AF(N2P1,NP1), LDAF ) - END IF - END IF - END IF -C - IF ( LJOBB ) THEN -C - IF ( OPTC ) THEN - CALL DLACPY( 'Full', N, M, B, LDB, AF(1,N2P1), LDAF ) - ELSE -C - DO 320 I = 1, P - CALL DCOPY( N, Q(I,1), LDQ, AF(1,N2+I), 1 ) - 320 CONTINUE -C - END IF -C - IF ( LJOBL ) THEN - CALL DLASET( 'Full', N, M, ZERO, ZERO, AF(NP1,N2P1), LDAF ) - ELSE - CALL DLACPY( 'Full', N, M, L, LDL, AF(NP1,N2P1), LDAF ) - END IF -C - IF ( .NOT.LFACR .AND. .NOT.LFACB ) THEN - CALL DLACPY( UPLO, M, M, R, LDR, AF(N2P1,N2P1), LDAF ) - IF ( LUPLO ) THEN -C -C Construct the lower triangle of R. -C - DO 340 J = 1, M - 1 - CALL DCOPY( M-J, R(J,J+1), LDR, AF(N2P1+J,N2+J), 1 ) - 340 CONTINUE -C - ELSE -C -C Construct the upper triangle of R. -C - DO 360 J = 2, M - CALL DCOPY( J-1, R(J,1), LDR, AF(N2P1,N2+J), 1 ) - 360 CONTINUE -C - END IF - ELSE IF ( OPTC ) THEN - CALL DSYRK( 'Upper', 'Transpose', M, P, ONE, R, LDR, ZERO, - $ AF(N2P1,N2P1), LDAF ) -C - DO 380 J = 2, M - CALL DCOPY( J-1, AF(N2P1,N2+J), 1, AF(N2+J,N2P1), LDAF ) - 380 CONTINUE -C - ELSE -C - DO 420 J = 1, M -C - DO 400 I = 1, P - AF(N2+I,N2+J) = R(I,J) + R(J,I) - 400 CONTINUE -C - 420 CONTINUE -C - END IF - END IF -C - IF ( .NOT.LJOBB .AND. .NOT.DISCR .AND. LJOBE ) - $ RETURN -C -C Construct the first two block columns of BF. -C - IF ( LJOBE ) THEN - CALL DLASET( 'Full', N+NM, N, ZERO, ONE, BF, LDBF ) - ELSE - CALL DLACPY( 'Full', N, N, E, LDE, BF, LDBF ) - CALL DLASET( 'Full', NM, N, ZERO, ZERO, BF(NP1,1), LDBF ) - END IF -C - IF ( .NOT.DISCR.OR.LJOBB ) THEN - CALL DLASET( 'Full', N, N, ZERO, ZERO, BF(1,NP1), LDBF ) - ELSE - IF ( LUPLO ) THEN -C -C Construct (1,2) block of BF using the upper triangle of G. -C - DO 480 J = 1, N -C - DO 440 I = 1, J - BF(I,N+J)= B(I,J) - 440 CONTINUE -C - DO 460 I = J + 1, N - BF(I,N+J)= B(J,I) - 460 CONTINUE -C - 480 CONTINUE -C - ELSE -C -C Construct (1,2) block of BF using the lower triangle of G. -C - DO 540 J = 1, N -C - DO 500 I = 1, J - 1 - BF(I,N+J)= B(J,I) - 500 CONTINUE -C - DO 520 I = J, N - BF(I,N+J)= B(I,J) - 520 CONTINUE -C - 540 CONTINUE -C - END IF - END IF -C - IF ( DISCR ) THEN -C - DO 580 J = 1, N -C - DO 560 I = 1, N - BF(N+I,N+J)= -A(J,I) - 560 CONTINUE -C - 580 CONTINUE -C - IF ( LJOBB ) THEN -C - IF ( OPTC ) THEN -C - DO 620 J = 1, N -C - DO 600 I = 1, M - BF(N2+I,N+J)= -B(J,I) - 600 CONTINUE -C - 620 CONTINUE -C - ELSE -C - DO 660 J = 1, N -C - DO 640 I = 1, P - BF(N2+I,N+J) = -Q(I,J) - 640 CONTINUE -C - 660 CONTINUE -C - END IF - END IF -C - ELSE - IF ( LJOBE ) THEN - CALL DLASET( 'Full', NM, N, ZERO, -ONE, BF(NP1,NP1), LDBF ) - ELSE -C - DO 700 J = 1, N -C - DO 680 I = 1, N - BF(N+I,N+J)= -E(J,I) - 680 CONTINUE -C - 700 CONTINUE -C - IF ( LJOBB ) - $ CALL DLASET( 'Full', M, N, ZERO, ZERO, BF(N2P1,NP1), - $ LDBF ) - END IF - END IF -C - IF ( .NOT.LJOBB ) - $ RETURN -C -C Compress the pencil lambda x BF - AF, using QL factorization. -C (Note: Comments in the code beginning "Workspace:" describe the -C minimal amount of real workspace needed at that point in the -C code, as well as the preferred amount for good performance. -C NB refers to the optimal block size for the immediately -C following subroutine, as returned by ILAENV.) -C -C Workspace: need 2*M; prefer M + M*NB. -C - ITAU = 1 - JWORK = ITAU + M - CALL DGEQLF( NNM, M, AF(1,N2P1), LDAF, DWORK(ITAU), DWORK(JWORK), - $ LDWORK-JWORK+1, INFO ) - WRKOPT = DWORK(JWORK) -C -C Workspace: need 2*N+M; prefer M + 2*N*NB. -C - CALL DORMQL( 'Left', 'Transpose', NNM, N2, M, AF(1,N2P1), LDAF, - $ DWORK(ITAU), AF, LDAF, DWORK(JWORK), LDWORK-JWORK+1, - $ INFO ) - WRKOPT = MAX( WRKOPT, INT( DWORK(JWORK) )+JWORK-1 ) -C - CALL DORMQL( 'Left', 'Transpose', NNM, N2, M, AF(1,N2P1), LDAF, - $ DWORK(ITAU), BF, LDBF, DWORK(JWORK), LDWORK-JWORK+1, - $ INFO ) -C -C Check the singularity of the L factor in the QL factorization: -C if singular, then the extended matrix pencil is also singular. -C Workspace 3*M. -C - TOLDEF = TOL - IF ( TOLDEF.LE.ZERO ) - $ TOLDEF = DLAMCH( 'Epsilon' ) -C - CALL DTRCON( '1-norm', 'Lower', 'Non unit', M, AF(N2P1,N2P1), - $ LDAF, RCOND, DWORK, IWORK, INFO ) - WRKOPT = MAX( WRKOPT, 3*M ) -C - IF ( RCOND.LE.TOLDEF ) - $ INFO = 1 -C - DWORK(1) = WRKOPT - DWORK(2) = RCOND -C - RETURN -C *** Last line of SB02OY *** - END diff --git a/mex/sources/libslicot/SB02PD.f b/mex/sources/libslicot/SB02PD.f deleted file mode 100644 index fe63ddfca..000000000 --- a/mex/sources/libslicot/SB02PD.f +++ /dev/null @@ -1,756 +0,0 @@ - SUBROUTINE SB02PD( JOB, TRANA, UPLO, N, A, LDA, G, LDG, Q, LDQ, X, - $ LDX, RCOND, FERR, WR, WI, IWORK, DWORK, LDWORK, - $ INFO ) -C -C SLICOT RELEASE 5.0. -C -C Copyright (c) 2002-2009 NICONET e.V. -C -C This program is free software: you can redistribute it and/or -C modify it under the terms of the GNU General Public License as -C published by the Free Software Foundation, either version 2 of -C the License, or (at your option) any later version. -C -C This program is distributed in the hope that it will be useful, -C but WITHOUT ANY WARRANTY; without even the implied warranty of -C MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the -C GNU General Public License for more details. -C -C You should have received a copy of the GNU General Public License -C along with this program. If not, see -C . -C -C PURPOSE -C -C To solve the real continuous-time matrix algebraic Riccati -C equation -C -C op(A)'*X + X*op(A) + Q - X*G*X = 0, -C -C where op(A) = A or A' = A**T and G, Q are symmetric (G = G**T, -C Q = Q**T). The matrices A, G and Q are N-by-N and the solution X -C is an N-by-N symmetric matrix. -C -C An error bound on the solution and a condition estimate are also -C optionally provided. -C -C It is assumed that the matrices A, G and Q are such that the -C corresponding Hamiltonian matrix has N eigenvalues with negative -C real parts. -C -C ARGUMENTS -C -C Mode Parameters -C -C JOB CHARACTER*1 -C Specifies the computation to be performed, as follows: -C = 'X': Compute the solution only; -C = 'A': Compute all: the solution, reciprocal condition -C number, and the error bound. -C -C TRANA CHARACTER*1 -C Specifies the option op(A): -C = 'N': op(A) = A (No transpose); -C = 'T': op(A) = A**T (Transpose); -C = 'C': op(A) = A**T (Conjugate transpose = Transpose). -C -C UPLO CHARACTER*1 -C Specifies which triangle of the matrices G and Q is -C stored, as follows: -C = 'U': Upper triangles of G and Q are stored; -C = 'L': Lower triangles of G and Q are stored. -C -C Input/Output Parameters -C -C N (input) INTEGER -C The order of the matrices A, G, Q, and X. N >= 0. -C -C A (input) DOUBLE PRECISION array, dimension (LDA,N) -C The leading N-by-N part of this array must contain the -C coefficient matrix A of the equation. -C -C LDA INTEGER -C The leading dimension of the array A. LDA >= max(1,N). -C -C G (input) DOUBLE PRECISION array, dimension (LDG,N) -C If UPLO = 'U', the leading N-by-N upper triangular part of -C this array must contain the upper triangular part of the -C matrix G. -C If UPLO = 'L', the leading N-by-N lower triangular part of -C this array must contain the lower triangular part of the -C matrix G. -C -C LDG INTEGER -C The leading dimension of the array G. LDG >= max(1,N). -C -C Q (input) DOUBLE PRECISION array, dimension (LDQ,N) -C If UPLO = 'U', the leading N-by-N upper triangular part of -C this array must contain the upper triangular part of the -C matrix Q. -C If UPLO = 'L', the leading N-by-N lower triangular part of -C this array must contain the lower triangular part of the -C matrix Q. -C -C LDQ INTEGER -C The leading dimension of the array Q. LDQ >= max(1,N). -C -C X (output) DOUBLE PRECISION array, dimension (LDX,N) -C If INFO = 0, INFO = 2, or INFO = 4, the leading N-by-N -C part of this array contains the symmetric solution matrix -C X of the algebraic Riccati equation. -C -C LDX INTEGER -C The leading dimension of the array X. LDX >= max(1,N). -C -C RCOND (output) DOUBLE PRECISION -C If JOB = 'A', the estimate of the reciprocal condition -C number of the Riccati equation. -C -C FERR (output) DOUBLE PRECISION -C If JOB = 'A', the estimated forward error bound for the -C solution X. If XTRUE is the true solution, FERR bounds the -C magnitude of the largest entry in (X - XTRUE) divided by -C the magnitude of the largest entry in X. -C -C WR (output) DOUBLE PRECISION array, dimension (N) -C WI (output) DOUBLE PRECISION array, dimension (N) -C If JOB = 'A' and TRANA = 'N', WR and WI contain the real -C and imaginary parts, respectively, of the eigenvalues of -C the matrix A - G*X, i.e., the closed-loop system poles. -C If JOB = 'A' and TRANA = 'T' or 'C', WR and WI contain the -C real and imaginary parts, respectively, of the eigenvalues -C of the matrix A - X*G, i.e., the closed-loop system poles. -C If JOB = 'X', these arrays are not referenced. -C -C Workspace -C -C IWORK INTEGER array, dimension (LIWORK), where -C LIWORK >= 2*N, if JOB = 'X'; -C LIWORK >= max(2*N,N*N), if JOB = 'A'. -C -C DWORK DOUBLE PRECISION array, dimension (LDWORK) -C On exit, if INFO = 0 or INFO = 2, DWORK(1) contains the -C optimal value of LDWORK. If JOB = 'A', then DWORK(2:N*N+1) -C and DWORK(N*N+2:2*N*N+1) contain a real Schur form of the -C closed-loop system matrix, Ac = A - G*X (if TRANA = 'N') -C or Ac = A - X*G (if TRANA = 'T' or 'C'), and the -C orthogonal matrix which reduced Ac to real Schur form, -C respectively. -C -C LDWORK INTEGER -C The dimension of the array DWORK. -C LDWORK >= 4*N*N + 8*N + 1, if JOB = 'X'; -C LDWORK >= max( 4*N*N + 8*N, 6*N*N ) + 1, if JOB = 'A'. -C For good performance, LDWORK should be larger, e.g., -C LDWORK >= 4*N*N + 6*N +( 2*N+1 )*NB, if JOB = 'X', -C where NB is the optimal blocksize. -C -C Error indicator -C -C INFO INTEGER -C = 0: successful exit; -C < 0: if INFO = -i, the i-th argument had an illegal -C value; -C = 1: the Hamiltonian matrix has eigenvalues on the -C imaginary axis, so the solution and error bounds -C could not be computed; -C = 2: the iteration for the matrix sign function failed to -C converge after 50 iterations, but an approximate -C solution and error bounds (if JOB = 'A') have been -C computed; -C = 3: the system of linear equations for the solution is -C singular to working precision, so the solution and -C error bounds could not be computed; -C = 4: the matrix A-G*X (or A-X*G) cannot be reduced to -C Schur canonical form and condition number estimate -C and forward error estimate have not been computed. -C -C METHOD -C -C The Riccati equation is solved by the matrix sign function -C approach [1], [2], implementing a scaling which enhances the -C numerical stability [4]. -C -C REFERENCES -C -C [1] Bai, Z., Demmel, J., Dongarra, J., Petitet, A., Robinson, H., -C and Stanley, K. -C The spectral decomposition of nonsymmetric matrices on -C distributed memory parallel computers. -C SIAM J. Sci. Comput., vol. 18, pp. 1446-1461, 1997. -C -C [2] Byers, R., He, C., and Mehrmann, V. -C The matrix sign function method and the computation of -C invariant subspaces. -C SIAM J. Matrix Anal. Appl., vol. 18, pp. 615-632, 1997. -C -C [3] Higham, N.J. -C Perturbation theory and backward error for AX-XB=C. -C BIT, vol. 33, pp. 124-136, 1993. -C -C [4] Petkov, P.Hr., Konstantinov, M.M., and Mehrmann, V., -C DGRSVX and DMSRIC: Fortran 77 subroutines for solving -C continuous-time matrix algebraic Riccati equations with -C condition and accuracy estimates. -C Preprint SFB393/98-16, Fak. f. Mathematik, Technical -C University Chemnitz, May 1998. -C -C NUMERICAL ASPECTS -C -C The solution accuracy can be controlled by the output parameter -C FERR. -C -C FURTHER COMMENTS -C -C The condition number of the Riccati equation is estimated as -C -C cond = ( norm(Theta)*norm(A) + norm(inv(Omega))*norm(Q) + -C norm(Pi)*norm(G) ) / norm(X), -C -C where Omega, Theta and Pi are linear operators defined by -C -C Omega(W) = op(Ac)'*W + W*op(Ac), -C Theta(W) = inv(Omega(op(W)'*X + X*op(W))), -C Pi(W) = inv(Omega(X*W*X)), -C -C and the matrix Ac (the closed-loop system matrix) is given by -C Ac = A - G*X, if TRANA = 'N', or -C Ac = A - X*G, if TRANA = 'T' or 'C'. -C -C The program estimates the quantities -C -C sep(op(Ac),-op(Ac)') = 1 / norm(inv(Omega)), -C -C norm(Theta) and norm(Pi) using 1-norm condition estimator. -C -C The forward error bound is estimated using a practical error bound -C similar to the one proposed in [3]. -C -C CONTRIBUTOR -C -C P. Petkov, Tech. University of Sofia, March 2000. -C -C REVISIONS -C -C V. Sima, Katholieke Univ. Leuven, Belgium, June 2000. -C -C KEYWORDS -C -C Algebraic Riccati equation, continuous-time system, -C optimal control, optimal regulator. -C -C ****************************************************************** -C -C .. Parameters .. - INTEGER MAXIT - PARAMETER ( MAXIT = 50 ) - DOUBLE PRECISION ZERO, HALF, ONE, TWO, TEN - PARAMETER ( ZERO = 0.0D+0, HALF = 0.5D+0, ONE = 1.0D+0, - $ TWO = 2.0D+0, TEN = 10.0D+0 ) -C .. -C .. Scalar Arguments .. - CHARACTER JOB, TRANA, UPLO - INTEGER INFO, LDA, LDG, LDQ, LDWORK, LDX, N - DOUBLE PRECISION FERR, RCOND -C .. -C .. Array Arguments .. - INTEGER IWORK( * ) - DOUBLE PRECISION A( LDA, * ), DWORK( * ), G( LDG, * ), - $ Q( LDQ, * ), WI( * ), WR( * ), X( LDX, * ) -C .. -C .. Local Scalars .. - LOGICAL ALL, LOWER, NOTRNA - CHARACTER EQUED, LOUP - INTEGER I, IAF, IB, IBR, IC, IFR, IJ, IJ1, IJ2, INFO2, - $ INI, IR, ISCL, ISV, IT, ITAU, ITER, IU, IWRK, - $ J, JI, LWAMAX, MINWRK, N2, SDIM - DOUBLE PRECISION CONV, GNORM2, EPS, HNORM, HINNRM, QNORM2, - $ SCALE, SEP, TEMP, TOL -C .. -C .. Local Arrays .. - LOGICAL BWORK( 1 ) -C .. -C .. External Functions .. - LOGICAL LSAME, SELECT - INTEGER ILAENV - DOUBLE PRECISION DLAMCH, DLANSY - EXTERNAL DLAMCH, DLANSY, ILAENV, LSAME, SELECT -C .. -C .. External Subroutines .. - EXTERNAL DCOPY, DGEES, DGEQP3, DGESVX, DLACPY, DLASCL, - $ DLASET, DORMQR, DSCAL, DSWAP, DSYMM, DSYTRF, - $ DSYTRI, MA02AD, MA02ED, SB02QD, XERBLA -C .. -C .. Intrinsic Functions .. - INTRINSIC DBLE, INT, MAX, SQRT -C .. -C .. Executable Statements .. -C -C Decode and Test input parameters. -C - ALL = LSAME( JOB, 'A' ) - NOTRNA = LSAME( TRANA, 'N' ) - LOWER = LSAME( UPLO, 'L' ) -C - INFO = 0 - IF( .NOT.ALL .AND. .NOT.LSAME( JOB, 'X' ) ) THEN - INFO = -1 - ELSE IF( .NOT.LSAME( TRANA, 'T' ) .AND. - $ .NOT.LSAME( TRANA, 'C' ) .AND. .NOT.NOTRNA ) THEN - INFO = -2 - ELSE IF( .NOT.LOWER .AND. .NOT.LSAME( UPLO, 'U' ) ) THEN - INFO = -3 - ELSE IF( N.LT.0 ) THEN - INFO = -4 - ELSE IF( LDA.LT.MAX( 1, N ) ) THEN - INFO = -6 - ELSE IF( LDG.LT.MAX( 1, N ) ) THEN - INFO = -8 - ELSE IF( LDQ.LT.MAX( 1, N ) ) THEN - INFO = -10 - ELSE IF( LDX.LT.MAX( 1, N ) ) THEN - INFO = -12 - ELSE -C -C Compute workspace. -C - IF( ALL ) THEN - MINWRK = MAX( 4*N*N + 8*N + 1, 6*N*N ) - ELSE - MINWRK = 4*N*N + 8*N + 1 - END IF - IF( LDWORK.LT.MINWRK ) THEN - INFO = -19 - END IF - END IF - IF( INFO.NE.0 ) THEN - CALL XERBLA( 'SB02PD', -INFO ) - RETURN - END IF -C -C Quick return if possible. -C - IF( N.EQ.0 ) THEN - IF( ALL ) THEN - RCOND = ONE - FERR = ZERO - END IF - DWORK(1) = ONE - RETURN - END IF -C -C Set tol. -C - EPS = DLAMCH( 'P' ) - TOL = TEN*DBLE( N )*EPS -C -C Compute the square-roots of the norms of the matrices Q and G . -C - QNORM2 = SQRT( DLANSY( '1', UPLO, N, Q, LDQ, DWORK ) ) - GNORM2 = SQRT( DLANSY( '1', UPLO, N, G, LDG, DWORK ) ) -C - N2 = 2*N -C -C Construct the lower (if UPLO = 'L') or upper (if UPLO = 'U') -C triangle of the symmetric block-permuted Hamiltonian matrix. -C During iteration, both the current iterate corresponding to the -C Hamiltonian matrix, and its inverse are needed. To reduce the -C workspace length, the transpose of the triangle specified by UPLO -C of the current iterate H is saved in the opposite triangle, -C suitably shifted with one column, and then the inverse of H -C overwrites H. The triangles of the saved iterate and its inverse -C are stored together in an 2*N-by-(2*N+1) matrix. For instance, if -C UPLO = 'U', then the upper triangle is built starting from the -C location 2*N+1 of the array DWORK, so that its transpose can be -C stored in the lower triangle of DWORK. -C Workspace: need 4*N*N, if UPLO = 'L'; -C 4*N*N + 2*N, if UPLO = 'U'. -C - IF ( LOWER ) THEN - INI = 0 - ISV = N2 - LOUP = 'U' -C - DO 40 J = 1, N - IJ = ( J - 1 )*N2 + J -C - DO 10 I = J, N - DWORK(IJ) = -Q(I,J) - IJ = IJ + 1 - 10 CONTINUE -C - IF( NOTRNA ) THEN -C - DO 20 I = 1, N - DWORK( IJ ) = -A( I, J ) - IJ = IJ + 1 - 20 CONTINUE -C - ELSE -C - DO 30 I = 1, N - DWORK( IJ ) = -A( J, I ) - IJ = IJ + 1 - 30 CONTINUE -C - END IF - 40 CONTINUE -C - DO 60 J = 1, N - IJ = ( N + J - 1 )*N2 + N + J -C - DO 50 I = J, N - DWORK( IJ ) = G( I, J ) - IJ = IJ + 1 - 50 CONTINUE -C - 60 CONTINUE -C - ELSE - INI = N2 - ISV = 0 - LOUP = 'L' -C - DO 80 J = 1, N - IJ = J*N2 + 1 -C - DO 70 I = 1, J - DWORK(IJ) = -Q(I,J) - IJ = IJ + 1 - 70 CONTINUE -C - 80 CONTINUE -C - DO 120 J = 1, N - IJ = ( N + J )*N2 + 1 -C - IF( NOTRNA ) THEN -C - DO 90 I = 1, N - DWORK( IJ ) = -A( J, I ) - IJ = IJ + 1 - 90 CONTINUE -C - ELSE -C - DO 100 I = 1, N - DWORK( IJ ) = -A( I, J ) - IJ = IJ + 1 - 100 CONTINUE -C - END IF -C - DO 110 I = 1, J - DWORK( IJ ) = G( I, J ) - IJ = IJ + 1 - 110 CONTINUE -C - 120 CONTINUE -C - END IF -C -C Block-scaling. -C - ISCL = 0 - IF( QNORM2.GT.GNORM2 .AND. GNORM2.GT.ZERO ) THEN - CALL DLASCL( UPLO, 0, 0, QNORM2, GNORM2, N, N, DWORK( INI+1 ), - $ N2, INFO2 ) - CALL DLASCL( UPLO, 0, 0, GNORM2, QNORM2, N, N, - $ DWORK( N2*N+N+INI+1 ), N2, INFO2 ) - ISCL = 1 - END IF -C -C Workspace usage. -C - ITAU = N2*N2 - IWRK = ITAU + N2 -C - LWAMAX = N2*ILAENV( 1, 'DSYTRF', UPLO, N2, -1, -1, -1 ) -C -C Compute the matrix sign function. -C - DO 230 ITER = 1, MAXIT -C -C Save the transpose of the corresponding triangle of the -C current iterate in the free locations of the shifted opposite -C triangle. -C Workspace: need 4*N*N + 2*N. -C - IF( LOWER ) THEN -C - DO 130 I = 1, N2 - CALL DCOPY( I, DWORK( I ), N2, DWORK( I*N2+1 ), 1 ) - 130 CONTINUE -C - ELSE -C - DO 140 I = 1, N2 - CALL DCOPY( I, DWORK( I*N2+1 ), 1, DWORK( I ), N2 ) - 140 CONTINUE -C - END IF -C -C Store the norm of the Hamiltonian matrix. -C - HNORM = DLANSY( 'F', UPLO, N2, DWORK( INI+1 ), N2, DWORK ) -C -C Compute the inverse of the block-permuted Hamiltonian matrix. -C Workspace: need 4*N*N + 2*N + 1; -C prefer 4*N*N + 2*N + 2*N*NB. -C - CALL DSYTRF( UPLO, N2, DWORK( INI+1 ), N2, IWORK, - $ DWORK( IWRK+1 ), LDWORK-IWRK, INFO2 ) - IF( INFO2.GT.0 ) THEN - INFO = 1 - RETURN - END IF -C -C Workspace: need 4*N*N + 4*N. -C - CALL DSYTRI( UPLO, N2, DWORK( INI+1 ), N2, IWORK, - $ DWORK( IWRK+1 ), INFO2 ) -C -C Block-permutation of the inverse matrix. -C - IF( LOWER ) THEN -C - DO 160 J = 1, N - IJ2 = ( N + J - 1 )*N2 + N + J -C - DO 150 IJ1 = ( J - 1 )*N2 + J, ( J - 1 )*N2 + N - TEMP = DWORK( IJ1 ) - DWORK( IJ1 ) = -DWORK( IJ2 ) - DWORK( IJ2 ) = -TEMP - IJ2 = IJ2 + 1 - 150 CONTINUE -C - CALL DSWAP( J-1, DWORK( N+J ), N2, DWORK( (J-1)*N2+N+1 ), - $ 1 ) - 160 CONTINUE -C - ELSE -C - DO 180 J = 1, N - IJ2 = ( N + J )*N2 + N + 1 -C - DO 170 IJ1 = J*N2 + 1, J*N2 + J - TEMP = DWORK( IJ1 ) - DWORK( IJ1 ) = -DWORK( IJ2 ) - DWORK( IJ2 ) = -TEMP - IJ2 = IJ2 + 1 - 170 CONTINUE -C - CALL DSWAP( J-1, DWORK( (N+1)*N2+J ), N2, - $ DWORK( (N+J)*N2+1 ), 1 ) - 180 CONTINUE -C - END IF -C -C Scale the Hamiltonian matrix and its inverse and compute -C the next iterate. -C - HINNRM = DLANSY( 'F', UPLO, N2, DWORK( INI+1 ), N2, DWORK ) - SCALE = SQRT( HINNRM / HNORM ) -C - IF( LOWER ) THEN -C - DO 200 J = 1, N2 - JI = ( J - 1 )*N2 + J -C - DO 190 IJ = JI, J*N2 - JI = JI + N2 - DWORK( IJ ) = ( DWORK( IJ ) / SCALE + - $ DWORK( JI )*SCALE ) / TWO - DWORK( JI ) = DWORK( JI ) - DWORK( IJ ) - 190 CONTINUE -C - 200 CONTINUE -C - ELSE -C - DO 220 J = 1, N2 - JI = J -C - DO 210 IJ = J*N2 + 1, J*N2 + J - DWORK( IJ ) = ( DWORK( IJ ) / SCALE + - $ DWORK( JI )*SCALE ) / TWO - DWORK( JI ) = DWORK( JI ) - DWORK( IJ ) - JI = JI + N2 - 210 CONTINUE -C - 220 CONTINUE -C - END IF -C -C Test for convergence. -C - CONV = DLANSY( 'F', LOUP, N2, DWORK( ISV+1 ), N2, DWORK ) - IF( CONV.LE.TOL*HNORM ) GO TO 240 - 230 CONTINUE -C -C No convergence after MAXIT iterations, but an approximate solution -C has been found. -C - INFO = 2 -C - 240 CONTINUE -C -C If UPLO = 'U', shift the upper triangle one column to the left. -C - IF( .NOT.LOWER ) - $ CALL DLACPY( 'U', N2, N2, DWORK( INI+1 ), N2, DWORK, N2 ) -C -C Divide the triangle elements by -2 and then fill-in the other -C triangle by symmetry. -C - IF( LOWER ) THEN -C - DO 250 I = 1, N2 - CALL DSCAL( N2-I+1, -HALF, DWORK( (I-1)*N2+I ), 1 ) - 250 CONTINUE -C - ELSE -C - DO 260 I = 1, N2 - CALL DSCAL( I, -HALF, DWORK( (I-1)*N2+1 ), 1 ) - 260 CONTINUE -C - END IF - CALL MA02ED( UPLO, N2, DWORK, N2 ) -C -C Back block-permutation. -C - DO 280 J = 1, N2 -C - DO 270 I = ( J - 1 )*N2 + 1, ( J - 1 )*N2 + N - TEMP = DWORK( I ) - DWORK( I ) = -DWORK( I+N ) - DWORK( I+N ) = TEMP - 270 CONTINUE -C - 280 CONTINUE -C -C Compute the QR decomposition of the projector onto the stable -C invariant subspace. -C Workspace: need 4*N*N + 8*N + 1. -C prefer 4*N*N + 6*N + ( 2*N+1 )*NB. -C - DO 290 I = 1, N2 - IWORK( I ) = 0 - DWORK( ( I-1 )*N2 + I ) = DWORK( ( I-1 )*N2 + I ) + HALF - 290 CONTINUE -C - CALL DGEQP3( N2, N2, DWORK, N2, IWORK, DWORK( ITAU+1 ), - $ DWORK( IWRK+1 ), LDWORK-IWRK, INFO2 ) - LWAMAX = MAX( INT( DWORK( IWRK+1 ) ), LWAMAX ) -C -C Accumulate the orthogonal transformations. Note that only the -C first N columns of the array DWORK, returned by DGEQP3, are -C needed, so that the last N columns of DWORK are used to get the -C orthogonal basis for the stable invariant subspace. -C Workspace: need 4*N*N + 3*N. -C prefer 4*N*N + 2*N + N*NB. -C - IB = N*N - IAF = N2*N - CALL DLASET( 'F', N2, N, ZERO, ONE, DWORK( IAF+1 ), N2 ) - CALL DORMQR( 'L', 'N', N2, N, N, DWORK, N2, DWORK( ITAU+1 ), - $ DWORK( IAF+1 ), N2, DWORK( IWRK+1 ), LDWORK-IWRK, - $ INFO2 ) - LWAMAX = IWRK + MAX( INT( DWORK( IWRK+1 ) ), LWAMAX ) -C -C Store the matrices V11 and V21' . -C - CALL DLACPY( 'F', N, N, DWORK( IAF+1 ), N2, DWORK, N ) - CALL MA02AD( 'F', N, N, DWORK( IAF+N+1 ), N2, DWORK( IB+1 ), N ) -C - IR = IAF + IB - IC = IR + N - IFR = IC + N - IBR = IFR + N - IWRK = IBR + N -C -C Compute the solution matrix X . -C Workspace: need 3*N*N + 8*N. -C - CALL DGESVX( 'E', 'T', N, N, DWORK, N, DWORK( IAF+1 ), N, - $ IWORK, EQUED, DWORK( IR+1 ), DWORK( IC+1 ), - $ DWORK( IB+1 ), N, X, LDX, RCOND, DWORK( IFR+1 ), - $ DWORK( IBR+1 ), DWORK( IWRK+1 ), IWORK( N+1 ), - $ INFO2 ) - IF( INFO2.GT.0 ) THEN - INFO = 3 - RETURN - END IF -C -C Symmetrize the solution. -C - DO 310 I = 1, N - 1 -C - DO 300 J = I + 1, N - TEMP = ( X( I, J ) + X( J, I ) ) / TWO - X( I, J ) = TEMP - X( J, I ) = TEMP - 300 CONTINUE -C - 310 CONTINUE -C -C Undo scaling for the solution matrix. -C - IF( ISCL.EQ.1 ) THEN - CALL DLASCL( 'G', 0, 0, GNORM2, QNORM2, N, N, X, LDX, INFO2 ) - END IF -C - IF( ALL ) THEN -C -C Compute the estimates of the reciprocal condition number and -C error bound. -C Workspace usage. -C - IT = 1 - IU = IT + N*N - IWRK = IU + N*N -C - CALL DLACPY( 'Full', N, N, A, LDA, DWORK( IT+1 ), N ) - IF( NOTRNA ) THEN -C -C Compute Ac = A-G*X . -C - CALL DSYMM( 'L', UPLO, N, N, -ONE, G, LDG, X, LDX, ONE, - $ DWORK( IT+1 ), N ) - ELSE -C -C Compute Ac = A-X*G . -C - CALL DSYMM( 'R', UPLO, N, N, -ONE, G, LDG, X, LDX, ONE, - $ DWORK( IT+1 ), N ) - END IF -C -C Compute the Schur factorization of Ac . -C Workspace: need 2*N*N + 5*N + 1; -C prefer larger. -C - CALL DGEES( 'V', 'N', SELECT, N, DWORK( IT+1 ), N, SDIM, WR, - $ WI, DWORK( IU+1 ), N, DWORK( IWRK+1 ), LDWORK-IWRK, - $ BWORK, INFO2 ) - IF( INFO2.GT.0 ) THEN - INFO = 4 - RETURN - END IF - LWAMAX = IWRK + MAX( INT( DWORK( IWRK+1 ) ), LWAMAX ) -C -C Estimate the reciprocal condition number and the forward error. -C Workspace: need 6*N*N + 1; -C prefer larger. -C - CALL SB02QD( 'B', 'F', TRANA, UPLO, 'O', N, A, LDA, - $ DWORK( IT+1 ), N, DWORK( IU+1 ), N, G, LDG, Q, - $ LDQ, X, LDX, SEP, RCOND, FERR, IWORK, - $ DWORK( IWRK+1 ), LDWORK-IWRK, INFO2 ) - LWAMAX = IWRK + MAX( INT( DWORK( IWRK+1 ) ), LWAMAX ) - END IF -C - DWORK( 1 ) = DBLE( LWAMAX ) - RETURN -C *** Last line of SB02PD - END diff --git a/mex/sources/libslicot/SB02QD.f b/mex/sources/libslicot/SB02QD.f deleted file mode 100644 index 8ce39d1b3..000000000 --- a/mex/sources/libslicot/SB02QD.f +++ /dev/null @@ -1,804 +0,0 @@ - SUBROUTINE SB02QD( JOB, FACT, TRANA, UPLO, LYAPUN, N, A, LDA, T, - $ LDT, U, LDU, G, LDG, Q, LDQ, X, LDX, SEP, - $ RCOND, FERR, IWORK, DWORK, LDWORK, INFO ) -C -C SLICOT RELEASE 5.0. -C -C Copyright (c) 2002-2009 NICONET e.V. -C -C This program is free software: you can redistribute it and/or -C modify it under the terms of the GNU General Public License as -C published by the Free Software Foundation, either version 2 of -C the License, or (at your option) any later version. -C -C This program is distributed in the hope that it will be useful, -C but WITHOUT ANY WARRANTY; without even the implied warranty of -C MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the -C GNU General Public License for more details. -C -C You should have received a copy of the GNU General Public License -C along with this program. If not, see -C . -C -C PURPOSE -C -C To estimate the conditioning and compute an error bound on the -C solution of the real continuous-time matrix algebraic Riccati -C equation -C -C op(A)'*X + X*op(A) + Q - X*G*X = 0, (1) -C -C where op(A) = A or A' (A**T) and Q, G are symmetric (Q = Q**T, -C G = G**T). The matrices A, Q and G are N-by-N and the solution X -C is N-by-N. -C -C ARGUMENTS -C -C Mode Parameters -C -C JOB CHARACTER*1 -C Specifies the computation to be performed, as follows: -C = 'C': Compute the reciprocal condition number only; -C = 'E': Compute the error bound only; -C = 'B': Compute both the reciprocal condition number and -C the error bound. -C -C FACT CHARACTER*1 -C Specifies whether or not the real Schur factorization of -C the matrix Ac = A - G*X (if TRANA = 'N') or Ac = A - X*G -C (if TRANA = 'T' or 'C') is supplied on entry, as follows: -C = 'F': On entry, T and U (if LYAPUN = 'O') contain the -C factors from the real Schur factorization of the -C matrix Ac; -C = 'N': The Schur factorization of Ac will be computed -C and the factors will be stored in T and U (if -C LYAPUN = 'O'). -C -C TRANA CHARACTER*1 -C Specifies the form of op(A) to be used, as follows: -C = 'N': op(A) = A (No transpose); -C = 'T': op(A) = A**T (Transpose); -C = 'C': op(A) = A**T (Conjugate transpose = Transpose). -C -C UPLO CHARACTER*1 -C Specifies which part of the symmetric matrices Q and G is -C to be used, as follows: -C = 'U': Upper triangular part; -C = 'L': Lower triangular part. -C -C LYAPUN CHARACTER*1 -C Specifies whether or not the original Lyapunov equations -C should be solved in the iterative estimation process, -C as follows: -C = 'O': Solve the original Lyapunov equations, updating -C the right-hand sides and solutions with the -C matrix U, e.g., RHS <-- U'*RHS*U; -C = 'R': Solve reduced Lyapunov equations only, without -C updating the right-hand sides and solutions. -C -C Input/Output Parameters -C -C N (input) INTEGER -C The order of the matrices A, X, Q, and G. N >= 0. -C -C A (input) DOUBLE PRECISION array, dimension (LDA,N) -C If FACT = 'N' or LYAPUN = 'O', the leading N-by-N part of -C this array must contain the matrix A. -C If FACT = 'F' and LYAPUN = 'R', A is not referenced. -C -C LDA INTEGER -C The leading dimension of the array A. -C LDA >= max(1,N), if FACT = 'N' or LYAPUN = 'O'; -C LDA >= 1, if FACT = 'F' and LYAPUN = 'R'. -C -C T (input or output) DOUBLE PRECISION array, dimension -C (LDT,N) -C If FACT = 'F', then T is an input argument and on entry, -C the leading N-by-N upper Hessenberg part of this array -C must contain the upper quasi-triangular matrix T in Schur -C canonical form from a Schur factorization of Ac (see -C argument FACT). -C If FACT = 'N', then T is an output argument and on exit, -C if INFO = 0 or INFO = N+1, the leading N-by-N upper -C Hessenberg part of this array contains the upper quasi- -C triangular matrix T in Schur canonical form from a Schur -C factorization of Ac (see argument FACT). -C -C LDT INTEGER -C The leading dimension of the array T. LDT >= max(1,N). -C -C U (input or output) DOUBLE PRECISION array, dimension -C (LDU,N) -C If LYAPUN = 'O' and FACT = 'F', then U is an input -C argument and on entry, the leading N-by-N part of this -C array must contain the orthogonal matrix U from a real -C Schur factorization of Ac (see argument FACT). -C If LYAPUN = 'O' and FACT = 'N', then U is an output -C argument and on exit, if INFO = 0 or INFO = N+1, it -C contains the orthogonal N-by-N matrix from a real Schur -C factorization of Ac (see argument FACT). -C If LYAPUN = 'R', the array U is not referenced. -C -C LDU INTEGER -C The leading dimension of the array U. -C LDU >= 1, if LYAPUN = 'R'; -C LDU >= MAX(1,N), if LYAPUN = 'O'. -C -C G (input) DOUBLE PRECISION array, dimension (LDG,N) -C If UPLO = 'U', the leading N-by-N upper triangular part of -C this array must contain the upper triangular part of the -C matrix G. -C If UPLO = 'L', the leading N-by-N lower triangular part of -C this array must contain the lower triangular part of the -C matrix G. _ -C Matrix G should correspond to G in the "reduced" Riccati -C equation (with matrix T, instead of A), if LYAPUN = 'R'. -C See METHOD. -C -C LDG INTEGER -C The leading dimension of the array G. LDG >= max(1,N). -C -C Q (input) DOUBLE PRECISION array, dimension (LDQ,N) -C If UPLO = 'U', the leading N-by-N upper triangular part of -C this array must contain the upper triangular part of the -C matrix Q. -C If UPLO = 'L', the leading N-by-N lower triangular part of -C this array must contain the lower triangular part of the -C matrix Q. _ -C Matrix Q should correspond to Q in the "reduced" Riccati -C equation (with matrix T, instead of A), if LYAPUN = 'R'. -C See METHOD. -C -C LDQ INTEGER -C The leading dimension of the array Q. LDQ >= max(1,N). -C -C X (input) DOUBLE PRECISION array, dimension (LDX,N) -C The leading N-by-N part of this array must contain the -C symmetric solution matrix of the original Riccati -C equation (with matrix A), if LYAPUN = 'O', or of the -C "reduced" Riccati equation (with matrix T), if -C LYAPUN = 'R'. See METHOD. -C -C LDX INTEGER -C The leading dimension of the array X. LDX >= max(1,N). -C -C SEP (output) DOUBLE PRECISION -C If JOB = 'C' or JOB = 'B', the estimated quantity -C sep(op(Ac),-op(Ac)'). -C If N = 0, or X = 0, or JOB = 'E', SEP is not referenced. -C -C RCOND (output) DOUBLE PRECISION -C If JOB = 'C' or JOB = 'B', an estimate of the reciprocal -C condition number of the continuous-time Riccati equation. -C If N = 0 or X = 0, RCOND is set to 1 or 0, respectively. -C If JOB = 'E', RCOND is not referenced. -C -C FERR (output) DOUBLE PRECISION -C If JOB = 'E' or JOB = 'B', an estimated forward error -C bound for the solution X. If XTRUE is the true solution, -C FERR bounds the magnitude of the largest entry in -C (X - XTRUE) divided by the magnitude of the largest entry -C in X. -C If N = 0 or X = 0, FERR is set to 0. -C If JOB = 'C', FERR is not referenced. -C -C Workspace -C -C IWORK INTEGER array, dimension (N*N) -C -C DWORK DOUBLE PRECISION array, dimension (LDWORK) -C On exit, if INFO = 0 or INFO = N+1, DWORK(1) returns the -C optimal value of LDWORK. -C -C LDWORK INTEGER -C The dimension of the array DWORK. -C Let LWA = N*N, if LYAPUN = 'O' and JOB = 'E' or 'B'; -C LWA = 0, otherwise. -C If FACT = 'N', then -C LDWORK = MAX(1, 5*N, 2*N*N), if JOB = 'C'; -C LDWORK = MAX(1, LWA + 5*N, 4*N*N ), if JOB = 'E', 'B'. -C If FACT = 'F', then -C LDWORK = MAX(1, 2*N*N), if JOB = 'C'; -C LDWORK = MAX(1, 4*N*N ), if JOB = 'E' or 'B'. -C For good performance, LDWORK must generally be larger. -C -C Error indicator -C -C INFO INTEGER -C = 0: successful exit; -C < 0: if INFO = -i, the i-th argument had an illegal -C value; -C > 0: if INFO = i, i <= N, the QR algorithm failed to -C complete the reduction of the matrix Ac to Schur -C canonical form (see LAPACK Library routine DGEES); -C on exit, the matrix T(i+1:N,i+1:N) contains the -C partially converged Schur form, and DWORK(i+1:N) and -C DWORK(N+i+1:2*N) contain the real and imaginary -C parts, respectively, of the converged eigenvalues; -C this error is unlikely to appear; -C = N+1: if the matrices T and -T' have common or very -C close eigenvalues; perturbed values were used to -C solve Lyapunov equations, but the matrix T, if given -C (for FACT = 'F'), is unchanged. -C -C METHOD -C -C The condition number of the Riccati equation is estimated as -C -C cond = ( norm(Theta)*norm(A) + norm(inv(Omega))*norm(Q) + -C norm(Pi)*norm(G) ) / norm(X), -C -C where Omega, Theta and Pi are linear operators defined by -C -C Omega(W) = op(Ac)'*W + W*op(Ac), -C Theta(W) = inv(Omega(op(W)'*X + X*op(W))), -C Pi(W) = inv(Omega(X*W*X)), -C -C and Ac = A - G*X (if TRANA = 'N') or Ac = A - X*G (if TRANA = 'T' -C or 'C'). Note that the Riccati equation (1) is equivalent to -C _ _ _ _ _ _ -C op(T)'*X + X*op(T) + Q + X*G*X = 0, (2) -C _ _ _ -C where X = U'*X*U, Q = U'*Q*U, and G = U'*G*U, with U the -C orthogonal matrix reducing Ac to a real Schur form, T = U'*Ac*U. -C -C The routine estimates the quantities -C -C sep(op(Ac),-op(Ac)') = 1 / norm(inv(Omega)), -C -C norm(Theta) and norm(Pi) using 1-norm condition estimator. -C -C The forward error bound is estimated using a practical error bound -C similar to the one proposed in [2]. -C -C REFERENCES -C -C [1] Ghavimi, A.R. and Laub, A.J. -C Backward error, sensitivity, and refinement of computed -C solutions of algebraic Riccati equations. -C Numerical Linear Algebra with Applications, vol. 2, pp. 29-49, -C 1995. -C -C [2] Higham, N.J. -C Perturbation theory and backward error for AX-XB=C. -C BIT, vol. 33, pp. 124-136, 1993. -C -C [3] Petkov, P.Hr., Konstantinov, M.M., and Mehrmann, V. -C DGRSVX and DMSRIC: Fortran 77 subroutines for solving -C continuous-time matrix algebraic Riccati equations with -C condition and accuracy estimates. -C Preprint SFB393/98-16, Fak. f. Mathematik, Tech. Univ. -C Chemnitz, May 1998. -C -C NUMERICAL ASPECTS -C 3 -C The algorithm requires 0(N ) operations. -C The accuracy of the estimates obtained depends on the solution -C accuracy and on the properties of the 1-norm estimator. -C -C FURTHER COMMENTS -C -C The option LYAPUN = 'R' may occasionally produce slightly worse -C or better estimates, and it is much faster than the option 'O'. -C When SEP is computed and it is zero, the routine returns -C immediately, with RCOND and FERR (if requested) set to 0 and 1, -C respectively. In this case, the equation is singular. -C -C CONTRIBUTOR -C -C P.Hr. Petkov, Technical University of Sofia, December 1998. -C V. Sima, Katholieke Univ. Leuven, Belgium, February 1999. -C -C REVISIONS -C -C V. Sima, Research Institute for Informatics, Bucharest, Oct. 2004. -C -C KEYWORDS -C -C Conditioning, error estimates, orthogonal transformation, -C real Schur form, Riccati equation. -C -C ****************************************************************** -C -C .. Parameters .. - DOUBLE PRECISION ZERO, ONE, TWO, FOUR, HALF - PARAMETER ( ZERO = 0.0D+0, ONE = 1.0D+0, TWO = 2.0D+0, - $ FOUR = 4.0D+0, HALF = 0.5D+0 ) -C .. -C .. Scalar Arguments .. - CHARACTER FACT, JOB, LYAPUN, TRANA, UPLO - INTEGER INFO, LDA, LDG, LDQ, LDT, LDU, LDWORK, LDX, N - DOUBLE PRECISION FERR, RCOND, SEP -C .. -C .. Array Arguments .. - INTEGER IWORK( * ) - DOUBLE PRECISION A( LDA, * ), DWORK( * ), G( LDG, * ), - $ Q( LDQ, * ), T( LDT, * ), U( LDU, * ), - $ X( LDX, * ) -C .. -C .. Local Scalars .. - LOGICAL JOBB, JOBC, JOBE, LOWER, NEEDAC, NOFACT, - $ NOTRNA, UPDATE - CHARACTER LOUP, SJOB, TRANAT - INTEGER I, IABS, INFO2, IRES, ITMP, IXBS, J, JJ, JX, - $ KASE, LDW, LWA, NN, SDIM, WRKOPT - DOUBLE PRECISION ANORM, BIGNUM, DENOM, EPS, EPSN, EST, GNORM, - $ PINORM, QNORM, SCALE, SIG, TEMP, THNORM, TMAX, - $ XANORM, XNORM -C .. -C .. Local Arrays .. - LOGICAL BWORK( 1 ) -C .. -C .. External Functions .. - LOGICAL LSAME, SELECT - DOUBLE PRECISION DLAMCH, DLANGE, DLANHS, DLANSY - EXTERNAL DLAMCH, DLANGE, DLANHS, DLANSY, LSAME, SELECT -C .. -C .. External Subroutines .. - EXTERNAL DAXPY, DCOPY, DGEES, DLACON, DLACPY, DSCAL, - $ DSYMM, DSYR2K, MA02ED, MB01RU, MB01UD, SB03MY, - $ SB03QX, SB03QY, XERBLA -C .. -C .. Intrinsic Functions .. - INTRINSIC ABS, DBLE, INT, MAX, MIN -C .. -C .. Executable Statements .. -C -C Decode and Test input parameters. -C - JOBC = LSAME( JOB, 'C' ) - JOBE = LSAME( JOB, 'E' ) - JOBB = LSAME( JOB, 'B' ) - NOFACT = LSAME( FACT, 'N' ) - NOTRNA = LSAME( TRANA, 'N' ) - LOWER = LSAME( UPLO, 'L' ) - UPDATE = LSAME( LYAPUN, 'O' ) -C - NEEDAC = UPDATE .AND. .NOT.JOBC -C - NN = N*N - IF( NEEDAC ) THEN - LWA = NN - ELSE - LWA = 0 - END IF -C - IF( NOFACT ) THEN - IF( JOBC ) THEN - LDW = MAX( 5*N, 2*NN ) - ELSE - LDW = MAX( LWA + 5*N, 4*NN ) - END IF - ELSE - IF( JOBC ) THEN - LDW = 2*NN - ELSE - LDW = 4*NN - END IF - END IF -C - INFO = 0 - IF( .NOT.( JOBB .OR. JOBC .OR. JOBE ) ) THEN - INFO = -1 - ELSE IF( .NOT.( NOFACT .OR. LSAME( FACT, 'F' ) ) ) THEN - INFO = -2 - ELSE IF( .NOT.( NOTRNA .OR. LSAME( TRANA, 'T' ) .OR. - $ LSAME( TRANA, 'C' ) ) ) THEN - INFO = -3 - ELSE IF( .NOT.( LOWER .OR. LSAME( UPLO, 'U' ) ) ) THEN - INFO = -4 - ELSE IF( .NOT.( UPDATE .OR. LSAME( LYAPUN, 'R' ) ) ) THEN - INFO = -5 - ELSE IF( N.LT.0 ) THEN - INFO = -6 - ELSE IF( LDA.LT.1 .OR. - $ ( LDA.LT.N .AND. ( UPDATE .OR. NOFACT ) ) ) THEN - INFO = -8 - ELSE IF( LDT.LT.MAX( 1, N ) ) THEN - INFO = -10 - ELSE IF( LDU.LT.1 .OR. ( LDU.LT.N .AND. UPDATE ) ) THEN - INFO = -12 - ELSE IF( LDG.LT.MAX( 1, N ) ) THEN - INFO = -14 - ELSE IF( LDQ.LT.MAX( 1, N ) ) THEN - INFO = -16 - ELSE IF( LDX.LT.MAX( 1, N ) ) THEN - INFO = -18 - ELSE IF( LDWORK.LT.MAX( 1, LDW ) ) THEN - INFO = -24 - END IF -C - IF( INFO.NE.0 ) THEN - CALL XERBLA( 'SB02QD', -INFO ) - RETURN - END IF -C -C Quick return if possible. -C - IF( N.EQ.0 ) THEN - IF( .NOT.JOBE ) - $ RCOND = ONE - IF( .NOT.JOBC ) - $ FERR = ZERO - DWORK( 1 ) = ONE - RETURN - END IF -C -C Compute the 1-norm of the matrix X. -C - XNORM = DLANSY( '1-norm', UPLO, N, X, LDX, DWORK ) - IF( XNORM.EQ.ZERO ) THEN -C -C The solution is zero. -C - IF( .NOT.JOBE ) - $ RCOND = ZERO - IF( .NOT.JOBC ) - $ FERR = ZERO - DWORK( 1 ) = DBLE( N ) - RETURN - END IF -C -C Workspace usage. -C - IXBS = 0 - ITMP = IXBS + NN - IABS = ITMP + NN - IRES = IABS + NN -C -C Workspace: LWR, where -C LWR = N*N, if LYAPUN = 'O' and JOB = 'E' or 'B', or -C FACT = 'N', -C LWR = 0, otherwise. -C - IF( NEEDAC .OR. NOFACT ) THEN -C - CALL DLACPY( 'Full', N, N, A, LDA, DWORK, N ) - IF( NOTRNA ) THEN -C -C Compute Ac = A - G*X. -C - CALL DSYMM( 'Left', UPLO, N, N, -ONE, G, LDG, X, LDX, ONE, - $ DWORK, N ) - ELSE -C -C Compute Ac = A - X*G. -C - CALL DSYMM( 'Right', UPLO, N, N, -ONE, G, LDG, X, LDX, ONE, - $ DWORK, N ) - END IF -C - WRKOPT = DBLE( NN ) - IF( NOFACT ) - $ CALL DLACPY( 'Full', N, N, DWORK, N, T, LDT ) - ELSE - WRKOPT = DBLE( N ) - END IF -C - IF( NOFACT ) THEN -C -C Compute the Schur factorization of Ac, Ac = U*T*U'. -C Workspace: need LWA + 5*N; -C prefer larger; -C LWA = N*N, if LYAPUN = 'O' and JOB = 'E' or 'B'; -C LWA = 0, otherwise. -C (Note: Comments in the code beginning "Workspace:" describe the -C minimal amount of real workspace needed at that point in the -C code, as well as the preferred amount for good performance.) -C - IF( UPDATE ) THEN - SJOB = 'V' - ELSE - SJOB = 'N' - END IF - CALL DGEES( SJOB, 'Not ordered', SELECT, N, T, LDT, SDIM, - $ DWORK( LWA+1 ), DWORK( LWA+N+1 ), U, LDU, - $ DWORK( LWA+2*N+1 ), LDWORK-LWA-2*N, BWORK, INFO ) - IF( INFO.GT.0 ) THEN - IF( LWA.GT.0 ) - $ CALL DCOPY( 2*N, DWORK( LWA+1 ), 1, DWORK, 1 ) - RETURN - END IF -C - WRKOPT = MAX( WRKOPT, INT( DWORK( LWA+2*N+1 ) ) + LWA + 2*N ) - END IF - IF( NEEDAC ) - $ CALL DLACPY( 'Full', N, N, DWORK, N, DWORK( IABS+1 ), N ) -C - IF( NOTRNA ) THEN - TRANAT = 'T' - ELSE - TRANAT = 'N' - END IF -C - IF( .NOT.JOBE ) THEN -C -C Estimate sep(op(Ac),-op(Ac)') = sep(op(T),-op(T)') and -C norm(Theta). -C Workspace LWA + 2*N*N. -C - CALL SB03QY( 'Both', TRANA, LYAPUN, N, T, LDT, U, LDU, X, LDX, - $ SEP, THNORM, IWORK, DWORK, LDWORK, INFO ) -C - WRKOPT = MAX( WRKOPT, LWA + 2*NN ) -C -C Return if the equation is singular. -C - IF( SEP.EQ.ZERO ) THEN - RCOND = ZERO - IF( JOBB ) - $ FERR = ONE - DWORK( 1 ) = DBLE( WRKOPT ) - RETURN - END IF -C -C Estimate norm(Pi). -C Workspace LWA + 2*N*N. -C - KASE = 0 -C -C REPEAT - 10 CONTINUE - CALL DLACON( NN, DWORK( ITMP+1 ), DWORK, IWORK, EST, KASE ) - IF( KASE.NE.0 ) THEN -C -C Select the triangular part of symmetric matrix to be used. -C - IF( DLANSY( '1-norm', 'Upper', N, DWORK, N, DWORK( ITMP+1 )) - $ .GE. - $ DLANSY( '1-norm', 'Lower', N, DWORK, N, DWORK( ITMP+1 )) - $ ) THEN - LOUP = 'U' - ELSE - LOUP = 'L' - END IF -C -C Compute RHS = X*W*X. -C - CALL MB01RU( LOUP, 'No Transpose', N, N, ZERO, ONE, DWORK, - $ N, X, LDX, DWORK, N, DWORK( ITMP+1 ), NN, - $ INFO2 ) - CALL DSCAL( N, HALF, DWORK, N+1 ) -C - IF( UPDATE ) THEN -C -C Transform the right-hand side: RHS := U'*RHS*U. -C - CALL MB01RU( LOUP, 'Transpose', N, N, ZERO, ONE, DWORK, - $ N, U, LDU, DWORK, N, DWORK( ITMP+1 ), NN, - $ INFO2 ) - CALL DSCAL( N, HALF, DWORK, N+1 ) - END IF -C -C Fill in the remaining triangle of the symmetric matrix. -C - CALL MA02ED( LOUP, N, DWORK, N ) -C - IF( KASE.EQ.1 ) THEN -C -C Solve op(T)'*Y + Y*op(T) = scale*RHS. -C - CALL SB03MY( TRANA, N, T, LDT, DWORK, N, SCALE, INFO2 ) - ELSE -C -C Solve op(T)*W + W*op(T)' = scale*RHS. -C - CALL SB03MY( TRANAT, N, T, LDT, DWORK, N, SCALE, INFO2 ) - END IF -C - IF( UPDATE ) THEN -C -C Transform back to obtain the solution: Z := U*Z*U', with -C Z = Y or Z = W. -C - CALL MB01RU( LOUP, 'No transpose', N, N, ZERO, ONE, - $ DWORK, N, U, LDU, DWORK, N, DWORK( ITMP+1 ), - $ NN, INFO2 ) - CALL DSCAL( N, HALF, DWORK, N+1 ) -C -C Fill in the remaining triangle of the symmetric matrix. -C - CALL MA02ED( LOUP, N, DWORK, N ) - END IF - GO TO 10 - END IF -C UNTIL KASE = 0 -C - IF( EST.LT.SCALE ) THEN - PINORM = EST / SCALE - ELSE - BIGNUM = ONE / DLAMCH( 'Safe minimum' ) - IF( EST.LT.SCALE*BIGNUM ) THEN - PINORM = EST / SCALE - ELSE - PINORM = BIGNUM - END IF - END IF -C -C Compute the 1-norm of A or T. -C - IF( UPDATE ) THEN - ANORM = DLANGE( '1-norm', N, N, A, LDA, DWORK ) - ELSE - ANORM = DLANHS( '1-norm', N, T, LDT, DWORK ) - END IF -C -C Compute the 1-norms of the matrices Q and G. -C - QNORM = DLANSY( '1-norm', UPLO, N, Q, LDQ, DWORK ) - GNORM = DLANSY( '1-norm', UPLO, N, G, LDG, DWORK ) -C -C Estimate the reciprocal condition number. -C - TMAX = MAX( SEP, XNORM, ANORM, GNORM ) - IF( TMAX.LE.ONE ) THEN - TEMP = SEP*XNORM - DENOM = QNORM + ( SEP*ANORM )*THNORM + - $ ( SEP*GNORM )*PINORM - ELSE - TEMP = ( SEP / TMAX )*( XNORM / TMAX ) - DENOM = ( ( ONE / TMAX )*( QNORM / TMAX ) ) + - $ ( ( SEP / TMAX )*( ANORM / TMAX ) )*THNORM + - $ ( ( SEP / TMAX )*( GNORM / TMAX ) )*PINORM - END IF - IF( TEMP.GE.DENOM ) THEN - RCOND = ONE - ELSE - RCOND = TEMP / DENOM - END IF - END IF -C - IF( .NOT.JOBC ) THEN -C -C Form a triangle of the residual matrix -C R = op(A)'*X + X*op(A) + Q - X*G*X, -C or _ _ _ _ _ _ -C R = op(T)'*X + X*op(T) + Q + X*G*X, -C exploiting the symmetry. -C Workspace 4*N*N. -C - IF( UPDATE ) THEN - CALL DLACPY( UPLO, N, N, Q, LDQ, DWORK( IRES+1 ), N ) - CALL DSYR2K( UPLO, TRANAT, N, N, ONE, A, LDA, X, LDX, ONE, - $ DWORK( IRES+1 ), N ) - SIG = -ONE - ELSE - CALL MB01UD( 'Right', TRANA, N, N, ONE, T, LDT, X, LDX, - $ DWORK( IRES+1 ), N, INFO2 ) - JJ = IRES + 1 - IF( LOWER ) THEN - DO 20 J = 1, N - CALL DAXPY( N-J+1, ONE, DWORK( JJ ), N, DWORK( JJ ), - $ 1 ) - CALL DAXPY( N-J+1, ONE, Q( J, J ), 1, DWORK( JJ ), 1 ) - JJ = JJ + N + 1 - 20 CONTINUE - ELSE - DO 30 J = 1, N - CALL DAXPY( J, ONE, DWORK( IRES+J ), N, DWORK( JJ ), - $ 1 ) - CALL DAXPY( J, ONE, Q( 1, J ), 1, DWORK( JJ ), 1 ) - JJ = JJ + N - 30 CONTINUE - END IF - SIG = ONE - END IF - CALL MB01RU( UPLO, TRANAT, N, N, ONE, SIG, DWORK( IRES+1 ), - $ N, X, LDX, G, LDG, DWORK( ITMP+1 ), NN, INFO2 ) -C -C Get the machine precision. -C - EPS = DLAMCH( 'Epsilon' ) - EPSN = EPS*DBLE( N + 4 ) - TEMP = EPS*FOUR -C -C Add to abs(R) a term that takes account of rounding errors in -C forming R: -C abs(R) := abs(R) + EPS*(4*abs(Q) + (n+4)*(abs(op(Ac))'*abs(X) -C + abs(X)*abs(op(Ac))) + 2*(n+1)*abs(X)*abs(G)*abs(X)), -C or _ _ -C abs(R) := abs(R) + EPS*(4*abs(Q) + (n+4)*(abs(op(T))'*abs(X) -C _ _ _ _ -C + abs(X)*abs(op(T))) + 2*(n+1)*abs(X)*abs(G)*abs(X)), -C where EPS is the machine precision. -C - DO 50 J = 1, N - DO 40 I = 1, N - DWORK( IXBS+(J-1)*N+I ) = ABS( X( I, J ) ) - 40 CONTINUE - 50 CONTINUE -C - IF( LOWER ) THEN - DO 70 J = 1, N - DO 60 I = J, N - DWORK( IRES+(J-1)*N+I ) = TEMP*ABS( Q( I, J ) ) + - $ ABS( DWORK( IRES+(J-1)*N+I ) ) - 60 CONTINUE - 70 CONTINUE - ELSE - DO 90 J = 1, N - DO 80 I = 1, J - DWORK( IRES+(J-1)*N+I ) = TEMP*ABS( Q( I, J ) ) + - $ ABS( DWORK( IRES+(J-1)*N+I ) ) - 80 CONTINUE - 90 CONTINUE - END IF -C - IF( UPDATE ) THEN -C - DO 110 J = 1, N - DO 100 I = 1, N - DWORK( IABS+(J-1)*N+I ) = - $ ABS( DWORK( IABS+(J-1)*N+I ) ) - 100 CONTINUE - 110 CONTINUE -C - CALL DSYR2K( UPLO, TRANAT, N, N, EPSN, DWORK( IABS+1 ), N, - $ DWORK( IXBS+1 ), N, ONE, DWORK( IRES+1 ), N ) - ELSE -C - DO 130 J = 1, N - DO 120 I = 1, MIN( J+1, N ) - DWORK( IABS+(J-1)*N+I ) = ABS( T( I, J ) ) - 120 CONTINUE - 130 CONTINUE -C - CALL MB01UD( 'Left', TRANAT, N, N, EPSN, DWORK( IABS+1 ), N, - $ DWORK( IXBS+1), N, DWORK( ITMP+1 ), N, INFO2 ) - JJ = IRES + 1 - JX = ITMP + 1 - IF( LOWER ) THEN - DO 140 J = 1, N - CALL DAXPY( N-J+1, ONE, DWORK( JX ), N, DWORK( JX ), - $ 1 ) - CALL DAXPY( N-J+1, ONE, DWORK( JX ), 1, DWORK( JJ ), - $ 1 ) - JJ = JJ + N + 1 - JX = JX + N + 1 - 140 CONTINUE - ELSE - DO 150 J = 1, N - CALL DAXPY( J, ONE, DWORK( ITMP+J ), N, DWORK( JX ), - $ 1 ) - CALL DAXPY( J, ONE, DWORK( JX ), 1, DWORK( JJ ), 1 ) - JJ = JJ + N - JX = JX + N - 150 CONTINUE - END IF - END IF -C - IF( LOWER ) THEN - DO 170 J = 1, N - DO 160 I = J, N - DWORK( IABS+(J-1)*N+I ) = ABS( G( I, J ) ) - 160 CONTINUE - 170 CONTINUE - ELSE - DO 190 J = 1, N - DO 180 I = 1, J - DWORK( IABS+(J-1)*N+I ) = ABS( G( I, J ) ) - 180 CONTINUE - 190 CONTINUE - END IF -C - CALL MB01RU( UPLO, TRANA, N, N, ONE, EPS*DBLE( 2*( N + 1 ) ), - $ DWORK( IRES+1 ), N, DWORK( IXBS+1), N, - $ DWORK( IABS+1 ), N, DWORK( ITMP+1 ), NN, INFO2 ) -C - WRKOPT = MAX( WRKOPT, 4*NN ) -C -C Compute forward error bound, using matrix norm estimator. -C Workspace 4*N*N. -C - XANORM = DLANSY( 'Max', UPLO, N, X, LDX, DWORK ) -C - CALL SB03QX( TRANA, UPLO, LYAPUN, N, XANORM, T, LDT, U, LDU, - $ DWORK( IRES+1 ), N, FERR, IWORK, DWORK, IRES, - $ INFO ) - END IF -C - DWORK( 1 ) = DBLE( WRKOPT ) - RETURN -C -C *** Last line of SB02QD *** - END diff --git a/mex/sources/libslicot/SB02RD.f b/mex/sources/libslicot/SB02RD.f deleted file mode 100644 index e4d14172f..000000000 --- a/mex/sources/libslicot/SB02RD.f +++ /dev/null @@ -1,1133 +0,0 @@ - SUBROUTINE SB02RD( JOB, DICO, HINV, TRANA, UPLO, SCAL, SORT, FACT, - $ LYAPUN, N, A, LDA, T, LDT, V, LDV, G, LDG, Q, - $ LDQ, X, LDX, SEP, RCOND, FERR, WR, WI, S, LDS, - $ IWORK, DWORK, LDWORK, BWORK, INFO ) -C -C SLICOT RELEASE 5.0. -C -C Copyright (c) 2002-2009 NICONET e.V. -C -C This program is free software: you can redistribute it and/or -C modify it under the terms of the GNU General Public License as -C published by the Free Software Foundation, either version 2 of -C the License, or (at your option) any later version. -C -C This program is distributed in the hope that it will be useful, -C but WITHOUT ANY WARRANTY; without even the implied warranty of -C MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the -C GNU General Public License for more details. -C -C You should have received a copy of the GNU General Public License -C along with this program. If not, see -C . -C -C PURPOSE -C -C To solve for X either the continuous-time algebraic Riccati -C equation -C -1 -C Q + op(A)'*X + X*op(A) - X*op(B)*R op(B)'*X = 0, (1) -C -C or the discrete-time algebraic Riccati equation -C -1 -C X = op(A)'*X*op(A) - op(A)'*X*op(B)*(R + op(B)'*X*op(B)) * -C op(B)'*X*op(A) + Q, (2) -C -C where op(M) = M or M' (M**T), A, op(B), Q, and R are N-by-N, -C N-by-M, N-by-N, and M-by-M matrices respectively, with Q symmetric -C and R symmetric nonsingular; X is an N-by-N symmetric matrix. -C -1 -C The matrix G = op(B)*R *op(B)' must be provided on input, instead -C of B and R, that is, the continuous-time equation -C -C Q + op(A)'*X + X*op(A) - X*G*X = 0, (3) -C -C or the discrete-time equation -C -1 -C Q + op(A)'*X*(I_n + G*X) *op(A) - X = 0, (4) -C -C are solved, where G is an N-by-N symmetric matrix. SLICOT Library -C routine SB02MT should be used to compute G, given B and R. SB02MT -C also enables to solve Riccati equations corresponding to optimal -C problems with coupling terms. -C -C The routine also returns the computed values of the closed-loop -C spectrum of the optimal system, i.e., the stable eigenvalues -C lambda(1),...,lambda(N) of the corresponding Hamiltonian or -C symplectic matrix associated to the optimal problem. It is assumed -C that the matrices A, G, and Q are such that the associated -C Hamiltonian or symplectic matrix has N stable eigenvalues, i.e., -C with negative real parts, in the continuous-time case, and with -C moduli less than one, in the discrete-time case. -C -C Optionally, estimates of the conditioning and error bound on the -C solution of the Riccati equation (3) or (4) are returned. -C -C ARGUMENTS -C -C Mode Parameters -C -C JOB CHARACTER*1 -C Specifies the computation to be performed, as follows: -C = 'X': Compute the solution only; -C = 'C': Compute the reciprocal condition number only; -C = 'E': Compute the error bound only; -C = 'A': Compute all: the solution, reciprocal condition -C number, and the error bound. -C -C DICO CHARACTER*1 -C Specifies the type of Riccati equation to be solved or -C analyzed, as follows: -C = 'C': Equation (3), continuous-time case; -C = 'D': Equation (4), discrete-time case. -C -C HINV CHARACTER*1 -C If DICO = 'D' and JOB = 'X' or JOB = 'A', specifies which -C symplectic matrix is to be constructed, as follows: -C = 'D': The matrix H in (6) (see METHOD) is constructed; -C = 'I': The inverse of the matrix H in (6) is constructed. -C HINV is not used if DICO = 'C', or JOB = 'C' or 'E'. -C -C TRANA CHARACTER*1 -C Specifies the form of op(A) to be used, as follows: -C = 'N': op(A) = A (No transpose); -C = 'T': op(A) = A**T (Transpose); -C = 'C': op(A) = A**T (Conjugate transpose = Transpose). -C -C UPLO CHARACTER*1 -C Specifies which triangle of the matrices G and Q is -C stored, as follows: -C = 'U': Upper triangle is stored; -C = 'L': Lower triangle is stored. -C -C SCAL CHARACTER*1 -C If JOB = 'X' or JOB = 'A', specifies whether or not a -C scaling strategy should be used, as follows: -C = 'G': General scaling should be used; -C = 'N': No scaling should be used. -C SCAL is not used if JOB = 'C' or 'E'. -C -C SORT CHARACTER*1 -C If JOB = 'X' or JOB = 'A', specifies which eigenvalues -C should be obtained in the top of the Schur form, as -C follows: -C = 'S': Stable eigenvalues come first; -C = 'U': Unstable eigenvalues come first. -C SORT is not used if JOB = 'C' or 'E'. -C -C FACT CHARACTER*1 -C If JOB <> 'X', specifies whether or not a real Schur -C factorization of the closed-loop system matrix Ac is -C supplied on entry, as follows: -C = 'F': On entry, T and V contain the factors from a real -C Schur factorization of the matrix Ac; -C = 'N': A Schur factorization of Ac will be computed -C and the factors will be stored in T and V. -C For a continuous-time system, the matrix Ac is given by -C Ac = A - G*X, if TRANA = 'N', or -C Ac = A - X*G, if TRANA = 'T' or 'C', -C and for a discrete-time system, the matrix Ac is given by -C Ac = inv(I_n + G*X)*A, if TRANA = 'N', or -C Ac = A*inv(I_n + X*G), if TRANA = 'T' or 'C'. -C FACT is not used if JOB = 'X'. -C -C LYAPUN CHARACTER*1 -C If JOB <> 'X', specifies whether or not the original or -C "reduced" Lyapunov equations should be solved for -C estimating reciprocal condition number and/or the error -C bound, as follows: -C = 'O': Solve the original Lyapunov equations, updating -C the right-hand sides and solutions with the -C matrix V, e.g., X <-- V'*X*V; -C = 'R': Solve reduced Lyapunov equations only, without -C updating the right-hand sides and solutions. -C This means that a real Schur form T of Ac appears -C in the equations, instead of Ac. -C LYAPUN is not used if JOB = 'X'. -C -C Input/Output Parameters -C -C N (input) INTEGER -C The order of the matrices A, Q, G, and X. N >= 0. -C -C A (input) DOUBLE PRECISION array, dimension (LDA,N) -C If JOB = 'X' or JOB = 'A' or FACT = 'N' or LYAPUN = 'O', -C the leading N-by-N part of this array must contain the -C coefficient matrix A of the equation. -C If JOB = 'C' or 'E' and FACT = 'F' and LYAPUN = 'R', A is -C not referenced. -C -C LDA INTEGER -C The leading dimension of the array A. -C LDA >= MAX(1,N), if JOB = 'X' or JOB = 'A' or -C FACT = 'N' or LYAPUN = 'O'. -C LDA >= 1, otherwise. -C -C T (input or output) DOUBLE PRECISION array, dimension -C (LDT,N) -C If JOB <> 'X' and FACT = 'F', then T is an input argument -C and on entry, the leading N-by-N upper Hessenberg part of -C this array must contain the upper quasi-triangular matrix -C T in Schur canonical form from a Schur factorization of Ac -C (see argument FACT). -C If JOB <> 'X' and FACT = 'N', then T is an output argument -C and on exit, if INFO = 0 or INFO = 7, the leading N-by-N -C upper Hessenberg part of this array contains the upper -C quasi-triangular matrix T in Schur canonical form from a -C Schur factorization of Ac (see argument FACT). -C If JOB = 'X', the array T is not referenced. -C -C LDT INTEGER -C The leading dimension of the array T. -C LDT >= 1, if JOB = 'X'; -C LDT >= MAX(1,N), if JOB <> 'X'. -C -C V (input or output) DOUBLE PRECISION array, dimension -C (LDV,N) -C If JOB <> 'X' and FACT = 'F', then V is an input argument -C and on entry, the leading N-by-N part of this array must -C contain the orthogonal matrix V from a real Schur -C factorization of Ac (see argument FACT). -C If JOB <> 'X' and FACT = 'N', then V is an output argument -C and on exit, if INFO = 0 or INFO = 7, the leading N-by-N -C part of this array contains the orthogonal N-by-N matrix -C from a real Schur factorization of Ac (see argument FACT). -C If JOB = 'X', the array V is not referenced. -C -C LDV INTEGER -C The leading dimension of the array V. -C LDV >= 1, if JOB = 'X'; -C LDV >= MAX(1,N), if JOB <> 'X'. -C -C G (input/output) DOUBLE PRECISION array, dimension (LDG,N) -C On entry, the leading N-by-N upper triangular part (if -C UPLO = 'U') or lower triangular part (if UPLO = 'L') of -C this array must contain the upper triangular part or lower -C triangular part, respectively, of the symmetric matrix G. -C On exit, if JOB = 'X' and DICO = 'D', or JOB <> 'X' and -C LYAPUN = 'R', the leading N-by-N part of this array -C contains the symmetric matrix G fully stored. -C If JOB <> 'X' and LYAPUN = 'R', this array is modified -C internally, but restored on exit. -C -C LDG INTEGER -C The leading dimension of the array G. LDG >= MAX(1,N). -C -C Q (input/output) DOUBLE PRECISION array, dimension (LDQ,N) -C On entry, the leading N-by-N upper triangular part (if -C UPLO = 'U') or lower triangular part (if UPLO = 'L') of -C this array must contain the upper triangular part or lower -C triangular part, respectively, of the symmetric matrix Q. -C On exit, if JOB = 'X' and DICO = 'D', or JOB <> 'X' and -C LYAPUN = 'R', the leading N-by-N part of this array -C contains the symmetric matrix Q fully stored. -C If JOB <> 'X' and LYAPUN = 'R', this array is modified -C internally, but restored on exit. -C -C LDQ INTEGER -C The leading dimension of the array Q. LDQ >= MAX(1,N). -C -C X (input or output) DOUBLE PRECISION array, dimension -C (LDX,N) -C If JOB = 'C' or JOB = 'E', then X is an input argument -C and on entry, the leading N-by-N part of this array must -C contain the symmetric solution matrix of the algebraic -C Riccati equation. If LYAPUN = 'R', this array is modified -C internally, but restored on exit; however, it could differ -C from the input matrix at the round-off error level. -C If JOB = 'X' or JOB = 'A', then X is an output argument -C and on exit, if INFO = 0 or INFO >= 6, the leading N-by-N -C part of this array contains the symmetric solution matrix -C X of the algebraic Riccati equation. -C -C LDX INTEGER -C The leading dimension of the array X. LDX >= MAX(1,N). -C -C SEP (output) DOUBLE PRECISION -C If JOB = 'C' or JOB = 'A', and INFO = 0 or INFO = 7, the -C estimated quantity -C sep(op(Ac),-op(Ac)'), if DICO = 'C', or -C sepd(op(Ac),op(Ac)'), if DICO = 'D'. (See METHOD.) -C If JOB = 'C' or JOB = 'A' and X = 0, or JOB = 'E', SEP is -C not referenced. -C If JOB = 'X', and INFO = 0, INFO = 5 or INFO = 7, -C SEP contains the scaling factor used, which should -C multiply the (2,1) submatrix of U to recover X from the -C first N columns of U (see METHOD). If SCAL = 'N', SEP is -C set to 1. -C -C RCOND (output) DOUBLE PRECISION -C If JOB = 'C' or JOB = 'A', and INFO = 0 or INFO = 7, an -C estimate of the reciprocal condition number of the -C algebraic Riccati equation. -C If N = 0 or X = 0, RCOND is set to 1 or 0, respectively. -C If JOB = 'X', or JOB = 'E', RCOND is not referenced. -C -C FERR (output) DOUBLE PRECISION -C If JOB = 'E' or JOB = 'A', and INFO = 0 or INFO = 7, an -C estimated forward error bound for the solution X. If XTRUE -C is the true solution, FERR bounds the magnitude of the -C largest entry in (X - XTRUE) divided by the magnitude of -C the largest entry in X. -C If N = 0 or X = 0, FERR is set to 0. -C If JOB = 'X', or JOB = 'C', FERR is not referenced. -C -C WR (output) DOUBLE PRECISION array, dimension (2*N) -C WI (output) DOUBLE PRECISION array, dimension (2*N) -C If JOB = 'X' or JOB = 'A', and INFO = 0 or INFO >= 5, -C these arrays contain the real and imaginary parts, -C respectively, of the eigenvalues of the 2N-by-2N matrix S, -C ordered as specified by SORT (except for the case -C HINV = 'D', when the order is opposite to that specified -C by SORT). The leading N elements of these arrays contain -C the closed-loop spectrum of the system matrix Ac (see -C argument FACT). Specifically, -C lambda(k) = WR(k) + j*WI(k), for k = 1,2,...,N. -C If JOB = 'C' or JOB = 'E', these arrays are not -C referenced. -C -C S (output) DOUBLE PRECISION array, dimension (LDS,2*N) -C If JOB = 'X' or JOB = 'A', and INFO = 0 or INFO >= 5, the -C leading 2N-by-2N part of this array contains the ordered -C real Schur form S of the (scaled, if SCAL = 'G') -C Hamiltonian or symplectic matrix H. That is, -C -C ( S S ) -C ( 11 12 ) -C S = ( ), -C ( 0 S ) -C ( 22 ) -C -C where S , S and S are N-by-N matrices. -C 11 12 22 -C If JOB = 'C' or JOB = 'E', this array is not referenced. -C -C LDS INTEGER -C The leading dimension of the array S. -C LDS >= MAX(1,2*N), if JOB = 'X' or JOB = 'A'; -C LDS >= 1, if JOB = 'C' or JOB = 'E'. -C -C Workspace -C -C IWORK INTEGER array, dimension (LIWORK) -C LIWORK >= 2*N, if JOB = 'X'; -C LIWORK >= N*N, if JOB = 'C' or JOB = 'E'; -C LIWORK >= MAX(2*N,N*N), if JOB = 'A'. -C -C DWORK DOUBLE PRECISION array, dimension (LDWORK) -C On exit, if INFO = 0, or INFO = 7, DWORK(1) returns the -C optimal value of LDWORK. If INFO = 0, or INFO >= 5, and -C JOB = 'X', or JOB = 'A', then DWORK(2) returns an estimate -C RCONDU of the reciprocal of the condition number (in the -C 1-norm) of the N-th order system of algebraic equations -C from which the solution matrix X is obtained, and DWORK(3) -C returns the reciprocal pivot growth factor for the LU -C factorization of the coefficient matrix of that system -C (see SLICOT Library routine MB02PD); if DWORK(3) is much -C less than 1, then the computed X and RCONDU could be -C unreliable. -C If DICO = 'D', and JOB = 'X', or JOB = 'A', then DWORK(4) -C returns the reciprocal condition number RCONDA of the -C given matrix A, and DWORK(5) returns the reciprocal pivot -C growth factor for A or for its leading columns, if A is -C singular (see SLICOT Library routine MB02PD); if DWORK(5) -C is much less than 1, then the computed S and RCONDA could -C be unreliable. -C On exit, if INFO = 0, or INFO >= 4, and JOB = 'X', the -C elements DWORK(6:5+4*N*N) contain the 2*N-by-2*N -C transformation matrix U which reduced the Hamiltonian or -C symplectic matrix H to the ordered real Schur form S. -C -C LDWORK INTEGER -C The length of the array DWORK. -C LDWORK >= 5+MAX(1,4*N*N+8*N), if JOB = 'X' or JOB = 'A'; -C This may also be used for JOB = 'C' or JOB = 'E', but -C exact bounds are as follows: -C LDWORK >= 5 + MAX(1,LWS,LWE) + LWN, where -C LWS = 0, if FACT = 'F' or LYAPUN = 'R'; -C = 5*N, if FACT = 'N' and LYAPUN = 'O' and -C DICO = 'C' and JOB = 'C'; -C = 5*N+N*N, if FACT = 'N' and LYAPUN = 'O' and -C DICO = 'C' and JOB = 'E'; -C = 5*N+N*N, if FACT = 'N' and LYAPUN = 'O' and -C DICO = 'D'; -C LWE = 2*N*N, if DICO = 'C' and JOB = 'C'; -C = 4*N*N, if DICO = 'C' and JOB = 'E'; -C = MAX(3,2*N*N) + N*N, if DICO = 'D' and JOB = 'C'; -C = MAX(3,2*N*N) + 2*N*N, if DICO = 'D' and JOB = 'E'; -C LWN = 0, if LYAPUN = 'O' or JOB = 'C'; -C = 2*N, if LYAPUN = 'R' and DICO = 'C' and JOB = 'E'; -C = 3*N, if LYAPUN = 'R' and DICO = 'D' and JOB = 'E'. -C For optimum performance LDWORK should sometimes be larger. -C -C BWORK LOGICAL array, dimension (LBWORK) -C LBWORK >= 2*N, if JOB = 'X' or JOB = 'A'; -C LBWORK >= 1, if JOB = 'C' or JOB = 'E', and -C FACT = 'N' and LYAPUN = 'R'; -C LBWORK >= 0, otherwise. -C -C Error Indicator -C -C INFO INTEGER -C = 0: successful exit; -C < 0: if INFO = -i, the i-th argument had an illegal -C value; -C = 1: if matrix A is (numerically) singular in discrete- -C time case; -C = 2: if the Hamiltonian or symplectic matrix H cannot be -C reduced to real Schur form; -C = 3: if the real Schur form of the Hamiltonian or -C symplectic matrix H cannot be appropriately ordered; -C = 4: if the Hamiltonian or symplectic matrix H has less -C than N stable eigenvalues; -C = 5: if the N-th order system of linear algebraic -C equations, from which the solution matrix X would -C be obtained, is singular to working precision; -C = 6: if the QR algorithm failed to complete the reduction -C of the matrix Ac to Schur canonical form, T; -C = 7: if T and -T' have some almost equal eigenvalues, if -C DICO = 'C', or T has almost reciprocal eigenvalues, -C if DICO = 'D'; perturbed values were used to solve -C Lyapunov equations, but the matrix T, if given (for -C FACT = 'F'), is unchanged. (This is a warning -C indicator.) -C -C METHOD -C -C The method used is the Schur vector approach proposed by Laub [1], -C but with an optional scaling, which enhances the numerical -C stability [6]. It is assumed that [A,B] is a stabilizable pair -C (where for (3) or (4), B is any matrix such that B*B' = G with -C rank(B) = rank(G)), and [E,A] is a detectable pair, where E is any -C matrix such that E*E' = Q with rank(E) = rank(Q). Under these -C assumptions, any of the algebraic Riccati equations (1)-(4) is -C known to have a unique non-negative definite solution. See [2]. -C Now consider the 2N-by-2N Hamiltonian or symplectic matrix -C -C ( op(A) -G ) -C H = ( ), (5) -C ( -Q -op(A)' ), -C -C for continuous-time equation, and -C -1 -1 -C ( op(A) op(A) *G ) -C H = ( -1 -1 ), (6) -C ( Q*op(A) op(A)' + Q*op(A) *G ) -C -C for discrete-time equation, respectively, where -C -1 -C G = op(B)*R *op(B)'. -C The assumptions guarantee that H in (5) has no pure imaginary -C eigenvalues, and H in (6) has no eigenvalues on the unit circle. -C If Y is an N-by-N matrix then there exists an orthogonal matrix U -C such that U'*Y*U is an upper quasi-triangular matrix. Moreover, U -C can be chosen so that the 2-by-2 and 1-by-1 diagonal blocks -C (corresponding to the complex conjugate eigenvalues and real -C eigenvalues respectively) appear in any desired order. This is the -C ordered real Schur form. Thus, we can find an orthogonal -C similarity transformation U which puts (5) or (6) in ordered real -C Schur form -C -C U'*H*U = S = (S(1,1) S(1,2)) -C ( 0 S(2,2)) -C -C where S(i,j) is an N-by-N matrix and the eigenvalues of S(1,1) -C have negative real parts in case of (5), or moduli greater than -C one in case of (6). If U is conformably partitioned into four -C N-by-N blocks -C -C U = (U(1,1) U(1,2)) -C (U(2,1) U(2,2)) -C -C with respect to the assumptions we then have -C (a) U(1,1) is invertible and X = U(2,1)*inv(U(1,1)) solves (1), -C (2), (3), or (4) with X = X' and non-negative definite; -C (b) the eigenvalues of S(1,1) (if DICO = 'C') or S(2,2) (if -C DICO = 'D') are equal to the eigenvalues of optimal system -C (the 'closed-loop' spectrum). -C -C [A,B] is stabilizable if there exists a matrix F such that (A-BF) -C is stable. [E,A] is detectable if [A',E'] is stabilizable. -C -C The condition number of a Riccati equation is estimated as -C -C cond = ( norm(Theta)*norm(A) + norm(inv(Omega))*norm(Q) + -C norm(Pi)*norm(G) ) / norm(X), -C -C where Omega, Theta and Pi are linear operators defined by -C -C Omega(W) = op(Ac)'*W + W*op(Ac), -C Theta(W) = inv(Omega(op(W)'*X + X*op(W))), -C Pi(W) = inv(Omega(X*W*X)), -C -C in the continuous-time case, and -C -C Omega(W) = op(Ac)'*W*op(Ac) - W, -C Theta(W) = inv(Omega(op(W)'*X*op(Ac) + op(Ac)'X*op(W))), -C Pi(W) = inv(Omega(op(Ac)'*X*W*X*op(Ac))), -C -C in the discrete-time case, and Ac has been defined (see argument -C FACT). Details are given in the comments of SLICOT Library -C routines SB02QD and SB02SD. -C -C The routine estimates the quantities -C -C sep(op(Ac),-op(Ac)') = 1 / norm(inv(Omega)), -C sepd(op(Ac),op(Ac)') = 1 / norm(inv(Omega)), -C -C norm(Theta) and norm(Pi) using 1-norm condition estimator. -C -C The forward error bound is estimated using a practical error bound -C similar to the one proposed in [5]. -C -C REFERENCES -C -C [1] Laub, A.J. -C A Schur Method for Solving Algebraic Riccati equations. -C IEEE Trans. Auto. Contr., AC-24, pp. 913-921, 1979. -C -C [2] Wonham, W.M. -C On a matrix Riccati equation of stochastic control. -C SIAM J. Contr., 6, pp. 681-697, 1968. -C -C [3] Sima, V. -C Algorithms for Linear-Quadratic Optimization. -C Pure and Applied Mathematics: A Series of Monographs and -C Textbooks, vol. 200, Marcel Dekker, Inc., New York, 1996. -C -C [4] Ghavimi, A.R. and Laub, A.J. -C Backward error, sensitivity, and refinement of computed -C solutions of algebraic Riccati equations. -C Numerical Linear Algebra with Applications, vol. 2, pp. 29-49, -C 1995. -C -C [5] Higham, N.J. -C Perturbation theory and backward error for AX-XB=C. -C BIT, vol. 33, pp. 124-136, 1993. -C -C [6] Petkov, P.Hr., Konstantinov, M.M., and Mehrmann, V. -C DGRSVX and DMSRIC: Fortran 77 subroutines for solving -C continuous-time matrix algebraic Riccati equations with -C condition and accuracy estimates. -C Preprint SFB393/98-16, Fak. f. Mathematik, Tech. Univ. -C Chemnitz, May 1998. -C -C NUMERICAL ASPECTS -C 3 -C The algorithm requires 0(N ) operations. The solution accuracy -C can be controlled by the output parameter FERR. -C -C FURTHER COMMENTS -C -C To obtain a stabilizing solution of the algebraic Riccati -C equation for DICO = 'D', set SORT = 'U', if HINV = 'D', or set -C SORT = 'S', if HINV = 'I'. -C -C The routine can also compute the anti-stabilizing solutions of -C the algebraic Riccati equations, by specifying -C SORT = 'U' if DICO = 'D' and HINV = 'I', or DICO = 'C', or -C SORT = 'S' if DICO = 'D' and HINV = 'D'. -C -C Usually, the combinations HINV = 'D' and SORT = 'U', or HINV = 'I' -C and SORT = 'U', for stabilizing and anti-stabilizing solutions, -C respectively, will be faster then the other combinations [3]. -C -C The option LYAPUN = 'R' may produce slightly worse or better -C estimates, and it is faster than the option 'O'. -C -C This routine is a functionally extended and more accurate -C version of the SLICOT Library routine SB02MD. Transposed problems -C can be dealt with as well. Iterative refinement is used whenever -C useful to solve linear algebraic systems. Condition numbers and -C error bounds on the solutions are optionally provided. -C -C CONTRIBUTOR -C -C V. Sima, Research Institute for Informatics, Bucharest, Apr. 1999. -C -C REVISIONS -C -C V. Sima, Research Institute for Informatics, Bucharest, Oct. 2001, -C Dec. 2002, Oct. 2004. -C -C KEYWORDS -C -C Algebraic Riccati equation, closed loop system, continuous-time -C system, discrete-time system, optimal regulator, Schur form. -C -C ****************************************************************** -C -C .. Parameters .. - DOUBLE PRECISION ZERO, HALF, ONE - PARAMETER ( ZERO = 0.0D0, HALF = 0.5D0, ONE = 1.0D0 ) -C .. Scalar Arguments .. - CHARACTER DICO, FACT, HINV, JOB, LYAPUN, SCAL, SORT, - $ TRANA, UPLO - INTEGER INFO, LDA, LDG, LDQ, LDS, LDT, LDV, LDWORK, LDX, - $ N - DOUBLE PRECISION FERR, RCOND, SEP -C .. Array Arguments .. - LOGICAL BWORK(*) - INTEGER IWORK(*) - DOUBLE PRECISION A(LDA,*), DWORK(*), G(LDG,*), Q(LDQ,*), - $ S(LDS,*), T(LDT,*), V(LDV,*), WI(*), WR(*), - $ X(LDX,*) -C .. Local Scalars .. - LOGICAL COLEQU, DISCR, JBXA, JOBA, JOBC, JOBE, JOBX, - $ LHINV, LSCAL, LSCL, LSORT, LUPLO, NOFACT, - $ NOTRNA, ROWEQU, UPDATE - CHARACTER EQUED, JOBS, LOFACT, LOUP, TRANAT - INTEGER I, IERR, IU, IW, IWB, IWC, IWF, IWI, IWR, LDW, - $ LWE, LWN, LWS, N2, NN, NP1, NROT - DOUBLE PRECISION GNORM, QNORM, PIVOTA, PIVOTU, RCONDA, RCONDU, - $ WRKOPT -C .. External Functions .. - LOGICAL LSAME, SB02MR, SB02MS, SB02MV, SB02MW - DOUBLE PRECISION DLAMCH, DLANGE, DLANSY - EXTERNAL DLAMCH, DLANGE, DLANSY, LSAME, SB02MR, SB02MS, - $ SB02MV, SB02MW -C .. External Subroutines .. - EXTERNAL DAXPY, DCOPY, DGEES, DGESV, DLACPY, DLASCL, - $ DLASET, DSCAL, DSWAP, DSYMM, MA02AD, MA02ED, - $ MB01RU, MB01SD, MB02PD, SB02QD, SB02RU, SB02SD, - $ XERBLA -C .. Intrinsic Functions .. - INTRINSIC DBLE, MAX -C .. Executable Statements .. -C -C Decode the input parameters. -C - N2 = N + N - NN = N*N - NP1 = N + 1 - INFO = 0 - JOBA = LSAME( JOB, 'A' ) - JOBC = LSAME( JOB, 'C' ) - JOBE = LSAME( JOB, 'E' ) - JOBX = LSAME( JOB, 'X' ) - NOFACT = LSAME( FACT, 'N' ) - NOTRNA = LSAME( TRANA, 'N' ) - DISCR = LSAME( DICO, 'D' ) - LUPLO = LSAME( UPLO, 'U' ) - LSCAL = LSAME( SCAL, 'G' ) - LSORT = LSAME( SORT, 'S' ) - UPDATE = LSAME( LYAPUN, 'O' ) - JBXA = JOBX .OR. JOBA - LHINV = .FALSE. - IF ( DISCR .AND. JBXA ) - $ LHINV = LSAME( HINV, 'D' ) -C -C Test the input scalar arguments. -C - IF( .NOT.( JBXA .OR. JOBC .OR. JOBE ) ) THEN - INFO = -1 - ELSE IF( .NOT.( DISCR .OR. LSAME( DICO, 'C' ) ) ) THEN - INFO = -2 - ELSE IF( DISCR .AND. JBXA ) THEN - IF( .NOT.( LHINV .OR. LSAME( HINV, 'I' ) ) ) - $ INFO = -3 - END IF - IF( INFO.EQ.0 ) THEN - IF( .NOT.( NOTRNA .OR. LSAME( TRANA, 'T' ) .OR. - $ LSAME( TRANA, 'C' ) ) ) THEN - INFO = -4 - ELSE IF( .NOT.( LUPLO .OR. LSAME( UPLO, 'L' ) ) ) - $ THEN - INFO = -5 - ELSE IF( JBXA ) THEN - IF( .NOT.( LSCAL .OR. LSAME( SCAL, 'N' ) ) ) THEN - INFO = -6 - ELSE IF( .NOT.( LSORT .OR. LSAME( SORT, 'U' ) ) ) THEN - INFO = -7 - END IF - END IF - IF( INFO.EQ.0 .AND. .NOT.JOBX ) THEN - IF( .NOT.( NOFACT .OR. LSAME( FACT, 'F' ) ) ) THEN - INFO = -8 - ELSE IF( .NOT.( UPDATE .OR. LSAME( LYAPUN, 'R' ) ) ) THEN - INFO = -9 - END IF - END IF - IF( INFO.EQ.0 ) THEN - IF( N.LT.0 ) THEN - INFO = -10 - ELSE IF( LDA.LT.1 .OR. ( ( JBXA .OR. NOFACT .OR. UPDATE ) - $ .AND. LDA.LT.N ) ) THEN - INFO = -12 - ELSE IF( LDT.LT.1 .OR. ( .NOT. JOBX .AND. LDT.LT.N ) ) THEN - INFO = -14 - ELSE IF( LDV.LT.1 .OR. ( .NOT. JOBX .AND. LDV.LT.N ) ) THEN - INFO = -16 - ELSE IF( LDG.LT.MAX( 1, N ) ) THEN - INFO = -18 - ELSE IF( LDQ.LT.MAX( 1, N ) ) THEN - INFO = -20 - ELSE IF( LDX.LT.MAX( 1, N ) ) THEN - INFO = -22 - ELSE IF( LDS.LT.1 .OR. ( JBXA .AND. LDS.LT.N2 ) ) THEN - INFO = -29 - ELSE - IF( JBXA ) THEN - IF( LDWORK.LT.5 + MAX( 1, 4*NN + 8*N ) ) - $ INFO = -32 - ELSE - IF( NOFACT .AND. UPDATE ) THEN - IF( .NOT.DISCR .AND. JOBC ) THEN - LWS = 5*N - ELSE - LWS = 5*N + NN - END IF - ELSE - LWS = 0 - END IF - IF( DISCR ) THEN - IF( JOBC ) THEN - LWE = MAX( 3, 2*NN) + NN - ELSE - LWE = MAX( 3, 2*NN) + 2*NN - END IF - ELSE - IF( JOBC ) THEN - LWE = 2*NN - ELSE - LWE = 4*NN - END IF - END IF - IF( UPDATE .OR. JOBC ) THEN - LWN = 0 - ELSE - IF( DISCR ) THEN - LWN = 3*N - ELSE - LWN = 2*N - END IF - END IF - IF( LDWORK.LT.5 + MAX( 1, LWS, LWE ) + LWN ) - $ INFO = -32 - END IF - END IF - END IF - END IF -C - IF ( INFO.NE.0 ) THEN -C -C Error return. -C - CALL XERBLA( 'SB02RD', -INFO ) - RETURN - END IF -C -C Quick return if possible. -C - IF ( N.EQ.0 ) THEN - IF( JOBX ) - $ SEP = ONE - IF( JOBC .OR. JOBA ) - $ RCOND = ONE - IF( JOBE .OR. JOBA ) - $ FERR = ZERO - DWORK(1) = ONE - DWORK(2) = ONE - DWORK(3) = ONE - IF ( DISCR ) THEN - DWORK(4) = ONE - DWORK(5) = ONE - END IF - RETURN - END IF -C - IF ( JBXA ) THEN -C -C Compute the solution matrix X. -C -C Initialise the Hamiltonian or symplectic matrix associated with -C the problem. -C Workspace: need 0 if DICO = 'C'; -C 6*N, if DICO = 'D'. -C - CALL SB02RU( DICO, HINV, TRANA, UPLO, N, A, LDA, G, LDG, Q, - $ LDQ, S, LDS, IWORK, DWORK, LDWORK, IERR ) -C - IF ( IERR.NE.0 ) THEN - INFO = 1 - IF ( DISCR ) THEN - DWORK(4) = DWORK(1) - DWORK(5) = DWORK(2) - END IF - RETURN - END IF -C - IF ( DISCR ) THEN - WRKOPT = 6*N - RCONDA = DWORK(1) - PIVOTA = DWORK(2) - ELSE - WRKOPT = 0 - END IF -C - IF ( LSCAL ) THEN -C -C Scale the Hamiltonian or symplectic matrix S, using the -C square roots of the norms of the matrices Q and G. -C - QNORM = SQRT( DLANSY( '1-norm', UPLO, N, Q, LDQ, DWORK ) ) - GNORM = SQRT( DLANSY( '1-norm', UPLO, N, G, LDG, DWORK ) ) -C - LSCL = QNORM.GT.GNORM .AND. GNORM.GT.ZERO - IF( LSCL ) THEN - CALL DLASCL( 'G', 0, 0, QNORM, GNORM, N, N, S(NP1,1), - $ LDS, IERR ) - CALL DLASCL( 'G', 0, 0, GNORM, QNORM, N, N, S(1,NP1), - $ LDS, IERR ) - END IF - ELSE - LSCL = .FALSE. - END IF -C -C Find the ordered Schur factorization of S, S = U*H*U'. -C Workspace: need 5 + 4*N*N + 6*N; -C prefer larger. -C - IU = 6 - IW = IU + 4*NN - LDW = LDWORK - IW + 1 - IF ( .NOT.DISCR ) THEN - IF ( LSORT ) THEN - CALL DGEES( 'Vectors', 'Sorted', SB02MV, N2, S, LDS, - $ NROT, WR, WI, DWORK(IU), N2, DWORK(IW), LDW, - $ BWORK, IERR ) - ELSE - CALL DGEES( 'Vectors', 'Sorted', SB02MR, N2, S, LDS, - $ NROT, WR, WI, DWORK(IU), N2, DWORK(IW), LDW, - $ BWORK, IERR ) - END IF - ELSE - IF ( LSORT ) THEN - CALL DGEES( 'Vectors', 'Sorted', SB02MW, N2, S, LDS, - $ NROT, WR, WI, DWORK(IU), N2, DWORK(IW), LDW, - $ BWORK, IERR ) - ELSE - CALL DGEES( 'Vectors', 'Sorted', SB02MS, N2, S, LDS, - $ NROT, WR, WI, DWORK(IU), N2, DWORK(IW), LDW, - $ BWORK, IERR ) - END IF - IF ( LHINV ) THEN - CALL DSWAP( N, WR, 1, WR(NP1), 1 ) - CALL DSWAP( N, WI, 1, WI(NP1), 1 ) - END IF - END IF - IF ( IERR.GT.N2 ) THEN - INFO = 3 - ELSE IF ( IERR.GT.0 ) THEN - INFO = 2 - ELSE IF ( NROT.NE.N ) THEN - INFO = 4 - END IF - IF ( INFO.NE.0 ) THEN - IF ( DISCR ) THEN - DWORK(4) = RCONDA - DWORK(5) = PIVOTA - END IF - RETURN - END IF -C - WRKOPT = MAX( WRKOPT, DWORK(IW) + DBLE( IW - 1 ) ) -C -C Compute the solution of X*U(1,1) = U(2,1) using -C LU factorization and iterative refinement. The (2,1) block of S -C is used as a workspace for factoring U(1,1). -C Workspace: need 5 + 4*N*N + 8*N. -C -C First transpose U(2,1) in-situ. -C - DO 20 I = 1, N - 1 - CALL DSWAP( N-I, DWORK(IU+N+I*(N2+1)-1), N2, - $ DWORK(IU+N+(I-1)*(N2+1)+1), 1 ) - 20 CONTINUE -C - IWR = IW - IWC = IWR + N - IWF = IWC + N - IWB = IWF + N - IW = IWB + N -C - CALL MB02PD( 'Equilibrate', 'Transpose', N, N, DWORK(IU), N2, - $ S(NP1,1), LDS, IWORK, EQUED, DWORK(IWR), - $ DWORK(IWC), DWORK(IU+N), N2, X, LDX, RCONDU, - $ DWORK(IWF), DWORK(IWB), IWORK(NP1), DWORK(IW), - $ IERR ) - IF( JOBX ) THEN -C -C Restore U(2,1) back in-situ. -C - DO 40 I = 1, N - 1 - CALL DSWAP( N-I, DWORK(IU+N+I*(N2+1)-1), N2, - $ DWORK(IU+N+(I-1)*(N2+1)+1), 1 ) - 40 CONTINUE -C - IF( .NOT.LSAME( EQUED, 'N' ) ) THEN -C -C Undo the equilibration of U(1,1) and U(2,1). -C - ROWEQU = LSAME( EQUED, 'R' ) .OR. LSAME( EQUED, 'B' ) - COLEQU = LSAME( EQUED, 'C' ) .OR. LSAME( EQUED, 'B' ) -C - IF( ROWEQU ) THEN -C - DO 60 I = 1, N - DWORK(IWR+I-1) = ONE / DWORK(IWR+I-1) - 60 CONTINUE -C - CALL MB01SD( 'Row scaling', N, N, DWORK(IU), N2, - $ DWORK(IWR), DWORK(IWC) ) - END IF -C - IF( COLEQU ) THEN -C - DO 80 I = 1, N - DWORK(IWC+I-1) = ONE / DWORK(IWC+I-1) - 80 CONTINUE -C - CALL MB01SD( 'Column scaling', N, N, DWORK(IU), N2, - $ DWORK(IWR), DWORK(IWC) ) - CALL MB01SD( 'Column scaling', N, N, DWORK(IU+N), N2, - $ DWORK(IWR), DWORK(IWC) ) - END IF - END IF -C -C Set S(2,1) to zero. -C - CALL DLASET( 'Full', N, N, ZERO, ZERO, S(NP1,1), LDS ) - END IF -C - PIVOTU = DWORK(IW) -C - IF ( IERR.GT.0 ) THEN -C -C Singular matrix. Set INFO and DWORK for error return. -C - INFO = 5 - GO TO 160 - END IF -C -C Make sure the solution matrix X is symmetric. -C - DO 100 I = 1, N - 1 - CALL DAXPY( N-I, ONE, X(I,I+1), LDX, X(I+1,I), 1 ) - CALL DSCAL( N-I, HALF, X(I+1,I), 1 ) - CALL DCOPY( N-I, X(I+1,I), 1, X(I,I+1), LDX ) - 100 CONTINUE -C - IF( LSCAL ) THEN -C -C Undo scaling for the solution matrix. -C - IF( LSCL ) - $ CALL DLASCL( 'G', 0, 0, GNORM, QNORM, N, N, X, LDX, - $ IERR ) - END IF - END IF -C - IF ( .NOT.JOBX ) THEN - IF ( .NOT.JOBA ) - $ WRKOPT = 0 -C -C Estimate the conditioning and compute an error bound on the -C solution of the algebraic Riccati equation. -C - IW = 6 - LOFACT = FACT - IF ( NOFACT .AND. .NOT.UPDATE ) THEN -C -C Compute Ac and its Schur factorization. -C - IF ( DISCR ) THEN - CALL DLASET( 'Full', N, N, ZERO, ONE, DWORK(IW), N ) - CALL DSYMM( 'Left', UPLO, N, N, ONE, G, LDG, X, LDX, - $ ONE, DWORK(IW), N ) - IF ( NOTRNA ) THEN -C -C Compute Ac = inv(I_n + G*X)*A. -C - CALL DLACPY( 'Full', N, N, A, LDA, T, LDT ) - CALL DGESV( N, N, DWORK(IW), N, IWORK, T, LDT, IERR ) - ELSE -C -C Compute Ac = A*inv(I_n + X*G). -C - CALL MA02AD( 'Full', N, N, A, LDA, T, LDT ) - CALL DGESV( N, N, DWORK(IW), N, IWORK, T, LDT, IERR ) - DO 120 I = 2, N - CALL DSWAP( I-1, T(1,I), 1, T(I,1), LDT ) - 120 CONTINUE - END IF -C - ELSE -C - CALL DLACPY( 'Full', N, N, A, LDA, T, LDT ) - IF ( NOTRNA ) THEN -C -C Compute Ac = A - G*X. -C - CALL DSYMM( 'Left', UPLO, N, N, -ONE, G, LDG, X, LDX, - $ ONE, T, LDT ) - ELSE -C -C Compute Ac = A - X*G. -C - CALL DSYMM( 'Right', UPLO, N, N, -ONE, G, LDG, X, LDX, - $ ONE, T, LDT ) - END IF - END IF -C -C Compute the Schur factorization of Ac, Ac = V*T*V'. -C Workspace: need 5 + 5*N. -C prefer larger. -C - IWR = IW - IWI = IWR + N - IW = IWI + N - LDW = LDWORK - IW + 1 -C - CALL DGEES( 'Vectors', 'Not ordered', SB02MS, N, T, LDT, - $ NROT, DWORK(IWR), DWORK(IWI), V, LDV, DWORK(IW), - $ LDW, BWORK, IERR ) -C - IF( IERR.NE.0 ) THEN - INFO = 6 - GO TO 160 - END IF -C - WRKOPT = MAX( WRKOPT, DWORK(IW) + DBLE( IW - 1 ) ) - LOFACT = 'F' - IW = 6 - END IF -C - IF ( .NOT.UPDATE ) THEN -C -C Update G, Q, and X using the orthogonal matrix V. -C - TRANAT = 'T' -C -C Save the diagonal elements of G and Q. -C - CALL DCOPY( N, G, LDG+1, DWORK(IW), 1 ) - CALL DCOPY( N, Q, LDQ+1, DWORK(IW+N), 1 ) - IW = IW + N2 -C - IF ( JOBA ) - $ CALL DLACPY( 'Full', N, N, X, LDX, S(NP1,1), LDS ) - CALL MB01RU( UPLO, TRANAT, N, N, ZERO, ONE, X, LDX, V, LDV, - $ X, LDX, DWORK(IW), NN, IERR ) - CALL DSCAL( N, HALF, X, LDX+1 ) - CALL MA02ED( UPLO, N, X, LDX ) - IF( .NOT.DISCR ) THEN - CALL MA02ED( UPLO, N, G, LDG ) - CALL MA02ED( UPLO, N, Q, LDQ ) - END IF - CALL MB01RU( UPLO, TRANAT, N, N, ZERO, ONE, G, LDG, V, LDV, - $ G, LDG, DWORK(IW), NN, IERR ) - CALL DSCAL( N, HALF, G, LDG+1 ) - CALL MB01RU( UPLO, TRANAT, N, N, ZERO, ONE, Q, LDQ, V, LDV, - $ Q, LDQ, DWORK(IW), NN, IERR ) - CALL DSCAL( N, HALF, Q, LDQ+1 ) - END IF -C -C Estimate the conditioning and/or the error bound. -C Workspace: 5 + MAX(1,LWS,LWE) + LWN, where -C -C LWS = 0, if FACT = 'F' or LYAPUN = 'R'; -C = 5*N, if FACT = 'N' and LYAPUN = 'O' and DICO = 'C' -C and JOB = 'C'; -C = 5*N+N*N, if FACT = 'N' and LYAPUN = 'O' and DICO = 'C' -C and (JOB = 'E' or JOB = 'A'); -C = 5*N+N*N, if FACT = 'N' and LYAPUN = 'O' and -C DICO = 'D'; -C LWE = 2*N*N, if DICO = 'C' and JOB = 'C'; -C = 4*N*N, if DICO = 'C' and (JOB = 'E' or -C JOB = 'A'); -C = MAX(3,2*N*N) + N*N, if DICO = 'D' and JOB = 'C'; -C = MAX(3,2*N*N) + 2*N*N, if DICO = 'D' and (JOB = 'E' or -C JOB = 'A'); -C LWN = 0, if LYAPUN = 'O' or JOB = 'C'; -C = 2*N, if LYAPUN = 'R' and DICO = 'C' and (JOB = 'E' or -C JOB = 'A'); -C = 3*N, if LYAPUN = 'R' and DICO = 'D' and (JOB = 'E' or -C JOB = 'A'). -C - LDW = LDWORK - IW + 1 - IF ( JOBA ) THEN - JOBS = 'B' - ELSE - JOBS = JOB - END IF -C - IF ( DISCR ) THEN - CALL SB02SD( JOBS, LOFACT, TRANA, UPLO, LYAPUN, N, A, LDA, - $ T, LDT, V, LDV, G, LDG, Q, LDQ, X, LDX, SEP, - $ RCOND, FERR, IWORK, DWORK(IW), LDW, IERR ) - ELSE - CALL SB02QD( JOBS, LOFACT, TRANA, UPLO, LYAPUN, N, A, LDA, - $ T, LDT, V, LDV, G, LDG, Q, LDQ, X, LDX, SEP, - $ RCOND, FERR, IWORK, DWORK(IW), LDW, IERR ) - END IF -C - WRKOPT = MAX( WRKOPT, DWORK(IW) + DBLE( IW - 1 ) ) - IF( IERR.EQ.NP1 ) THEN - INFO = 7 - ELSE IF( IERR.GT.0 ) THEN - INFO = 6 - GO TO 160 - END IF -C - IF ( .NOT.UPDATE ) THEN -C -C Restore X, G, and Q and set S(2,1) to zero, if needed. -C - IF ( JOBA ) THEN - CALL DLACPY( 'Full', N, N, S(NP1,1), LDS, X, LDX ) - CALL DLASET( 'Full', N, N, ZERO, ZERO, S(NP1,1), LDS ) - ELSE - CALL MB01RU( UPLO, TRANA, N, N, ZERO, ONE, X, LDX, V, - $ LDV, X, LDX, DWORK(IW), NN, IERR ) - CALL DSCAL( N, HALF, X, LDX+1 ) - CALL MA02ED( UPLO, N, X, LDX ) - END IF - IF ( LUPLO ) THEN - LOUP = 'L' - ELSE - LOUP = 'U' - END IF -C - IW = 6 - CALL DCOPY( N, DWORK(IW), 1, G, LDG+1 ) - CALL MA02ED( LOUP, N, G, LDG ) - CALL DCOPY( N, DWORK(IW+N), 1, Q, LDQ+1 ) - CALL MA02ED( LOUP, N, Q, LDQ ) - END IF -C - END IF -C -C Set the optimal workspace and other details. -C - DWORK(1) = WRKOPT - 160 CONTINUE - IF( JBXA ) THEN - DWORK(2) = RCONDU - DWORK(3) = PIVOTU - IF ( DISCR ) THEN - DWORK(4) = RCONDA - DWORK(5) = PIVOTA - END IF - IF( JOBX ) THEN - IF ( LSCL ) THEN - SEP = QNORM / GNORM - ELSE - SEP = ONE - END IF - END IF - END IF -C - RETURN -C *** Last line of SB02RD *** - END diff --git a/mex/sources/libslicot/SB02RU.f b/mex/sources/libslicot/SB02RU.f deleted file mode 100644 index 947d18148..000000000 --- a/mex/sources/libslicot/SB02RU.f +++ /dev/null @@ -1,508 +0,0 @@ - SUBROUTINE SB02RU( DICO, HINV, TRANA, UPLO, N, A, LDA, G, LDG, Q, - $ LDQ, S, LDS, IWORK, DWORK, LDWORK, INFO ) -C -C SLICOT RELEASE 5.0. -C -C Copyright (c) 2002-2009 NICONET e.V. -C -C This program is free software: you can redistribute it and/or -C modify it under the terms of the GNU General Public License as -C published by the Free Software Foundation, either version 2 of -C the License, or (at your option) any later version. -C -C This program is distributed in the hope that it will be useful, -C but WITHOUT ANY WARRANTY; without even the implied warranty of -C MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the -C GNU General Public License for more details. -C -C You should have received a copy of the GNU General Public License -C along with this program. If not, see -C . -C -C PURPOSE -C -C To construct the 2n-by-2n Hamiltonian or symplectic matrix S -C associated to the linear-quadratic optimization problem, used to -C solve the continuous- or discrete-time algebraic Riccati equation, -C respectively. -C -C For a continuous-time problem, S is defined by -C -C ( op(A) -G ) -C S = ( ), (1) -C ( -Q -op(A)' ) -C -C and for a discrete-time problem by -C -C -1 -1 -C ( op(A) op(A) *G ) -C S = ( -1 -1 ), (2) -C ( Q*op(A) op(A)' + Q*op(A) *G ) -C -C or -C -T -T -C ( op(A) + G*op(A) *Q -G*op(A) ) -C S = ( -T -T ), (3) -C ( -op(A) *Q op(A) ) -C -C where op(A) = A or A' (A**T), A, G, and Q are n-by-n matrices, -C with G and Q symmetric. Matrix A must be nonsingular in the -C discrete-time case. -C -C ARGUMENTS -C -C Mode Parameters -C -C DICO CHARACTER*1 -C Specifies the type of the system as follows: -C = 'C': Continuous-time system; -C = 'D': Discrete-time system. -C -C HINV CHARACTER*1 -C If DICO = 'D', specifies which of the matrices (2) or (3) -C is constructed, as follows: -C = 'D': The matrix S in (2) is constructed; -C = 'I': The (inverse) matrix S in (3) is constructed. -C HINV is not referenced if DICO = 'C'. -C -C TRANA CHARACTER*1 -C Specifies the form of op(A) to be used, as follows: -C = 'N': op(A) = A (No transpose); -C = 'T': op(A) = A**T (Transpose); -C = 'C': op(A) = A**T (Conjugate transpose = Transpose). -C -C UPLO CHARACTER*1 -C Specifies which triangle of the matrices G and Q is -C stored, as follows: -C = 'U': Upper triangle is stored; -C = 'L': Lower triangle is stored. -C -C Input/Output Parameters -C -C N (input) INTEGER -C The order of the matrices A, G, and Q. N >= 0. -C -C A (input) DOUBLE PRECISION array, dimension (LDA,N) -C The leading N-by-N part of this array must contain the -C matrix A. -C -C LDA INTEGER -C The leading dimension of the array A. LDA >= MAX(1,N). -C -C G (input/output) DOUBLE PRECISION array, dimension (LDG,N) -C On entry, the leading N-by-N upper triangular part (if -C UPLO = 'U') or lower triangular part (if UPLO = 'L') of -C this array must contain the upper triangular part or lower -C triangular part, respectively, of the symmetric matrix G. -C On exit, if DICO = 'D', the leading N-by-N part of this -C array contains the symmetric matrix G fully stored. -C If DICO = 'C', this array is not modified on exit, and the -C strictly lower triangular part (if UPLO = 'U') or strictly -C upper triangular part (if UPLO = 'L') is not referenced. -C -C LDG INTEGER -C The leading dimension of the array G. LDG >= MAX(1,N). -C -C Q (input/output) DOUBLE PRECISION array, dimension (LDQ,N) -C On entry, the leading N-by-N upper triangular part (if -C UPLO = 'U') or lower triangular part (if UPLO = 'L') of -C this array must contain the upper triangular part or lower -C triangular part, respectively, of the symmetric matrix Q. -C On exit, if DICO = 'D', the leading N-by-N part of this -C array contains the symmetric matrix Q fully stored. -C If DICO = 'C', this array is not modified on exit, and the -C strictly lower triangular part (if UPLO = 'U') or strictly -C upper triangular part (if UPLO = 'L') is not referenced. -C -C LDQ INTEGER -C The leading dimension of the array Q. LDQ >= MAX(1,N). -C -C S (output) DOUBLE PRECISION array, dimension (LDS,2*N) -C If INFO = 0, the leading 2N-by-2N part of this array -C contains the Hamiltonian or symplectic matrix of the -C problem. -C -C LDS INTEGER -C The leading dimension of the array S. LDS >= MAX(1,2*N). -C -C Workspace -C -C IWORK INTEGER array, dimension (LIWORK), where -C LIWORK >= 0, if DICO = 'C'; -C LIWORK >= 2*N, if DICO = 'D'. -C -C DWORK DOUBLE PRECISION array, dimension (LDWORK) -C On exit, if DICO = 'D', DWORK(1) returns the reciprocal -C condition number RCOND of the given matrix A, and -C DWORK(2) returns the reciprocal pivot growth factor -C norm(A)/norm(U) (see SLICOT Library routine MB02PD). -C If DWORK(2) is much less than 1, then the computed S -C and RCOND could be unreliable. If 0 < INFO <= N, then -C DWORK(2) contains the reciprocal pivot growth factor for -C the leading INFO columns of A. -C -C LDWORK INTEGER -C The length of the array DWORK. -C LDWORK >= 0, if DICO = 'C'; -C LDWORK >= MAX(2,6*N), if DICO = 'D'. -C -C Error Indicator -C -C INFO INTEGER -C = 0: successful exit; -C < 0: if INFO = -i, the i-th argument had an illegal -C value; -C = i: if the leading i-by-i (1 <= i <= N) upper triangular -C submatrix of A is singular in discrete-time case; -C = N+1: if matrix A is numerically singular in discrete- -C time case. -C -C METHOD -C -C For a continuous-time problem, the 2n-by-2n Hamiltonian matrix (1) -C is constructed. -C For a discrete-time problem, the 2n-by-2n symplectic matrix (2) or -C (3) - the inverse of the matrix in (2) - is constructed. -C -C NUMERICAL ASPECTS -C -C The discrete-time case needs the inverse of the matrix A, hence -C the routine should not be used when A is ill-conditioned. -C 3 -C The algorithm requires 0(n ) floating point operations in the -C discrete-time case. -C -C FURTHER COMMENTS -C -C This routine is a functionally extended and with improved accuracy -C version of the SLICOT Library routine SB02MU. Transposed problems -C can be dealt with as well. The LU factorization of op(A) (with -C no equilibration) and iterative refinement are used for solving -C the various linear algebraic systems involved. -C -C CONTRIBUTOR -C -C V. Sima, Research Institute for Informatics, Bucharest, Apr. 1999. -C -C REVISIONS -C -C - -C -C KEYWORDS -C -C Algebraic Riccati equation, closed loop system, continuous-time -C system, discrete-time system, optimal regulator, Schur form. -C -C ****************************************************************** -C -C .. Parameters .. - DOUBLE PRECISION ZERO, ONE - PARAMETER ( ZERO = 0.0D0, ONE = 1.0D0 ) -C .. Scalar Arguments .. - CHARACTER DICO, HINV, TRANA, UPLO - INTEGER INFO, LDA, LDG, LDQ, LDS, LDWORK, N -C .. Array Arguments .. - INTEGER IWORK(*) - DOUBLE PRECISION A(LDA,*), DWORK(*), G(LDG,*), Q(LDQ,*), - $ S(LDS,*) -C .. Local Scalars .. - CHARACTER EQUED, TRANAT - LOGICAL DISCR, LHINV, LUPLO, NOTRNA - INTEGER I, J, N2, NJ, NP1 - DOUBLE PRECISION PIVOTG, RCOND, RCONDA, TEMP -C .. External Functions .. - LOGICAL LSAME - EXTERNAL LSAME -C .. External Subroutines .. - EXTERNAL DCOPY, DGEMM, DLACPY, DLASET, DSWAP, MA02AD, - $ MA02ED, MB02PD, XERBLA -C .. Intrinsic Functions .. - INTRINSIC MAX -C .. Executable Statements .. -C - N2 = N + N - INFO = 0 - DISCR = LSAME( DICO, 'D' ) - LUPLO = LSAME( UPLO, 'U' ) - NOTRNA = LSAME( TRANA, 'N' ) - IF( DISCR ) - $ LHINV = LSAME( HINV, 'D' ) -C -C Test the input scalar arguments. -C - IF( .NOT.DISCR .AND. .NOT.LSAME( DICO, 'C' ) ) THEN - INFO = -1 - ELSE IF( DISCR ) THEN - IF( .NOT.LHINV .AND. .NOT.LSAME( HINV, 'I' ) ) - $ INFO = -2 - ELSE IF( INFO.EQ.0 ) THEN - IF( .NOT.NOTRNA .AND. .NOT.LSAME( TRANA, 'T' ) - $ .AND. .NOT.LSAME( TRANA, 'C' ) ) THEN - INFO = -3 - ELSE IF( .NOT.LUPLO .AND. .NOT.LSAME( UPLO, 'L' ) ) THEN - INFO = -4 - ELSE IF( N.LT.0 ) THEN - INFO = -5 - ELSE IF( LDA.LT.MAX( 1, N ) ) THEN - INFO = -7 - ELSE IF( LDG.LT.MAX( 1, N ) ) THEN - INFO = -9 - ELSE IF( LDQ.LT.MAX( 1, N ) ) THEN - INFO = -11 - ELSE IF( LDS.LT.MAX( 1, N2 ) ) THEN - INFO = -13 - ELSE IF( ( LDWORK.LT.0 ) .OR. - $ ( DISCR .AND. LDWORK.LT.MAX( 2, 6*N ) ) ) THEN - INFO = -16 - END IF - END IF -C - IF ( INFO.NE.0 ) THEN -C -C Error return. -C - CALL XERBLA( 'SB02RU', -INFO ) - RETURN - END IF -C -C Quick return if possible. -C - IF ( N.EQ.0 ) THEN - IF ( DISCR ) THEN - DWORK(1) = ONE - DWORK(2) = ONE - END IF - RETURN - END IF -C -C The code tries to exploit data locality as much as possible, -C assuming that LDS is greater than LDA, LDQ, and/or LDG. -C - IF ( .NOT.DISCR ) THEN -C -C Continuous-time case: Construct Hamiltonian matrix column-wise. -C -C Copy op(A) in S(1:N,1:N), and construct full Q -C in S(N+1:2*N,1:N) and change the sign. -C - DO 100 J = 1, N - IF ( NOTRNA ) THEN - CALL DCOPY( N, A(1,J), 1, S(1,J), 1 ) - ELSE - CALL DCOPY( N, A(J,1), LDA, S(1,J), 1 ) - END IF -C - IF ( LUPLO ) THEN -C - DO 20 I = 1, J - S(N+I,J) = -Q(I,J) - 20 CONTINUE -C - DO 40 I = J + 1, N - S(N+I,J) = -Q(J,I) - 40 CONTINUE -C - ELSE -C - DO 60 I = 1, J - 1 - S(N+I,J) = -Q(J,I) - 60 CONTINUE -C - DO 80 I = J, N - S(N+I,J) = -Q(I,J) - 80 CONTINUE -C - END IF - 100 CONTINUE -C -C Construct full G in S(1:N,N+1:2*N) and change the sign, and -C construct -op(A)' in S(N+1:2*N,N+1:2*N). -C - DO 240 J = 1, N - NJ = N + J - IF ( LUPLO ) THEN -C - DO 120 I = 1, J - S(I,NJ) = -G(I,J) - 120 CONTINUE -C - DO 140 I = J + 1, N - S(I,NJ) = -G(J,I) - 140 CONTINUE -C - ELSE -C - DO 160 I = 1, J - 1 - S(I,NJ) = -G(J,I) - 160 CONTINUE -C - DO 180 I = J, N - S(I,NJ) = -G(I,J) - 180 CONTINUE -C - END IF -C - IF ( NOTRNA ) THEN -C - DO 200 I = 1, N - S(N+I,NJ) = -A(J,I) - 200 CONTINUE -C - ELSE -C - DO 220 I = 1, N - S(N+I,NJ) = -A(I,J) - 220 CONTINUE -C - END IF - 240 CONTINUE -C - ELSE -C -C Discrete-time case: Construct the symplectic matrix (2) or (3). -C -C Fill in the remaining triangles of the symmetric matrices Q -C and G. -C - CALL MA02ED( UPLO, N, Q, LDQ ) - CALL MA02ED( UPLO, N, G, LDG ) -C -C Prepare the construction of S in (2) or (3). -C - NP1 = N + 1 - IF ( NOTRNA ) THEN - TRANAT = 'T' - ELSE - TRANAT = 'N' - END IF -C -C Solve op(A)'*X = Q in S(N+1:2*N,1:N), using the LU -C factorization of op(A), obtained in S(1:N,1:N), and -C iterative refinement. No equilibration of A is used. -C Workspace: 6*N. -C - CALL MB02PD( 'No equilibration', TRANAT, N, N, A, LDA, S, - $ LDS, IWORK, EQUED, DWORK, DWORK, Q, LDQ, - $ S(NP1,1), LDS, RCOND, DWORK, DWORK(NP1), - $ IWORK(NP1), DWORK(N2+1), INFO ) -C -C Return if the matrix is exactly singular or singular to -C working precision. -C - IF( INFO.GT.0 ) THEN - DWORK(1) = RCOND - DWORK(2) = DWORK(N2+1) - RETURN - END IF -C - RCONDA = RCOND - PIVOTG = DWORK(N2+1) -C - IF ( LHINV ) THEN -C -C Complete the construction of S in (2). -C -C Transpose X in-situ. -C - DO 260 J = 1, N - 1 - CALL DSWAP( N-J, S(NP1+J,J), 1, S(N+J,J+1), LDS ) - 260 CONTINUE -C -C Solve op(A)*X = I_n in S(N+1:2*N,N+1:2*N), using the LU -C factorization of op(A), computed in S(1:N,1:N), and -C iterative refinement. -C - CALL DLASET( 'Full', N, N, ZERO, ONE, S(1,NP1), LDS ) - CALL MB02PD( 'Factored', TRANA, N, N, A, LDA, S, LDS, IWORK, - $ EQUED, DWORK, DWORK, S(1,NP1), LDS, S(NP1,NP1), - $ LDS, RCOND, DWORK, DWORK(NP1), IWORK(NP1), - $ DWORK(N2+1), INFO ) -C -C Solve op(A)*X = G in S(1:N,N+1:2*N), using the LU -C factorization of op(A), computed in S(1:N,1:N), and -C iterative refinement. -C - CALL MB02PD( 'Factored', TRANA, N, N, A, LDA, S, LDS, IWORK, - $ EQUED, DWORK, DWORK, G, LDG, S(1,NP1), LDS, - $ RCOND, DWORK, DWORK(NP1), IWORK(NP1), - $ DWORK(N2+1), INFO ) -C -C -1 -C Copy op(A) from S(N+1:2*N,N+1:2*N) in S(1:N,1:N). -C - CALL DLACPY( 'Full', N, N, S(NP1,NP1), LDS, S, LDS ) -C -C -1 -C Compute op(A)' + Q*op(A) *G in S(N+1:2*N,N+1:2*N). -C - IF ( NOTRNA ) THEN - CALL MA02AD( 'Full', N, N, A, LDA, S(NP1,NP1), LDS ) - ELSE - CALL DLACPY( 'Full', N, N, A, LDA, S(NP1,NP1), LDS ) - END IF - CALL DGEMM( 'No transpose', 'No transpose', N, N, N, ONE, - $ Q, LDQ, S(1,NP1), LDS, ONE, S(NP1,NP1), LDS ) -C - ELSE -C -C Complete the construction of S in (3). -C -C Change the sign of X. -C - DO 300 J = 1, N -C - DO 280 I = NP1, N2 - S(I,J) = -S(I,J) - 280 CONTINUE -C - 300 CONTINUE -C -C Solve op(A)'*X = I_n in S(N+1:2*N,N+1:2*N), using the LU -C factorization of op(A), computed in S(1:N,1:N), and -C iterative refinement. -C - CALL DLASET( 'Full', N, N, ZERO, ONE, S(1,NP1), LDS ) - CALL MB02PD( 'Factored', TRANAT, N, N, A, LDA, S, LDS, - $ IWORK, EQUED, DWORK, DWORK, S(1,NP1), LDS, - $ S(NP1,NP1), LDS, RCOND, DWORK, DWORK(NP1), - $ IWORK(NP1), DWORK(N2+1), INFO ) -C -C Solve op(A)*X' = -G in S(1:N,N+1:2*N), using the LU -C factorization of op(A), obtained in S(1:N,1:N), and -C iterative refinement. -C - CALL MB02PD( 'Factored', TRANA, N, N, A, LDA, S, LDS, IWORK, - $ EQUED, DWORK, DWORK, G, LDG, S(1,NP1), LDS, - $ RCOND, DWORK, DWORK(NP1), IWORK(NP1), - $ DWORK(N2+1), INFO ) -C -C Change the sign of X and transpose it in-situ. -C - DO 340 J = NP1, N2 -C - DO 320 I = 1, N - TEMP = -S(I,J) - S(I,J) = -S(J-N,I+N) - S(J-N,I+N) = TEMP - 320 CONTINUE -C - 340 CONTINUE -C -T -C Compute op(A) + G*op(A) *Q in S(1:N,1:N). -C - IF ( NOTRNA ) THEN - CALL DLACPY( 'Full', N, N, A, LDA, S, LDS ) - ELSE - CALL MA02AD( 'Full', N, N, A, LDA, S, LDS ) - END IF - CALL DGEMM( 'No transpose', 'No transpose', N, N, N, -ONE, - $ G, LDG, S(NP1,1), LDS, ONE, S, LDS ) -C - END IF - DWORK(1) = RCONDA - DWORK(2) = PIVOTG - END IF - RETURN -C -C *** Last line of SB02RU *** - END diff --git a/mex/sources/libslicot/SB02SD.f b/mex/sources/libslicot/SB02SD.f deleted file mode 100644 index 81685c3b6..000000000 --- a/mex/sources/libslicot/SB02SD.f +++ /dev/null @@ -1,859 +0,0 @@ - SUBROUTINE SB02SD( JOB, FACT, TRANA, UPLO, LYAPUN, N, A, LDA, T, - $ LDT, U, LDU, G, LDG, Q, LDQ, X, LDX, SEPD, - $ RCOND, FERR, IWORK, DWORK, LDWORK, INFO ) -C -C SLICOT RELEASE 5.0. -C -C Copyright (c) 2002-2009 NICONET e.V. -C -C This program is free software: you can redistribute it and/or -C modify it under the terms of the GNU General Public License as -C published by the Free Software Foundation, either version 2 of -C the License, or (at your option) any later version. -C -C This program is distributed in the hope that it will be useful, -C but WITHOUT ANY WARRANTY; without even the implied warranty of -C MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the -C GNU General Public License for more details. -C -C You should have received a copy of the GNU General Public License -C along with this program. If not, see -C . -C -C PURPOSE -C -C To estimate the conditioning and compute an error bound on the -C solution of the real discrete-time matrix algebraic Riccati -C equation (see FURTHER COMMENTS) -C -1 -C X = op(A)'*X*(I_n + G*X) *op(A) + Q, (1) -C -C where op(A) = A or A' (A**T) and Q, G are symmetric (Q = Q**T, -C G = G**T). The matrices A, Q and G are N-by-N and the solution X -C is N-by-N. -C -C ARGUMENTS -C -C Mode Parameters -C -C JOB CHARACTER*1 -C Specifies the computation to be performed, as follows: -C = 'C': Compute the reciprocal condition number only; -C = 'E': Compute the error bound only; -C = 'B': Compute both the reciprocal condition number and -C the error bound. -C -C FACT CHARACTER*1 -C Specifies whether or not the real Schur factorization of -C the matrix Ac = inv(I_n + G*X)*A (if TRANA = 'N'), or -C Ac = A*inv(I_n + X*G) (if TRANA = 'T' or 'C'), is supplied -C on entry, as follows: -C = 'F': On entry, T and U (if LYAPUN = 'O') contain the -C factors from the real Schur factorization of the -C matrix Ac; -C = 'N': The Schur factorization of Ac will be computed -C and the factors will be stored in T and U (if -C LYAPUN = 'O'). -C -C TRANA CHARACTER*1 -C Specifies the form of op(A) to be used, as follows: -C = 'N': op(A) = A (No transpose); -C = 'T': op(A) = A**T (Transpose); -C = 'C': op(A) = A**T (Conjugate transpose = Transpose). -C -C UPLO CHARACTER*1 -C Specifies which part of the symmetric matrices Q and G is -C to be used, as follows: -C = 'U': Upper triangular part; -C = 'L': Lower triangular part. -C -C LYAPUN CHARACTER*1 -C Specifies whether or not the original Lyapunov equations -C should be solved in the iterative estimation process, -C as follows: -C = 'O': Solve the original Lyapunov equations, updating -C the right-hand sides and solutions with the -C matrix U, e.g., RHS <-- U'*RHS*U; -C = 'R': Solve reduced Lyapunov equations only, without -C updating the right-hand sides and solutions. -C -C Input/Output Parameters -C -C N (input) INTEGER -C The order of the matrices A, X, Q, and G. N >= 0. -C -C A (input) DOUBLE PRECISION array, dimension (LDA,N) -C If FACT = 'N' or LYAPUN = 'O', the leading N-by-N part of -C this array must contain the matrix A. -C If FACT = 'F' and LYAPUN = 'R', A is not referenced. -C -C LDA INTEGER -C The leading dimension of the array A. -C LDA >= max(1,N), if FACT = 'N' or LYAPUN = 'O'; -C LDA >= 1, if FACT = 'F' and LYAPUN = 'R'. -C -C T (input or output) DOUBLE PRECISION array, dimension -C (LDT,N) -C If FACT = 'F', then T is an input argument and on entry, -C the leading N-by-N upper Hessenberg part of this array -C must contain the upper quasi-triangular matrix T in Schur -C canonical form from a Schur factorization of Ac (see -C argument FACT). -C If FACT = 'N', then T is an output argument and on exit, -C if INFO = 0 or INFO = N+1, the leading N-by-N upper -C Hessenberg part of this array contains the upper quasi- -C triangular matrix T in Schur canonical form from a Schur -C factorization of Ac (see argument FACT). -C -C LDT INTEGER -C The leading dimension of the array T. LDT >= max(1,N). -C -C U (input or output) DOUBLE PRECISION array, dimension -C (LDU,N) -C If LYAPUN = 'O' and FACT = 'F', then U is an input -C argument and on entry, the leading N-by-N part of this -C array must contain the orthogonal matrix U from a real -C Schur factorization of Ac (see argument FACT). -C If LYAPUN = 'O' and FACT = 'N', then U is an output -C argument and on exit, if INFO = 0 or INFO = N+1, it -C contains the orthogonal N-by-N matrix from a real Schur -C factorization of Ac (see argument FACT). -C If LYAPUN = 'R', the array U is not referenced. -C -C LDU INTEGER -C The leading dimension of the array U. -C LDU >= 1, if LYAPUN = 'R'; -C LDU >= MAX(1,N), if LYAPUN = 'O'. -C -C G (input) DOUBLE PRECISION array, dimension (LDG,N) -C If UPLO = 'U', the leading N-by-N upper triangular part of -C this array must contain the upper triangular part of the -C matrix G. -C If UPLO = 'L', the leading N-by-N lower triangular part of -C this array must contain the lower triangular part of the -C matrix G. _ -C Matrix G should correspond to G in the "reduced" Riccati -C equation (with matrix T, instead of A), if LYAPUN = 'R'. -C See METHOD. -C -C LDG INTEGER -C The leading dimension of the array G. LDG >= max(1,N). -C -C Q (input) DOUBLE PRECISION array, dimension (LDQ,N) -C If UPLO = 'U', the leading N-by-N upper triangular part of -C this array must contain the upper triangular part of the -C matrix Q. -C If UPLO = 'L', the leading N-by-N lower triangular part of -C this array must contain the lower triangular part of the -C matrix Q. _ -C Matrix Q should correspond to Q in the "reduced" Riccati -C equation (with matrix T, instead of A), if LYAPUN = 'R'. -C See METHOD. -C -C LDQ INTEGER -C The leading dimension of the array Q. LDQ >= max(1,N). -C -C X (input) DOUBLE PRECISION array, dimension (LDX,N) -C The leading N-by-N part of this array must contain the -C symmetric solution matrix of the original Riccati -C equation (with matrix A), if LYAPUN = 'O', or of the -C "reduced" Riccati equation (with matrix T), if -C LYAPUN = 'R'. See METHOD. -C -C LDX INTEGER -C The leading dimension of the array X. LDX >= max(1,N). -C -C SEPD (output) DOUBLE PRECISION -C If JOB = 'C' or JOB = 'B', the estimated quantity -C sepd(op(Ac),op(Ac)'). -C If N = 0, or X = 0, or JOB = 'E', SEPD is not referenced. -C -C RCOND (output) DOUBLE PRECISION -C If JOB = 'C' or JOB = 'B', an estimate of the reciprocal -C condition number of the discrete-time Riccati equation. -C If N = 0 or X = 0, RCOND is set to 1 or 0, respectively. -C If JOB = 'E', RCOND is not referenced. -C -C FERR (output) DOUBLE PRECISION -C If JOB = 'E' or JOB = 'B', an estimated forward error -C bound for the solution X. If XTRUE is the true solution, -C FERR bounds the magnitude of the largest entry in -C (X - XTRUE) divided by the magnitude of the largest entry -C in X. -C If N = 0 or X = 0, FERR is set to 0. -C If JOB = 'C', FERR is not referenced. -C -C Workspace -C -C IWORK INTEGER array, dimension (N*N) -C -C DWORK DOUBLE PRECISION array, dimension (LDWORK) -C On exit, if INFO = 0 or INFO = N+1, DWORK(1) returns the -C optimal value of LDWORK. -C -C LDWORK INTEGER -C The dimension of the array DWORK. -C Let LWA = N*N, if LYAPUN = 'O'; -C LWA = 0, otherwise, -C and LWN = N, if LYAPUN = 'R' and JOB = 'E' or 'B'; -C LWN = 0, otherwise. -C If FACT = 'N', then -C LDWORK = MAX(LWA + 5*N, MAX(3,2*N*N) + N*N), -C if JOB = 'C'; -C LDWORK = MAX(LWA + 5*N, MAX(3,2*N*N) + 2*N*N + LWN), -C if JOB = 'E' or 'B'. -C If FACT = 'F', then -C LDWORK = MAX(3,2*N*N) + N*N, if JOB = 'C'; -C LDWORK = MAX(3,2*N*N) + 2*N*N + LWN, -C if JOB = 'E' or 'B'. -C For good performance, LDWORK must generally be larger. -C -C Error indicator -C -C INFO INTEGER -C = 0: successful exit; -C < 0: if INFO = -i, the i-th argument had an illegal -C value; -C > 0: if INFO = i, i <= N, the QR algorithm failed to -C complete the reduction of the matrix Ac to Schur -C canonical form (see LAPACK Library routine DGEES); -C on exit, the matrix T(i+1:N,i+1:N) contains the -C partially converged Schur form, and DWORK(i+1:N) and -C DWORK(N+i+1:2*N) contain the real and imaginary -C parts, respectively, of the converged eigenvalues; -C this error is unlikely to appear; -C = N+1: if T has almost reciprocal eigenvalues; perturbed -C values were used to solve Lyapunov equations, but -C the matrix T, if given (for FACT = 'F'), is -C unchanged. -C -C METHOD -C -C The condition number of the Riccati equation is estimated as -C -C cond = ( norm(Theta)*norm(A) + norm(inv(Omega))*norm(Q) + -C norm(Pi)*norm(G) ) / norm(X), -C -C where Omega, Theta and Pi are linear operators defined by -C -C Omega(W) = op(Ac)'*W*op(Ac) - W, -C Theta(W) = inv(Omega(op(W)'*X*op(Ac) + op(Ac)'X*op(W))), -C Pi(W) = inv(Omega(op(Ac)'*X*W*X*op(Ac))), -C -C and Ac = inv(I_n + G*X)*A (if TRANA = 'N'), or -C Ac = A*inv(I_n + X*G) (if TRANA = 'T' or 'C'). -C -C Note that the Riccati equation (1) is equivalent to -C -C X = op(Ac)'*X*op(Ac) + op(Ac)'*X*G*X*op(Ac) + Q, (2) -C -C and to -C _ _ _ _ _ _ -C X = op(T)'*X*op(T) + op(T)'*X*G*X*op(T) + Q, (3) -C _ _ _ -C where X = U'*X*U, Q = U'*Q*U, and G = U'*G*U, with U the -C orthogonal matrix reducing Ac to a real Schur form, T = U'*Ac*U. -C -C The routine estimates the quantities -C -C sepd(op(Ac),op(Ac)') = 1 / norm(inv(Omega)), -C -C norm(Theta) and norm(Pi) using 1-norm condition estimator. -C -C The forward error bound is estimated using a practical error bound -C similar to the one proposed in [2]. -C -C REFERENCES -C -C [1] Ghavimi, A.R. and Laub, A.J. -C Backward error, sensitivity, and refinement of computed -C solutions of algebraic Riccati equations. -C Numerical Linear Algebra with Applications, vol. 2, pp. 29-49, -C 1995. -C -C [2] Higham, N.J. -C Perturbation theory and backward error for AX-XB=C. -C BIT, vol. 33, pp. 124-136, 1993. -C -C [3] Petkov, P.Hr., Konstantinov, M.M., and Mehrmann, V. -C DGRSVX and DMSRIC: Fortran 77 subroutines for solving -C continuous-time matrix algebraic Riccati equations with -C condition and accuracy estimates. -C Preprint SFB393/98-16, Fak. f. Mathematik, Tech. Univ. -C Chemnitz, May 1998. -C -C NUMERICAL ASPECTS -C 3 -C The algorithm requires 0(N ) operations. -C The accuracy of the estimates obtained depends on the solution -C accuracy and on the properties of the 1-norm estimator. -C -C FURTHER COMMENTS -C -C The option LYAPUN = 'R' may occasionally produce slightly worse -C or better estimates, and it is much faster than the option 'O'. -C When SEPD is computed and it is zero, the routine returns -C immediately, with RCOND and FERR (if requested) set to 0 and 1, -C respectively. In this case, the equation is singular. -C -C Let B be an N-by-M matrix (if TRANA = 'N') or an M-by-N matrix -C (if TRANA = 'T' or 'C'), let R be an M-by-M symmetric positive -C definite matrix (R = R**T), and denote G = op(B)*inv(R)*op(B)'. -C Then, the Riccati equation (1) is equivalent to the standard -C discrete-time matrix algebraic Riccati equation -C -C X = op(A)'*X*op(A) - (4) -C -1 -C op(A)'*X*op(B)*(R + op(B)'*X*op(B)) *op(B)'*X*op(A) + Q. -C -C By symmetry, the equation (1) is also equivalent to -C -1 -C X = op(A)'*(I_n + X*G) *X*op(A) + Q. -C -C CONTRIBUTOR -C -C V. Sima, Research Institute for Informatics, Bucharest, and -C P.Hr. Petkov, Technical University of Sofia, March 1999. -C -C REVISIONS -C -C V. Sima, Research Institute for Informatics, Bucharest, Oct. 2004. -C -C KEYWORDS -C -C Conditioning, error estimates, orthogonal transformation, -C real Schur form, Riccati equation. -C -C ****************************************************************** -C -C .. Parameters .. - DOUBLE PRECISION ZERO, ONE, TWO, FOUR, HALF - PARAMETER ( ZERO = 0.0D+0, ONE = 1.0D+0, TWO = 2.0D+0, - $ FOUR = 4.0D+0, HALF = 0.5D+0 ) -C .. -C .. Scalar Arguments .. - CHARACTER FACT, JOB, LYAPUN, TRANA, UPLO - INTEGER INFO, LDA, LDG, LDQ, LDT, LDU, LDWORK, LDX, N - DOUBLE PRECISION FERR, RCOND, SEPD -C .. -C .. Array Arguments .. - INTEGER IWORK( * ) - DOUBLE PRECISION A( LDA, * ), DWORK( * ), G( LDG, * ), - $ Q( LDQ, * ), T( LDT, * ), U( LDU, * ), - $ X( LDX, * ) -C .. -C .. Local Scalars .. - LOGICAL JOBB, JOBC, JOBE, LOWER, NEEDAC, NOFACT, - $ NOTRNA, UPDATE - CHARACTER LOUP, SJOB, TRANAT - INTEGER I, IABS, INFO2, IRES, IWRK, IXBS, IXMA, J, JJ, - $ KASE, LDW, LWA, LWR, NN, SDIM, WRKOPT - DOUBLE PRECISION ANORM, BIGNUM, DENOM, EPS, EPSN, EPST, EST, - $ GNORM, PINORM, QNORM, SCALE, TEMP, THNORM, - $ TMAX, XANORM, XNORM -C .. -C .. Local Arrays .. - LOGICAL BWORK( 1 ) -C .. -C .. External Functions .. - LOGICAL LSAME, SELECT - DOUBLE PRECISION DLAMCH, DLANGE, DLANHS, DLANSY - EXTERNAL DLAMCH, DLANGE, DLANHS, DLANSY, LSAME, SELECT -C .. -C .. External Subroutines .. - EXTERNAL DAXPY, DCOPY, DGEES, DGEMM, DGESV, DLACON, - $ DLACPY, DLASET, DSCAL, DSWAP, DSYMM, MA02ED, - $ MB01RU, MB01RX, MB01RY, MB01UD, SB03MX, SB03SX, - $ SB03SY, XERBLA -C .. -C .. Intrinsic Functions .. - INTRINSIC ABS, DBLE, INT, MAX, MIN -C .. -C .. Executable Statements .. -C -C Decode and Test input parameters. -C - JOBC = LSAME( JOB, 'C' ) - JOBE = LSAME( JOB, 'E' ) - JOBB = LSAME( JOB, 'B' ) - NOFACT = LSAME( FACT, 'N' ) - NOTRNA = LSAME( TRANA, 'N' ) - LOWER = LSAME( UPLO, 'L' ) - UPDATE = LSAME( LYAPUN, 'O' ) -C - NEEDAC = UPDATE .AND. .NOT.JOBC -C - NN = N*N - IF( UPDATE ) THEN - LWA = NN - ELSE - LWA = 0 - END IF -C - IF( JOBC ) THEN - LDW = MAX( 3, 2*NN ) + NN - ELSE - LDW = MAX( 3, 2*NN ) + 2*NN - IF( .NOT.UPDATE ) - $ LDW = LDW + N - END IF - IF( NOFACT ) - $ LDW = MAX( LWA + 5*N, LDW ) -C - INFO = 0 - IF( .NOT.( JOBB .OR. JOBC .OR. JOBE ) ) THEN - INFO = -1 - ELSE IF( .NOT.( NOFACT .OR. LSAME( FACT, 'F' ) ) ) THEN - INFO = -2 - ELSE IF( .NOT.( NOTRNA .OR. LSAME( TRANA, 'T' ) .OR. - $ LSAME( TRANA, 'C' ) ) ) THEN - INFO = -3 - ELSE IF( .NOT.( LOWER .OR. LSAME( UPLO, 'U' ) ) ) THEN - INFO = -4 - ELSE IF( .NOT.( UPDATE .OR. LSAME( LYAPUN, 'R' ) ) ) THEN - INFO = -5 - ELSE IF( N.LT.0 ) THEN - INFO = -6 - ELSE IF( LDA.LT.1 .OR. - $ ( LDA.LT.N .AND. ( UPDATE .OR. NOFACT ) ) ) THEN - INFO = -8 - ELSE IF( LDT.LT.MAX( 1, N ) ) THEN - INFO = -10 - ELSE IF( LDU.LT.1 .OR. ( LDU.LT.N .AND. UPDATE ) ) THEN - INFO = -12 - ELSE IF( LDG.LT.MAX( 1, N ) ) THEN - INFO = -14 - ELSE IF( LDQ.LT.MAX( 1, N ) ) THEN - INFO = -16 - ELSE IF( LDX.LT.MAX( 1, N ) ) THEN - INFO = -18 - ELSE IF( LDWORK.LT.LDW ) THEN - INFO = -24 - END IF -C - IF( INFO.NE.0 ) THEN - CALL XERBLA( 'SB02SD', -INFO ) - RETURN - END IF -C -C Quick return if possible. -C - IF( N.EQ.0 ) THEN - IF( .NOT.JOBE ) - $ RCOND = ONE - IF( .NOT.JOBC ) - $ FERR = ZERO - DWORK( 1 ) = ONE - RETURN - END IF -C -C Compute the 1-norm of the matrix X. -C - XNORM = DLANSY( '1-norm', UPLO, N, X, LDX, DWORK ) - IF( XNORM.EQ.ZERO ) THEN -C -C The solution is zero. -C - IF( .NOT.JOBE ) - $ RCOND = ZERO - IF( .NOT.JOBC ) - $ FERR = ZERO - DWORK( 1 ) = DBLE( N ) - RETURN - END IF -C -C Workspace usage. -C - IRES = 0 - IXBS = IRES + NN - IXMA = MAX( 3, 2*NN ) - IABS = IXMA + NN - IWRK = IABS + NN -C -C Workspace: LWK, where -C LWK = 2*N*N, if LYAPUN = 'O', or FACT = 'N', -C LWK = N, otherwise. -C - IF( UPDATE .OR. NOFACT ) THEN -C - CALL DLASET( 'Full', N, N, ZERO, ONE, DWORK( IXBS+1 ), N ) - CALL DSYMM( 'Left', UPLO, N, N, ONE, G, LDG, X, LDX, ONE, - $ DWORK( IXBS+1 ), N ) - IF( NOTRNA ) THEN -C -1 -C Compute Ac = (I_n + G*X) *A. -C - CALL DLACPY( 'Full', N, N, A, LDA, DWORK, N ) - CALL DGESV( N, N, DWORK( IXBS+1 ), N, IWORK, DWORK, N, - $ INFO2 ) - ELSE -C -1 -C Compute Ac = A*(I_n + X*G) . -C - DO 10 J = 1, N - CALL DCOPY( N, A( 1, J ), 1, DWORK( J ), N ) - 10 CONTINUE - CALL DGESV( N, N, DWORK( IXBS+1 ), N, IWORK, DWORK, N, - $ INFO2 ) - DO 20 J = 2, N - CALL DSWAP( J-1, DWORK( (J-1)*N+1 ), 1, DWORK( J ), N ) - 20 CONTINUE - END IF -C - WRKOPT = DBLE( 2*NN ) - IF( NOFACT ) - $ CALL DLACPY( 'Full', N, N, DWORK, N, T, LDT ) - ELSE - WRKOPT = DBLE( N ) - END IF -C - IF( NOFACT ) THEN -C -C Compute the Schur factorization of Ac, Ac = U*T*U'. -C Workspace: need LWA + 5*N; -C prefer larger; -C LWA = N*N, if LYAPUN = 'O'; -C LWA = 0, otherwise. -C (Note: Comments in the code beginning "Workspace:" describe the -C minimal amount of real workspace needed at that point in the -C code, as well as the preferred amount for good performance.) -C - IF( UPDATE ) THEN - SJOB = 'V' - ELSE - SJOB = 'N' - END IF - CALL DGEES( SJOB, 'Not ordered', SELECT, N, T, LDT, SDIM, - $ DWORK( LWA+1 ), DWORK( LWA+N+1 ), U, LDU, - $ DWORK( LWA+2*N+1 ), LDWORK-LWA-2*N, BWORK, INFO ) - IF( INFO.GT.0 ) THEN - IF( LWA.GT.0 ) - $ CALL DCOPY( 2*N, DWORK( LWA+1 ), 1, DWORK, 1 ) - RETURN - END IF -C - WRKOPT = MAX( WRKOPT, INT( DWORK( LWA+2*N+1 ) ) + LWA + 2*N ) - END IF - IF( NEEDAC ) THEN - CALL DLACPY( 'Full', N, N, DWORK, N, DWORK( IABS+1 ), N ) - LWR = NN - ELSE - LWR = 0 - END IF -C - IF( NOTRNA ) THEN - TRANAT = 'T' - ELSE - TRANAT = 'N' - END IF -C _ -C Compute X*op(Ac) or X*op(T). -C - IF( UPDATE ) THEN - CALL DGEMM( 'NoTranspose', TRANA, N, N, N, ONE, X, LDX, DWORK, - $ N, ZERO, DWORK( IXMA+1 ), N ) - ELSE - CALL MB01UD( 'Right', TRANA, N, N, ONE, T, LDT, X, LDX, - $ DWORK( IXMA+1 ), N, INFO2 ) - END IF -C - IF( .NOT.JOBE ) THEN -C -C Estimate sepd(op(Ac),op(Ac)') = sepd(op(T),op(T)') and -C norm(Theta). -C Workspace LWR + MAX(3,2*N*N) + N*N, where -C LWR = N*N, if LYAPUN = 'O' and JOB = 'B', -C LWR = 0, otherwise. -C - CALL SB03SY( 'Both', TRANA, LYAPUN, N, T, LDT, U, LDU, - $ DWORK( IXMA+1 ), N, SEPD, THNORM, IWORK, DWORK, - $ IXMA, INFO ) -C - WRKOPT = MAX( WRKOPT, LWR + MAX( 3, 2*NN ) + NN ) -C -C Return if the equation is singular. -C - IF( SEPD.EQ.ZERO ) THEN - RCOND = ZERO - IF( JOBB ) - $ FERR = ONE - DWORK( 1 ) = DBLE( WRKOPT ) - RETURN - END IF -C -C Estimate norm(Pi). -C Workspace LWR + MAX(3,2*N*N) + N*N. -C - KASE = 0 -C -C REPEAT - 30 CONTINUE - CALL DLACON( NN, DWORK( IXBS+1 ), DWORK, IWORK, EST, KASE ) - IF( KASE.NE.0 ) THEN -C -C Select the triangular part of symmetric matrix to be used. -C - IF( DLANSY( '1-norm', 'Upper', N, DWORK, N, DWORK( IXBS+1 )) - $ .GE. - $ DLANSY( '1-norm', 'Lower', N, DWORK, N, DWORK( IXBS+1 )) - $ ) THEN - LOUP = 'U' - ELSE - LOUP = 'L' - END IF -C _ _ -C Compute RHS = op(Ac)'*X*W*X*op(Ac) or op(T)'*X*W*X*op(T). -C - CALL MB01RU( LOUP, TRANAT, N, N, ZERO, ONE, DWORK, N, - $ DWORK( IXMA+1 ), N, DWORK, N, DWORK( IXBS+1 ), - $ NN, INFO2 ) - CALL DSCAL( N, HALF, DWORK, N+1 ) -C - IF( UPDATE ) THEN -C -C Transform the right-hand side: RHS := U'*RHS*U. -C - CALL MB01RU( LOUP, 'Transpose', N, N, ZERO, ONE, DWORK, - $ N, U, LDU, DWORK, N, DWORK( IXBS+1 ), NN, - $ INFO2 ) - CALL DSCAL( N, HALF, DWORK, N+1 ) - END IF -C -C Fill in the remaining triangle of the symmetric matrix. -C - CALL MA02ED( LOUP, N, DWORK, N ) -C - IF( KASE.EQ.1 ) THEN -C -C Solve op(T)'*Y*op(T) - Y = scale*RHS. -C - CALL SB03MX( TRANA, N, T, LDT, DWORK, N, SCALE, - $ DWORK( IXBS+1 ), INFO2 ) - ELSE -C -C Solve op(T)*W*op(T)' - W = scale*RHS. -C - CALL SB03MX( TRANAT, N, T, LDT, DWORK, N, SCALE, - $ DWORK( IXBS+1 ), INFO2 ) - END IF -C - IF( UPDATE ) THEN -C -C Transform back to obtain the solution: Z := U*Z*U', with -C Z = Y or Z = W. -C - CALL MB01RU( LOUP, 'No transpose', N, N, ZERO, ONE, - $ DWORK, N, U, LDU, DWORK, N, DWORK( IXBS+1 ), - $ NN, INFO2 ) - CALL DSCAL( N, HALF, DWORK, N+1 ) -C -C Fill in the remaining triangle of the symmetric matrix. -C - CALL MA02ED( LOUP, N, DWORK, N ) - END IF - GO TO 30 - END IF -C UNTIL KASE = 0 -C - IF( EST.LT.SCALE ) THEN - PINORM = EST / SCALE - ELSE - BIGNUM = ONE / DLAMCH( 'Safe minimum' ) - IF( EST.LT.SCALE*BIGNUM ) THEN - PINORM = EST / SCALE - ELSE - PINORM = BIGNUM - END IF - END IF -C -C Compute the 1-norm of A or T. -C - IF( UPDATE ) THEN - ANORM = DLANGE( '1-norm', N, N, A, LDA, DWORK ) - ELSE - ANORM = DLANHS( '1-norm', N, T, LDT, DWORK ) - END IF -C -C Compute the 1-norms of the matrices Q and G. -C - QNORM = DLANSY( '1-norm', UPLO, N, Q, LDQ, DWORK ) - GNORM = DLANSY( '1-norm', UPLO, N, G, LDG, DWORK ) -C -C Estimate the reciprocal condition number. -C - TMAX = MAX( SEPD, XNORM, ANORM, GNORM ) - IF( TMAX.LE.ONE ) THEN - TEMP = SEPD*XNORM - DENOM = QNORM + ( SEPD*ANORM )*THNORM + - $ ( SEPD*GNORM )*PINORM - ELSE - TEMP = ( SEPD / TMAX )*( XNORM / TMAX ) - DENOM = ( ( ONE / TMAX )*( QNORM / TMAX ) ) + - $ ( ( SEPD / TMAX )*( ANORM / TMAX ) )*THNORM + - $ ( ( SEPD / TMAX )*( GNORM / TMAX ) )*PINORM - END IF - IF( TEMP.GE.DENOM ) THEN - RCOND = ONE - ELSE - RCOND = TEMP / DENOM - END IF - END IF -C - IF( .NOT.JOBC ) THEN -C -C Form a triangle of the residual matrix -C R = op(Ac)'*X*op(Ac) + op(Ac)'*X*G*X*op(Ac) + Q - X, -C or _ _ _ _ _ _ -C R = op(T)'*X*op(T) + op(T)'*X*G*X*op(T) + Q - X, -C exploiting the symmetry. Actually, the equivalent formula -C R = op(A)'*X*op(Ac) + Q - X -C is used in the first case. -C Workspace MAX(3,2*N*N) + 2*N*N, if LYAPUN = 'O'; -C MAX(3,2*N*N) + 2*N*N + N, if LYAPUN = 'R'. -C - CALL DLACPY( UPLO, N, N, Q, LDQ, DWORK( IRES+1 ), N ) - JJ = IRES + 1 - IF( LOWER ) THEN - DO 40 J = 1, N - CALL DAXPY( N-J+1, -ONE, X( J, J ), 1, DWORK( JJ ), 1 ) - JJ = JJ + N + 1 - 40 CONTINUE - ELSE - DO 50 J = 1, N - CALL DAXPY( J, -ONE, X( 1, J ), 1, DWORK( JJ ), 1 ) - JJ = JJ + N - 50 CONTINUE - END IF -C - IF( UPDATE ) THEN - CALL MB01RX( 'Left', UPLO, TRANAT, N, N, ONE, ONE, - $ DWORK( IRES+1 ), N, A, LDA, DWORK( IXMA+1 ), N, - $ INFO2 ) - ELSE - CALL MB01RY( 'Left', UPLO, TRANAT, N, ONE, ONE, - $ DWORK( IRES+1 ), N, T, LDT, DWORK( IXMA+1 ), N, - $ DWORK( IWRK+1 ), INFO2 ) - CALL DSYMM( 'Left', UPLO, N, N, ONE, G, LDG, - $ DWORK( IXMA+1 ), N, ZERO, DWORK( IXBS+1 ), N ) - CALL MB01RX( 'Left', UPLO, 'Transpose', N, N, ONE, ONE, - $ DWORK( IRES+1 ), N, DWORK( IXMA+1 ), N, - $ DWORK( IXBS+1 ), N, INFO2 ) - END IF -C -C Get the machine precision. -C - EPS = DLAMCH( 'Epsilon' ) - EPSN = EPS*DBLE( N + 4 ) - EPST = EPS*DBLE( 2*( N + 1 ) ) - TEMP = EPS*FOUR -C -C Add to abs(R) a term that takes account of rounding errors in -C forming R: -C abs(R) := abs(R) + EPS*(4*abs(Q) + 4*abs(X) + -C (n+4)*abs(op(Ac))'*abs(X)*abs(op(Ac)) + 2*(n+1)* -C abs(op(Ac))'*abs(X)*abs(G)*abs(X)*abs(op(Ac))), -C or _ _ -C abs(R) := abs(R) + EPS*(4*abs(Q) + 4*abs(X) + -C _ -C (n+4)*abs(op(T))'*abs(X)*abs(op(T)) + -C _ _ _ -C 2*(n+1)*abs(op(T))'*abs(X)*abs(G)*abs(X)*abs(op(T))), -C where EPS is the machine precision. -C - DO 70 J = 1, N - DO 60 I = 1, N - DWORK( IXBS+(J-1)*N+I ) = ABS( X( I, J ) ) - 60 CONTINUE - 70 CONTINUE -C - IF( LOWER ) THEN - DO 90 J = 1, N - DO 80 I = J, N - DWORK( IRES+(J-1)*N+I ) = TEMP*( ABS( Q( I, J ) ) + - $ ABS( X( I, J ) ) ) + - $ ABS( DWORK( IRES+(J-1)*N+I ) ) - 80 CONTINUE - 90 CONTINUE - ELSE - DO 110 J = 1, N - DO 100 I = 1, J - DWORK( IRES+(J-1)*N+I ) = TEMP*( ABS( Q( I, J ) ) + - $ ABS( X( I, J ) ) ) + - $ ABS( DWORK( IRES+(J-1)*N+I ) ) - 100 CONTINUE - 110 CONTINUE - END IF -C - IF( UPDATE ) THEN -C - DO 130 J = 1, N - DO 120 I = 1, N - DWORK( IABS+(J-1)*N+I ) = - $ ABS( DWORK( IABS+(J-1)*N+I ) ) - 120 CONTINUE - 130 CONTINUE -C - CALL DGEMM( 'NoTranspose', TRANA, N, N, N, ONE, - $ DWORK( IXBS+1 ), N, DWORK( IABS+1 ), N, ZERO, - $ DWORK( IXMA+1 ), N ) - CALL MB01RX( 'Left', UPLO, TRANAT, N, N, ONE, EPSN, - $ DWORK( IRES+1 ), N, DWORK( IABS+1 ), N, - $ DWORK( IXMA+1 ), N, INFO2 ) - ELSE -C - DO 150 J = 1, N - DO 140 I = 1, MIN( J+1, N ) - DWORK( IABS+(J-1)*N+I ) = ABS( T( I, J ) ) - 140 CONTINUE - 150 CONTINUE -C - CALL MB01UD( 'Right', TRANA, N, N, ONE, DWORK( IABS+1 ), N, - $ DWORK( IXBS+1 ), N, DWORK( IXMA+1 ), N, INFO2 ) - CALL MB01RY( 'Left', UPLO, TRANAT, N, ONE, EPSN, - $ DWORK( IRES+1 ), N, DWORK( IABS+1 ), N, - $ DWORK( IXMA+1 ), N, DWORK( IWRK+1 ), INFO2 ) - END IF -C - IF( LOWER ) THEN - DO 170 J = 1, N - DO 160 I = J, N - DWORK( IABS+(J-1)*N+I ) = ABS( G( I, J ) ) - 160 CONTINUE - 170 CONTINUE - ELSE - DO 190 J = 1, N - DO 180 I = 1, J - DWORK( IABS+(J-1)*N+I ) = ABS( G( I, J ) ) - 180 CONTINUE - 190 CONTINUE - END IF -C - IF( UPDATE ) THEN - CALL MB01RU( UPLO, TRANAT, N, N, ONE, EPST, DWORK( IRES+1 ), - $ N, DWORK( IXMA+1 ), N, DWORK( IABS+1 ), N, - $ DWORK( IXBS+1 ), NN, INFO2 ) - WRKOPT = MAX( WRKOPT, MAX( 3, 2*NN ) + 2*NN ) - ELSE - CALL DSYMM( 'Left', UPLO, N, N, ONE, DWORK( IABS+1 ), N, - $ DWORK( IXMA+1 ), N, ZERO, DWORK( IXBS+1 ), N ) - CALL MB01RY( 'Left', UPLO, TRANAT, N, ONE, EPST, - $ DWORK( IRES+1 ), N, DWORK( IXMA+1 ), N, - $ DWORK( IXBS+1 ), N, DWORK( IWRK+1 ), INFO2 ) - WRKOPT = MAX( WRKOPT, MAX( 3, 2*NN ) + 2*NN + N ) - END IF -C -C Compute forward error bound, using matrix norm estimator. -C Workspace MAX(3,2*N*N) + N*N. -C - XANORM = DLANSY( 'Max', UPLO, N, X, LDX, DWORK ) -C - CALL SB03SX( TRANA, UPLO, LYAPUN, N, XANORM, T, LDT, U, LDU, - $ DWORK( IRES+1 ), N, FERR, IWORK, DWORK( IXBS+1 ), - $ IXMA, INFO ) - END IF -C - DWORK( 1 ) = DBLE( WRKOPT ) - RETURN -C -C *** Last line of SB02SD *** - END diff --git a/mex/sources/libslicot/SB03MD.f b/mex/sources/libslicot/SB03MD.f deleted file mode 100644 index 986998155..000000000 --- a/mex/sources/libslicot/SB03MD.f +++ /dev/null @@ -1,556 +0,0 @@ - SUBROUTINE SB03MD( DICO, JOB, FACT, TRANA, N, A, LDA, U, LDU, C, - $ LDC, SCALE, SEP, FERR, WR, WI, IWORK, DWORK, - $ LDWORK, INFO ) -C -C SLICOT RELEASE 5.0. -C -C Copyright (c) 2002-2009 NICONET e.V. -C -C This program is free software: you can redistribute it and/or -C modify it under the terms of the GNU General Public License as -C published by the Free Software Foundation, either version 2 of -C the License, or (at your option) any later version. -C -C This program is distributed in the hope that it will be useful, -C but WITHOUT ANY WARRANTY; without even the implied warranty of -C MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the -C GNU General Public License for more details. -C -C You should have received a copy of the GNU General Public License -C along with this program. If not, see -C . -C -C PURPOSE -C -C To solve for X either the real continuous-time Lyapunov equation -C -C op(A)'*X + X*op(A) = scale*C (1) -C -C or the real discrete-time Lyapunov equation -C -C op(A)'*X*op(A) - X = scale*C (2) -C -C and/or estimate an associated condition number, called separation, -C where op(A) = A or A' (A**T) and C is symmetric (C = C'). -C (A' denotes the transpose of the matrix A.) A is N-by-N, the right -C hand side C and the solution X are N-by-N, and scale is an output -C scale factor, set less than or equal to 1 to avoid overflow in X. -C -C ARGUMENTS -C -C Mode Parameters -C -C DICO CHARACTER*1 -C Specifies the equation from which X is to be determined -C as follows: -C = 'C': Equation (1), continuous-time case; -C = 'D': Equation (2), discrete-time case. -C -C JOB CHARACTER*1 -C Specifies the computation to be performed, as follows: -C = 'X': Compute the solution only; -C = 'S': Compute the separation only; -C = 'B': Compute both the solution and the separation. -C -C FACT CHARACTER*1 -C Specifies whether or not the real Schur factorization -C of the matrix A is supplied on entry, as follows: -C = 'F': On entry, A and U contain the factors from the -C real Schur factorization of the matrix A; -C = 'N': The Schur factorization of A will be computed -C and the factors will be stored in A and U. -C -C TRANA CHARACTER*1 -C Specifies the form of op(A) to be used, as follows: -C = 'N': op(A) = A (No transpose); -C = 'T': op(A) = A**T (Transpose); -C = 'C': op(A) = A**T (Conjugate transpose = Transpose). -C -C Input/Output Parameters -C -C N (input) INTEGER -C The order of the matrices A, X, and C. N >= 0. -C -C A (input/output) DOUBLE PRECISION array, dimension (LDA,N) -C On entry, the leading N-by-N part of this array must -C contain the matrix A. If FACT = 'F', then A contains -C an upper quasi-triangular matrix in Schur canonical form; -C the elements below the upper Hessenberg part of the -C array A are not referenced. -C On exit, if INFO = 0 or INFO = N+1, the leading N-by-N -C upper Hessenberg part of this array contains the upper -C quasi-triangular matrix in Schur canonical form from the -C Schur factorization of A. The contents of array A is not -C modified if FACT = 'F'. -C -C LDA INTEGER -C The leading dimension of array A. LDA >= MAX(1,N). -C -C U (input or output) DOUBLE PRECISION array, dimension -C (LDU,N) -C If FACT = 'F', then U is an input argument and on entry -C the leading N-by-N part of this array must contain the -C orthogonal matrix U of the real Schur factorization of A. -C If FACT = 'N', then U is an output argument and on exit, -C if INFO = 0 or INFO = N+1, it contains the orthogonal -C N-by-N matrix from the real Schur factorization of A. -C -C LDU INTEGER -C The leading dimension of array U. LDU >= MAX(1,N). -C -C C (input/output) DOUBLE PRECISION array, dimension (LDC,N) -C On entry with JOB = 'X' or 'B', the leading N-by-N part of -C this array must contain the symmetric matrix C. -C On exit with JOB = 'X' or 'B', if INFO = 0 or INFO = N+1, -C the leading N-by-N part of C has been overwritten by the -C symmetric solution matrix X. -C If JOB = 'S', C is not referenced. -C -C LDC INTEGER -C The leading dimension of array C. -C LDC >= 1, if JOB = 'S'; -C LDC >= MAX(1,N), otherwise. -C -C SCALE (output) DOUBLE PRECISION -C The scale factor, scale, set less than or equal to 1 to -C prevent the solution overflowing. -C -C SEP (output) DOUBLE PRECISION -C If JOB = 'S' or JOB = 'B', and INFO = 0 or INFO = N+1, SEP -C contains the estimated separation of the matrices op(A) -C and -op(A)', if DICO = 'C' or of op(A) and op(A)', if -C DICO = 'D'. -C If JOB = 'X' or N = 0, SEP is not referenced. -C -C FERR (output) DOUBLE PRECISION -C If JOB = 'B', and INFO = 0 or INFO = N+1, FERR contains an -C estimated forward error bound for the solution X. -C If XTRUE is the true solution, FERR bounds the relative -C error in the computed solution, measured in the Frobenius -C norm: norm(X - XTRUE)/norm(XTRUE). -C If JOB = 'X' or JOB = 'S', FERR is not referenced. -C -C WR (output) DOUBLE PRECISION array, dimension (N) -C WI (output) DOUBLE PRECISION array, dimension (N) -C If FACT = 'N', and INFO = 0 or INFO = N+1, WR and WI -C contain the real and imaginary parts, respectively, of -C the eigenvalues of A. -C If FACT = 'F', WR and WI are not referenced. -C -C Workspace -C -C IWORK INTEGER array, dimension (N*N) -C This array is not referenced if JOB = 'X'. -C -C DWORK DOUBLE PRECISION array, dimension (LDWORK) -C On exit, if INFO = 0 or INFO = N+1, DWORK(1) returns the -C optimal value of LDWORK. -C -C LDWORK INTEGER -C The length of the array DWORK. LDWORK >= 1, and -C If JOB = 'X' then -C If FACT = 'F', LDWORK >= N*N, for DICO = 'C'; -C LDWORK >= MAX(N*N, 2*N), for DICO = 'D'; -C If FACT = 'N', LDWORK >= MAX(N*N, 3*N). -C If JOB = 'S' or JOB = 'B' then -C If FACT = 'F', LDWORK >= 2*N*N, for DICO = 'C'; -C LDWORK >= 2*N*N + 2*N, for DICO = 'D'. -C If FACT = 'N', LDWORK >= MAX(2*N*N, 3*N), DICO = 'C'; -C LDWORK >= 2*N*N + 2*N, for DICO = 'D'. -C For optimum performance LDWORK should be larger. -C -C Error Indicator -C -C INFO INTEGER -C = 0: successful exit; -C < 0: if INFO = -i, the i-th argument had an illegal -C value; -C > 0: if INFO = i, the QR algorithm failed to compute all -C the eigenvalues (see LAPACK Library routine DGEES); -C elements i+1:n of WR and WI contain eigenvalues -C which have converged, and A contains the partially -C converged Schur form; -C = N+1: if DICO = 'C', and the matrices A and -A' have -C common or very close eigenvalues, or -C if DICO = 'D', and matrix A has almost reciprocal -C eigenvalues (that is, lambda(i) = 1/lambda(j) for -C some i and j, where lambda(i) and lambda(j) are -C eigenvalues of A and i <> j); perturbed values were -C used to solve the equation (but the matrix A is -C unchanged). -C -C METHOD -C -C The Schur factorization of a square matrix A is given by -C -C A = U*S*U' -C -C where U is orthogonal and S is block upper triangular with 1-by-1 -C and 2-by-2 blocks on its diagonal, these blocks corresponding to -C the eigenvalues of A, the 2-by-2 blocks being complex conjugate -C pairs. This factorization is obtained by numerically stable -C methods: first A is reduced to upper Hessenberg form (if FACT = -C 'N') by means of Householder transformations and then the -C QR Algorithm is applied to reduce the Hessenberg form to S, the -C transformation matrices being accumulated at each step to give U. -C If A has already been factorized prior to calling the routine -C however, then the factors U and S may be supplied and the initial -C factorization omitted. -C _ _ -C If we now put C = U'CU and X = UXU' equations (1) and (2) (see -C PURPOSE) become (for TRANS = 'N') -C _ _ _ -C S'X + XS = C, (3) -C and -C _ _ _ -C S'XS - X = C, (4) -C -C respectively. Partition S, C and X as -C _ _ _ _ -C (s s') (c c') (x x') -C ( 11 ) _ ( 11 ) _ ( 11 ) -C S = ( ), C = ( ), X = ( ) -C ( ) ( _ ) ( _ ) -C ( 0 S ) ( c C ) ( x X ) -C 1 1 1 -C _ _ -C where s , c and x are either scalars or 2-by-2 matrices and s, -C 11 11 11 -C _ _ -C c and x are either (N-1) element vectors or matrices with two -C columns. Equations (3) and (4) can then be re-written as -C _ _ _ -C s' x + x s = c (3.1) -C 11 11 11 11 11 -C -C _ _ _ _ -C S'x + xs = c - sx (3.2) -C 1 11 11 -C -C _ _ -C S'X + X S = C - (sx' + xs') (3.3) -C 1 1 1 1 1 -C and -C _ _ _ -C s' x s - x = c (4.1) -C 11 11 11 11 11 -C -C _ _ _ _ -C S'xs - x = c - sx s (4.2) -C 1 11 11 11 -C -C _ _ _ -C S'X S - X = C - sx s' - [s(S'x)' + (S'x)s'] (4.3) -C 1 1 1 1 1 11 1 1 -C _ -C respectively. If DICO = 'C' ['D'], then once x has been -C 11 -C found from equation (3.1) [(4.1)], equation (3.2) [(4.2)] can be -C _ -C solved by forward substitution for x and then equation (3.3) -C [(4.3)] is of the same form as (3) [(4)] but of the order (N-1) or -C (N-2) depending upon whether s is 1-by-1 or 2-by-2. -C 11 -C _ _ -C When s is 2-by-2 then x and c will be 1-by-2 matrices and s, -C 11 11 11 -C _ _ -C x and c are matrices with two columns. In this case, equation -C (3.1) [(4.1)] defines the three equations in the unknown elements -C _ -C of x and equation (3.2) [(4.2)] can then be solved by forward -C 11 _ -C substitution, a row of x being found at each step. -C -C REFERENCES -C -C [1] Barraud, A.Y. T -C A numerical algorithm to solve A XA - X = Q. -C IEEE Trans. Auto. Contr., AC-22, pp. 883-885, 1977. -C -C [2] Bartels, R.H. and Stewart, G.W. T -C Solution of the matrix equation A X + XB = C. -C Comm. A.C.M., 15, pp. 820-826, 1972. -C -C [3] Hammarling, S.J. -C Numerical solution of the stable, non-negative definite -C Lyapunov equation. -C IMA J. Num. Anal., 2, pp. 303-325, 1982. -C -C NUMERICAL ASPECTS -C 3 -C The algorithm requires 0(N ) operations and is backward stable. -C -C FURTHER COMMENTS -C -C If DICO = 'C', SEP is defined as the separation of op(A) and -C -op(A)': -C -C sep( op(A), -op(A)' ) = sigma_min( T ) -C -C and if DICO = 'D', SEP is defined as -C -C sep( op(A), op(A)' ) = sigma_min( T ) -C -C where sigma_min(T) is the smallest singular value of the -C N*N-by-N*N matrix -C -C T = kprod( I(N), op(A)' ) + kprod( op(A)', I(N) ) (DICO = 'C'), -C -C T = kprod( op(A)', op(A)' ) - I(N**2) (DICO = 'D'). -C -C I(x) is an x-by-x identity matrix, and kprod denotes the Kronecker -C product. The program estimates sigma_min(T) by the reciprocal of -C an estimate of the 1-norm of inverse(T). The true reciprocal -C 1-norm of inverse(T) cannot differ from sigma_min(T) by more -C than a factor of N. -C -C When SEP is small, small changes in A, C can cause large changes -C in the solution of the equation. An approximate bound on the -C maximum relative error in the computed solution is -C -C EPS * norm(A) / SEP (DICO = 'C'), -C -C EPS * norm(A)**2 / SEP (DICO = 'D'), -C -C where EPS is the machine precision. -C -C CONTRIBUTOR -C -C Release 3.0: V. Sima, Katholieke Univ. Leuven, Belgium, July 1997. -C Supersedes Release 2.0 routine SB03AD by Control Systems Research -C Group, Kingston Polytechnic, United Kingdom. -C -C REVISIONS -C -C V. Sima, Katholieke Univ. Leuven, Belgium, May 1999. -C -C KEYWORDS -C -C Lyapunov equation, orthogonal transformation, real Schur form, -C Sylvester equation. -C -C ****************************************************************** -C -C .. Parameters .. - DOUBLE PRECISION ZERO, ONE - PARAMETER ( ZERO = 0.0D0, ONE = 1.0D0 ) -C .. Scalar Arguments .. - CHARACTER DICO, FACT, JOB, TRANA - INTEGER INFO, LDA, LDC, LDU, LDWORK, N - DOUBLE PRECISION FERR, SCALE, SEP -C .. Array Arguments .. - INTEGER IWORK( * ) - DOUBLE PRECISION A( LDA, * ), C( LDC, * ), DWORK( * ), - $ U( LDU, * ), WI( * ), WR( * ) -C .. Local Scalars .. - LOGICAL CONT, NOFACT, NOTA, WANTBH, WANTSP, WANTX - CHARACTER NOTRA, NTRNST, TRANST, UPLO - INTEGER I, IERR, KASE, LWA, MINWRK, NN, NN2, SDIM - DOUBLE PRECISION EPS, EST, SCALEF -C .. Local Arrays .. - LOGICAL BWORK( 1 ) -C .. External Functions .. - LOGICAL LSAME, SELECT - DOUBLE PRECISION DLAMCH, DLANHS - EXTERNAL DLAMCH, DLANHS, LSAME, SELECT -C .. External Subroutines .. - EXTERNAL DCOPY, DGEES, DLACON, MB01RD, SB03MX, SB03MY, - $ XERBLA -C .. Intrinsic Functions .. - INTRINSIC DBLE, INT, MAX -C .. Executable Statements .. -C -C Decode and Test input parameters. -C - CONT = LSAME( DICO, 'C' ) - WANTX = LSAME( JOB, 'X' ) - WANTSP = LSAME( JOB, 'S' ) - WANTBH = LSAME( JOB, 'B' ) - NOFACT = LSAME( FACT, 'N' ) - NOTA = LSAME( TRANA, 'N' ) - NN = N*N - NN2 = 2*NN -C - INFO = 0 - IF( .NOT.CONT .AND. .NOT.LSAME( DICO, 'D' ) ) THEN - INFO = -1 - ELSE IF( .NOT.WANTBH .AND. .NOT.WANTSP .AND. .NOT.WANTX ) THEN - INFO = -2 - ELSE IF( .NOT.NOFACT .AND. .NOT.LSAME( FACT, 'F' ) ) THEN - INFO = -3 - ELSE IF( .NOT.NOTA .AND. .NOT.LSAME( TRANA, 'T' ) .AND. - $ .NOT.LSAME( TRANA, 'C' ) ) THEN - INFO = -4 - ELSE IF( N.LT.0 ) THEN - INFO = -5 - ELSE IF( LDA.LT.MAX( 1, N ) ) THEN - INFO = -7 - ELSE IF( LDU.LT.MAX( 1, N ) ) THEN - INFO = -9 - ELSE IF( WANTSP .AND. LDC.LT.1 .OR. - $ .NOT.WANTSP .AND. LDC.LT.MAX( 1, N ) ) THEN - INFO = -11 - ELSE - IF ( WANTX ) THEN - IF ( NOFACT ) THEN - MINWRK = MAX( NN, 3*N ) - ELSE IF ( CONT ) THEN - MINWRK = NN - ELSE - MINWRK = MAX( NN, 2*N ) - END IF - ELSE - IF ( CONT ) THEN - IF ( NOFACT ) THEN - MINWRK = MAX( NN2, 3*N ) - ELSE - MINWRK = NN2 - END IF - ELSE - MINWRK = NN2 + 2*N - END IF - END IF - IF( LDWORK.LT.MAX( 1, MINWRK ) ) - $ INFO = -19 - END IF -C - IF ( INFO.NE.0 ) THEN -C -C Error return. -C - CALL XERBLA( 'SB03MD', -INFO ) - RETURN - END IF -C -C Quick return if possible. -C - IF( N.EQ.0 ) THEN - SCALE = ONE - IF( WANTBH ) - $ FERR = ZERO - DWORK(1) = ONE - RETURN - END IF -C - LWA = 0 -C - IF( NOFACT ) THEN -C -C Compute the Schur factorization of A. -C Workspace: need 3*N; -C prefer larger. -C (Note: Comments in the code beginning "Workspace:" describe the -C minimal amount of real workspace needed at that point in the -C code, as well as the preferred amount for good performance. -C NB refers to the optimal block size for the immediately -C following subroutine, as returned by ILAENV.) -C - CALL DGEES( 'Vectors', 'Not ordered', SELECT, N, A, LDA, SDIM, - $ WR, WI, U, LDU, DWORK, LDWORK, BWORK, INFO ) - IF( INFO.GT.0 ) - $ RETURN - LWA = INT( DWORK( 1 ) ) - END IF -C - IF( .NOT.WANTSP ) THEN -C -C Transform the right-hand side. -C Workspace: N*N. -C - NTRNST = 'N' - TRANST = 'T' - UPLO = 'U' - CALL MB01RD( UPLO, TRANST, N, N, ZERO, ONE, C, LDC, U, LDU, C, - $ LDC, DWORK, LDWORK, INFO ) -C - DO 10 I = 2, N - CALL DCOPY( I-1, C(1,I), 1, C(I,1), LDC ) - 10 CONTINUE -C - LWA = MAX( LWA, NN ) -C -C Solve the transformed equation. -C Workspace for DICO = 'D': 2*N. -C - IF ( CONT ) THEN - CALL SB03MY( TRANA, N, A, LDA, C, LDC, SCALE, INFO ) - ELSE - CALL SB03MX( TRANA, N, A, LDA, C, LDC, SCALE, DWORK, INFO ) - END IF - IF( INFO.GT.0 ) - $ INFO = N + 1 -C -C Transform back the solution. -C Workspace: N*N. -C - CALL MB01RD( UPLO, NTRNST, N, N, ZERO, ONE, C, LDC, U, LDU, C, - $ LDC, DWORK, LDWORK, IERR ) -C - DO 20 I = 2, N - CALL DCOPY( I-1, C(1,I), 1, C(I,1), LDC ) - 20 CONTINUE -C - END IF -C - IF( .NOT.WANTX ) THEN -C -C Estimate the separation. -C Workspace: 2*N*N for DICO = 'C'; -C 2*N*N + 2*N for DICO = 'D'. -C - IF( NOTA ) THEN - NOTRA = 'T' - ELSE - NOTRA = 'N' - END IF -C - EST = ZERO - KASE = 0 -C REPEAT - 30 CONTINUE - CALL DLACON( NN, DWORK(NN+1), DWORK, IWORK, EST, KASE ) - IF( KASE.NE.0 ) THEN - IF( KASE.EQ.1 ) THEN - IF( CONT ) THEN - CALL SB03MY( TRANA, N, A, LDA, DWORK, N, SCALEF, - $ IERR ) - ELSE - CALL SB03MX( TRANA, N, A, LDA, DWORK, N, SCALEF, - $ DWORK(NN2+1), IERR ) - END IF - ELSE - IF( CONT ) THEN - CALL SB03MY( NOTRA, N, A, LDA, DWORK, N, SCALEF, - $ IERR ) - ELSE - CALL SB03MX( NOTRA, N, A, LDA, DWORK, N, SCALEF, - $ DWORK(NN2+1), IERR ) - END IF - END IF - GO TO 30 - END IF -C UNTIL KASE = 0 -C - SEP = SCALEF / EST -C - IF( WANTBH ) THEN -C -C Get the machine precision. -C - EPS = DLAMCH( 'P' ) -C -C Compute the estimate of the relative error. -C - IF ( CONT ) THEN - FERR = EPS*DLANHS( 'Frobenius', N, A, LDA, DWORK )/SEP - ELSE - FERR = EPS*DLANHS( 'Frobenius', N, A, LDA, DWORK )**2/SEP - END IF - END IF - END IF -C - DWORK( 1 ) = DBLE( MAX( LWA, MINWRK ) ) - RETURN -C *** Last line of SB03MD *** - END diff --git a/mex/sources/libslicot/SB03MU.f b/mex/sources/libslicot/SB03MU.f deleted file mode 100644 index 69ddd7429..000000000 --- a/mex/sources/libslicot/SB03MU.f +++ /dev/null @@ -1,467 +0,0 @@ - SUBROUTINE SB03MU( LTRANL, LTRANR, ISGN, N1, N2, TL, LDTL, TR, - $ LDTR, B, LDB, SCALE, X, LDX, XNORM, INFO ) -C -C SLICOT RELEASE 5.0. -C -C Copyright (c) 2002-2009 NICONET e.V. -C -C This program is free software: you can redistribute it and/or -C modify it under the terms of the GNU General Public License as -C published by the Free Software Foundation, either version 2 of -C the License, or (at your option) any later version. -C -C This program is distributed in the hope that it will be useful, -C but WITHOUT ANY WARRANTY; without even the implied warranty of -C MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the -C GNU General Public License for more details. -C -C You should have received a copy of the GNU General Public License -C along with this program. If not, see -C . -C -C PURPOSE -C -C To solve for the N1-by-N2 matrix X, 1 <= N1,N2 <= 2, in -C -C ISGN*op(TL)*X*op(TR) - X = SCALE*B, -C -C where TL is N1-by-N1, TR is N2-by-N2, B is N1-by-N2, and ISGN = 1 -C or -1. op(T) = T or T', where T' denotes the transpose of T. -C -C ARGUMENTS -C -C Mode Parameters -C -C LTRANL LOGICAL -C Specifies the form of op(TL) to be used, as follows: -C = .FALSE.: op(TL) = TL, -C = .TRUE. : op(TL) = TL'. -C -C LTRANR LOGICAL -C Specifies the form of op(TR) to be used, as follows: -C = .FALSE.: op(TR) = TR, -C = .TRUE. : op(TR) = TR'. -C -C ISGN INTEGER -C Specifies the sign of the equation as described before. -C ISGN may only be 1 or -1. -C -C Input/Output Parameters -C -C N1 (input) INTEGER -C The order of matrix TL. N1 may only be 0, 1 or 2. -C -C N2 (input) INTEGER -C The order of matrix TR. N2 may only be 0, 1 or 2. -C -C TL (input) DOUBLE PRECISION array, dimension (LDTL,2) -C The leading N1-by-N1 part of this array must contain the -C matrix TL. -C -C LDTL INTEGER -C The leading dimension of array TL. LDTL >= MAX(1,N1). -C -C TR (input) DOUBLE PRECISION array, dimension (LDTR,2) -C The leading N2-by-N2 part of this array must contain the -C matrix TR. -C -C LDTR INTEGER -C The leading dimension of array TR. LDTR >= MAX(1,N2). -C -C B (input) DOUBLE PRECISION array, dimension (LDB,2) -C The leading N1-by-N2 part of this array must contain the -C right-hand side of the equation. -C -C LDB INTEGER -C The leading dimension of array B. LDB >= MAX(1,N1). -C -C SCALE (output) DOUBLE PRECISION -C The scale factor. SCALE is chosen less than or equal to 1 -C to prevent the solution overflowing. -C -C X (output) DOUBLE PRECISION array, dimension (LDX,N2) -C The leading N1-by-N2 part of this array contains the -C solution of the equation. -C Note that X may be identified with B in the calling -C statement. -C -C LDX INTEGER -C The leading dimension of array X. LDX >= MAX(1,N1). -C -C XNORM (output) DOUBLE PRECISION -C The infinity-norm of the solution. -C -C Error Indicator -C -C INFO INTEGER -C = 0: successful exit; -C = 1: if TL and TR have almost reciprocal eigenvalues, so -C TL or TR is perturbed to get a nonsingular equation. -C -C NOTE: In the interests of speed, this routine does not -C check the inputs for errors. -C -C METHOD -C -C The equivalent linear algebraic system of equations is formed and -C solved using Gaussian elimination with complete pivoting. -C -C REFERENCES -C -C [1] Anderson, E., Bai, Z., Bischof, C., Demmel, J., Dongarra, J., -C Du Croz, J., Greenbaum, A., Hammarling, S., McKenney, A., -C Ostrouchov, S., and Sorensen, D. -C LAPACK Users' Guide: Second Edition. -C SIAM, Philadelphia, 1995. -C -C NUMERICAL ASPECTS -C -C The algorithm is stable and reliable, since Gaussian elimination -C with complete pivoting is used. -C -C CONTRIBUTOR -C -C Release 3.0: V. Sima, Katholieke Univ. Leuven, Belgium, May 1997. -C Based on DLASD2 by P. Petkov, Tech. University of Sofia, September -C 1993. -C -C REVISIONS -C -C V. Sima, Katholieke Univ. Leuven, Belgium, May 1999. -C -C KEYWORDS -C -C Discrete-time system, Sylvester equation, matrix algebra. -C -C ****************************************************************** -C -C .. Parameters .. - DOUBLE PRECISION ZERO, ONE, TWO, HALF, EIGHT - PARAMETER ( ZERO = 0.0D+0, ONE = 1.0D+0, - $ TWO = 2.0D+0, HALF = 0.5D+0, EIGHT = 8.0D+0 ) -C .. -C .. Scalar Arguments .. - LOGICAL LTRANL, LTRANR - INTEGER INFO, ISGN, LDB, LDTL, LDTR, LDX, N1, N2 - DOUBLE PRECISION SCALE, XNORM -C .. -C .. Array Arguments .. - DOUBLE PRECISION B( LDB, * ), TL( LDTL, * ), TR( LDTR, * ), - $ X( LDX, * ) -C .. -C .. Local Scalars .. - LOGICAL BSWAP, XSWAP - INTEGER I, IP, IPIV, IPSV, J, JP, JPSV, K - DOUBLE PRECISION BET, EPS, GAM, L21, SGN, SMIN, SMLNUM, TAU1, - $ TEMP, U11, U12, U22, XMAX -C .. -C .. Local Arrays .. - LOGICAL BSWPIV( 4 ), XSWPIV( 4 ) - INTEGER JPIV( 4 ), LOCL21( 4 ), LOCU12( 4 ), - $ LOCU22( 4 ) - DOUBLE PRECISION BTMP( 4 ), T16( 4, 4 ), TMP( 4 ), X2( 2 ) -C .. -C .. External Functions .. - INTEGER IDAMAX - DOUBLE PRECISION DLAMCH - EXTERNAL DLAMCH, IDAMAX -C .. -C .. External Subroutines .. - EXTERNAL DSWAP -C .. -C .. Intrinsic Functions .. - INTRINSIC ABS, MAX -C .. -C .. Data statements .. - DATA LOCU12 / 3, 4, 1, 2 / , LOCL21 / 2, 1, 4, 3 / , - $ LOCU22 / 4, 3, 2, 1 / - DATA XSWPIV / .FALSE., .FALSE., .TRUE., .TRUE. / - DATA BSWPIV / .FALSE., .TRUE., .FALSE., .TRUE. / -C .. -C .. Executable Statements .. -C -C Do not check the input parameters for errors. -C - INFO = 0 - SCALE = ONE -C -C Quick return if possible. -C - IF( N1.EQ.0 .OR. N2.EQ.0 ) THEN - XNORM = ZERO - RETURN - END IF -C -C Set constants to control overflow. -C - EPS = DLAMCH( 'P' ) - SMLNUM = DLAMCH( 'S' ) / EPS - SGN = ISGN -C - K = N1 + N1 + N2 - 2 - GO TO ( 10, 20, 30, 50 )K -C -C 1-by-1: SGN*TL11*X*TR11 - X = B11. -C - 10 CONTINUE - TAU1 = SGN*TL( 1, 1 )*TR( 1, 1 ) - ONE - BET = ABS( TAU1 ) - IF( BET.LE.SMLNUM ) THEN - TAU1 = SMLNUM - BET = SMLNUM - INFO = 1 - END IF -C - GAM = ABS( B( 1, 1 ) ) - IF( SMLNUM*GAM.GT.BET ) - $ SCALE = ONE / GAM -C - X( 1, 1 ) = ( B( 1, 1 )*SCALE ) / TAU1 - XNORM = ABS( X( 1, 1 ) ) - RETURN -C -C 1-by-2: -C ISGN*TL11*[X11 X12]*op[TR11 TR12] = [B11 B12]. -C [TR21 TR22] -C - 20 CONTINUE -C - SMIN = MAX( MAX( ABS( TR( 1, 1 ) ), ABS( TR( 1, 2 ) ), - $ ABS( TR( 2, 1 ) ), ABS( TR( 2, 2 ) ) ) - $ *ABS( TL( 1, 1 ) )*EPS, - $ SMLNUM ) - TMP( 1 ) = SGN*TL( 1, 1 )*TR( 1, 1 ) - ONE - TMP( 4 ) = SGN*TL( 1, 1 )*TR( 2, 2 ) - ONE - IF( LTRANR ) THEN - TMP( 2 ) = SGN*TL( 1, 1 )*TR( 2, 1 ) - TMP( 3 ) = SGN*TL( 1, 1 )*TR( 1, 2 ) - ELSE - TMP( 2 ) = SGN*TL( 1, 1 )*TR( 1, 2 ) - TMP( 3 ) = SGN*TL( 1, 1 )*TR( 2, 1 ) - END IF - BTMP( 1 ) = B( 1, 1 ) - BTMP( 2 ) = B( 1, 2 ) - GO TO 40 -C -C 2-by-1: -C ISGN*op[TL11 TL12]*[X11]*TR11 = [B11]. -C [TL21 TL22] [X21] [B21] -C - 30 CONTINUE - SMIN = MAX( MAX( ABS( TL( 1, 1 ) ), ABS( TL( 1, 2 ) ), - $ ABS( TL( 2, 1 ) ), ABS( TL( 2, 2 ) ) ) - $ *ABS( TR( 1, 1 ) )*EPS, - $ SMLNUM ) - TMP( 1 ) = SGN*TL( 1, 1 )*TR( 1, 1 ) - ONE - TMP( 4 ) = SGN*TL( 2, 2 )*TR( 1, 1 ) - ONE - IF( LTRANL ) THEN - TMP( 2 ) = SGN*TL( 1, 2 )*TR( 1, 1 ) - TMP( 3 ) = SGN*TL( 2, 1 )*TR( 1, 1 ) - ELSE - TMP( 2 ) = SGN*TL( 2, 1 )*TR( 1, 1 ) - TMP( 3 ) = SGN*TL( 1, 2 )*TR( 1, 1 ) - END IF - BTMP( 1 ) = B( 1, 1 ) - BTMP( 2 ) = B( 2, 1 ) - 40 CONTINUE -C -C Solve 2-by-2 system using complete pivoting. -C Set pivots less than SMIN to SMIN. -C - IPIV = IDAMAX( 4, TMP, 1 ) - U11 = TMP( IPIV ) - IF( ABS( U11 ).LE.SMIN ) THEN - INFO = 1 - U11 = SMIN - END IF - U12 = TMP( LOCU12( IPIV ) ) - L21 = TMP( LOCL21( IPIV ) ) / U11 - U22 = TMP( LOCU22( IPIV ) ) - U12*L21 - XSWAP = XSWPIV( IPIV ) - BSWAP = BSWPIV( IPIV ) - IF( ABS( U22 ).LE.SMIN ) THEN - INFO = 1 - U22 = SMIN - END IF - IF( BSWAP ) THEN - TEMP = BTMP( 2 ) - BTMP( 2 ) = BTMP( 1 ) - L21*TEMP - BTMP( 1 ) = TEMP - ELSE - BTMP( 2 ) = BTMP( 2 ) - L21*BTMP( 1 ) - END IF - IF( ( TWO*SMLNUM )*ABS( BTMP( 2 ) ).GT.ABS( U22 ) .OR. - $ ( TWO*SMLNUM )*ABS( BTMP( 1 ) ).GT.ABS( U11 ) ) THEN - SCALE = HALF / MAX( ABS( BTMP( 1 ) ), ABS( BTMP( 2 ) ) ) - BTMP( 1 ) = BTMP( 1 )*SCALE - BTMP( 2 ) = BTMP( 2 )*SCALE - END IF - X2( 2 ) = BTMP( 2 ) / U22 - X2( 1 ) = BTMP( 1 ) / U11 - ( U12 / U11 )*X2( 2 ) - IF( XSWAP ) THEN - TEMP = X2( 2 ) - X2( 2 ) = X2( 1 ) - X2( 1 ) = TEMP - END IF - X( 1, 1 ) = X2( 1 ) - IF( N1.EQ.1 ) THEN - X( 1, 2 ) = X2( 2 ) - XNORM = ABS( X2( 1 ) ) + ABS( X2( 2 ) ) - ELSE - X( 2, 1 ) = X2( 2 ) - XNORM = MAX( ABS( X2( 1 ) ), ABS( X2( 2 ) ) ) - END IF - RETURN -C -C 2-by-2: -C ISGN*op[TL11 TL12]*[X11 X12]*op[TR11 TR12]-[X11 X12] = [B11 B12]. -C [TL21 TL22] [X21 X22] [TR21 TR22] [X21 X22] [B21 B22] -C -C Solve equivalent 4-by-4 system using complete pivoting. -C Set pivots less than SMIN to SMIN. -C - 50 CONTINUE - SMIN = MAX( ABS( TR( 1, 1 ) ), ABS( TR( 1, 2 ) ), - $ ABS( TR( 2, 1 ) ), ABS( TR( 2, 2 ) ) ) - SMIN = MAX( ABS( TL( 1, 1 ) ), ABS( TL( 1, 2 ) ), - $ ABS( TL( 2, 1 ) ), ABS( TL( 2, 2 ) ) )*SMIN - SMIN = MAX( EPS*SMIN, SMLNUM ) - T16( 1, 1 ) = SGN*TL( 1, 1 )*TR( 1, 1 ) - ONE - T16( 2, 2 ) = SGN*TL( 2, 2 )*TR( 1, 1 ) - ONE - T16( 3, 3 ) = SGN*TL( 1, 1 )*TR( 2, 2 ) - ONE - T16( 4, 4 ) = SGN*TL( 2, 2 )*TR( 2, 2 ) - ONE - IF( LTRANL ) THEN - T16( 1, 2 ) = SGN*TL( 2, 1 )*TR( 1, 1 ) - T16( 2, 1 ) = SGN*TL( 1, 2 )*TR( 1, 1 ) - T16( 3, 4 ) = SGN*TL( 2, 1 )*TR( 2, 2 ) - T16( 4, 3 ) = SGN*TL( 1, 2 )*TR( 2, 2 ) - ELSE - T16( 1, 2 ) = SGN*TL( 1, 2 )*TR( 1, 1 ) - T16( 2, 1 ) = SGN*TL( 2, 1 )*TR( 1, 1 ) - T16( 3, 4 ) = SGN*TL( 1, 2 )*TR( 2, 2 ) - T16( 4, 3 ) = SGN*TL( 2, 1 )*TR( 2, 2 ) - END IF - IF( LTRANR ) THEN - T16( 1, 3 ) = SGN*TL( 1, 1 )*TR( 1, 2 ) - T16( 2, 4 ) = SGN*TL( 2, 2 )*TR( 1, 2 ) - T16( 3, 1 ) = SGN*TL( 1, 1 )*TR( 2, 1 ) - T16( 4, 2 ) = SGN*TL( 2, 2 )*TR( 2, 1 ) - ELSE - T16( 1, 3 ) = SGN*TL( 1, 1 )*TR( 2, 1 ) - T16( 2, 4 ) = SGN*TL( 2, 2 )*TR( 2, 1 ) - T16( 3, 1 ) = SGN*TL( 1, 1 )*TR( 1, 2 ) - T16( 4, 2 ) = SGN*TL( 2, 2 )*TR( 1, 2 ) - END IF - IF( LTRANL .AND. LTRANR ) THEN - T16( 1, 4 ) = SGN*TL( 2, 1 )*TR( 1, 2 ) - T16( 2, 3 ) = SGN*TL( 1, 2 )*TR( 1, 2 ) - T16( 3, 2 ) = SGN*TL( 2, 1 )*TR( 2, 1 ) - T16( 4, 1 ) = SGN*TL( 1, 2 )*TR( 2, 1 ) - ELSE IF( LTRANL .AND. .NOT.LTRANR ) THEN - T16( 1, 4 ) = SGN*TL( 2, 1 )*TR( 2, 1 ) - T16( 2, 3 ) = SGN*TL( 1, 2 )*TR( 2, 1 ) - T16( 3, 2 ) = SGN*TL( 2, 1 )*TR( 1, 2 ) - T16( 4, 1 ) = SGN*TL( 1, 2 )*TR( 1, 2 ) - ELSE IF( .NOT.LTRANL .AND. LTRANR ) THEN - T16( 1, 4 ) = SGN*TL( 1, 2 )*TR( 1, 2 ) - T16( 2, 3 ) = SGN*TL( 2, 1 )*TR( 1, 2 ) - T16( 3, 2 ) = SGN*TL( 1, 2 )*TR( 2, 1 ) - T16( 4, 1 ) = SGN*TL( 2, 1 )*TR( 2, 1 ) - ELSE - T16( 1, 4 ) = SGN*TL( 1, 2 )*TR( 2, 1 ) - T16( 2, 3 ) = SGN*TL( 2, 1 )*TR( 2, 1 ) - T16( 3, 2 ) = SGN*TL( 1, 2 )*TR( 1, 2 ) - T16( 4, 1 ) = SGN*TL( 2, 1 )*TR( 1, 2 ) - END IF - BTMP( 1 ) = B( 1, 1 ) - BTMP( 2 ) = B( 2, 1 ) - BTMP( 3 ) = B( 1, 2 ) - BTMP( 4 ) = B( 2, 2 ) -C -C Perform elimination -C - DO 100 I = 1, 3 - XMAX = ZERO -C - DO 70 IP = I, 4 -C - DO 60 JP = I, 4 - IF( ABS( T16( IP, JP ) ).GE.XMAX ) THEN - XMAX = ABS( T16( IP, JP ) ) - IPSV = IP - JPSV = JP - END IF - 60 CONTINUE -C - 70 CONTINUE -C - IF( IPSV.NE.I ) THEN - CALL DSWAP( 4, T16( IPSV, 1 ), 4, T16( I, 1 ), 4 ) - TEMP = BTMP( I ) - BTMP( I ) = BTMP( IPSV ) - BTMP( IPSV ) = TEMP - END IF - IF( JPSV.NE.I ) - $ CALL DSWAP( 4, T16( 1, JPSV ), 1, T16( 1, I ), 1 ) - JPIV( I ) = JPSV - IF( ABS( T16( I, I ) ).LT.SMIN ) THEN - INFO = 1 - T16( I, I ) = SMIN - END IF -C - DO 90 J = I + 1, 4 - T16( J, I ) = T16( J, I ) / T16( I, I ) - BTMP( J ) = BTMP( J ) - T16( J, I )*BTMP( I ) -C - DO 80 K = I + 1, 4 - T16( J, K ) = T16( J, K ) - T16( J, I )*T16( I, K ) - 80 CONTINUE -C - 90 CONTINUE -C - 100 CONTINUE -C - IF( ABS( T16( 4, 4 ) ).LT.SMIN ) - $ T16( 4, 4 ) = SMIN - IF( ( EIGHT*SMLNUM )*ABS( BTMP( 1 ) ).GT.ABS( T16( 1, 1 ) ) .OR. - $ ( EIGHT*SMLNUM )*ABS( BTMP( 2 ) ).GT.ABS( T16( 2, 2 ) ) .OR. - $ ( EIGHT*SMLNUM )*ABS( BTMP( 3 ) ).GT.ABS( T16( 3, 3 ) ) .OR. - $ ( EIGHT*SMLNUM )*ABS( BTMP( 4 ) ).GT.ABS( T16( 4, 4 ) ) ) THEN - SCALE = ( ONE / EIGHT ) / MAX( ABS( BTMP( 1 ) ), - $ ABS( BTMP( 2 ) ), ABS( BTMP( 3 ) ), - $ ABS( BTMP( 4 ) ) ) - BTMP( 1 ) = BTMP( 1 )*SCALE - BTMP( 2 ) = BTMP( 2 )*SCALE - BTMP( 3 ) = BTMP( 3 )*SCALE - BTMP( 4 ) = BTMP( 4 )*SCALE - END IF -C - DO 120 I = 1, 4 - K = 5 - I - TEMP = ONE / T16( K, K ) - TMP( K ) = BTMP( K )*TEMP -C - DO 110 J = K + 1, 4 - TMP( K ) = TMP( K ) - ( TEMP*T16( K, J ) )*TMP( J ) - 110 CONTINUE -C - 120 CONTINUE -C - DO 130 I = 1, 3 - IF( JPIV( 4-I ).NE.4-I ) THEN - TEMP = TMP( 4-I ) - TMP( 4-I ) = TMP( JPIV( 4-I ) ) - TMP( JPIV( 4-I ) ) = TEMP - END IF - 130 CONTINUE -C - X( 1, 1 ) = TMP( 1 ) - X( 2, 1 ) = TMP( 2 ) - X( 1, 2 ) = TMP( 3 ) - X( 2, 2 ) = TMP( 4 ) - XNORM = MAX( ABS( TMP( 1 ) ) + ABS( TMP( 3 ) ), - $ ABS( TMP( 2 ) ) + ABS( TMP( 4 ) ) ) -C - RETURN -C *** Last line of SB03MU *** - END diff --git a/mex/sources/libslicot/SB03MV.f b/mex/sources/libslicot/SB03MV.f deleted file mode 100644 index 30dcc6af0..000000000 --- a/mex/sources/libslicot/SB03MV.f +++ /dev/null @@ -1,295 +0,0 @@ - SUBROUTINE SB03MV( LTRAN, LUPPER, T, LDT, B, LDB, SCALE, X, LDX, - $ XNORM, INFO ) -C -C SLICOT RELEASE 5.0. -C -C Copyright (c) 2002-2009 NICONET e.V. -C -C This program is free software: you can redistribute it and/or -C modify it under the terms of the GNU General Public License as -C published by the Free Software Foundation, either version 2 of -C the License, or (at your option) any later version. -C -C This program is distributed in the hope that it will be useful, -C but WITHOUT ANY WARRANTY; without even the implied warranty of -C MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the -C GNU General Public License for more details. -C -C You should have received a copy of the GNU General Public License -C along with this program. If not, see -C . -C -C PURPOSE -C -C To solve for the 2-by-2 symmetric matrix X in -C -C op(T)'*X*op(T) - X = SCALE*B, -C -C where T is 2-by-2, B is symmetric 2-by-2, and op(T) = T or T', -C where T' denotes the transpose of T. -C -C ARGUMENTS -C -C Mode Parameters -C -C LTRAN LOGICAL -C Specifies the form of op(T) to be used, as follows: -C = .FALSE.: op(T) = T, -C = .TRUE. : op(T) = T'. -C -C LUPPER LOGICAL -C Specifies which triangle of the matrix B is used, and -C which triangle of the matrix X is computed, as follows: -C = .TRUE. : The upper triangular part; -C = .FALSE.: The lower triangular part. -C -C Input/Output Parameters -C -C T (input) DOUBLE PRECISION array, dimension (LDT,2) -C The leading 2-by-2 part of this array must contain the -C matrix T. -C -C LDT INTEGER -C The leading dimension of array T. LDT >= 2. -C -C B (input) DOUBLE PRECISION array, dimension (LDB,2) -C On entry with LUPPER = .TRUE., the leading 2-by-2 upper -C triangular part of this array must contain the upper -C triangular part of the symmetric matrix B and the strictly -C lower triangular part of B is not referenced. -C On entry with LUPPER = .FALSE., the leading 2-by-2 lower -C triangular part of this array must contain the lower -C triangular part of the symmetric matrix B and the strictly -C upper triangular part of B is not referenced. -C -C LDB INTEGER -C The leading dimension of array B. LDB >= 2. -C -C SCALE (output) DOUBLE PRECISION -C The scale factor. SCALE is chosen less than or equal to 1 -C to prevent the solution overflowing. -C -C X (output) DOUBLE PRECISION array, dimension (LDX,2) -C On exit with LUPPER = .TRUE., the leading 2-by-2 upper -C triangular part of this array contains the upper -C triangular part of the symmetric solution matrix X and the -C strictly lower triangular part of X is not referenced. -C On exit with LUPPER = .FALSE., the leading 2-by-2 lower -C triangular part of this array contains the lower -C triangular part of the symmetric solution matrix X and the -C strictly upper triangular part of X is not referenced. -C Note that X may be identified with B in the calling -C statement. -C -C LDX INTEGER -C The leading dimension of array X. LDX >= 2. -C -C XNORM (output) DOUBLE PRECISION -C The infinity-norm of the solution. -C -C Error Indicator -C -C INFO INTEGER -C = 0: successful exit; -C = 1: if T has almost reciprocal eigenvalues, so T -C is perturbed to get a nonsingular equation. -C -C NOTE: In the interests of speed, this routine does not -C check the inputs for errors. -C -C METHOD -C -C The equivalent linear algebraic system of equations is formed and -C solved using Gaussian elimination with complete pivoting. -C -C REFERENCES -C -C [1] Anderson, E., Bai, Z., Bischof, C., Demmel, J., Dongarra, J., -C Du Croz, J., Greenbaum, A., Hammarling, S., McKenney, A., -C Ostrouchov, S., and Sorensen, D. -C LAPACK Users' Guide: Second Edition. -C SIAM, Philadelphia, 1995. -C -C NUMERICAL ASPECTS -C -C The algorithm is stable and reliable, since Gaussian elimination -C with complete pivoting is used. -C -C CONTRIBUTOR -C -C Release 3.0: V. Sima, Katholieke Univ. Leuven, Belgium, May 1997. -C Based on DLALD2 by P. Petkov, Tech. University of Sofia, September -C 1993. -C -C REVISIONS -C -C - -C -C KEYWORDS -C -C Discrete-time system, Lyapunov equation, matrix algebra. -C -C ****************************************************************** -C -C .. Parameters .. - DOUBLE PRECISION ZERO, ONE, TWO, FOUR - PARAMETER ( ZERO = 0.0D+0, ONE = 1.0D+0, TWO = 2.0D+0, - $ FOUR = 4.0D+0 ) -C .. -C .. Scalar Arguments .. - LOGICAL LTRAN, LUPPER - INTEGER INFO, LDB, LDT, LDX - DOUBLE PRECISION SCALE, XNORM -C .. -C .. Array Arguments .. - DOUBLE PRECISION B( LDB, * ), T( LDT, * ), X( LDX, * ) -C .. -C .. Local Scalars .. - INTEGER I, IP, IPSV, J, JP, JPSV, K - DOUBLE PRECISION EPS, SMIN, SMLNUM, TEMP, XMAX -C .. -C .. Local Arrays .. - INTEGER JPIV( 3 ) - DOUBLE PRECISION BTMP( 3 ), T9( 3, 3 ), TMP( 3 ) -C .. -C .. External Functions .. - DOUBLE PRECISION DLAMCH - EXTERNAL DLAMCH -C .. -C .. External Subroutines .. - EXTERNAL DSWAP -C .. -C .. Intrinsic Functions .. - INTRINSIC ABS, MAX -C .. -C .. Executable Statements .. -C -C Do not check the input parameters for errors. -C - INFO = 0 -C -C Set constants to control overflow. -C - EPS = DLAMCH( 'P' ) - SMLNUM = DLAMCH( 'S' ) / EPS -C -C Solve equivalent 3-by-3 system using complete pivoting. -C Set pivots less than SMIN to SMIN. -C - SMIN = MAX( ABS( T( 1, 1 ) ), ABS( T( 1, 2 ) ), - $ ABS( T( 2, 1 ) ), ABS( T( 2, 2 ) ) ) - SMIN = MAX( EPS*SMIN, SMLNUM ) - T9( 1, 1 ) = T( 1, 1 )*T( 1, 1 ) - ONE - T9( 2, 2 ) = T( 1, 1 )*T( 2, 2 ) + T( 1, 2 )*T( 2, 1 ) - ONE - T9( 3, 3 ) = T( 2, 2 )*T( 2, 2 ) - ONE - IF( LTRAN ) THEN - T9( 1, 2 ) = T( 1, 1 )*T( 1, 2 ) + T( 1, 1 )*T( 1, 2 ) - T9( 1, 3 ) = T( 1, 2 )*T( 1, 2 ) - T9( 2, 1 ) = T( 1, 1 )*T( 2, 1 ) - T9( 2, 3 ) = T( 1, 2 )*T( 2, 2 ) - T9( 3, 1 ) = T( 2, 1 )*T( 2, 1 ) - T9( 3, 2 ) = T( 2, 1 )*T( 2, 2 ) + T( 2, 1 )*T( 2, 2 ) - ELSE - T9( 1, 2 ) = T( 1, 1 )*T( 2, 1 ) + T( 1, 1 )*T( 2, 1 ) - T9( 1, 3 ) = T( 2, 1 )*T( 2, 1 ) - T9( 2, 1 ) = T( 1, 1 )*T( 1, 2 ) - T9( 2, 3 ) = T( 2, 1 )*T( 2, 2 ) - T9( 3, 1 ) = T( 1, 2 )*T( 1, 2 ) - T9( 3, 2 ) = T( 1, 2 )*T( 2, 2 ) + T( 1, 2 )*T( 2, 2 ) - END IF - BTMP( 1 ) = B( 1, 1 ) - IF ( LUPPER ) THEN - BTMP( 2 ) = B( 1, 2 ) - ELSE - BTMP( 2 ) = B( 2, 1 ) - END IF - BTMP( 3 ) = B( 2, 2 ) -C -C Perform elimination. -C - DO 50 I = 1, 2 - XMAX = ZERO -C - DO 20 IP = I, 3 -C - DO 10 JP = I, 3 - IF( ABS( T9( IP, JP ) ).GE.XMAX ) THEN - XMAX = ABS( T9( IP, JP ) ) - IPSV = IP - JPSV = JP - END IF - 10 CONTINUE -C - 20 CONTINUE -C - IF( IPSV.NE.I ) THEN - CALL DSWAP( 3, T9( IPSV, 1 ), 3, T9( I, 1 ), 3 ) - TEMP = BTMP( I ) - BTMP( I ) = BTMP( IPSV ) - BTMP( IPSV ) = TEMP - END IF - IF( JPSV.NE.I ) - $ CALL DSWAP( 3, T9( 1, JPSV ), 1, T9( 1, I ), 1 ) - JPIV( I ) = JPSV - IF( ABS( T9( I, I ) ).LT.SMIN ) THEN - INFO = 1 - T9( I, I ) = SMIN - END IF -C - DO 40 J = I + 1, 3 - T9( J, I ) = T9( J, I ) / T9( I, I ) - BTMP( J ) = BTMP( J ) - T9( J, I )*BTMP( I ) -C - DO 30 K = I + 1, 3 - T9( J, K ) = T9( J, K ) - T9( J, I )*T9( I, K ) - 30 CONTINUE -C - 40 CONTINUE -C - 50 CONTINUE -C - IF( ABS( T9( 3, 3 ) ).LT.SMIN ) - $ T9( 3, 3 ) = SMIN - SCALE = ONE - IF( ( FOUR*SMLNUM )*ABS( BTMP( 1 ) ).GT.ABS( T9( 1, 1 ) ) .OR. - $ ( FOUR*SMLNUM )*ABS( BTMP( 2 ) ).GT.ABS( T9( 2, 2 ) ) .OR. - $ ( FOUR*SMLNUM )*ABS( BTMP( 3 ) ).GT.ABS( T9( 3, 3 ) ) ) THEN - SCALE = ( ONE / FOUR ) / MAX( ABS( BTMP( 1 ) ), - $ ABS( BTMP( 2 ) ), ABS( BTMP( 3 ) ) ) - BTMP( 1 ) = BTMP( 1 )*SCALE - BTMP( 2 ) = BTMP( 2 )*SCALE - BTMP( 3 ) = BTMP( 3 )*SCALE - END IF -C - DO 70 I = 1, 3 - K = 4 - I - TEMP = ONE / T9( K, K ) - TMP( K ) = BTMP( K )*TEMP -C - DO 60 J = K + 1, 3 - TMP( K ) = TMP( K ) - ( TEMP*T9( K, J ) )*TMP( J ) - 60 CONTINUE -C - 70 CONTINUE -C - DO 80 I = 1, 2 - IF( JPIV( 3-I ).NE.3-I ) THEN - TEMP = TMP( 3-I ) - TMP( 3-I ) = TMP( JPIV( 3-I ) ) - TMP( JPIV( 3-I ) ) = TEMP - END IF - 80 CONTINUE -C - X( 1, 1 ) = TMP( 1 ) - IF ( LUPPER ) THEN - X( 1, 2 ) = TMP( 2 ) - ELSE - X( 2, 1 ) = TMP( 2 ) - END IF - X( 2, 2 ) = TMP( 3 ) - XNORM = MAX( ABS( TMP( 1 ) ) + ABS( TMP( 2 ) ), - $ ABS( TMP( 2 ) ) + ABS( TMP( 3 ) ) ) -C - RETURN -C *** Last line of SB03MV *** - END diff --git a/mex/sources/libslicot/SB03MW.f b/mex/sources/libslicot/SB03MW.f deleted file mode 100644 index 8a0a51202..000000000 --- a/mex/sources/libslicot/SB03MW.f +++ /dev/null @@ -1,293 +0,0 @@ - SUBROUTINE SB03MW( LTRAN, LUPPER, T, LDT, B, LDB, SCALE, X, LDX, - $ XNORM, INFO ) -C -C SLICOT RELEASE 5.0. -C -C Copyright (c) 2002-2009 NICONET e.V. -C -C This program is free software: you can redistribute it and/or -C modify it under the terms of the GNU General Public License as -C published by the Free Software Foundation, either version 2 of -C the License, or (at your option) any later version. -C -C This program is distributed in the hope that it will be useful, -C but WITHOUT ANY WARRANTY; without even the implied warranty of -C MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the -C GNU General Public License for more details. -C -C You should have received a copy of the GNU General Public License -C along with this program. If not, see -C . -C -C PURPOSE -C -C To solve for the 2-by-2 symmetric matrix X in -C -C op(T)'*X + X*op(T) = SCALE*B, -C -C where T is 2-by-2, B is symmetric 2-by-2, and op(T) = T or T', -C where T' denotes the transpose of T. -C -C ARGUMENTS -C -C Mode Parameters -C -C LTRAN LOGICAL -C Specifies the form of op(T) to be used, as follows: -C = .FALSE.: op(T) = T, -C = .TRUE. : op(T) = T'. -C -C LUPPER LOGICAL -C Specifies which triangle of the matrix B is used, and -C which triangle of the matrix X is computed, as follows: -C = .TRUE. : The upper triangular part; -C = .FALSE.: The lower triangular part. -C -C Input/Output Parameters -C -C T (input) DOUBLE PRECISION array, dimension (LDT,2) -C The leading 2-by-2 part of this array must contain the -C matrix T. -C -C LDT INTEGER -C The leading dimension of array T. LDT >= 2. -C -C B (input) DOUBLE PRECISION array, dimension (LDB,2) -C On entry with LUPPER = .TRUE., the leading 2-by-2 upper -C triangular part of this array must contain the upper -C triangular part of the symmetric matrix B and the strictly -C lower triangular part of B is not referenced. -C On entry with LUPPER = .FALSE., the leading 2-by-2 lower -C triangular part of this array must contain the lower -C triangular part of the symmetric matrix B and the strictly -C upper triangular part of B is not referenced. -C -C LDB INTEGER -C The leading dimension of array B. LDB >= 2. -C -C SCALE (output) DOUBLE PRECISION -C The scale factor. SCALE is chosen less than or equal to 1 -C to prevent the solution overflowing. -C -C X (output) DOUBLE PRECISION array, dimension (LDX,2) -C On exit with LUPPER = .TRUE., the leading 2-by-2 upper -C triangular part of this array contains the upper -C triangular part of the symmetric solution matrix X and the -C strictly lower triangular part of X is not referenced. -C On exit with LUPPER = .FALSE., the leading 2-by-2 lower -C triangular part of this array contains the lower -C triangular part of the symmetric solution matrix X and the -C strictly upper triangular part of X is not referenced. -C Note that X may be identified with B in the calling -C statement. -C -C LDX INTEGER -C The leading dimension of array X. LDX >= 2. -C -C XNORM (output) DOUBLE PRECISION -C The infinity-norm of the solution. -C -C Error Indicator -C -C INFO INTEGER -C = 0: successful exit; -C = 1: if T and -T have too close eigenvalues, so T -C is perturbed to get a nonsingular equation. -C -C NOTE: In the interests of speed, this routine does not -C check the inputs for errors. -C -C METHOD -C -C The equivalent linear algebraic system of equations is formed and -C solved using Gaussian elimination with complete pivoting. -C -C REFERENCES -C -C [1] Anderson, E., Bai, Z., Bischof, C., Demmel, J., Dongarra, J., -C Du Croz, J., Greenbaum, A., Hammarling, S., McKenney, A., -C Ostrouchov, S., and Sorensen, D. -C LAPACK Users' Guide: Second Edition. -C SIAM, Philadelphia, 1995. -C -C NUMERICAL ASPECTS -C -C The algorithm is stable and reliable, since Gaussian elimination -C with complete pivoting is used. -C -C CONTRIBUTOR -C -C Release 3.0: V. Sima, Katholieke Univ. Leuven, Belgium, May 1997. -C Based on DLALY2 by P. Petkov, Tech. University of Sofia, September -C 1993. -C -C REVISIONS -C -C - -C -C KEYWORDS -C -C Continuous-time system, Lyapunov equation, matrix algebra. -C -C ****************************************************************** -C -C .. Parameters .. - DOUBLE PRECISION ZERO, ONE, TWO, FOUR - PARAMETER ( ZERO = 0.0D+0, ONE = 1.0D+0, TWO = 2.0D+0, - $ FOUR = 4.0D+0 ) -C .. -C .. Scalar Arguments .. - LOGICAL LTRAN, LUPPER - INTEGER INFO, LDB, LDT, LDX - DOUBLE PRECISION SCALE, XNORM -C .. -C .. Array Arguments .. - DOUBLE PRECISION B( LDB, * ), T( LDT, * ), X( LDX, * ) -C .. -C .. Local Scalars .. - INTEGER I, IP, IPSV, J, JP, JPSV, K - DOUBLE PRECISION EPS, SMIN, SMLNUM, TEMP, XMAX -C .. -C .. Local Arrays .. - INTEGER JPIV( 3 ) - DOUBLE PRECISION BTMP( 3 ), T9( 3, 3 ), TMP( 3 ) -C .. -C .. External Functions .. - DOUBLE PRECISION DLAMCH - EXTERNAL DLAMCH -C .. -C .. External Subroutines .. - EXTERNAL DSWAP -C .. -C .. Intrinsic Functions .. - INTRINSIC ABS, MAX -C .. -C .. Executable Statements .. -C -C Do not check the input parameters for errors -C - INFO = 0 -C -C Set constants to control overflow -C - EPS = DLAMCH( 'P' ) - SMLNUM = DLAMCH( 'S' ) / EPS -C -C Solve equivalent 3-by-3 system using complete pivoting. -C Set pivots less than SMIN to SMIN. -C - SMIN = MAX( MAX( ABS( T( 1, 1 ) ), ABS( T( 1, 2 ) ), - $ ABS( T( 2, 1 ) ), ABS( T( 2, 2 ) ) )*EPS, - $ SMLNUM ) - T9( 1, 3 ) = ZERO - T9( 3, 1 ) = ZERO - T9( 1, 1 ) = T( 1, 1 ) - T9( 2, 2 ) = T( 1, 1 ) + T( 2, 2 ) - T9( 3, 3 ) = T( 2, 2 ) - IF( LTRAN ) THEN - T9( 1, 2 ) = T( 1, 2 ) - T9( 2, 1 ) = T( 2, 1 ) - T9( 2, 3 ) = T( 1, 2 ) - T9( 3, 2 ) = T( 2, 1 ) - ELSE - T9( 1, 2 ) = T( 2, 1 ) - T9( 2, 1 ) = T( 1, 2 ) - T9( 2, 3 ) = T( 2, 1 ) - T9( 3, 2 ) = T( 1, 2 ) - END IF - BTMP( 1 ) = B( 1, 1 )/TWO - IF ( LUPPER ) THEN - BTMP( 2 ) = B( 1, 2 ) - ELSE - BTMP( 2 ) = B( 2, 1 ) - END IF - BTMP( 3 ) = B( 2, 2 )/TWO -C -C Perform elimination -C - DO 50 I = 1, 2 - XMAX = ZERO -C - DO 20 IP = I, 3 -C - DO 10 JP = I, 3 - IF( ABS( T9( IP, JP ) ).GE.XMAX ) THEN - XMAX = ABS( T9( IP, JP ) ) - IPSV = IP - JPSV = JP - END IF - 10 CONTINUE -C - 20 CONTINUE -C - IF( IPSV.NE.I ) THEN - CALL DSWAP( 3, T9( IPSV, 1 ), 3, T9( I, 1 ), 3 ) - TEMP = BTMP( I ) - BTMP( I ) = BTMP( IPSV ) - BTMP( IPSV ) = TEMP - END IF - IF( JPSV.NE.I ) - $ CALL DSWAP( 3, T9( 1, JPSV ), 1, T9( 1, I ), 1 ) - JPIV( I ) = JPSV - IF( ABS( T9( I, I ) ).LT.SMIN ) THEN - INFO = 1 - T9( I, I ) = SMIN - END IF -C - DO 40 J = I + 1, 3 - T9( J, I ) = T9( J, I ) / T9( I, I ) - BTMP( J ) = BTMP( J ) - T9( J, I )*BTMP( I ) -C - DO 30 K = I + 1, 3 - T9( J, K ) = T9( J, K ) - T9( J, I )*T9( I, K ) - 30 CONTINUE -C - 40 CONTINUE -C - 50 CONTINUE -C - IF( ABS( T9( 3, 3 ) ).LT.SMIN ) - $ T9( 3, 3 ) = SMIN - SCALE = ONE - IF( ( FOUR*SMLNUM )*ABS( BTMP( 1 ) ).GT.ABS( T9( 1, 1 ) ) .OR. - $ ( FOUR*SMLNUM )*ABS( BTMP( 2 ) ).GT.ABS( T9( 2, 2 ) ) .OR. - $ ( FOUR*SMLNUM )*ABS( BTMP( 3 ) ).GT.ABS( T9( 3, 3 ) ) ) THEN - SCALE = ( ONE / FOUR ) / MAX( ABS( BTMP( 1 ) ), - $ ABS( BTMP( 2 ) ), ABS( BTMP( 3 ) ) ) - BTMP( 1 ) = BTMP( 1 )*SCALE - BTMP( 2 ) = BTMP( 2 )*SCALE - BTMP( 3 ) = BTMP( 3 )*SCALE - END IF -C - DO 70 I = 1, 3 - K = 4 - I - TEMP = ONE / T9( K, K ) - TMP( K ) = BTMP( K )*TEMP -C - DO 60 J = K + 1, 3 - TMP( K ) = TMP( K ) - ( TEMP*T9( K, J ) )*TMP( J ) - 60 CONTINUE -C - 70 CONTINUE -C - DO 80 I = 1, 2 - IF( JPIV( 3-I ).NE.3-I ) THEN - TEMP = TMP( 3-I ) - TMP( 3-I ) = TMP( JPIV( 3-I ) ) - TMP( JPIV( 3-I ) ) = TEMP - END IF - 80 CONTINUE -C - X( 1, 1 ) = TMP( 1 ) - IF ( LUPPER ) THEN - X( 1, 2 ) = TMP( 2 ) - ELSE - X( 2, 1 ) = TMP( 2 ) - END IF - X( 2, 2 ) = TMP( 3 ) - XNORM = MAX( ABS( TMP( 1 ) ) + ABS( TMP( 2 ) ), - $ ABS( TMP( 2 ) ) + ABS( TMP( 3 ) ) ) -C - RETURN -C *** Last line of SB03MW *** - END diff --git a/mex/sources/libslicot/SB03MX.f b/mex/sources/libslicot/SB03MX.f deleted file mode 100644 index 31b392998..000000000 --- a/mex/sources/libslicot/SB03MX.f +++ /dev/null @@ -1,711 +0,0 @@ - SUBROUTINE SB03MX( TRANA, N, A, LDA, C, LDC, SCALE, DWORK, INFO ) -C -C SLICOT RELEASE 5.0. -C -C Copyright (c) 2002-2009 NICONET e.V. -C -C This program is free software: you can redistribute it and/or -C modify it under the terms of the GNU General Public License as -C published by the Free Software Foundation, either version 2 of -C the License, or (at your option) any later version. -C -C This program is distributed in the hope that it will be useful, -C but WITHOUT ANY WARRANTY; without even the implied warranty of -C MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the -C GNU General Public License for more details. -C -C You should have received a copy of the GNU General Public License -C along with this program. If not, see -C . -C -C PURPOSE -C -C To solve the real discrete Lyapunov matrix equation -C -C op(A)'*X*op(A) - X = scale*C -C -C where op(A) = A or A' (A**T), A is upper quasi-triangular and C is -C symmetric (C = C'). (A' denotes the transpose of the matrix A.) -C A is N-by-N, the right hand side C and the solution X are N-by-N, -C and scale is an output scale factor, set less than or equal to 1 -C to avoid overflow in X. The solution matrix X is overwritten -C onto C. -C -C A must be in Schur canonical form (as returned by LAPACK routines -C DGEES or DHSEQR), that is, block upper triangular with 1-by-1 and -C 2-by-2 diagonal blocks; each 2-by-2 diagonal block has its -C diagonal elements equal and its off-diagonal elements of opposite -C sign. -C -C ARGUMENTS -C -C Mode Parameters -C -C TRANA CHARACTER*1 -C Specifies the form of op(A) to be used, as follows: -C = 'N': op(A) = A (No transpose); -C = 'T': op(A) = A**T (Transpose); -C = 'C': op(A) = A**T (Conjugate transpose = Transpose). -C -C Input/Output Parameters -C -C N (input) INTEGER -C The order of the matrices A, X, and C. N >= 0. -C -C A (input) DOUBLE PRECISION array, dimension (LDA,N) -C The leading N-by-N part of this array must contain the -C upper quasi-triangular matrix A, in Schur canonical form. -C The part of A below the first sub-diagonal is not -C referenced. -C -C LDA INTEGER -C The leading dimension of array A. LDA >= MAX(1,N). -C -C C (input/output) DOUBLE PRECISION array, dimension (LDC,N) -C On entry, the leading N-by-N part of this array must -C contain the symmetric matrix C. -C On exit, if INFO >= 0, the leading N-by-N part of this -C array contains the symmetric solution matrix X. -C -C LDC INTEGER -C The leading dimension of array C. LDC >= MAX(1,N). -C -C SCALE (output) DOUBLE PRECISION -C The scale factor, scale, set less than or equal to 1 to -C prevent the solution overflowing. -C -C Workspace -C -C DWORK DOUBLE PRECISION array, dimension (2*N) -C -C Error Indicator -C -C INFO INTEGER -C = 0: successful exit; -C < 0: if INFO = -i, the i-th argument had an illegal -C value; -C = 1: if A has almost reciprocal eigenvalues; perturbed -C values were used to solve the equation (but the -C matrix A is unchanged). -C -C METHOD -C -C A discrete-time version of the Bartels-Stewart algorithm is used. -C A set of equivalent linear algebraic systems of equations of order -C at most four are formed and solved using Gaussian elimination with -C complete pivoting. -C -C REFERENCES -C -C [1] Barraud, A.Y. T -C A numerical algorithm to solve A XA - X = Q. -C IEEE Trans. Auto. Contr., AC-22, pp. 883-885, 1977. -C -C [2] Bartels, R.H. and Stewart, G.W. T -C Solution of the matrix equation A X + XB = C. -C Comm. A.C.M., 15, pp. 820-826, 1972. -C -C NUMERICAL ASPECTS -C 3 -C The algorithm requires 0(N ) operations. -C -C CONTRIBUTOR -C -C Release 3.0: V. Sima, Katholieke Univ. Leuven, Belgium, May 1997. -C Supersedes Release 2.0 routine SB03AZ by Control Systems Research -C Group, Kingston Polytechnic, United Kingdom, October 1982. -C Based on DTRLPD by P. Petkov, Tech. University of Sofia, September -C 1993. -C -C REVISIONS -C -C V. Sima, Katholieke Univ. Leuven, Belgium, May 1999. -C V. Sima, Research Institute for Informatics, Bucharest, Apr. 2000. -C A. Varga, DLR Oberpfaffenhofen, March 2002. -C -C KEYWORDS -C -C Discrete-time system, Lyapunov equation, matrix algebra, real -C Schur form. -C -C ****************************************************************** -C -C .. Parameters .. - DOUBLE PRECISION ZERO, ONE - PARAMETER ( ZERO = 0.0D+0, ONE = 1.0D+0 ) -C .. -C .. Scalar Arguments .. - CHARACTER TRANA - INTEGER INFO, LDA, LDC, N - DOUBLE PRECISION SCALE -C .. -C .. Array Arguments .. - DOUBLE PRECISION A( LDA, * ), C( LDC, * ), DWORK( * ) -C .. -C .. Local Scalars .. - LOGICAL NOTRNA, LUPPER - INTEGER IERR, J, K, K1, K2, KNEXT, L, L1, L2, LNEXT, - $ MINK1N, MINK2N, MINL1N, MINL2N, NP1 - DOUBLE PRECISION A11, BIGNUM, DA11, DB, EPS, P11, P12, P21, P22, - $ SCALOC, SMIN, SMLNUM, XNORM -C .. -C .. Local Arrays .. - DOUBLE PRECISION VEC( 2, 2 ), X( 2, 2 ) -C .. -C .. External Functions .. - LOGICAL LSAME - DOUBLE PRECISION DDOT, DLAMCH, DLANHS - EXTERNAL DDOT, DLAMCH, DLANHS, LSAME -C .. -C .. External Subroutines .. - EXTERNAL DLABAD, DLALN2, DSCAL, DSYMV, SB03MV, SB04PX, - $ XERBLA -C .. -C .. Intrinsic Functions .. - INTRINSIC ABS, DBLE, MAX, MIN -C .. -C .. Executable Statements .. -C -C Decode and Test input parameters. -C - NOTRNA = LSAME( TRANA, 'N' ) - LUPPER = .TRUE. -C - INFO = 0 - IF( .NOT.NOTRNA .AND. .NOT.LSAME( TRANA, 'T' ) .AND. - $ .NOT.LSAME( TRANA, 'C' ) ) THEN - INFO = -1 - ELSE IF( N.LT.0 ) THEN - INFO = -2 - ELSE IF( LDA.LT.MAX( 1, N ) ) THEN - INFO = -4 - ELSE IF( LDC.LT.MAX( 1, N ) ) THEN - INFO = -6 - END IF -C - IF( INFO.NE.0 ) THEN - CALL XERBLA( 'SB03MX', -INFO ) - RETURN - END IF -C - SCALE = ONE -C -C Quick return if possible. -C - IF( N.EQ.0 ) - $ RETURN -C -C Set constants to control overflow. -C - EPS = DLAMCH( 'P' ) - SMLNUM = DLAMCH( 'S' ) - BIGNUM = ONE / SMLNUM - CALL DLABAD( SMLNUM, BIGNUM ) - SMLNUM = SMLNUM*DBLE( N*N ) / EPS - BIGNUM = ONE / SMLNUM -C - SMIN = MAX( SMLNUM, EPS*DLANHS( 'Max', N, A, LDA, DWORK ) ) - NP1 = N + 1 -C - IF( NOTRNA ) THEN -C -C Solve A'*X*A - X = scale*C. -C -C The (K,L)th block of X is determined starting from -C upper-left corner column by column by -C -C A(K,K)'*X(K,L)*A(L,L) - X(K,L) = C(K,L) - R(K,L), -C -C where -C K L-1 -C R(K,L) = SUM {A(I,K)'*SUM [X(I,J)*A(J,L)]} + -C I=1 J=1 -C -C K-1 -C {SUM [A(I,K)'*X(I,L)]}*A(L,L). -C I=1 -C -C Start column loop (index = L). -C L1 (L2): column index of the first (last) row of X(K,L). -C - LNEXT = 1 -C - DO 60 L = 1, N - IF( L.LT.LNEXT ) - $ GO TO 60 - L1 = L - L2 = L - IF( L.LT.N ) THEN - IF( A( L+1, L ).NE.ZERO ) - $ L2 = L2 + 1 - LNEXT = L2 + 1 - END IF -C -C Start row loop (index = K). -C K1 (K2): row index of the first (last) row of X(K,L). -C - DWORK( L1 ) = ZERO - DWORK( N+L1 ) = ZERO - CALL DSYMV( 'Lower', L1-1, ONE, C, LDC, A( 1, L1 ), 1, ZERO, - $ DWORK, 1 ) - CALL DSYMV( 'Lower', L1-1, ONE, C, LDC, A( 1, L2 ), 1, ZERO, - $ DWORK( NP1 ), 1 ) -C - KNEXT = L -C - DO 50 K = L, N - IF( K.LT.KNEXT ) - $ GO TO 50 - K1 = K - K2 = K - IF( K.LT.N ) THEN - IF( A( K+1, K ).NE.ZERO ) - $ K2 = K2 + 1 - KNEXT = K2 + 1 - END IF -C - IF( L1.EQ.L2 .AND. K1.EQ.K2 ) THEN - DWORK( K1 ) = DDOT( L1-1, C( K1, 1 ), LDC, A( 1, L1 ), - $ 1 ) -C - VEC( 1, 1 ) = C( K1, L1 ) - - $ ( DDOT( K1, A( 1, K1 ), 1, DWORK, 1 ) + A( L1, L1 ) - $ *DDOT( K1-1, A( 1, K1 ), 1, C( 1, L1 ), 1 ) ) - SCALOC = ONE -C - A11 = A( K1, K1 )*A( L1, L1 ) - ONE - DA11 = ABS( A11 ) - IF( DA11.LE.SMIN ) THEN - A11 = SMIN - DA11 = SMIN - INFO = 1 - END IF - DB = ABS( VEC( 1, 1 ) ) - IF( DA11.LT.ONE .AND. DB.GT.ONE ) THEN - IF( DB.GT.BIGNUM*DA11 ) - $ SCALOC = ONE / DB - END IF - X( 1, 1 ) = ( VEC( 1, 1 )*SCALOC ) / A11 -C - IF( SCALOC.NE.ONE ) THEN -C - DO 10 J = 1, N - CALL DSCAL( N, SCALOC, C( 1, J ), 1 ) - 10 CONTINUE -C - CALL DSCAL( N, SCALOC, DWORK, 1 ) - SCALE = SCALE*SCALOC - END IF - C( K1, L1 ) = X( 1, 1 ) - IF( K1.NE.L1 ) THEN - C( L1, K1 ) = X( 1, 1 ) - END IF -C - ELSE IF( L1.EQ.L2 .AND. K1.NE.K2 ) THEN -C - DWORK( K1 ) = DDOT( L1-1, C( K1, 1 ), LDC, A( 1, L1 ), - $ 1 ) - DWORK( K2 ) = DDOT( L1-1, C( K2, 1 ), LDC, A( 1, L1 ), - $ 1 ) -C - VEC( 1, 1 ) = C( K1, L1 ) - - $ ( DDOT( K2, A( 1, K1 ), 1, DWORK, 1 ) + A( L1, L1 ) - $ *DDOT( K1-1, A( 1, K1 ), 1, C( 1, L1 ), 1 ) ) -C - VEC( 2, 1 ) = C( K2, L1 ) - - $ ( DDOT( K2, A( 1, K2 ), 1, DWORK, 1 ) + A( L1, L1 ) - $ *DDOT( K1-1, A( 1, K2 ), 1, C( 1, L1 ), 1 ) ) -C - CALL DLALN2( .TRUE., 2, 1, SMIN, A( L1, L1 ), - $ A( K1, K1 ), LDA, ONE, ONE, VEC, 2, ONE, - $ ZERO, X, 2, SCALOC, XNORM, IERR ) - IF( IERR.NE.0 ) - $ INFO = 1 -C - IF( SCALOC.NE.ONE ) THEN -C - DO 20 J = 1, N - CALL DSCAL( N, SCALOC, C( 1, J ), 1 ) - 20 CONTINUE -C - CALL DSCAL( N, SCALOC, DWORK, 1 ) - SCALE = SCALE*SCALOC - END IF - C( K1, L1 ) = X( 1, 1 ) - C( K2, L1 ) = X( 2, 1 ) - C( L1, K1 ) = X( 1, 1 ) - C( L1, K2 ) = X( 2, 1 ) -C - ELSE IF( L1.NE.L2 .AND. K1.EQ.K2 ) THEN -C - DWORK( K1 ) = DDOT( L1-1, C( K1, 1 ), LDC, A( 1, L1 ), - $ 1 ) - DWORK( N+K1 ) = DDOT( L1-1, C( K1, 1 ), LDC, - $ A( 1, L2 ), 1 ) - P11 = DDOT( K1-1, A( 1, K1 ), 1, C( 1, L1 ), 1 ) - P12 = DDOT( K1-1, A( 1, K1 ), 1, C( 1, L2 ), 1 ) -C - VEC( 1, 1 ) = C( K1, L1 ) - - $ ( DDOT( K1, A( 1, K1 ), 1, DWORK, 1 ) + - $ P11*A( L1, L1 ) + P12*A( L2, L1 ) ) -C - VEC( 2, 1 ) = C( K1, L2 ) - - $ ( DDOT( K1, A( 1, K1 ), 1, DWORK( NP1 ), 1 ) + - $ P11*A( L1, L2 ) + P12*A( L2, L2 ) ) -C - CALL DLALN2( .TRUE., 2, 1, SMIN, A( K1, K1 ), - $ A( L1, L1 ), LDA, ONE, ONE, VEC, 2, ONE, - $ ZERO, X, 2, SCALOC, XNORM, IERR ) - IF( IERR.NE.0 ) - $ INFO = 1 -C - IF( SCALOC.NE.ONE ) THEN -C - DO 30 J = 1, N - CALL DSCAL( N, SCALOC, C( 1, J ), 1 ) - 30 CONTINUE -C - CALL DSCAL( N, SCALOC, DWORK, 1 ) - CALL DSCAL( N, SCALOC, DWORK( NP1 ), 1 ) - SCALE = SCALE*SCALOC - END IF - C( K1, L1 ) = X( 1, 1 ) - C( K1, L2 ) = X( 2, 1 ) - C( L1, K1 ) = X( 1, 1 ) - C( L2, K1 ) = X( 2, 1 ) -C - ELSE IF( L1.NE.L2 .AND. K1.NE.K2 ) THEN -C - DWORK( K1 ) = DDOT( L1-1, C( K1, 1 ), LDC, A( 1, L1 ), - $ 1 ) - DWORK( K2 ) = DDOT( L1-1, C( K2, 1 ), LDC, A( 1, L1 ), - $ 1 ) - DWORK( N+K1 ) = DDOT( L1-1, C( K1, 1 ), LDC, - $ A( 1, L2 ), 1 ) - DWORK( N+K2 ) = DDOT( L1-1, C( K2, 1 ), LDC, - $ A( 1, L2 ), 1 ) - P11 = DDOT( K1-1, A( 1, K1 ), 1, C( 1, L1 ), 1 ) - P12 = DDOT( K1-1, A( 1, K1 ), 1, C( 1, L2 ), 1 ) - P21 = DDOT( K1-1, A( 1, K2 ), 1, C( 1, L1 ), 1 ) - P22 = DDOT( K1-1, A( 1, K2 ), 1, C( 1, L2 ), 1 ) -C - VEC( 1, 1 ) = C( K1, L1 ) - - $ ( DDOT( K2, A( 1, K1 ), 1, DWORK, 1 ) + - $ P11*A( L1, L1 ) + P12*A( L2, L1 ) ) -C - VEC( 1, 2 ) = C( K1, L2 ) - - $ ( DDOT( K2, A( 1, K1 ), 1, DWORK( NP1 ), 1 ) + - $ P11*A( L1, L2 ) + P12*A( L2, L2 ) ) -C - VEC( 2, 1 ) = C( K2, L1 ) - - $ ( DDOT( K2, A( 1, K2 ), 1, DWORK, 1 ) + - $ P21*A( L1, L1 ) + P22*A( L2, L1 ) ) -C - VEC( 2, 2 ) = C( K2, L2 ) - - $ ( DDOT( K2, A( 1, K2 ), 1, DWORK( NP1 ), 1 ) + - $ P21*A( L1, L2 ) + P22*A( L2, L2 ) ) -C - IF( K1.EQ.L1 ) THEN - CALL SB03MV( .FALSE., LUPPER, A( K1, K1 ), LDA, - $ VEC, 2, SCALOC, X, 2, XNORM, IERR ) - IF( LUPPER ) THEN - X( 2, 1 ) = X( 1, 2 ) - ELSE - X( 1, 2 ) = X( 2, 1 ) - END IF - ELSE - CALL SB04PX( .TRUE., .FALSE., -1, 2, 2, - $ A( K1, K1 ), LDA, A( L1, L1 ), LDA, - $ VEC, 2, SCALOC, X, 2, XNORM, IERR ) - END IF - IF( IERR.NE.0 ) - $ INFO = 1 -C - IF( SCALOC.NE.ONE ) THEN -C - DO 40 J = 1, N - CALL DSCAL( N, SCALOC, C( 1, J ), 1 ) - 40 CONTINUE -C - CALL DSCAL( N, SCALOC, DWORK, 1 ) - CALL DSCAL( N, SCALOC, DWORK( NP1 ), 1 ) - SCALE = SCALE*SCALOC - END IF - C( K1, L1 ) = X( 1, 1 ) - C( K1, L2 ) = X( 1, 2 ) - C( K2, L1 ) = X( 2, 1 ) - C( K2, L2 ) = X( 2, 2 ) - IF( K1.NE.L1 ) THEN - C( L1, K1 ) = X( 1, 1 ) - C( L2, K1 ) = X( 1, 2 ) - C( L1, K2 ) = X( 2, 1 ) - C( L2, K2 ) = X( 2, 2 ) - END IF - END IF -C - 50 CONTINUE -C - 60 CONTINUE -C - ELSE -C -C Solve A*X*A' - X = scale*C. -C -C The (K,L)th block of X is determined starting from -C bottom-right corner column by column by -C -C A(K,K)*X(K,L)*A(L,L)' - X(K,L) = C(K,L) - R(K,L), -C -C where -C -C N N -C R(K,L) = SUM {A(K,I)* SUM [X(I,J)*A(L,J)']} + -C I=K J=L+1 -C -C N -C { SUM [A(K,J)*X(J,L)]}*A(L,L)' -C J=K+1 -C -C Start column loop (index = L) -C L1 (L2): column index of the first (last) row of X(K,L) -C - LNEXT = N -C - DO 120 L = N, 1, -1 - IF( L.GT.LNEXT ) - $ GO TO 120 - L1 = L - L2 = L - IF( L.GT.1 ) THEN - IF( A( L, L-1 ).NE.ZERO ) THEN - L1 = L1 - 1 - DWORK( L1 ) = ZERO - DWORK( N+L1 ) = ZERO - END IF - LNEXT = L1 - 1 - END IF - MINL1N = MIN( L1+1, N ) - MINL2N = MIN( L2+1, N ) -C -C Start row loop (index = K) -C K1 (K2): row index of the first (last) row of X(K,L) -C - IF( L2.LT.N ) THEN - CALL DSYMV( 'Upper', N-L2, ONE, C( L2+1, L2+1 ), LDC, - $ A( L1, L2+1 ), LDA, ZERO, DWORK( L2+1 ), 1 ) - CALL DSYMV( 'Upper', N-L2, ONE, C( L2+1, L2+1 ), LDC, - $ A( L2, L2+1 ), LDA, ZERO, DWORK( NP1+L2 ), 1) - END IF -C - KNEXT = L -C - DO 110 K = L, 1, -1 - IF( K.GT.KNEXT ) - $ GO TO 110 - K1 = K - K2 = K - IF( K.GT.1 ) THEN - IF( A( K, K-1 ).NE.ZERO ) - $ K1 = K1 - 1 - KNEXT = K1 - 1 - END IF - MINK1N = MIN( K1+1, N ) - MINK2N = MIN( K2+1, N ) -C - IF( L1.EQ.L2 .AND. K1.EQ.K2 ) THEN - DWORK( K1 ) = DDOT( N-L1, C( K1, MINL1N ), LDC, - $ A( L1, MINL1N ), LDA ) -C - VEC( 1, 1 ) = C( K1, L1 ) - - $ ( DDOT( N-K1+1, A( K1, K1 ), LDA, DWORK( K1 ), 1 ) - $ + DDOT( N-K1, A( K1, MINK1N ), LDA, - $ C( MINK1N, L1 ), 1 )*A( L1, L1 ) ) - SCALOC = ONE -C - A11 = A( K1, K1 )*A( L1, L1 ) - ONE - DA11 = ABS( A11 ) - IF( DA11.LE.SMIN ) THEN - A11 = SMIN - DA11 = SMIN - INFO = 1 - END IF - DB = ABS( VEC( 1, 1 ) ) - IF( DA11.LT.ONE .AND. DB.GT.ONE ) THEN - IF( DB.GT.BIGNUM*DA11 ) - $ SCALOC = ONE / DB - END IF - X( 1, 1 ) = ( VEC( 1, 1 )*SCALOC ) / A11 -C - IF( SCALOC.NE.ONE ) THEN -C - DO 70 J = 1, N - CALL DSCAL( N, SCALOC, C( 1, J ), 1 ) - 70 CONTINUE -C - CALL DSCAL( N, SCALOC, DWORK, 1 ) - SCALE = SCALE*SCALOC - END IF - C( K1, L1 ) = X( 1, 1 ) - IF( K1.NE.L1 ) THEN - C( L1, K1 ) = X( 1, 1 ) - END IF -C - ELSE IF( L1.EQ.L2 .AND. K1.NE.K2 ) THEN -C - DWORK( K1 ) = DDOT( N-L1, C( K1, MINL1N ), LDC, - $ A( L1, MINL1N ), LDA ) - DWORK( K2 ) = DDOT( N-L1, C( K2, MINL1N ), LDC, - $ A( L1, MINL1N ), LDA ) -C - VEC( 1, 1 ) = C( K1, L1 ) - - $ ( DDOT( NP1-K1, A( K1, K1 ), LDA, DWORK( K1 ), 1 ) - $ + DDOT( N-K2, A( K1, MINK2N ), LDA, - $ C( MINK2N, L1 ), 1 )*A( L1, L1 ) ) -C - VEC( 2, 1 ) = C( K2, L1 ) - - $ ( DDOT( NP1-K1, A( K2, K1 ), LDA, DWORK( K1 ), 1 ) - $ + DDOT( N-K2, A( K2, MINK2N ), LDA, - $ C( MINK2N, L1 ), 1 )*A( L1, L1 ) ) -C - CALL DLALN2( .FALSE., 2, 1, SMIN, A( L1, L1 ), - $ A( K1, K1 ), LDA, ONE, ONE, VEC, 2, ONE, - $ ZERO, X, 2, SCALOC, XNORM, IERR ) - IF( IERR.NE.0 ) - $ INFO = 1 -C - IF( SCALOC.NE.ONE ) THEN -C - DO 80 J = 1, N - CALL DSCAL( N, SCALOC, C( 1, J ), 1 ) - 80 CONTINUE -C - CALL DSCAL( N, SCALOC, DWORK, 1 ) - SCALE = SCALE*SCALOC - END IF - C( K1, L1 ) = X( 1, 1 ) - C( K2, L1 ) = X( 2, 1 ) - C( L1, K1 ) = X( 1, 1 ) - C( L1, K2 ) = X( 2, 1 ) -C - ELSE IF( L1.NE.L2 .AND. K1.EQ.K2 ) THEN -C - DWORK( K1 ) = DDOT( N-L2, C( K1, MINL2N ), LDC, - $ A( L1, MINL2N ), LDA ) - DWORK( N+K1 ) = DDOT( N-L2, C( K1, MINL2N ), LDC, - $ A( L2, MINL2N ), LDA ) - P11 = DDOT( N-K1, A( K1, MINK1N ), LDA, - $ C( MINK1N, L1 ), 1 ) - P12 = DDOT( N-K1, A( K1, MINK1N ), LDA, - $ C( MINK1N, L2 ), 1 ) -C - VEC( 1, 1 ) = C( K1, L1 ) - - $ ( DDOT( NP1-K1, A( K1, K1 ), LDA, DWORK( K1 ), 1 ) - $ + P11*A( L1, L1 ) + P12*A( L1, L2 ) ) -C - VEC( 2, 1 ) = C( K1, L2 ) - - $ ( DDOT( NP1-K1, A( K1, K1 ), LDA, DWORK( N+K1 ), 1) - $ + P11*A( L2, L1 ) + P12*A( L2, L2 ) ) -C - CALL DLALN2( .FALSE., 2, 1, SMIN, A( K1, K1 ), - $ A( L1, L1 ), LDA, ONE, ONE, VEC, 2, ONE, - $ ZERO, X, 2, SCALOC, XNORM, IERR ) - IF( IERR.NE.0 ) - $ INFO = 1 -C - IF( SCALOC.NE.ONE ) THEN -C - DO 90 J = 1, N - CALL DSCAL( N, SCALOC, C( 1, J ), 1 ) - 90 CONTINUE -C - CALL DSCAL( N, SCALOC, DWORK, 1 ) - CALL DSCAL( N, SCALOC, DWORK( NP1 ), 1 ) - SCALE = SCALE*SCALOC - END IF - C( K1, L1 ) = X( 1, 1 ) - C( K1, L2 ) = X( 2, 1 ) - C( L1, K1 ) = X( 1, 1 ) - C( L2, K1 ) = X( 2, 1 ) -C - ELSE IF( L1.NE.L2 .AND. K1.NE.K2 ) THEN -C - DWORK( K1 ) = DDOT( N-L2, C( K1, MINL2N ), LDC, - $ A( L1, MINL2N ), LDA ) - DWORK( K2 ) = DDOT( N-L2, C( K2, MINL2N ), LDC, - $ A( L1, MINL2N ), LDA ) - DWORK( N+K1 ) = DDOT( N-L2, C( K1, MINL2N ), LDC, - $ A( L2, MINL2N ), LDA ) - DWORK( N+K2 ) = DDOT( N-L2, C( K2, MINL2N ), LDC, - $ A( L2, MINL2N ), LDA ) - P11 = DDOT( N-K2, A( K1, MINK2N ), LDA, - $ C( MINK2N, L1 ), 1 ) - P12 = DDOT( N-K2, A( K1, MINK2N ), LDA, - $ C( MINK2N, L2 ), 1 ) - P21 = DDOT( N-K2, A( K2, MINK2N ), LDA, - $ C( MINK2N, L1 ), 1 ) - P22 = DDOT( N-K2, A( K2, MINK2N ), LDA, - $ C( MINK2N, L2 ), 1 ) -C - VEC( 1, 1 ) = C( K1, L1 ) - - $ ( DDOT( NP1-K1, A( K1, K1 ), LDA, DWORK( K1 ), 1 ) - $ + P11*A( L1, L1 ) + P12*A( L1, L2 ) ) -C - VEC( 1, 2 ) = C( K1, L2 ) - - $ ( DDOT( NP1-K1, A( K1, K1 ), LDA, DWORK( N+K1 ), - $ 1) + P11*A( L2, L1 ) + P12*A( L2, L2 ) ) -C - VEC( 2, 1 ) = C( K2, L1 ) - - $ ( DDOT( NP1-K1, A( K2, K1 ), LDA, DWORK( K1 ), - $ 1) + P21*A( L1, L1 ) + P22*A( L1, L2 ) ) -C - VEC( 2, 2 ) = C( K2, L2 ) - - $ ( DDOT( NP1-K1, A( K2, K1 ), LDA, DWORK( N+K1 ), 1) - $ + P21*A( L2, L1 ) + P22*A( L2, L2 ) ) -C - IF( K1.EQ.L1 ) THEN - CALL SB03MV( .TRUE., LUPPER, A( K1, K1 ), LDA, VEC, - $ 2, SCALOC, X, 2, XNORM, IERR ) - IF( LUPPER ) THEN - X( 2, 1 ) = X( 1, 2 ) - ELSE - X( 1, 2 ) = X( 2, 1 ) - END IF - ELSE - CALL SB04PX( .FALSE., .TRUE., -1, 2, 2, - $ A( K1, K1 ), LDA, A( L1, L1 ), LDA, - $ VEC, 2, SCALOC, X, 2, XNORM, IERR ) - END IF - IF( IERR.NE.0 ) - $ INFO = 1 -C - IF( SCALOC.NE.ONE ) THEN -C - DO 100 J = 1, N - CALL DSCAL( N, SCALOC, C( 1, J ), 1 ) - 100 CONTINUE -C - CALL DSCAL( N, SCALOC, DWORK, 1 ) - CALL DSCAL( N, SCALOC, DWORK( NP1 ), 1 ) - SCALE = SCALE*SCALOC - END IF - C( K1, L1 ) = X( 1, 1 ) - C( K1, L2 ) = X( 1, 2 ) - C( K2, L1 ) = X( 2, 1 ) - C( K2, L2 ) = X( 2, 2 ) - IF( K1.NE.L1 ) THEN - C( L1, K1 ) = X( 1, 1 ) - C( L2, K1 ) = X( 1, 2 ) - C( L1, K2 ) = X( 2, 1 ) - C( L2, K2 ) = X( 2, 2 ) - END IF - END IF -C - 110 CONTINUE -C - 120 CONTINUE -C - END IF -C - RETURN -C *** Last line of SB03MX *** - END diff --git a/mex/sources/libslicot/SB03MY.f b/mex/sources/libslicot/SB03MY.f deleted file mode 100644 index 6aa1642cd..000000000 --- a/mex/sources/libslicot/SB03MY.f +++ /dev/null @@ -1,613 +0,0 @@ - SUBROUTINE SB03MY( TRANA, N, A, LDA, C, LDC, SCALE, INFO ) -C -C SLICOT RELEASE 5.0. -C -C Copyright (c) 2002-2009 NICONET e.V. -C -C This program is free software: you can redistribute it and/or -C modify it under the terms of the GNU General Public License as -C published by the Free Software Foundation, either version 2 of -C the License, or (at your option) any later version. -C -C This program is distributed in the hope that it will be useful, -C but WITHOUT ANY WARRANTY; without even the implied warranty of -C MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the -C GNU General Public License for more details. -C -C You should have received a copy of the GNU General Public License -C along with this program. If not, see -C . -C -C PURPOSE -C -C To solve the real Lyapunov matrix equation -C -C op(A)'*X + X*op(A) = scale*C -C -C where op(A) = A or A' (A**T), A is upper quasi-triangular and C is -C symmetric (C = C'). (A' denotes the transpose of the matrix A.) -C A is N-by-N, the right hand side C and the solution X are N-by-N, -C and scale is an output scale factor, set less than or equal to 1 -C to avoid overflow in X. The solution matrix X is overwritten -C onto C. -C -C A must be in Schur canonical form (as returned by LAPACK routines -C DGEES or DHSEQR), that is, block upper triangular with 1-by-1 and -C 2-by-2 diagonal blocks; each 2-by-2 diagonal block has its -C diagonal elements equal and its off-diagonal elements of opposite -C sign. -C -C ARGUMENTS -C -C Mode Parameters -C -C TRANA CHARACTER*1 -C Specifies the form of op(A) to be used, as follows: -C = 'N': op(A) = A (No transpose); -C = 'T': op(A) = A**T (Transpose); -C = 'C': op(A) = A**T (Conjugate transpose = Transpose). -C -C Input/Output Parameters -C -C N (input) INTEGER -C The order of the matrices A, X, and C. N >= 0. -C -C A (input) DOUBLE PRECISION array, dimension (LDA,N) -C The leading N-by-N part of this array must contain the -C upper quasi-triangular matrix A, in Schur canonical form. -C The part of A below the first sub-diagonal is not -C referenced. -C -C LDA INTEGER -C The leading dimension of array A. LDA >= MAX(1,N). -C -C C (input/output) DOUBLE PRECISION array, dimension (LDC,N) -C On entry, the leading N-by-N part of this array must -C contain the symmetric matrix C. -C On exit, if INFO >= 0, the leading N-by-N part of this -C array contains the symmetric solution matrix X. -C -C LDC INTEGER -C The leading dimension of array C. LDC >= MAX(1,N). -C -C SCALE (output) DOUBLE PRECISION -C The scale factor, scale, set less than or equal to 1 to -C prevent the solution overflowing. -C -C Error Indicator -C -C INFO INTEGER -C = 0: successful exit; -C < 0: if INFO = -i, the i-th argument had an illegal -C value; -C = 1: if A and -A have common or very close eigenvalues; -C perturbed values were used to solve the equation -C (but the matrix A is unchanged). -C -C METHOD -C -C Bartels-Stewart algorithm is used. A set of equivalent linear -C algebraic systems of equations of order at most four are formed -C and solved using Gaussian elimination with complete pivoting. -C -C REFERENCES -C -C [1] Bartels, R.H. and Stewart, G.W. T -C Solution of the matrix equation A X + XB = C. -C Comm. A.C.M., 15, pp. 820-826, 1972. -C -C NUMERICAL ASPECTS -C 3 -C The algorithm requires 0(N ) operations. -C -C CONTRIBUTOR -C -C Release 3.0: V. Sima, Katholieke Univ. Leuven, Belgium, May 1997. -C Supersedes Release 2.0 routine SB03AY by Control Systems Research -C Group, Kingston Polytechnic, United Kingdom, October 1982. -C Based on DTRLYP by P. Petkov, Tech. University of Sofia, September -C 1993. -C -C REVISIONS -C -C V. Sima, Katholieke Univ. Leuven, Belgium, May 1999. -C -C KEYWORDS -C -C Continuous-time system, Lyapunov equation, matrix algebra, real -C Schur form. -C -C ****************************************************************** -C -C .. Parameters .. - DOUBLE PRECISION ZERO, ONE - PARAMETER ( ZERO = 0.0D+0, ONE = 1.0D+0 ) -C .. -C .. Scalar Arguments .. - CHARACTER TRANA - INTEGER INFO, LDA, LDC, N - DOUBLE PRECISION SCALE -C .. -C .. Array Arguments .. - DOUBLE PRECISION A( LDA, * ), C( LDC, * ) -C .. -C .. Local Scalars .. - LOGICAL NOTRNA, LUPPER - INTEGER IERR, J, K, K1, K2, KNEXT, L, L1, L2, LNEXT, - $ MINK1N, MINK2N, MINL1N, MINL2N - DOUBLE PRECISION A11, BIGNUM, DA11, DB, EPS, SCALOC, SMIN, - $ SMLNUM, XNORM -C .. -C .. Local Arrays .. - DOUBLE PRECISION DUM( 1 ), VEC( 2, 2 ), X( 2, 2 ) -C .. -C .. External Functions .. - LOGICAL LSAME - DOUBLE PRECISION DDOT, DLAMCH, DLANHS - EXTERNAL DDOT, DLAMCH, DLANHS, LSAME -C .. -C .. External Subroutines .. - EXTERNAL DLABAD, DLALN2, DLASY2, DSCAL, SB03MW, XERBLA -C .. -C .. Intrinsic Functions .. - INTRINSIC ABS, DBLE, MAX, MIN -C .. -C .. Executable Statements .. -C -C Decode and Test input parameters. -C - NOTRNA = LSAME( TRANA, 'N' ) - LUPPER = .TRUE. -C - INFO = 0 - IF( .NOT.NOTRNA .AND. .NOT.LSAME( TRANA, 'T' ) .AND. - $ .NOT.LSAME( TRANA, 'C' ) ) THEN - INFO = -1 - ELSE IF( N.LT.0 ) THEN - INFO = -2 - ELSE IF( LDA.LT.MAX( 1, N ) ) THEN - INFO = -4 - ELSE IF( LDC.LT.MAX( 1, N ) ) THEN - INFO = -6 - END IF -C - IF( INFO.NE.0 ) THEN - CALL XERBLA( 'SB03MY', -INFO ) - RETURN - END IF -C - SCALE = ONE -C -C Quick return if possible. -C - IF( N.EQ.0 ) - $ RETURN -C -C Set constants to control overflow. -C - EPS = DLAMCH( 'P' ) - SMLNUM = DLAMCH( 'S' ) - BIGNUM = ONE / SMLNUM - CALL DLABAD( SMLNUM, BIGNUM ) - SMLNUM = SMLNUM*DBLE( N*N ) / EPS - BIGNUM = ONE / SMLNUM -C - SMIN = MAX( SMLNUM, EPS*DLANHS( 'Max', N, A, LDA, DUM ) ) -C - IF( NOTRNA ) THEN -C -C Solve A'*X + X*A = scale*C. -C -C The (K,L)th block of X is determined starting from -C upper-left corner column by column by -C -C A(K,K)'*X(K,L) + X(K,L)*A(L,L) = C(K,L) - R(K,L), -C -C where -C K-1 L-1 -C R(K,L) = SUM [A(I,K)'*X(I,L)] + SUM [X(K,J)*A(J,L)]. -C I=1 J=1 -C -C Start column loop (index = L). -C L1 (L2): column index of the first (last) row of X(K,L). -C - LNEXT = 1 -C - DO 60 L = 1, N - IF( L.LT.LNEXT ) - $ GO TO 60 - L1 = L - L2 = L - IF( L.LT.N ) THEN - IF( A( L+1, L ).NE.ZERO ) - $ L2 = L2 + 1 - LNEXT = L2 + 1 - END IF -C -C Start row loop (index = K). -C K1 (K2): row index of the first (last) row of X(K,L). -C - KNEXT = L -C - DO 50 K = L, N - IF( K.LT.KNEXT ) - $ GO TO 50 - K1 = K - K2 = K - IF( K.LT.N ) THEN - IF( A( K+1, K ).NE.ZERO ) - $ K2 = K2 + 1 - KNEXT = K2 + 1 - END IF -C - IF( L1.EQ.L2 .AND. K1.EQ.K2 ) THEN - VEC( 1, 1 ) = C( K1, L1 ) - - $ ( DDOT( K1-1, A( 1, K1 ), 1, C( 1, L1 ), 1 ) + - $ DDOT( L1-1, C( K1, 1 ), LDC, A( 1, L1 ), 1 ) ) - SCALOC = ONE -C - A11 = A( K1, K1 ) + A( L1, L1 ) - DA11 = ABS( A11 ) - IF( DA11.LE.SMIN ) THEN - A11 = SMIN - DA11 = SMIN - INFO = 1 - END IF - DB = ABS( VEC( 1, 1 ) ) - IF( DA11.LT.ONE .AND. DB.GT.ONE ) THEN - IF( DB.GT.BIGNUM*DA11 ) - $ SCALOC = ONE / DB - END IF - X( 1, 1 ) = ( VEC( 1, 1 )*SCALOC ) / A11 -C - IF( SCALOC.NE.ONE ) THEN -C - DO 10 J = 1, N - CALL DSCAL( N, SCALOC, C( 1, J ), 1 ) - 10 CONTINUE -C - SCALE = SCALE*SCALOC - END IF - C( K1, L1 ) = X( 1, 1 ) - IF( K1.NE.L1 ) THEN - C( L1, K1 ) = X( 1, 1 ) - END IF -C - ELSE IF( L1.EQ.L2 .AND. K1.NE.K2 ) THEN -C - VEC( 1, 1 ) = C( K1, L1 ) - - $ ( DDOT( K1-1, A( 1, K1 ), 1, C( 1, L1 ), 1 ) + - $ DDOT( L1-1, C( K1, 1 ), LDC, A( 1, L1 ), 1 ) ) -C - VEC( 2, 1 ) = C( K2, L1 ) - - $ ( DDOT( K1-1, A( 1, K2 ), 1, C( 1, L1 ), 1 ) + - $ DDOT( L1-1, C( K2, 1 ), LDC, A( 1, L1 ), 1 ) ) -C - CALL DLALN2( .TRUE., 2, 1, SMIN, ONE, A( K1, K1 ), - $ LDA, ONE, ONE, VEC, 2, -A( L1, L1 ), - $ ZERO, X, 2, SCALOC, XNORM, IERR ) - IF( IERR.NE.0 ) - $ INFO = 1 -C - IF( SCALOC.NE.ONE ) THEN -C - DO 20 J = 1, N - CALL DSCAL( N, SCALOC, C( 1, J ), 1 ) - 20 CONTINUE -C - SCALE = SCALE*SCALOC - END IF - C( K1, L1 ) = X( 1, 1 ) - C( K2, L1 ) = X( 2, 1 ) - C( L1, K1 ) = X( 1, 1 ) - C( L1, K2 ) = X( 2, 1 ) -C - ELSE IF( L1.NE.L2 .AND. K1.EQ.K2 ) THEN -C - VEC( 1, 1 ) = C( K1, L1 ) - - $ ( DDOT( K1-1, A( 1, K1 ), 1, C( 1, L1 ), 1 ) + - $ DDOT( L1-1, C( K1, 1 ), LDC, A( 1, L1 ), 1 ) ) -C - VEC( 2, 1 ) = C( K1, L2 ) - - $ ( DDOT( K1-1, A( 1, K1 ), 1, C( 1, L2 ), 1 ) + - $ DDOT( L1-1, C( K1, 1 ), LDC, A( 1, L2 ), 1 ) ) -C - CALL DLALN2( .TRUE., 2, 1, SMIN, ONE, A( L1, L1 ), - $ LDA, ONE, ONE, VEC, 2, -A( K1, K1 ), - $ ZERO, X, 2, SCALOC, XNORM, IERR ) - IF( IERR.NE.0 ) - $ INFO = 1 -C - IF( SCALOC.NE.ONE ) THEN -C - DO 30 J = 1, N - CALL DSCAL( N, SCALOC, C( 1, J ), 1 ) - 30 CONTINUE -C - SCALE = SCALE*SCALOC - END IF - C( K1, L1 ) = X( 1, 1 ) - C( K1, L2 ) = X( 2, 1 ) - C( L1, K1 ) = X( 1, 1 ) - C( L2, K1 ) = X( 2, 1 ) -C - ELSE IF( L1.NE.L2 .AND. K1.NE.K2 ) THEN -C - VEC( 1, 1 ) = C( K1, L1 ) - - $ ( DDOT( K1-1, A( 1, K1 ), 1, C( 1, L1 ), 1 ) + - $ DDOT( L1-1, C( K1, 1 ), LDC, A( 1, L1 ), 1 ) ) -C - VEC( 1, 2 ) = C( K1, L2 ) - - $ ( DDOT( K1-1, A( 1, K1 ), 1, C( 1, L2 ), 1 ) + - $ DDOT( L1-1, C( K1, 1 ), LDC, A( 1, L2 ), 1 ) ) -C - VEC( 2, 1 ) = C( K2, L1 ) - - $ ( DDOT( K1-1, A( 1, K2 ), 1, C( 1, L1 ), 1 ) + - $ DDOT( L1-1, C( K2, 1 ), LDC, A( 1, L1 ), 1 ) ) -C - VEC( 2, 2 ) = C( K2, L2 ) - - $ ( DDOT( K1-1, A( 1, K2 ), 1, C( 1, L2 ), 1 ) + - $ DDOT( L1-1, C( K2, 1 ), LDC, A( 1, L2 ), 1 ) ) -C - IF( K1.EQ.L1 ) THEN - CALL SB03MW( .FALSE., LUPPER, A( K1, K1 ), LDA, - $ VEC, 2, SCALOC, X, 2, XNORM, IERR ) - IF( LUPPER ) THEN - X( 2, 1 ) = X( 1, 2 ) - ELSE - X( 1, 2 ) = X( 2, 1 ) - END IF - ELSE - CALL DLASY2( .TRUE., .FALSE., 1, 2, 2, A( K1, K1 ), - $ LDA, A( L1, L1 ), LDA, VEC, 2, SCALOC, - $ X, 2, XNORM, IERR ) - END IF - IF( IERR.NE.0 ) - $ INFO = 1 -C - IF( SCALOC.NE.ONE ) THEN -C - DO 40 J = 1, N - CALL DSCAL( N, SCALOC, C( 1, J ), 1 ) - 40 CONTINUE -C - SCALE = SCALE*SCALOC - END IF - C( K1, L1 ) = X( 1, 1 ) - C( K1, L2 ) = X( 1, 2 ) - C( K2, L1 ) = X( 2, 1 ) - C( K2, L2 ) = X( 2, 2 ) - IF( K1.NE.L1 ) THEN - C( L1, K1 ) = X( 1, 1 ) - C( L2, K1 ) = X( 1, 2 ) - C( L1, K2 ) = X( 2, 1 ) - C( L2, K2 ) = X( 2, 2 ) - END IF - END IF -C - 50 CONTINUE -C - 60 CONTINUE -C - ELSE -C -C Solve A*X + X*A' = scale*C. -C -C The (K,L)th block of X is determined starting from -C bottom-right corner column by column by -C -C A(K,K)*X(K,L) + X(K,L)*A(L,L)' = C(K,L) - R(K,L), -C -C where -C N N -C R(K,L) = SUM [A(K,I)*X(I,L)] + SUM [X(K,J)*A(L,J)']. -C I=K+1 J=L+1 -C -C Start column loop (index = L). -C L1 (L2): column index of the first (last) row of X(K,L). -C - LNEXT = N -C - DO 120 L = N, 1, -1 - IF( L.GT.LNEXT ) - $ GO TO 120 - L1 = L - L2 = L - IF( L.GT.1 ) THEN - IF( A( L, L-1 ).NE.ZERO ) - $ L1 = L1 - 1 - LNEXT = L1 - 1 - END IF - MINL1N = MIN( L1+1, N ) - MINL2N = MIN( L2+1, N ) -C -C Start row loop (index = K). -C K1 (K2): row index of the first (last) row of X(K,L). -C - KNEXT = L -C - DO 110 K = L, 1, -1 - IF( K.GT.KNEXT ) - $ GO TO 110 - K1 = K - K2 = K - IF( K.GT.1 ) THEN - IF( A( K, K-1 ).NE.ZERO ) - $ K1 = K1 - 1 - KNEXT = K1 - 1 - END IF - MINK1N = MIN( K1+1, N ) - MINK2N = MIN( K2+1, N ) -C - IF( L1.EQ.L2 .AND. K1.EQ.K2 ) THEN - VEC( 1, 1 ) = C( K1, L1 ) - - $ ( DDOT( N-K1, A( K1, MINK1N ), LDA, - $ C( MINK1N, L1 ), 1 ) + - $ DDOT( N-L1, C( K1, MINL1N ), LDC, - $ A( L1, MINL1N ), LDA ) ) - SCALOC = ONE -C - A11 = A( K1, K1 ) + A( L1, L1 ) - DA11 = ABS( A11 ) - IF( DA11.LE.SMIN ) THEN - A11 = SMIN - DA11 = SMIN - INFO = 1 - END IF - DB = ABS( VEC( 1, 1 ) ) - IF( DA11.LT.ONE .AND. DB.GT.ONE ) THEN - IF( DB.GT.BIGNUM*DA11 ) - $ SCALOC = ONE / DB - END IF - X( 1, 1 ) = ( VEC( 1, 1 )*SCALOC ) / A11 -C - IF( SCALOC.NE.ONE ) THEN -C - DO 70 J = 1, N - CALL DSCAL( N, SCALOC, C( 1, J ), 1 ) - 70 CONTINUE -C - SCALE = SCALE*SCALOC - END IF - C( K1, L1 ) = X( 1, 1 ) - IF( K1.NE.L1 ) THEN - C( L1, K1 ) = X( 1, 1 ) - END IF -C - ELSE IF( L1.EQ.L2 .AND. K1.NE.K2 ) THEN -C - VEC( 1, 1 ) = C( K1, L1 ) - - $ ( DDOT( N-K2, A( K1, MINK2N ), LDA, - $ C( MINK2N, L1 ), 1 ) + - $ DDOT( N-L2, C( K1, MINL2N ), LDC, - $ A( L1, MINL2N ), LDA ) ) -C - VEC( 2, 1 ) = C( K2, L1 ) - - $ ( DDOT( N-K2, A( K2, MINK2N ), LDA, - $ C( MINK2N, L1 ), 1 ) + - $ DDOT( N-L2, C( K2, MINL2N ), LDC, - $ A( L1, MINL2N ), LDA ) ) -C - CALL DLALN2( .FALSE., 2, 1, SMIN, ONE, A( K1, K1 ), - $ LDA, ONE, ONE, VEC, 2, -A( L1, L1 ), - $ ZERO, X, 2, SCALOC, XNORM, IERR ) - IF( IERR.NE.0 ) - $ INFO = 1 -C - IF( SCALOC.NE.ONE ) THEN -C - DO 80 J = 1, N - CALL DSCAL( N, SCALOC, C( 1, J ), 1 ) - 80 CONTINUE -C - SCALE = SCALE*SCALOC - END IF - C( K1, L1 ) = X( 1, 1 ) - C( K2, L1 ) = X( 2, 1 ) - C( L1, K1 ) = X( 1, 1 ) - C( L1, K2 ) = X( 2, 1 ) -C - ELSE IF( L1.NE.L2 .AND. K1.EQ.K2 ) THEN -C - VEC( 1, 1 ) = C( K1, L1 ) - - $ ( DDOT( N-K1, A( K1, MINK1N ), LDA, - $ C( MINK1N, L1 ), 1 ) + - $ DDOT( N-L2, C( K1, MINL2N ), LDC, - $ A( L1, MINL2N ), LDA ) ) -C - VEC( 2, 1 ) = C( K1, L2 ) - - $ ( DDOT( N-K1, A( K1, MINK1N ), LDA, - $ C( MINK1N, L2 ), 1 ) + - $ DDOT( N-L2, C( K1, MINL2N ), LDC, - $ A( L2, MINL2N ), LDA ) ) -C - CALL DLALN2( .FALSE., 2, 1, SMIN, ONE, A( L1, L1 ), - $ LDA, ONE, ONE, VEC, 2, -A( K1, K1 ), - $ ZERO, X, 2, SCALOC, XNORM, IERR ) - IF( IERR.NE.0 ) - $ INFO = 1 -C - IF( SCALOC.NE.ONE ) THEN -C - DO 90 J = 1, N - CALL DSCAL( N, SCALOC, C( 1, J ), 1 ) - 90 CONTINUE -C - SCALE = SCALE*SCALOC - END IF - C( K1, L1 ) = X( 1, 1 ) - C( K1, L2 ) = X( 2, 1 ) - C( L1, K1 ) = X( 1, 1 ) - C( L2, K1 ) = X( 2, 1 ) -C - ELSE IF( L1.NE.L2 .AND. K1.NE.K2 ) THEN -C - VEC( 1, 1 ) = C( K1, L1 ) - - $ ( DDOT( N-K2, A( K1, MINK2N ), LDA, - $ C( MINK2N, L1 ), 1 ) + - $ DDOT( N-L2, C( K1, MINL2N ), LDC, - $ A( L1, MINL2N ), LDA ) ) -C - VEC( 1, 2 ) = C( K1, L2 ) - - $ ( DDOT( N-K2, A( K1, MINK2N ), LDA, - $ C( MINK2N, L2 ), 1 ) + - $ DDOT( N-L2, C( K1, MINL2N ), LDC, - $ A( L2, MINL2N ), LDA ) ) -C - VEC( 2, 1 ) = C( K2, L1 ) - - $ ( DDOT( N-K2, A( K2, MINK2N ), LDA, - $ C( MINK2N, L1 ), 1 ) + - $ DDOT( N-L2, C( K2, MINL2N ), LDC, - $ A( L1, MINL2N ), LDA ) ) -C - VEC( 2, 2 ) = C( K2, L2 ) - - $ ( DDOT( N-K2, A( K2, MINK2N ), LDA, - $ C( MINK2N, L2 ), 1 ) + - $ DDOT( N-L2, C( K2, MINL2N ), LDC, - $ A( L2, MINL2N ), LDA ) ) -C - IF( K1.EQ.L1 ) THEN - CALL SB03MW( .TRUE., LUPPER, A( K1, K1 ), LDA, VEC, - $ 2, SCALOC, X, 2, XNORM, IERR ) - IF( LUPPER ) THEN - X( 2, 1 ) = X( 1, 2 ) - ELSE - X( 1, 2 ) = X( 2, 1 ) - END IF - ELSE - CALL DLASY2( .FALSE., .TRUE., 1, 2, 2, A( K1, K1 ), - $ LDA, A( L1, L1 ), LDA, VEC, 2, SCALOC, - $ X, 2, XNORM, IERR ) - END IF - IF( IERR.NE.0 ) - $ INFO = 1 -C - IF( SCALOC.NE.ONE ) THEN -C - DO 100 J = 1, N - CALL DSCAL( N, SCALOC, C( 1, J ), 1 ) - 100 CONTINUE -C - SCALE = SCALE*SCALOC - END IF - C( K1, L1 ) = X( 1, 1 ) - C( K1, L2 ) = X( 1, 2 ) - C( K2, L1 ) = X( 2, 1 ) - C( K2, L2 ) = X( 2, 2 ) - IF( K1.NE.L1 ) THEN - C( L1, K1 ) = X( 1, 1 ) - C( L2, K1 ) = X( 1, 2 ) - C( L1, K2 ) = X( 2, 1 ) - C( L2, K2 ) = X( 2, 2 ) - END IF - END IF -C - 110 CONTINUE -C - 120 CONTINUE -C - END IF -C - RETURN -C *** Last line of SB03MY *** - END diff --git a/mex/sources/libslicot/SB03OD.f b/mex/sources/libslicot/SB03OD.f deleted file mode 100644 index 0b93c7472..000000000 --- a/mex/sources/libslicot/SB03OD.f +++ /dev/null @@ -1,662 +0,0 @@ - SUBROUTINE SB03OD( DICO, FACT, TRANS, N, M, A, LDA, Q, LDQ, B, - $ LDB, SCALE, WR, WI, DWORK, LDWORK, INFO ) -C -C SLICOT RELEASE 5.0. -C -C Copyright (c) 2002-2009 NICONET e.V. -C -C This program is free software: you can redistribute it and/or -C modify it under the terms of the GNU General Public License as -C published by the Free Software Foundation, either version 2 of -C the License, or (at your option) any later version. -C -C This program is distributed in the hope that it will be useful, -C but WITHOUT ANY WARRANTY; without even the implied warranty of -C MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the -C GNU General Public License for more details. -C -C You should have received a copy of the GNU General Public License -C along with this program. If not, see -C . -C -C PURPOSE -C -C To solve for X = op(U)'*op(U) either the stable non-negative -C definite continuous-time Lyapunov equation -C 2 -C op(A)'*X + X*op(A) = -scale *op(B)'*op(B) (1) -C -C or the convergent non-negative definite discrete-time Lyapunov -C equation -C 2 -C op(A)'*X*op(A) - X = -scale *op(B)'*op(B) (2) -C -C where op(K) = K or K' (i.e., the transpose of the matrix K), A is -C an N-by-N matrix, op(B) is an M-by-N matrix, U is an upper -C triangular matrix containing the Cholesky factor of the solution -C matrix X, X = op(U)'*op(U), and scale is an output scale factor, -C set less than or equal to 1 to avoid overflow in X. If matrix B -C has full rank then the solution matrix X will be positive-definite -C and hence the Cholesky factor U will be nonsingular, but if B is -C rank deficient then X may be only positive semi-definite and U -C will be singular. -C -C In the case of equation (1) the matrix A must be stable (that -C is, all the eigenvalues of A must have negative real parts), -C and for equation (2) the matrix A must be convergent (that is, -C all the eigenvalues of A must lie inside the unit circle). -C -C ARGUMENTS -C -C Mode Parameters -C -C DICO CHARACTER*1 -C Specifies the type of Lyapunov equation to be solved as -C follows: -C = 'C': Equation (1), continuous-time case; -C = 'D': Equation (2), discrete-time case. -C -C FACT CHARACTER*1 -C Specifies whether or not the real Schur factorization -C of the matrix A is supplied on entry, as follows: -C = 'F': On entry, A and Q contain the factors from the -C real Schur factorization of the matrix A; -C = 'N': The Schur factorization of A will be computed -C and the factors will be stored in A and Q. -C -C TRANS CHARACTER*1 -C Specifies the form of op(K) to be used, as follows: -C = 'N': op(K) = K (No transpose); -C = 'T': op(K) = K**T (Transpose). -C -C Input/Output Parameters -C -C N (input) INTEGER -C The order of the matrix A and the number of columns in -C matrix op(B). N >= 0. -C -C M (input) INTEGER -C The number of rows in matrix op(B). M >= 0. -C -C A (input/output) DOUBLE PRECISION array, dimension (LDA,N) -C On entry, the leading N-by-N part of this array must -C contain the matrix A. If FACT = 'F', then A contains -C an upper quasi-triangular matrix S in Schur canonical -C form; the elements below the upper Hessenberg part of the -C array A are not referenced. -C On exit, the leading N-by-N upper Hessenberg part of this -C array contains the upper quasi-triangular matrix S in -C Schur canonical form from the Shur factorization of A. -C The contents of array A is not modified if FACT = 'F'. -C -C LDA INTEGER -C The leading dimension of array A. LDA >= MAX(1,N). -C -C Q (input or output) DOUBLE PRECISION array, dimension -C (LDQ,N) -C On entry, if FACT = 'F', then the leading N-by-N part of -C this array must contain the orthogonal matrix Q of the -C Schur factorization of A. -C Otherwise, Q need not be set on entry. -C On exit, the leading N-by-N part of this array contains -C the orthogonal matrix Q of the Schur factorization of A. -C The contents of array Q is not modified if FACT = 'F'. -C -C LDQ INTEGER -C The leading dimension of array Q. LDQ >= MAX(1,N). -C -C B (input/output) DOUBLE PRECISION array, dimension (LDB,N) -C if TRANS = 'N', and dimension (LDB,max(M,N)), if -C TRANS = 'T'. -C On entry, if TRANS = 'N', the leading M-by-N part of this -C array must contain the coefficient matrix B of the -C equation. -C On entry, if TRANS = 'T', the leading N-by-M part of this -C array must contain the coefficient matrix B of the -C equation. -C On exit, the leading N-by-N part of this array contains -C the upper triangular Cholesky factor U of the solution -C matrix X of the problem, X = op(U)'*op(U). -C If M = 0 and N > 0, then U is set to zero. -C -C LDB INTEGER -C The leading dimension of array B. -C LDB >= MAX(1,N,M), if TRANS = 'N'; -C LDB >= MAX(1,N), if TRANS = 'T'. -C -C SCALE (output) DOUBLE PRECISION -C The scale factor, scale, set less than or equal to 1 to -C prevent the solution overflowing. -C -C WR (output) DOUBLE PRECISION array, dimension (N) -C WI (output) DOUBLE PRECISION array, dimension (N) -C If FACT = 'N', and INFO >= 0 and INFO <= 2, WR and WI -C contain the real and imaginary parts, respectively, of -C the eigenvalues of A. -C If FACT = 'F', WR and WI are not referenced. -C -C Workspace -C -C DWORK DOUBLE PRECISION array, dimension (LDWORK) -C On exit, if INFO = 0, or INFO = 1, DWORK(1) returns the -C optimal value of LDWORK. -C -C LDWORK INTEGER -C The length of the array DWORK. -C If M > 0, LDWORK >= MAX(1,4*N + MIN(M,N)); -C If M = 0, LDWORK >= 1. -C For optimum performance LDWORK should sometimes be larger. -C -C Error Indicator -C -C INFO INTEGER -C = 0: successful exit; -C < 0: if INFO = -i, the i-th argument had an illegal -C value; -C = 1: if the Lyapunov equation is (nearly) singular -C (warning indicator); -C if DICO = 'C' this means that while the matrix A -C (or the factor S) has computed eigenvalues with -C negative real parts, it is only just stable in the -C sense that small perturbations in A can make one or -C more of the eigenvalues have a non-negative real -C part; -C if DICO = 'D' this means that while the matrix A -C (or the factor S) has computed eigenvalues inside -C the unit circle, it is nevertheless only just -C convergent, in the sense that small perturbations -C in A can make one or more of the eigenvalues lie -C outside the unit circle; -C perturbed values were used to solve the equation; -C = 2: if FACT = 'N' and DICO = 'C', but the matrix A is -C not stable (that is, one or more of the eigenvalues -C of A has a non-negative real part), or DICO = 'D', -C but the matrix A is not convergent (that is, one or -C more of the eigenvalues of A lies outside the unit -C circle); however, A will still have been factored -C and the eigenvalues of A returned in WR and WI. -C = 3: if FACT = 'F' and DICO = 'C', but the Schur factor S -C supplied in the array A is not stable (that is, one -C or more of the eigenvalues of S has a non-negative -C real part), or DICO = 'D', but the Schur factor S -C supplied in the array A is not convergent (that is, -C one or more of the eigenvalues of S lies outside the -C unit circle); -C = 4: if FACT = 'F' and the Schur factor S supplied in -C the array A has two or more consecutive non-zero -C elements on the first sub-diagonal, so that there is -C a block larger than 2-by-2 on the diagonal; -C = 5: if FACT = 'F' and the Schur factor S supplied in -C the array A has a 2-by-2 diagonal block with real -C eigenvalues instead of a complex conjugate pair; -C = 6: if FACT = 'N' and the LAPACK Library routine DGEES -C has failed to converge. This failure is not likely -C to occur. The matrix B will be unaltered but A will -C be destroyed. -C -C METHOD -C -C The method used by the routine is based on the Bartels and Stewart -C method [1], except that it finds the upper triangular matrix U -C directly without first finding X and without the need to form the -C normal matrix op(B)'*op(B). -C -C The Schur factorization of a square matrix A is given by -C -C A = QSQ', -C -C where Q is orthogonal and S is an N-by-N block upper triangular -C matrix with 1-by-1 and 2-by-2 blocks on its diagonal (which -C correspond to the eigenvalues of A). If A has already been -C factored prior to calling the routine however, then the factors -C Q and S may be supplied and the initial factorization omitted. -C -C If TRANS = 'N', the matrix B is factored as (QR factorization) -C _ _ _ _ _ -C B = P ( R ), M >= N, B = P ( R Z ), M < N, -C ( 0 ) -C _ _ -C where P is an M-by-M orthogonal matrix and R is a square upper -C _ _ _ _ _ -C triangular matrix. Then, the matrix B = RQ, or B = ( R Z )Q (if -C M < N) is factored as -C _ _ -C B = P ( R ), M >= N, B = P ( R Z ), M < N. -C -C If TRANS = 'T', the matrix B is factored as (RQ factorization) -C _ -C _ _ ( Z ) _ -C B = ( 0 R ) P, M >= N, B = ( _ ) P, M < N, -C ( R ) -C _ _ -C where P is an M-by-M orthogonal matrix and R is a square upper -C _ _ _ _ _ -C triangular matrix. Then, the matrix B = Q'R, or B = Q'( Z' R' )' -C (if M < N) is factored as -C _ _ -C B = ( R ) P, M >= N, B = ( Z ) P, M < N. -C ( R ) -C -C These factorizations are utilised to either transform the -C continuous-time Lyapunov equation to the canonical form -C 2 -C op(S)'*op(V)'*op(V) + op(V)'*op(V)*op(S) = -scale *op(F)'*op(F), -C -C or the discrete-time Lyapunov equation to the canonical form -C 2 -C op(S)'*op(V)'*op(V)*op(S) - op(V)'*op(V) = -scale *op(F)'*op(F), -C -C where V and F are upper triangular, and -C -C F = R, M >= N, F = ( R Z ), M < N, if TRANS = 'N'; -C ( 0 0 ) -C -C F = R, M >= N, F = ( 0 Z ), M < N, if TRANS = 'T'. -C ( 0 R ) -C -C The transformed equation is then solved for V, from which U is -C obtained via the QR factorization of V*Q', if TRANS = 'N', or -C via the RQ factorization of Q*V, if TRANS = 'T'. -C -C REFERENCES -C -C [1] Bartels, R.H. and Stewart, G.W. -C Solution of the matrix equation A'X + XB = C. -C Comm. A.C.M., 15, pp. 820-826, 1972. -C -C [2] Hammarling, S.J. -C Numerical solution of the stable, non-negative definite -C Lyapunov equation. -C IMA J. Num. Anal., 2, pp. 303-325, 1982. -C -C NUMERICAL ASPECTS -C 3 -C The algorithm requires 0(N ) operations and is backward stable. -C -C FURTHER COMMENTS -C -C The Lyapunov equation may be very ill-conditioned. In particular, -C if A is only just stable (or convergent) then the Lyapunov -C equation will be ill-conditioned. A symptom of ill-conditioning -C is "large" elements in U relative to those of A and B, or a -C "small" value for scale. A condition estimate can be computed -C using SLICOT Library routine SB03MD. -C -C SB03OD routine can be also used for solving "unstable" Lyapunov -C equations, i.e., when matrix A has all eigenvalues with positive -C real parts, if DICO = 'C', or with moduli greater than one, -C if DICO = 'D'. Specifically, one may solve for X = op(U)'*op(U) -C either the continuous-time Lyapunov equation -C 2 -C op(A)'*X + X*op(A) = scale *op(B)'*op(B), (3) -C -C or the discrete-time Lyapunov equation -C 2 -C op(A)'*X*op(A) - X = scale *op(B)'*op(B), (4) -C -C provided, for equation (3), the given matrix A is replaced by -A, -C or, for equation (4), the given matrices A and B are replaced by -C inv(A) and B*inv(A), if TRANS = 'N' (or inv(A)*B, if TRANS = 'T'), -C respectively. Although the inversion generally can rise numerical -C problems, in case of equation (4) it is expected that the matrix A -C is enough well-conditioned, having only eigenvalues with moduli -C greater than 1. However, if A is ill-conditioned, it could be -C preferable to use the more general SLICOT Lyapunov solver SB03MD. -C -C CONTRIBUTOR -C -C Release 3.0: V. Sima, Katholieke Univ. Leuven, Belgium, Aug. 1997. -C Supersedes Release 2.0 routine SB03CD by Sven Hammarling, -C NAG Ltd, United Kingdom. -C -C REVISIONS -C -C Dec. 1997, April 1998, May 1998, May 1999, Oct. 2001 (V. Sima). -C March 2002 (A. Varga). -C -C KEYWORDS -C -C Lyapunov equation, orthogonal transformation, real Schur form, -C Sylvester equation. -C -C ****************************************************************** -C -C .. Parameters .. - DOUBLE PRECISION ZERO, ONE - PARAMETER ( ZERO = 0.0D0, ONE = 1.0D0 ) -C .. Scalar Arguments .. - CHARACTER DICO, FACT, TRANS - INTEGER INFO, LDA, LDB, LDQ, LDWORK, M, N - DOUBLE PRECISION SCALE -C .. Array Arguments .. - DOUBLE PRECISION A(LDA,*), B(LDB,*), DWORK(*), Q(LDQ,*), WI(*), - $ WR(*) -C .. Local Scalars .. - LOGICAL CONT, LTRANS, NOFACT - INTEGER I, IFAIL, INFORM, ITAU, J, JWORK, K, L, MINMN, - $ NE, SDIM, WRKOPT - DOUBLE PRECISION EMAX, TEMP -C .. Local Arrays .. - LOGICAL BWORK(1) -C .. External Functions .. - LOGICAL LSAME, SELECT - DOUBLE PRECISION DLAPY2 - EXTERNAL DLAPY2, LSAME, SELECT -C .. External Subroutines .. - EXTERNAL DCOPY, DGEES, DGEMM, DGEMV, DGEQRF, DGERQF, - $ DLACPY, DLASET, DTRMM, SB03OU, XERBLA -C .. Intrinsic Functions .. - INTRINSIC INT, MAX, MIN -C .. Executable Statements .. -C -C Test the input scalar arguments. -C - CONT = LSAME( DICO, 'C' ) - NOFACT = LSAME( FACT, 'N' ) - LTRANS = LSAME( TRANS, 'T' ) - MINMN = MIN( M, N ) -C - INFO = 0 - IF( .NOT.CONT .AND. .NOT.LSAME( DICO, 'D' ) ) THEN - INFO = -1 - ELSE IF( .NOT.NOFACT .AND. .NOT.LSAME( FACT, 'F' ) ) THEN - INFO = -2 - ELSE IF( .NOT.LTRANS .AND. .NOT.LSAME( TRANS, 'N' ) ) THEN - INFO = -3 - ELSE IF( N.LT.0 ) THEN - INFO = -4 - ELSE IF( M.LT.0 ) THEN - INFO = -5 - ELSE IF( LDA.LT.MAX( 1, N ) ) THEN - INFO = -7 - ELSE IF( LDQ.LT.MAX( 1, N ) ) THEN - INFO = -9 - ELSE IF( ( LDB.LT.MAX( 1, N ) ) .OR. - $ ( LDB.LT.MAX( 1, N, M ) .AND. .NOT.LTRANS ) ) THEN - INFO = -11 - ELSE IF( LDWORK.LT.1 .OR. ( M.GT.0 .AND. LDWORK.LT.4*N + MINMN ) ) - $ THEN - INFO = -16 - END IF -C - IF ( INFO.NE.0 ) THEN -C -C Error return. -C - CALL XERBLA( 'SB03OD', -INFO ) - RETURN - END IF -C -C Quick return if possible. -C - IF( MINMN.EQ.0 ) THEN - IF( M.EQ.0 ) - $ CALL DLASET( 'Full', N, N, ZERO, ZERO, B, LDB ) - SCALE = ONE - DWORK(1) = ONE - RETURN - END IF -C -C Start the solution. -C -C (Note: Comments in the code beginning "Workspace:" describe the -C minimal amount of real workspace needed at that point in the -C code, as well as the preferred amount for good performance. -C NB refers to the optimal block size for the immediately -C following subroutine, as returned by ILAENV.) -C - IF ( NOFACT ) THEN -C -C Find the Schur factorization of A, A = Q*S*Q'. -C Workspace: need 3*N; -C prefer larger. -C - CALL DGEES( 'Vectors', 'Not ordered', SELECT, N, A, LDA, SDIM, - $ WR, WI, Q, LDQ, DWORK, LDWORK, BWORK, INFORM ) - IF ( INFORM.NE.0 ) THEN - INFO = 6 - RETURN - END IF - WRKOPT = DWORK(1) -C -C Check the eigenvalues for stability. -C - IF ( CONT ) THEN - EMAX = WR(1) -C - DO 20 J = 2, N - IF ( WR(J).GT.EMAX ) - $ EMAX = WR(J) - 20 CONTINUE -C - ELSE - EMAX = DLAPY2( WR(1), WI(1) ) -C - DO 40 J = 2, N - TEMP = DLAPY2( WR(J), WI(J) ) - IF ( TEMP.GT.EMAX ) - $ EMAX = TEMP - 40 CONTINUE -C - END IF -C - IF ( ( CONT ) .AND. ( EMAX.GE.ZERO ) .OR. - $ ( .NOT.CONT ) .AND. ( EMAX.GE.ONE ) ) THEN - INFO = 2 - RETURN - END IF - ELSE - WRKOPT = 0 - END IF -C -C Perform the QR or RQ factorization of B, -C _ _ _ _ _ -C B = P ( R ), or B = P ( R Z ), if TRANS = 'N', or -C ( 0 ) -C _ -C _ _ ( Z ) _ -C B = ( 0 R ) P, or B = ( _ ) P, if TRANS = 'T'. -C ( R ) -C Workspace: need MIN(M,N) + N; -C prefer MIN(M,N) + N*NB. -C - ITAU = 1 - JWORK = ITAU + MINMN - IF ( LTRANS ) THEN - CALL DGERQF( N, M, B, LDB, DWORK(ITAU), DWORK(JWORK), - $ LDWORK-JWORK+1, IFAIL ) - WRKOPT = MAX( WRKOPT, INT( DWORK(JWORK) ) + JWORK - 1, MINMN*N) - JWORK = ITAU -C -C Form in B -C _ _ _ _ _ _ -C B := Q'R, m >= n, B := Q'*( Z' R' )', m < n, with B an -C n-by-min(m,n) matrix. -C Use a BLAS 3 operation if enough workspace, and BLAS 2, -C _ -C otherwise: B is formed column by column. -C - IF ( LDWORK.GE.JWORK+MINMN*N-1 ) THEN - K = JWORK -C - DO 60 I = 1, MINMN - CALL DCOPY( N, Q(N-MINMN+I,1), LDQ, DWORK(K), 1 ) - K = K + N - 60 CONTINUE -C - CALL DTRMM( 'Right', 'Upper', 'No transpose', 'Non-unit', - $ N, MINMN, ONE, B(N-MINMN+1,M-MINMN+1), LDB, - $ DWORK(JWORK), N ) - IF ( M.LT.N ) - $ CALL DGEMM( 'Transpose', 'No transpose', N, M, N-M, - $ ONE, Q, LDQ, B, LDB, ONE, DWORK(JWORK), N ) - CALL DLACPY( 'Full', N, MINMN, DWORK(JWORK), N, B, LDB ) - ELSE - NE = N - MINMN -C - DO 80 J = 1, MINMN - NE = NE + 1 - CALL DCOPY( NE, B(1,M-MINMN+J), 1, DWORK(JWORK), 1 ) - CALL DGEMV( 'Transpose', NE, N, ONE, Q, LDQ, - $ DWORK(JWORK), 1, ZERO, B(1,J), 1 ) - 80 CONTINUE -C - END IF - ELSE - CALL DGEQRF( M, N, B, LDB, DWORK(ITAU), DWORK(JWORK), - $ LDWORK-JWORK+1, IFAIL ) - WRKOPT = MAX( WRKOPT, INT( DWORK(JWORK) ) + JWORK - 1, MINMN*N) - JWORK = ITAU -C -C Form in B -C _ _ _ _ _ _ -C B := RQ, m >= n, B := ( R Z )*Q, m < n, with B an -C min(m,n)-by-n matrix. -C Use a BLAS 3 operation if enough workspace, and BLAS 2, -C _ -C otherwise: B is formed row by row. -C - IF ( LDWORK.GE.JWORK+MINMN*N-1 ) THEN - CALL DLACPY( 'Full', MINMN, N, Q, LDQ, DWORK(JWORK), MINMN ) - CALL DTRMM( 'Left', 'Upper', 'No transpose', 'Non-unit', - $ MINMN, N, ONE, B, LDB, DWORK(JWORK), MINMN ) - IF ( M.LT.N ) - $ CALL DGEMM( 'No transpose', 'No transpose', M, N, N-M, - $ ONE, B(1,M+1), LDB, Q(M+1,1), LDQ, ONE, - $ DWORK(JWORK), MINMN ) - CALL DLACPY( 'Full', MINMN, N, DWORK(JWORK), MINMN, B, LDB ) - ELSE - NE = MINMN + MAX( 0, N-M ) -C - DO 100 J = 1, MINMN - CALL DCOPY( NE, B(J,J), LDB, DWORK(JWORK), 1 ) - CALL DGEMV( 'Transpose', NE, N, ONE, Q(J,1), LDQ, - $ DWORK(JWORK), 1, ZERO, B(J,1), LDB ) - NE = NE - 1 - 100 CONTINUE -C - END IF - END IF - JWORK = ITAU + MINMN -C -C Solve for U the transformed Lyapunov equation -C 2 _ _ -C op(S)'*op(U)'*op(U) + op(U)'*op(U)*op(S) = -scale *op(B)'*op(B), -C -C or -C 2 _ _ -C op(S)'*op(U)'*op(U)*op(S) - op(U)'*op(U) = -scale *op(B)'*op(B) -C -C Workspace: need MIN(M,N) + 4*N; -C prefer larger. -C - CALL SB03OU( .NOT.CONT, LTRANS, N, MINMN, A, LDA, B, LDB, - $ DWORK(ITAU), B, LDB, SCALE, DWORK(JWORK), - $ LDWORK-JWORK+1, INFO ) - IF ( INFO.GT.1 ) THEN - INFO = INFO + 1 - RETURN - END IF - WRKOPT = MAX( WRKOPT, INT( DWORK(JWORK) ) + JWORK - 1 ) - JWORK = ITAU -C -C Form U := U*Q' or U := Q*U in the array B. -C Use a BLAS 3 operation if enough workspace, and BLAS 2, otherwise. -C Workspace: need N; -C prefer N*N; -C - IF ( LDWORK.GE.JWORK+N*N-1 ) THEN - IF ( LTRANS ) THEN - CALL DLACPY( 'Full', N, N, Q, LDQ, DWORK(JWORK), N ) - CALL DTRMM( 'Right', 'Upper', 'No transpose', 'Non-unit', N, - $ N, ONE, B, LDB, DWORK(JWORK), N ) - ELSE - K = JWORK -C - DO 120 I = 1, N - CALL DCOPY( N, Q(1,I), 1, DWORK(K), N ) - K = K + 1 - 120 CONTINUE -C - CALL DTRMM( 'Left', 'Upper', 'No transpose', 'Non-unit', N, - $ N, ONE, B, LDB, DWORK(JWORK), N ) - END IF - CALL DLACPY( 'Full', N, N, DWORK(JWORK), N, B, LDB ) - WRKOPT = MAX( WRKOPT, JWORK + N*N - 1 ) - ELSE - IF ( LTRANS ) THEN -C -C U is formed column by column ( U := Q*U ). -C - DO 140 I = 1, N - CALL DCOPY( I, B(1,I), 1, DWORK(JWORK), 1 ) - CALL DGEMV( 'No transpose', N, I, ONE, Q, LDQ, - $ DWORK(JWORK), 1, ZERO, B(1,I), 1 ) - 140 CONTINUE - ELSE -C -C U is formed row by row ( U' := Q*U' ). -C - DO 160 I = 1, N - CALL DCOPY( N-I+1, B(I,I), LDB, DWORK(JWORK), 1 ) - CALL DGEMV( 'No transpose', N, N-I+1, ONE, Q(1,I), LDQ, - $ DWORK(JWORK), 1, ZERO, B(I,1), LDB ) - 160 CONTINUE - END IF - END IF -C -C Lastly find the QR or RQ factorization of U, overwriting on B, -C to give the required Cholesky factor. -C Workspace: need 2*N; -C prefer N + N*NB; -C - JWORK = ITAU + N - IF ( LTRANS ) THEN - CALL DGERQF( N, N, B, LDB, DWORK(ITAU), DWORK(JWORK), - $ LDWORK-JWORK+1, IFAIL ) - ELSE - CALL DGEQRF( N, N, B, LDB, DWORK(ITAU), DWORK(JWORK), - $ LDWORK-JWORK+1, IFAIL ) - END IF - WRKOPT = MAX( WRKOPT, INT( DWORK(JWORK) ) + JWORK - 1 ) -C -C Make the diagonal elements of U non-negative. -C - IF ( LTRANS ) THEN -C - DO 200 J = 1, N - IF ( B(J,J).LT.ZERO ) THEN -C - DO 180 I = 1, J - B(I,J) = -B(I,J) - 180 CONTINUE -C - END IF - 200 CONTINUE -C - ELSE - K = JWORK -C - DO 240 J = 1, N - DWORK(K) = B(J,J) - L = JWORK -C - DO 220 I = 1, J - IF ( DWORK(L).LT.ZERO ) B(I,J) = -B(I,J) - L = L + 1 - 220 CONTINUE -C - K = K + 1 - 240 CONTINUE - END IF -C - IF( N.GT.1 ) - $ CALL DLASET( 'Lower', N-1, N-1, ZERO, ZERO, B(2,1), LDB ) -C -C Set the optimal workspace. -C - DWORK(1) = WRKOPT -C - RETURN -C *** Last line of SB03OD *** - END diff --git a/mex/sources/libslicot/SB03OR.f b/mex/sources/libslicot/SB03OR.f deleted file mode 100644 index 1094f26f5..000000000 --- a/mex/sources/libslicot/SB03OR.f +++ /dev/null @@ -1,429 +0,0 @@ - SUBROUTINE SB03OR( DISCR, LTRANS, N, M, S, LDS, A, LDA, C, LDC, - $ SCALE, INFO ) -C -C SLICOT RELEASE 5.0. -C -C Copyright (c) 2002-2009 NICONET e.V. -C -C This program is free software: you can redistribute it and/or -C modify it under the terms of the GNU General Public License as -C published by the Free Software Foundation, either version 2 of -C the License, or (at your option) any later version. -C -C This program is distributed in the hope that it will be useful, -C but WITHOUT ANY WARRANTY; without even the implied warranty of -C MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the -C GNU General Public License for more details. -C -C You should have received a copy of the GNU General Public License -C along with this program. If not, see -C . -C -C PURPOSE -C -C To compute the solution of the Sylvester equations -C -C op(S)'*X + X*op(A) = scale*C, if DISCR = .FALSE. or -C -C op(S)'*X*op(A) - X = scale*C, if DISCR = .TRUE. -C -C where op(K) = K or K' (i.e., the transpose of the matrix K), S is -C an N-by-N block upper triangular matrix with one-by-one and -C two-by-two blocks on the diagonal, A is an M-by-M matrix (M = 1 or -C M = 2), X and C are each N-by-M matrices, and scale is an output -C scale factor, set less than or equal to 1 to avoid overflow in X. -C The solution X is overwritten on C. -C -C SB03OR is a service routine for the Lyapunov solver SB03OT. -C -C ARGUMENTS -C -C Mode Parameters -C -C DISCR LOGICAL -C Specifies the equation to be solved: -C = .FALSE.: op(S)'*X + X*op(A) = scale*C; -C = .TRUE. : op(S)'*X*op(A) - X = scale*C. -C -C LTRANS LOGICAL -C Specifies the form of op(K) to be used, as follows: -C = .FALSE.: op(K) = K (No transpose); -C = .TRUE. : op(K) = K**T (Transpose). -C -C Input/Output Parameters -C -C N (input) INTEGER -C The order of the matrix S and also the number of rows of -C matrices X and C. N >= 0. -C -C M (input) INTEGER -C The order of the matrix A and also the number of columns -C of matrices X and C. M = 1 or M = 2. -C -C S (input) DOUBLE PRECISION array, dimension (LDS,N) -C The leading N-by-N upper Hessenberg part of the array S -C must contain the block upper triangular matrix. The -C elements below the upper Hessenberg part of the array S -C are not referenced. The array S must not contain -C diagonal blocks larger than two-by-two and the two-by-two -C blocks must only correspond to complex conjugate pairs of -C eigenvalues, not to real eigenvalues. -C -C LDS INTEGER -C The leading dimension of array S. LDS >= MAX(1,N). -C -C A (input) DOUBLE PRECISION array, dimension (LDS,M) -C The leading M-by-M part of this array must contain a -C given matrix, where M = 1 or M = 2. -C -C LDA INTEGER -C The leading dimension of array A. LDA >= M. -C -C C (input/output) DOUBLE PRECISION array, dimension (LDC,M) -C On entry, C must contain an N-by-M matrix, where M = 1 or -C M = 2. -C On exit, C contains the N-by-M matrix X, the solution of -C the Sylvester equation. -C -C LDC INTEGER -C The leading dimension of array C. LDC >= MAX(1,N). -C -C SCALE (output) DOUBLE PRECISION -C The scale factor, scale, set less than or equal to 1 to -C prevent the solution overflowing. -C -C Error Indicator -C -C INFO INTEGER -C = 0: successful exit; -C = 1: if DISCR = .FALSE., and S and -A have common -C eigenvalues, or if DISCR = .TRUE., and S and A have -C eigenvalues whose product is equal to unity; -C a solution has been computed using slightly -C perturbed values. -C -C METHOD -C -C The LAPACK scheme for solving Sylvester equations is adapted. -C -C REFERENCES -C -C [1] Hammarling, S.J. -C Numerical solution of the stable, non-negative definite -C Lyapunov equation. -C IMA J. Num. Anal., 2, pp. 303-325, 1982. -C -C NUMERICAL ASPECTS -C 2 -C The algorithm requires 0(N M) operations and is backward stable. -C -C CONTRIBUTOR -C -C Release 3.0: V. Sima, Katholieke Univ. Leuven, Belgium, May 1997. -C Supersedes Release 2.0 routines SB03CW and SB03CX by -C Sven Hammarling, NAG Ltd, United Kingdom, Oct. 1986. -C Partly based on routine PLYAP4 by A. Varga, University of Bochum, -C May 1992. -C -C REVISIONS -C -C December 1997, April 1998, May 1999, April 2000. -C -C KEYWORDS -C -C Lyapunov equation, orthogonal transformation, real Schur form. -C -C ****************************************************************** -C -C .. Parameters .. - DOUBLE PRECISION ZERO, ONE - PARAMETER ( ZERO = 0.0D+0, ONE = 1.0D+0 ) -C .. Scalar Arguments .. - LOGICAL DISCR, LTRANS - INTEGER INFO, LDA, LDS, LDC, M, N - DOUBLE PRECISION SCALE -C .. -C .. Array Arguments .. - DOUBLE PRECISION A( LDA, * ), C( LDC, * ), S( LDS, * ) -C .. Local Scalars .. - LOGICAL TBYT - INTEGER DL, INFOM, ISGN, J, L, L1, L2, L2P1, LNEXT - DOUBLE PRECISION G11, G12, G21, G22, SCALOC, XNORM -C .. -C .. Local Arrays .. - DOUBLE PRECISION AT( 2, 2 ), VEC( 2, 2 ), X( 2, 2 ) -C .. -C .. External Functions .. - DOUBLE PRECISION DDOT - EXTERNAL DDOT -C .. -C .. External Subroutines .. - EXTERNAL DLASY2, DSCAL, SB04PX, XERBLA -C .. Intrinsic Functions .. - INTRINSIC MAX, MIN -C .. -C .. Executable Statements .. -C - INFO = 0 -C -C Test the input scalar arguments. -C - IF( N.LT.0 ) THEN - INFO = -3 - ELSE IF( .NOT.( M.EQ.1 .OR. M.EQ.2 ) ) THEN - INFO = -4 - ELSE IF( LDS.LT.MAX( 1, N ) ) THEN - INFO = -6 - ELSE IF( LDA.LT.M ) THEN - INFO = -8 - ELSE IF( LDC.LT.MAX( 1, N ) ) THEN - INFO = -10 - END IF -C - IF ( INFO.NE.0 ) THEN -C -C Error return. -C - CALL XERBLA( 'SB03OR', -INFO ) - RETURN - END IF -C - SCALE = ONE -C -C Quick return if possible. -C - IF ( N.EQ.0 ) - $ RETURN -C - ISGN = 1 - TBYT = M.EQ.2 - INFOM = 0 -C -C Construct A'. -C - AT(1,1) = A(1,1) - IF ( TBYT ) THEN - AT(1,2) = A(2,1) - AT(2,1) = A(1,2) - AT(2,2) = A(2,2) - END IF -C - IF ( LTRANS ) THEN -C -C Start row loop (index = L). -C L1 (L2) : row index of the first (last) row of X(L). -C - LNEXT = N -C - DO 20 L = N, 1, -1 - IF( L.GT.LNEXT ) - $ GO TO 20 - L1 = L - L2 = L - IF( L.GT.1 ) THEN - IF( S( L, L-1 ).NE.ZERO ) - $ L1 = L1 - 1 - LNEXT = L1 - 1 - END IF - DL = L2 - L1 + 1 - L2P1 = MIN( L2+1, N ) -C - IF ( DISCR ) THEN -C -C Solve S*X*A' - X = scale*C. -C -C The L-th block of X is determined from -C -C S(L,L)*X(L)*A' - X(L) = C(L) - R(L), -C -C where -C -C N -C R(L) = SUM [S(L,J)*X(J)] * A' . -C J=L+1 -C - G11 = -DDOT( N-L2, S( L1, L2P1 ), LDS, C( L2P1, 1 ), 1 ) - IF ( TBYT ) THEN - G12 = -DDOT( N-L2, S( L1, L2P1 ), LDS, C( L2P1, 2 ), - $ 1 ) - VEC( 1, 1 ) = C( L1, 1 ) + G11*AT(1,1) + G12*AT(2,1) - VEC( 1, 2 ) = C( L1, 2 ) + G11*AT(1,2) + G12*AT(2,2) - ELSE - VEC (1, 1 ) = C( L1, 1 ) + G11*AT(1,1) - END IF - IF ( DL.NE.1 ) THEN - G21 = -DDOT( N-L2, S( L2, L2P1 ), LDS, C( L2P1, 1 ), - $ 1 ) - IF ( TBYT ) THEN - G22 = -DDOT( N-L2, S( L2, L2P1 ), LDS, - $ C( L2P1, 2 ), 1 ) - VEC( 2, 1 ) = C( L2, 1 ) + G21*AT(1,1) + - $ G22*AT(2,1) - VEC( 2, 2 ) = C( L2, 2 ) + G21*AT(1,2) + - $ G22*AT(2,2) - ELSE - VEC( 2, 1 ) = C( L2, 1 ) + G21*AT(1,1) - END IF - END IF - CALL SB04PX( .FALSE., .FALSE., -ISGN, DL, M, S( L1, L1 ), - $ LDS, AT, 2, VEC, 2, SCALOC, X, 2, XNORM, - $ INFO ) - ELSE -C -C Solve S*X + X*A' = scale*C. -C -C The L-th block of X is determined from -C -C S(L,L)*X(L) + X(L)*A' = C(L) - R(L), -C -C where -C N -C R(L) = SUM S(L,J)*X(J) . -C J=L+1 -C - VEC( 1, 1 ) = C( L1, 1 ) - - $ DDOT( N-L2, S( L1, L2P1 ), LDS, - $ C( L2P1, 1 ), 1 ) - IF ( TBYT ) - $ VEC( 1, 2 ) = C( L1, 2 ) - - $ DDOT( N-L2, S( L1, L2P1 ), LDS, - $ C( L2P1, 2 ), 1 ) -C - IF ( DL.NE.1 ) THEN - VEC( 2, 1 ) = C( L2, 1 ) - - $ DDOT( N-L2, S( L2, L2P1 ), LDS, - $ C( L2P1, 1 ), 1 ) - IF ( TBYT ) - $ VEC( 2, 2 ) = C( L2, 2 ) - - $ DDOT( N-L2, S( L2, L2P1 ), LDS, - $ C( L2P1, 2 ), 1 ) - END IF - CALL DLASY2( .FALSE., .FALSE., ISGN, DL, M, S( L1, L1 ), - $ LDS, AT, 2, VEC, 2, SCALOC, X, 2, XNORM, - $ INFO ) - END IF - INFOM = MAX( INFO, INFOM ) - IF ( SCALOC.NE.ONE ) THEN -C - DO 10 J = 1, M - CALL DSCAL( N, SCALOC, C( 1, J ), 1 ) - 10 CONTINUE -C - SCALE = SCALE*SCALOC - END IF - C( L1, 1 ) = X( 1, 1 ) - IF ( TBYT ) C( L1, 2 ) = X( 1, 2 ) - IF ( DL.NE.1 ) THEN - C( L2, 1 ) = X( 2, 1 ) - IF ( TBYT ) C( L2, 2 ) = X( 2, 2 ) - END IF - 20 CONTINUE -C - ELSE -C -C Start row loop (index = L). -C L1 (L2) : row index of the first (last) row of X(L). -C - LNEXT = 1 -C - DO 40 L = 1, N - IF( L.LT.LNEXT ) - $ GO TO 40 - L1 = L - L2 = L - IF( L.LT.N ) THEN - IF( S( L+1, L ).NE.ZERO ) - $ L2 = L2 + 1 - LNEXT = L2 + 1 - END IF - DL = L2 - L1 + 1 -C - IF ( DISCR ) THEN -C -C Solve A'*X'*S - X' = scale*C'. -C -C The L-th block of X is determined from -C -C A'*X(L)'*S(L,L) - X(L)' = C(L)' - R(L), -C -C where -C -C L-1 -C R(L) = A' * SUM [X(J)'*S(J,L)] . -C J=1 -C - G11 = -DDOT( L1-1, C, 1, S( 1, L1 ), 1 ) - IF ( TBYT ) THEN - G21 = -DDOT( L1-1, C( 1, 2 ), 1, S( 1, L1 ), 1 ) - VEC( 1, 1 ) = C( L1, 1 ) + AT(1,1)*G11 + AT(1,2)*G21 - VEC( 2, 1 ) = C( L1, 2 ) + AT(2,1)*G11 + AT(2,2)*G21 - ELSE - VEC (1, 1 ) = C( L1, 1 ) + AT(1,1)*G11 - END IF - IF ( DL .NE. 1 ) THEN - G12 = -DDOT( L1-1, C, 1, S( 1, L2 ), 1 ) - IF ( TBYT ) THEN - G22 = -DDOT( L1-1, C( 1, 2 ), 1, S( 1, L2 ), 1 ) - VEC( 1, 2 ) = C( L2, 1 ) + AT(1,1)*G12 + - $ AT(1,2)*G22 - VEC( 2, 2 ) = C( L2, 2 ) + AT(2,1)*G12 + - $ AT(2,2)*G22 - ELSE - VEC( 1, 2 ) = C( L2, 1 ) + AT(1,1)*G12 - END IF - END IF - CALL SB04PX( .FALSE., .FALSE., -ISGN, M, DL, AT, 2, - $ S( L1, L1 ), LDS, VEC, 2, SCALOC, X, 2, - $ XNORM, INFO ) - ELSE -C -C Solve A'*X' + X'*S = scale*C'. -C -C The L-th block of X is determined from -C -C A'*X(L)' + X(L)'*S(L,L) = C(L)' - R(L), -C -C where -C L-1 -C R(L) = SUM [X(J)'*S(J,L)]. -C J=1 -C - VEC( 1, 1 ) = C( L1, 1 ) - - $ DDOT( L1-1, C, 1, S( 1, L1 ), 1 ) - IF ( TBYT ) - $ VEC( 2, 1 ) = C( L1, 2 ) - - $ DDOT( L1-1, C( 1, 2 ), 1, S( 1, L1 ), 1) -C - IF ( DL.NE.1 ) THEN - VEC( 1, 2 ) = C( L2, 1 ) - - $ DDOT( L1-1, C, 1, S( 1, L2 ), 1 ) - IF ( TBYT ) - $ VEC( 2, 2 ) = C( L2, 2 ) - - $ DDOT( L1-1, C( 1, 2 ), 1, S( 1, L2 ), 1) - END IF - CALL DLASY2( .FALSE., .FALSE., ISGN, M, DL, AT, 2, - $ S( L1, L1 ), LDS, VEC, 2, SCALOC, X, 2, - $ XNORM, INFO ) - END IF - INFOM = MAX( INFO, INFOM ) - IF ( SCALOC.NE.ONE ) THEN -C - DO 30 J = 1, M - CALL DSCAL( N, SCALOC, C( 1, J ), 1 ) - 30 CONTINUE -C - SCALE = SCALE*SCALOC - END IF - C( L1, 1 ) = X( 1, 1 ) - IF ( TBYT ) C( L1, 2 ) = X( 2, 1 ) - IF ( DL.NE.1 ) THEN - C( L2, 1 ) = X( 1, 2 ) - IF ( TBYT ) C( L2, 2 ) = X( 2, 2 ) - END IF - 40 CONTINUE - END IF -C - INFO = INFOM - RETURN -C *** Last line of SB03OR *** - END diff --git a/mex/sources/libslicot/SB03OT.f b/mex/sources/libslicot/SB03OT.f deleted file mode 100644 index 92550bf56..000000000 --- a/mex/sources/libslicot/SB03OT.f +++ /dev/null @@ -1,984 +0,0 @@ - SUBROUTINE SB03OT( DISCR, LTRANS, N, S, LDS, R, LDR, SCALE, DWORK, - $ INFO ) -C -C SLICOT RELEASE 5.0. -C -C Copyright (c) 2002-2009 NICONET e.V. -C -C This program is free software: you can redistribute it and/or -C modify it under the terms of the GNU General Public License as -C published by the Free Software Foundation, either version 2 of -C the License, or (at your option) any later version. -C -C This program is distributed in the hope that it will be useful, -C but WITHOUT ANY WARRANTY; without even the implied warranty of -C MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the -C GNU General Public License for more details. -C -C You should have received a copy of the GNU General Public License -C along with this program. If not, see -C . -C -C PURPOSE -C -C To solve for X = op(U)'*op(U) either the stable non-negative -C definite continuous-time Lyapunov equation -C 2 -C op(S)'*X + X*op(S) = -scale *op(R)'*op(R) (1) -C -C or the convergent non-negative definite discrete-time Lyapunov -C equation -C 2 -C op(S)'*X*op(S) - X = -scale *op(R)'*op(R) (2) -C -C where op(K) = K or K' (i.e., the transpose of the matrix K), S is -C an N-by-N block upper triangular matrix with one-by-one or -C two-by-two blocks on the diagonal, R is an N-by-N upper triangular -C matrix, and scale is an output scale factor, set less than or -C equal to 1 to avoid overflow in X. -C -C In the case of equation (1) the matrix S must be stable (that -C is, all the eigenvalues of S must have negative real parts), -C and for equation (2) the matrix S must be convergent (that is, -C all the eigenvalues of S must lie inside the unit circle). -C -C ARGUMENTS -C -C Mode Parameters -C -C DISCR LOGICAL -C Specifies the type of Lyapunov equation to be solved as -C follows: -C = .TRUE. : Equation (2), discrete-time case; -C = .FALSE.: Equation (1), continuous-time case. -C -C LTRANS LOGICAL -C Specifies the form of op(K) to be used, as follows: -C = .FALSE.: op(K) = K (No transpose); -C = .TRUE. : op(K) = K**T (Transpose). -C -C Input/Output Parameters -C -C N (input) INTEGER -C The order of the matrices S and R. N >= 0. -C -C S (input) DOUBLE PRECISION array of dimension (LDS,N) -C The leading N-by-N upper Hessenberg part of this array -C must contain the block upper triangular matrix. -C The elements below the upper Hessenberg part of the array -C S are not referenced. The 2-by-2 blocks must only -C correspond to complex conjugate pairs of eigenvalues (not -C to real eigenvalues). -C -C LDS INTEGER -C The leading dimension of array S. LDS >= MAX(1,N). -C -C R (input/output) DOUBLE PRECISION array of dimension (LDR,N) -C On entry, the leading N-by-N upper triangular part of this -C array must contain the upper triangular matrix R. -C On exit, the leading N-by-N upper triangular part of this -C array contains the upper triangular matrix U. -C The strict lower triangle of R is not referenced. -C -C LDR INTEGER -C The leading dimension of array R. LDR >= MAX(1,N). -C -C SCALE (output) DOUBLE PRECISION -C The scale factor, scale, set less than or equal to 1 to -C prevent the solution overflowing. -C -C Workspace -C -C DWORK DOUBLE PRECISION array, dimension (4*N) -C -C Error Indicator -C -C INFO INTEGER -C = 0: successful exit; -C < 0: if INFO = -i, the i-th argument had an illegal -C value; -C = 1: if the Lyapunov equation is (nearly) singular -C (warning indicator); -C if DISCR = .FALSE., this means that while the -C matrix S has computed eigenvalues with negative real -C parts, it is only just stable in the sense that -C small perturbations in S can make one or more of the -C eigenvalues have a non-negative real part; -C if DISCR = .TRUE., this means that while the -C matrix S has computed eigenvalues inside the unit -C circle, it is nevertheless only just convergent, in -C the sense that small perturbations in S can make one -C or more of the eigenvalues lie outside the unit -C circle; -C perturbed values were used to solve the equation -C (but the matrix S is unchanged); -C = 2: if the matrix S is not stable (that is, one or more -C of the eigenvalues of S has a non-negative real -C part), if DISCR = .FALSE., or not convergent (that -C is, one or more of the eigenvalues of S lies outside -C the unit circle), if DISCR = .TRUE.; -C = 3: if the matrix S has two or more consecutive non-zero -C elements on the first sub-diagonal, so that there is -C a block larger than 2-by-2 on the diagonal; -C = 4: if the matrix S has a 2-by-2 diagonal block with -C real eigenvalues instead of a complex conjugate -C pair. -C -C METHOD -C -C The method used by the routine is based on a variant of the -C Bartels and Stewart backward substitution method [1], that finds -C the Cholesky factor op(U) directly without first finding X and -C without the need to form the normal matrix op(R)'*op(R) [2]. -C -C The continuous-time Lyapunov equation in the canonical form -C 2 -C op(S)'*op(U)'*op(U) + op(U)'*op(U)*op(S) = -scale *op(R)'*op(R), -C -C or the discrete-time Lyapunov equation in the canonical form -C 2 -C op(S)'*op(U)'*op(U)*op(S) - op(U)'*op(U) = -scale *op(R)'*op(R), -C -C where U and R are upper triangular, is solved for U. -C -C REFERENCES -C -C [1] Bartels, R.H. and Stewart, G.W. -C Solution of the matrix equation A'X + XB = C. -C Comm. A.C.M., 15, pp. 820-826, 1972. -C -C [2] Hammarling, S.J. -C Numerical solution of the stable, non-negative definite -C Lyapunov equation. -C IMA J. Num. Anal., 2, pp. 303-325, 1982. -C -C NUMERICAL ASPECTS -C 3 -C The algorithm requires 0(N ) operations and is backward stable. -C -C FURTHER COMMENTS -C -C The Lyapunov equation may be very ill-conditioned. In particular -C if S is only just stable (or convergent) then the Lyapunov -C equation will be ill-conditioned. "Large" elements in U relative -C to those of S and R, or a "small" value for scale, is a symptom -C of ill-conditioning. A condition estimate can be computed using -C SLICOT Library routine SB03MD. -C -C CONTRIBUTOR -C -C Release 3.0: V. Sima, Katholieke Univ. Leuven, Belgium, May 1997. -C Supersedes Release 2.0 routine SB03CZ by Sven Hammarling, -C NAG Ltd, United Kingdom, Oct. 1986. -C Partly based on SB03CZ and PLYAP1 by A. Varga, University of -C Bochum, May 1992. -C -C REVISIONS -C -C Dec. 1997, April 1998, May 1999, Feb. 2004. -C -C KEYWORDS -C -C Lyapunov equation, orthogonal transformation, real Schur form. -C -C ****************************************************************** -C -C .. Parameters .. - DOUBLE PRECISION ZERO, ONE, TWO - PARAMETER ( ZERO = 0.0D0, ONE = 1.0D0, TWO = 2.0D0 ) -C .. Scalar Arguments .. - LOGICAL DISCR, LTRANS - INTEGER INFO, LDR, LDS, N - DOUBLE PRECISION SCALE -C .. Array Arguments .. - DOUBLE PRECISION DWORK(*), R(LDR,*), S(LDS,*) -C .. Local Scalars .. - LOGICAL CONT, TBYT - INTEGER INFOM, ISGN, J, J1, J2, J3, K, K1, K2, K3, - $ KOUNT, KSIZE - DOUBLE PRECISION ABSSKK, ALPHA, BIGNUM, D1, D2, DR, EPS, SCALOC, - $ SMIN, SMLNUM, SUM, T1, T2, T3, T4, TAU1, TAU2, - $ TEMP, V1, V2, V3, V4 -C .. Local Arrays .. - DOUBLE PRECISION A(2,2), B(2,2), U(2,2) -C .. External Functions .. - DOUBLE PRECISION DLAMCH, DLANHS - EXTERNAL DLAMCH, DLANHS -C .. External Subroutines .. - EXTERNAL DAXPY, DCOPY, DLABAD, DLARFG, DSCAL, DSWAP, - $ DTRMM, DTRMV, MB04ND, MB04OD, SB03OR, SB03OY, - $ XERBLA -C .. Intrinsic Functions .. - INTRINSIC ABS, MAX, SIGN, SQRT -C .. Executable Statements .. -C - INFO = 0 -C -C Test the input scalar arguments. -C - IF( N.LT.0 ) THEN - INFO = -3 - ELSE IF( LDS.LT.MAX( 1, N ) ) THEN - INFO = -5 - ELSE IF( LDR.LT.MAX( 1, N ) ) THEN - INFO = -7 - END IF -C - IF ( INFO.NE.0 ) THEN -C -C Error return. -C - CALL XERBLA( 'SB03OT', -INFO ) - RETURN - END IF -C - SCALE = ONE -C -C Quick return if possible. -C - IF (N.EQ.0) - $ RETURN -C -C Set constants to control overflow. -C - EPS = DLAMCH( 'P' ) - SMLNUM = DLAMCH( 'S' ) - BIGNUM = ONE / SMLNUM - CALL DLABAD( SMLNUM, BIGNUM ) - SMLNUM = SMLNUM*DBLE( N*N ) / EPS - BIGNUM = ONE / SMLNUM -C - SMIN = MAX( SMLNUM, EPS*DLANHS( 'Max', N, S, LDS, DWORK ) ) - INFOM = 0 -C -C Start the solution. Most of the comments refer to notation and -C equations in sections 5 and 10 of the second reference above. -C -C Determine whether or not the current block is two-by-two. -C K gives the position of the start of the current block and -C TBYT is true if the block is two-by-two. -C - CONT = .NOT.DISCR - ISGN = 1 - IF ( .NOT.LTRANS ) THEN -C -C Case op(M) = M. -C - KOUNT = 1 -C - 10 CONTINUE -C WHILE( KOUNT.LE.N )LOOP - IF ( KOUNT.LE.N ) THEN - K = KOUNT - IF ( KOUNT.GE.N ) THEN - TBYT = .FALSE. - KOUNT = KOUNT + 1 - ELSE IF ( S(K+1,K).EQ.ZERO ) THEN - TBYT = .FALSE. - KOUNT = KOUNT + 1 - ELSE - TBYT = .TRUE. - IF ( (K+1).LT.N ) THEN - IF ( S(K+2,K+1).NE.ZERO ) THEN - INFO = 3 - RETURN - END IF - END IF - KOUNT = KOUNT + 2 - END IF - IF ( TBYT ) THEN -C -C Solve the two-by-two Lyapunov equation (6.1) or (10.19), -C using the routine SB03OY. -C - B(1,1) = S(K,K) - B(2,1) = S(K+1,K) - B(1,2) = S(K,K+1) - B(2,2) = S(K+1,K+1) - U(1,1) = R(K,K) - U(1,2) = R(K,K+1) - U(2,2) = R(K+1,K+1) -C - CALL SB03OY( DISCR, LTRANS, ISGN, B, 2, U, 2, A, 2, - $ SCALOC, INFO ) - IF ( INFO.GT.1 ) - $ RETURN - INFOM = MAX( INFO, INFOM ) - IF( SCALOC.NE.ONE ) THEN -C - DO 20 J = 1, N - CALL DSCAL( J, SCALOC, R(1,J), 1 ) - 20 CONTINUE -C - SCALE = SCALE*SCALOC - END IF - R(K,K) = U(1,1) - R(K,K+1) = U(1,2) - R(K+1,K+1) = U(2,2) -C -C If we are not at the end of S then set up and solve -C equation (6.2) or (10.20). -C -C Note that SB03OY returns ( u11*s11*inv( u11 ) ) in B -C and returns scaled alpha in A. ksize is the order of -C the remainder of S. k1, k2 and k3 point to the start -C of vectors in DWORK. -C - IF ( KOUNT.LE.N ) THEN - KSIZE = N - K - 1 - K1 = KSIZE + 1 - K2 = KSIZE + K1 - K3 = KSIZE + K2 -C -C Form the right-hand side of (6.2) or (10.20), the -C first column in DWORK( 1 ) ,..., DWORK( n - k - 1 ) -C the second in DWORK( n - k ) ,..., -C DWORK( 2*( n - k - 1 ) ). -C - CALL DCOPY( KSIZE, R(K,K+2), LDR, DWORK, 1 ) - CALL DCOPY( KSIZE, R(K+1,K+2), LDR, DWORK(K1), 1 ) - CALL DTRMM( 'Right', 'Upper', 'No transpose', - $ 'Non-unit', KSIZE, 2, -ONE, A, 2, DWORK, - $ KSIZE ) - IF ( CONT ) THEN - CALL DAXPY( KSIZE, -R(K,K), S(K,K+2), LDS, DWORK, - $ 1 ) - CALL DAXPY( KSIZE, -R(K,K+1), S(K+1,K+2), LDS, - $ DWORK, 1) - CALL DAXPY( KSIZE, -R(K+1,K+1), S(K+1,K+2), LDS, - $ DWORK(K1), 1 ) - ELSE - CALL DAXPY( KSIZE, -R(K,K)*B(1,1), S(K,K+2), LDS, - $ DWORK, 1 ) - CALL DAXPY( KSIZE, -( R(K,K+1)*B(1,1) + R(K+1,K+1) - $ *B(2,1) ), S(K+1,K+2), LDS, DWORK, 1 ) - CALL DAXPY( KSIZE, -R(K,K)*B(1,2), S(K,K+2), LDS, - $ DWORK(K1), 1 ) - CALL DAXPY( KSIZE, -( R(K,K+1)*B(1,2) + R(K+1,K+1) - $ *B(2,2) ), S(K+1,K+2), LDS, DWORK(K1), - $ 1 ) - END IF -C -C SB03OR solves the Sylvester equations. The solution -C is overwritten on DWORK. -C - CALL SB03OR( DISCR, LTRANS, KSIZE, 2, S(K+2,K+2), LDS, - $ B, 2, DWORK, KSIZE, SCALOC, INFO ) - INFOM = MAX( INFO, INFOM ) - IF( SCALOC.NE.ONE ) THEN -C - DO 30 J = 1, N - CALL DSCAL( J, SCALOC, R(1,J), 1 ) - 30 CONTINUE -C - SCALE = SCALE*SCALOC - END IF -C -C Copy the solution into the next 2*( n - k - 1 ) -C elements of DWORK. -C - CALL DCOPY( 2*KSIZE, DWORK, 1, DWORK(K2), 1 ) -C -C Now form the matrix Rhat of equation (6.4) or -C (10.22). Note that (10.22) is incorrect, so here we -C implement a corrected version of (10.22). -C - IF ( CONT ) THEN -C -C Swap the two rows of R with DWORK. -C - CALL DSWAP( KSIZE, DWORK, 1, R(K,K+2), LDR ) - CALL DSWAP( KSIZE, DWORK(K1), 1, R(K+1,K+2), LDR ) -C -C 1st column: -C - CALL DAXPY( KSIZE, -A(1,1), DWORK(K2), 1, DWORK, - $ 1 ) - CALL DAXPY( KSIZE, -A(1,2), DWORK(K3), 1, DWORK, - $ 1 ) -C -C 2nd column: -C - CALL DAXPY( KSIZE, -A(2,2), DWORK(K3), 1, - $ DWORK(K1), 1 ) - ELSE -C -C Form v = S1'*u + s*u11', overwriting v on DWORK. -C -C Compute S1'*u, first multiplying by the -C triangular part of S1. -C - CALL DTRMM( 'Left', 'Upper', 'Transpose', - $ 'Non-unit', KSIZE, 2, ONE, S(K+2,K+2), - $ LDS, DWORK, KSIZE ) -C -C Then multiply by the subdiagonal of S1 and add in -C to the above result. -C - J1 = K1 - J2 = K + 2 -C - DO 40 J = 1, KSIZE-1 - IF ( S(J2+1,J2).NE.ZERO ) THEN - DWORK(J) = S(J2+1,J2)*DWORK(K2+J) + DWORK(J) - DWORK(J1) = S(J2+1,J2)*DWORK(K3+J) + - $ DWORK(J1) - END IF - J1 = J1 + 1 - J2 = J2 + 1 - 40 CONTINUE -C -C Add in s*u11'. -C - CALL DAXPY( KSIZE, R(K,K), S(K,K+2), LDS, DWORK, - $ 1 ) - CALL DAXPY( KSIZE, R(K,K+1), S(K+1,K+2), LDS, - $ DWORK, 1 ) - CALL DAXPY( KSIZE, R(K+1,K+1), S(K+1,K+2), LDS, - $ DWORK(K1), 1 ) -C -C Next recover r from R, swapping r with u. -C - CALL DSWAP( KSIZE, DWORK(K2), 1, R(K,K+2), LDR ) - CALL DSWAP( KSIZE, DWORK(K3), 1, R(K+1,K+2), LDR ) -C -C Now we perform the QR factorization. -C -C ( a ) = Q*( t ), -C ( b ) -C -C and form -C -C ( p' ) = Q'*( r' ). -C ( y' ) ( v' ) -C -C y is then the correct vector to use in (10.22). -C Note that a is upper triangular and that t and -C p are not required. -C - CALL DLARFG( 3, A(1,1), B(1,1), 1, TAU1 ) - V1 = B(1,1) - T1 = TAU1*V1 - V2 = B(2,1) - T2 = TAU1*V2 - SUM = A(1,2) + V1*B(1,2) + V2*B(2,2) - B(1,2) = B(1,2) - SUM*T1 - B(2,2) = B(2,2) - SUM*T2 - CALL DLARFG( 3, A(2,2), B(1,2), 1, TAU2 ) - V3 = B(1,2) - T3 = TAU2*V3 - V4 = B(2,2) - T4 = TAU2*V4 - J1 = K1 - J2 = K2 - J3 = K3 -C - DO 50 J = 1, KSIZE - SUM = DWORK(J2) + V1*DWORK(J) + V2*DWORK(J1) - D1 = DWORK(J) - SUM*T1 - D2 = DWORK(J1) - SUM*T2 - SUM = DWORK(J3) + V3*D1 + V4*D2 - DWORK(J) = D1 - SUM*T3 - DWORK(J1) = D2 - SUM*T4 - J1 = J1 + 1 - J2 = J2 + 1 - J3 = J3 + 1 - 50 CONTINUE -C - END IF -C -C Now update R1 to give Rhat. -C - CALL DCOPY( KSIZE, DWORK, 1, DWORK(K2), 1 ) - CALL DCOPY( KSIZE, DWORK(K1), 1, DWORK(K3), 1 ) - CALL DCOPY( KSIZE, DWORK(K3), 1, DWORK(2), 2 ) - CALL DCOPY( KSIZE, DWORK(K2), 1, DWORK(1), 2 ) - CALL MB04OD( 'Full', KSIZE, 0, 2, R(K+2,K+2), LDR, - $ DWORK, 2, DWORK, 1, DWORK, 1, DWORK(K2), - $ DWORK(K3) ) - END IF - ELSE -C -C 1-by-1 block. -C -C Make sure S is stable or convergent and find u11 in -C equation (5.13) or (10.15). -C - IF ( DISCR ) THEN - ABSSKK = ABS( S(K,K) ) - IF ( ( ABSSKK - ONE ).GE.ZERO ) THEN - INFO = 2 - RETURN - END IF - TEMP = SQRT( ( ONE - ABSSKK )*( ONE + ABSSKK ) ) - ELSE - IF ( S(K,K).GE.ZERO ) THEN - INFO = 2 - RETURN - END IF - TEMP = SQRT( ABS( TWO*S(K,K) ) ) - END IF -C - SCALOC = ONE - IF( TEMP.LT.SMIN ) THEN - TEMP = SMIN - INFOM = 1 - END IF - DR = ABS( R(K,K) ) - IF( TEMP.LT.ONE .AND. DR.GT.ONE ) THEN - IF( DR.GT.BIGNUM*TEMP ) - $ SCALOC = ONE / DR - END IF - ALPHA = SIGN( TEMP, R(K,K) ) - R(K,K) = R(K,K)/ALPHA - IF( SCALOC.NE.ONE ) THEN -C - DO 60 J = 1, N - CALL DSCAL( J, SCALOC, R(1,J), 1 ) - 60 CONTINUE -C - SCALE = SCALE*SCALOC - END IF -C -C If we are not at the end of S then set up and solve -C equation (5.14) or (10.16). ksize is the order of the -C remainder of S. k1 and k2 point to the start of vectors -C in DWORK. -C - IF ( KOUNT.LE.N ) THEN - KSIZE = N - K - K1 = KSIZE + 1 - K2 = KSIZE + K1 -C -C Form the right-hand side in DWORK( 1 ),..., -C DWORK( n - k ). -C - CALL DCOPY( KSIZE, R(K,K+1), LDR, DWORK, 1 ) - CALL DSCAL( KSIZE, -ALPHA, DWORK, 1 ) - IF ( CONT ) THEN - CALL DAXPY( KSIZE, -R(K,K), S(K,K+1), LDS, DWORK, - $ 1 ) - ELSE - CALL DAXPY( KSIZE, -S(K,K)*R(K,K), S(K,K+1), LDS, - $ DWORK, 1 ) - END IF -C -C SB03OR solves the Sylvester equations. The solution is -C overwritten on DWORK. -C - CALL SB03OR( DISCR, LTRANS, KSIZE, 1, S(K+1,K+1), LDS, - $ S(K,K), 1, DWORK, KSIZE, SCALOC, INFO ) - INFOM = MAX( INFO, INFOM ) - IF( SCALOC.NE.ONE ) THEN -C - DO 70 J = 1, N - CALL DSCAL( J, SCALOC, R(1,J), 1 ) - 70 CONTINUE -C - SCALE = SCALE*SCALOC - END IF -C -C Copy the solution into the next ( n - k ) elements -C of DWORK, copy the solution back into R and copy -C the row of R back into DWORK. -C - CALL DCOPY( KSIZE, DWORK, 1, DWORK(K1), 1 ) - CALL DSWAP( KSIZE, DWORK, 1, R(K,K+1), LDR ) -C -C Now form the matrix Rhat of equation (5.15) or -C (10.17), first computing y in DWORK, and then -C updating R1. -C - IF ( CONT ) THEN - CALL DAXPY( KSIZE, -ALPHA, DWORK(K1), 1, DWORK, 1 ) - ELSE -C -C First form lambda( 1 )*r and then add in -C alpha*u11*s. -C - CALL DSCAL( KSIZE, -S(K,K), DWORK, 1 ) - CALL DAXPY( KSIZE, ALPHA*R(K,K), S(K,K+1), LDS, - $ DWORK, 1 ) -C -C Now form alpha*S1'*u, first multiplying by the -C sub-diagonal of S1 and then the triangular part -C of S1, and add the result in DWORK. -C - J1 = K + 1 -C - DO 80 J = 1, KSIZE-1 - IF ( S(J1+1,J1).NE.ZERO ) DWORK(J) - $ = ALPHA*S(J1+1,J1)*DWORK(K1+J) + DWORK(J) - J1 = J1 + 1 - 80 CONTINUE -C - CALL DTRMV( 'Upper', 'Transpose', 'Non-unit', - $ KSIZE, S(K+1,K+1), LDS, DWORK(K1), 1 ) - CALL DAXPY( KSIZE, ALPHA, DWORK(K1), 1, DWORK, 1 ) - END IF - CALL MB04OD( 'Full', KSIZE, 0, 1, R(K+1,K+1), LDR, - $ DWORK, 1, DWORK, 1, DWORK, 1, DWORK(K2), - $ DWORK(K1) ) - END IF - END IF - GO TO 10 - END IF -C END WHILE 10 -C - ELSE -C -C Case op(M) = M'. -C - KOUNT = N -C - 90 CONTINUE -C WHILE( KOUNT.GE.1 )LOOP - IF ( KOUNT.GE.1 ) THEN - K = KOUNT - IF ( KOUNT.EQ.1 ) THEN - TBYT = .FALSE. - KOUNT = KOUNT - 1 - ELSE IF ( S(K,K-1).EQ.ZERO ) THEN - TBYT = .FALSE. - KOUNT = KOUNT - 1 - ELSE - TBYT = .TRUE. - K = K - 1 - IF ( K.GT.1 ) THEN - IF ( S(K,K-1).NE.ZERO ) THEN - INFO = 3 - RETURN - END IF - END IF - KOUNT = KOUNT - 2 - END IF - IF ( TBYT ) THEN -C -C Solve the two-by-two Lyapunov equation corresponding to -C (6.1) or (10.19), using the routine SB03OY. -C - B(1,1) = S(K,K) - B(2,1) = S(K+1,K) - B(1,2) = S(K,K+1) - B(2,2) = S(K+1,K+1) - U(1,1) = R(K,K) - U(1,2) = R(K,K+1) - U(2,2) = R(K+1,K+1) -C - CALL SB03OY( DISCR, LTRANS, ISGN, B, 2, U, 2, A, 2, - $ SCALOC, INFO ) - IF ( INFO.GT.1 ) - $ RETURN - INFOM = MAX( INFO, INFOM ) - IF( SCALOC.NE.ONE ) THEN -C - DO 100 J = 1, N - CALL DSCAL( J, SCALOC, R(1,J), 1 ) - 100 CONTINUE -C - SCALE = SCALE*SCALOC - END IF - R(K,K) = U(1,1) - R(K,K+1) = U(1,2) - R(K+1,K+1) = U(2,2) -C -C If we are not at the front of S then set up and solve -C equation corresponding to (6.2) or (10.20). -C -C Note that SB03OY returns ( inv( u11 )*s11*u11 ) in B -C and returns scaled alpha, alpha = inv( u11 )*r11, in A. -C ksize is the order of the remainder leading part of S. -C k1, k2 and k3 point to the start of vectors in DWORK. -C - IF ( KOUNT.GE.1 ) THEN - KSIZE = K - 1 - K1 = KSIZE + 1 - K2 = KSIZE + K1 - K3 = KSIZE + K2 -C -C Form the right-hand side of equations corresponding to -C (6.2) or (10.20), the first column in DWORK( 1 ) ,..., -C DWORK( k - 1 ) the second in DWORK( k ) ,..., -C DWORK( 2*( k - 1 ) ). -C - CALL DCOPY( KSIZE, R(1,K), 1, DWORK, 1 ) - CALL DCOPY( KSIZE, R(1,K+1), 1, DWORK(K1), 1 ) - CALL DTRMM( 'Right', 'Upper', 'Transpose', 'Non-unit', - $ KSIZE, 2, -ONE, A, 2, DWORK, KSIZE ) - IF ( CONT ) THEN - CALL DAXPY( KSIZE, -R(K,K), S(1,K), 1, DWORK, 1 ) - CALL DAXPY( KSIZE, -R(K,K+1), S(1,K), 1, DWORK(K1), - $ 1 ) - CALL DAXPY( KSIZE, -R(K+1,K+1), S(1,K+1), 1, - $ DWORK(K1), 1 ) - ELSE - CALL DAXPY( KSIZE, -( R(K,K)*B(1,1) + R(K,K+1) - $ *B(1,2) ), S(1,K), 1, DWORK, 1 ) - CALL DAXPY( KSIZE, -R(K+1,K+1)*B(1,2), S(1,K+1), 1, - $ DWORK, 1 ) - CALL DAXPY( KSIZE, -( R(K,K)*B(2,1) + R(K,K+1) - $ *B(2,2) ), S(1,K), 1, DWORK(K1), 1 ) - CALL DAXPY( KSIZE, -R(K+1,K+1)*B(2,2), S(1,K+1), 1, - $ DWORK(K1), 1 ) - END IF -C -C SB03OR solves the Sylvester equations. The solution -C is overwritten on DWORK. -C - CALL SB03OR( DISCR, LTRANS, KSIZE, 2, S, LDS, B, 2, - $ DWORK, KSIZE, SCALOC, INFO ) - INFOM = MAX( INFO, INFOM ) - IF( SCALOC.NE.ONE ) THEN -C - DO 110 J = 1, N - CALL DSCAL( J, SCALOC, R(1,J), 1 ) - 110 CONTINUE -C - SCALE = SCALE*SCALOC - END IF -C -C Copy the solution into the next 2*( k - 1 ) elements -C of DWORK. -C - CALL DCOPY( 2*KSIZE, DWORK, 1, DWORK(K2), 1 ) -C -C Now form the matrix Rhat of equation corresponding -C to (6.4) or (10.22) (corrected version). -C - IF ( CONT ) THEN -C -C Swap the two columns of R with DWORK. -C - CALL DSWAP( KSIZE, DWORK, 1, R(1,K), 1 ) - CALL DSWAP( KSIZE, DWORK(K1), 1, R(1,K+1), 1 ) -C -C 1st column: -C - CALL DAXPY( KSIZE, -A(1,1), DWORK(K2), 1, DWORK, - $ 1 ) -C -C 2nd column: -C - CALL DAXPY( KSIZE, -A(1,2), DWORK(K2), 1, - $ DWORK(K1), 1 ) - CALL DAXPY( KSIZE, -A(2,2), DWORK(K3), 1, - $ DWORK(K1), 1 ) - ELSE -C -C Form v = S1*u + s*u11, overwriting v on DWORK. -C -C Compute S1*u, first multiplying by the triangular -C part of S1. -C - CALL DTRMM( 'Left', 'Upper', 'No transpose', - $ 'Non-unit', KSIZE, 2, ONE, S, LDS, - $ DWORK, KSIZE ) -C -C Then multiply by the subdiagonal of S1 and add in -C to the above result. -C - J1 = K1 -C - DO 120 J = 2, KSIZE - J1 = J1 + 1 - IF ( S(J,J-1).NE.ZERO ) THEN - DWORK(J) = S(J,J-1)*DWORK(K2+J-2) + DWORK(J) - DWORK(J1) = S(J,J-1)*DWORK(K3+J-2) + - $ DWORK(J1) - END IF - 120 CONTINUE -C -C Add in s*u11. -C - CALL DAXPY( KSIZE, R(K,K), S(1,K), 1, DWORK, 1 ) - CALL DAXPY( KSIZE, R(K,K+1), S(1,K), 1, DWORK(K1), - $ 1 ) - CALL DAXPY( KSIZE, R(K+1,K+1), S(1,K+1), 1, - $ DWORK(K1), 1 ) -C -C Next recover r from R, swapping r with u. -C - CALL DSWAP( KSIZE, DWORK(K2), 1, R(1,K), 1 ) - CALL DSWAP( KSIZE, DWORK(K3), 1, R(1,K+1), 1 ) -C -C Now we perform the QL factorization. -C -C ( a' ) = Q*( t ), -C ( b' ) -C -C and form -C -C ( p' ) = Q'*( r' ). -C ( y' ) ( v' ) -C -C y is then the correct vector to use in the -C relation corresponding to (10.22). -C Note that a is upper triangular and that t and -C p are not required. -C - CALL DLARFG( 3, A(2,2), B(2,1), 2, TAU1 ) - V1 = B(2,1) - T1 = TAU1*V1 - V2 = B(2,2) - T2 = TAU1*V2 - SUM = A(1,2) + V1*B(1,1) + V2*B(1,2) - B(1,1) = B(1,1) - SUM*T1 - B(1,2) = B(1,2) - SUM*T2 - CALL DLARFG( 3, A(1,1), B(1,1), 2, TAU2 ) - V3 = B(1,1) - T3 = TAU2*V3 - V4 = B(1,2) - T4 = TAU2*V4 - J1 = K1 - J2 = K2 - J3 = K3 -C - DO 130 J = 1, KSIZE - SUM = DWORK(J3) + V1*DWORK(J) + V2*DWORK(J1) - D1 = DWORK(J) - SUM*T1 - D2 = DWORK(J1) - SUM*T2 - SUM = DWORK(J2) + V3*D1 + V4*D2 - DWORK(J) = D1 - SUM*T3 - DWORK(J1) = D2 - SUM*T4 - J1 = J1 + 1 - J2 = J2 + 1 - J3 = J3 + 1 - 130 CONTINUE -C - END IF -C -C Now update R1 to give Rhat. -C - CALL MB04ND( 'Full', KSIZE, 0, 2, R, LDR, DWORK, - $ KSIZE, DWORK, 1, DWORK, 1, DWORK(K2), - $ DWORK(K3) ) - END IF - ELSE -C -C 1-by-1 block. -C -C Make sure S is stable or convergent and find u11 in -C equation corresponding to (5.13) or (10.15). -C - IF ( DISCR ) THEN - ABSSKK = ABS( S(K,K) ) - IF ( ( ABSSKK - ONE ).GE.ZERO ) THEN - INFO = 2 - RETURN - END IF - TEMP = SQRT( ( ONE - ABSSKK )*( ONE + ABSSKK ) ) - ELSE - IF ( S(K,K).GE.ZERO ) THEN - INFO = 2 - RETURN - END IF - TEMP = SQRT( ABS( TWO*S(K,K) ) ) - END IF -C - SCALOC = ONE - IF( TEMP.LT.SMIN ) THEN - TEMP = SMIN - INFOM = 1 - END IF - DR = ABS( R(K,K) ) - IF( TEMP.LT.ONE .AND. DR.GT.ONE ) THEN - IF( DR.GT.BIGNUM*TEMP ) - $ SCALOC = ONE / DR - END IF - ALPHA = SIGN( TEMP, R(K,K) ) - R(K,K) = R(K,K)/ALPHA - IF( SCALOC.NE.ONE ) THEN -C - DO 140 J = 1, N - CALL DSCAL( J, SCALOC, R(1,J), 1 ) - 140 CONTINUE -C - SCALE = SCALE*SCALOC - END IF -C -C If we are not at the front of S then set up and solve -C equation corresponding to (5.14) or (10.16). ksize is -C the order of the remainder leading part of S. k1 and k2 -C point to the start of vectors in DWORK. -C - IF ( KOUNT.GE.1 ) THEN - KSIZE = K - 1 - K1 = KSIZE + 1 - K2 = KSIZE + K1 -C -C Form the right-hand side in DWORK( 1 ),..., -C DWORK( k - 1 ). -C - CALL DCOPY( KSIZE, R(1,K), 1, DWORK, 1 ) - CALL DSCAL( KSIZE, -ALPHA, DWORK, 1 ) - IF ( CONT ) THEN - CALL DAXPY( KSIZE, -R(K,K), S(1,K), 1, DWORK, 1 ) - ELSE - CALL DAXPY( KSIZE, -S(K,K)*R(K,K), S(1,K), 1, - $ DWORK, 1 ) - END IF -C -C SB03OR solves the Sylvester equations. The solution is -C overwritten on DWORK. -C - CALL SB03OR( DISCR, LTRANS, KSIZE, 1, S, LDS, S(K,K), - $ 1, DWORK, KSIZE, SCALOC, INFO ) - INFOM = MAX( INFO, INFOM ) - IF( SCALOC.NE.ONE ) THEN -C - DO 150 J = 1, N - CALL DSCAL( J, SCALOC, R(1,J), 1 ) - 150 CONTINUE -C - SCALE = SCALE*SCALOC - END IF -C -C Copy the solution into the next ( k - 1 ) elements -C of DWORK, copy the solution back into R and copy -C the column of R back into DWORK. -C - CALL DCOPY( KSIZE, DWORK, 1, DWORK(K1), 1 ) - CALL DSWAP( KSIZE, DWORK, 1, R(1,K), 1 ) -C -C Now form the matrix Rhat of equation corresponding -C to (5.15) or (10.17), first computing y in DWORK, -C and then updating R1. -C - IF ( CONT ) THEN - CALL DAXPY( KSIZE, -ALPHA, DWORK(K1), 1, DWORK, 1 ) - ELSE -C -C First form lambda( 1 )*r and then add in -C alpha*u11*s. -C - CALL DSCAL( KSIZE, -S(K,K), DWORK, 1 ) - CALL DAXPY( KSIZE, ALPHA*R(K,K), S(1,K), 1, DWORK, - $ 1 ) -C -C Now form alpha*S1*u, first multiplying by the -C sub-diagonal of S1 and then the triangular part -C of S1, and add the result in DWORK. -C - DO 160 J = 2, KSIZE - IF ( S(J,J-1).NE.ZERO ) DWORK(J) - $ = ALPHA*S(J,J-1)*DWORK(K1+J-2) + DWORK(J) - 160 CONTINUE -C - CALL DTRMV( 'Upper', 'No transpose', 'Non-unit', - $ KSIZE, S, LDS, DWORK(K1), 1 ) - CALL DAXPY( KSIZE, ALPHA, DWORK(K1), 1, DWORK, 1 ) - END IF - CALL MB04ND( 'Full', KSIZE, 0, 1, R, LDR, DWORK, - $ KSIZE, DWORK, 1, DWORK, 1, DWORK(K2), - $ DWORK(K1) ) - END IF - END IF - GO TO 90 - END IF -C END WHILE 90 -C - END IF - INFO = INFOM - RETURN -C *** Last line of SB03OT *** - END diff --git a/mex/sources/libslicot/SB03OU.f b/mex/sources/libslicot/SB03OU.f deleted file mode 100644 index d9ae8cb17..000000000 --- a/mex/sources/libslicot/SB03OU.f +++ /dev/null @@ -1,410 +0,0 @@ - SUBROUTINE SB03OU( DISCR, LTRANS, N, M, A, LDA, B, LDB, TAU, U, - $ LDU, SCALE, DWORK, LDWORK, INFO ) -C -C SLICOT RELEASE 5.0. -C -C Copyright (c) 2002-2009 NICONET e.V. -C -C This program is free software: you can redistribute it and/or -C modify it under the terms of the GNU General Public License as -C published by the Free Software Foundation, either version 2 of -C the License, or (at your option) any later version. -C -C This program is distributed in the hope that it will be useful, -C but WITHOUT ANY WARRANTY; without even the implied warranty of -C MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the -C GNU General Public License for more details. -C -C You should have received a copy of the GNU General Public License -C along with this program. If not, see -C . -C -C PURPOSE -C -C To solve for X = op(U)'*op(U) either the stable non-negative -C definite continuous-time Lyapunov equation -C 2 -C op(A)'*X + X*op(A) = -scale *op(B)'*op(B) (1) -C -C or the convergent non-negative definite discrete-time Lyapunov -C equation -C 2 -C op(A)'*X*op(A) - X = -scale *op(B)'*op(B) (2) -C -C where op(K) = K or K' (i.e., the transpose of the matrix K), A is -C an N-by-N matrix in real Schur form, op(B) is an M-by-N matrix, -C U is an upper triangular matrix containing the Cholesky factor of -C the solution matrix X, X = op(U)'*op(U), and scale is an output -C scale factor, set less than or equal to 1 to avoid overflow in X. -C If matrix B has full rank then the solution matrix X will be -C positive-definite and hence the Cholesky factor U will be -C nonsingular, but if B is rank deficient then X may only be -C positive semi-definite and U will be singular. -C -C In the case of equation (1) the matrix A must be stable (that -C is, all the eigenvalues of A must have negative real parts), -C and for equation (2) the matrix A must be convergent (that is, -C all the eigenvalues of A must lie inside the unit circle). -C -C ARGUMENTS -C -C Mode Parameters -C -C DISCR LOGICAL -C Specifies the type of Lyapunov equation to be solved as -C follows: -C = .TRUE. : Equation (2), discrete-time case; -C = .FALSE.: Equation (1), continuous-time case. -C -C LTRANS LOGICAL -C Specifies the form of op(K) to be used, as follows: -C = .FALSE.: op(K) = K (No transpose); -C = .TRUE. : op(K) = K**T (Transpose). -C -C Input/Output Parameters -C -C N (input) INTEGER -C The order of the matrix A and the number of columns in -C matrix op(B). N >= 0. -C -C M (input) INTEGER -C The number of rows in matrix op(B). M >= 0. -C -C A (input) DOUBLE PRECISION array, dimension (LDA,N) -C The leading N-by-N upper Hessenberg part of this array -C must contain a real Schur form matrix S. The elements -C below the upper Hessenberg part of the array A are not -C referenced. The 2-by-2 blocks must only correspond to -C complex conjugate pairs of eigenvalues (not to real -C eigenvalues). -C -C LDA INTEGER -C The leading dimension of array A. LDA >= MAX(1,N). -C -C B (input/output) DOUBLE PRECISION array, dimension (LDB,N) -C if LTRANS = .FALSE., and dimension (LDB,M), if -C LTRANS = .TRUE.. -C On entry, if LTRANS = .FALSE., the leading M-by-N part of -C this array must contain the coefficient matrix B of the -C equation. -C On entry, if LTRANS = .TRUE., the leading N-by-M part of -C this array must contain the coefficient matrix B of the -C equation. -C On exit, if LTRANS = .FALSE., the leading -C MIN(M,N)-by-MIN(M,N) upper triangular part of this array -C contains the upper triangular matrix R (as defined in -C METHOD), and the M-by-MIN(M,N) strictly lower triangular -C part together with the elements of the array TAU are -C overwritten by details of the matrix P (also defined in -C METHOD). When M < N, columns (M+1),...,N of the array B -C are overwritten by the matrix Z (see METHOD). -C On exit, if LTRANS = .TRUE., the leading -C MIN(M,N)-by-MIN(M,N) upper triangular part of -C B(1:N,M-N+1), if M >= N, or of B(N-M+1:N,1:M), if M < N, -C contains the upper triangular matrix R (as defined in -C METHOD), and the remaining elements (below the diagonal -C of R) together with the elements of the array TAU are -C overwritten by details of the matrix P (also defined in -C METHOD). When M < N, rows 1,...,(N-M) of the array B -C are overwritten by the matrix Z (see METHOD). -C -C LDB INTEGER -C The leading dimension of array B. -C LDB >= MAX(1,M), if LTRANS = .FALSE., -C LDB >= MAX(1,N), if LTRANS = .TRUE.. -C -C TAU (output) DOUBLE PRECISION array of dimension (MIN(N,M)) -C This array contains the scalar factors of the elementary -C reflectors defining the matrix P. -C -C U (output) DOUBLE PRECISION array of dimension (LDU,N) -C The leading N-by-N upper triangular part of this array -C contains the Cholesky factor of the solution matrix X of -C the problem, X = op(U)'*op(U). -C The array U may be identified with B in the calling -C statement, if B is properly dimensioned, and the -C intermediate results returned in B are not needed. -C -C LDU INTEGER -C The leading dimension of array U. LDU >= MAX(1,N). -C -C SCALE (output) DOUBLE PRECISION -C The scale factor, scale, set less than or equal to 1 to -C prevent the solution overflowing. -C -C Workspace -C -C DWORK DOUBLE PRECISION array, dimension (LDWORK) -C On exit, if INFO = 0, or INFO = 1, DWORK(1) returns the -C optimal value of LDWORK. -C -C LDWORK INTEGER -C The length of the array DWORK. LDWORK >= MAX(1,4*N). -C For optimum performance LDWORK should sometimes be larger. -C -C Error Indicator -C -C INFO INTEGER -C = 0: successful exit; -C < 0: if INFO = -i, the i-th argument had an illegal -C value; -C = 1: if the Lyapunov equation is (nearly) singular -C (warning indicator); -C if DISCR = .FALSE., this means that while the matrix -C A has computed eigenvalues with negative real parts, -C it is only just stable in the sense that small -C perturbations in A can make one or more of the -C eigenvalues have a non-negative real part; -C if DISCR = .TRUE., this means that while the matrix -C A has computed eigenvalues inside the unit circle, -C it is nevertheless only just convergent, in the -C sense that small perturbations in A can make one or -C more of the eigenvalues lie outside the unit circle; -C perturbed values were used to solve the equation -C (but the matrix A is unchanged); -C = 2: if matrix A is not stable (that is, one or more of -C the eigenvalues of A has a non-negative real part), -C if DISCR = .FALSE., or not convergent (that is, one -C or more of the eigenvalues of A lies outside the -C unit circle), if DISCR = .TRUE.; -C = 3: if matrix A has two or more consecutive non-zero -C elements on the first sub-diagonal, so that there is -C a block larger than 2-by-2 on the diagonal; -C = 4: if matrix A has a 2-by-2 diagonal block with real -C eigenvalues instead of a complex conjugate pair. -C -C METHOD -C -C The method used by the routine is based on the Bartels and -C Stewart method [1], except that it finds the upper triangular -C matrix U directly without first finding X and without the need -C to form the normal matrix op(B)'*op(B) [2]. -C -C If LTRANS = .FALSE., the matrix B is factored as -C -C B = P ( R ), M >= N, B = P ( R Z ), M < N, -C ( 0 ) -C -C (QR factorization), where P is an M-by-M orthogonal matrix and -C R is a square upper triangular matrix. -C -C If LTRANS = .TRUE., the matrix B is factored as -C -C B = ( 0 R ) P, M >= N, B = ( Z ) P, M < N, -C ( R ) -C -C (RQ factorization), where P is an M-by-M orthogonal matrix and -C R is a square upper triangular matrix. -C -C These factorizations are used to solve the continuous-time -C Lyapunov equation in the canonical form -C 2 -C op(A)'*op(U)'*op(U) + op(U)'*op(U)*op(A) = -scale *op(F)'*op(F), -C -C or the discrete-time Lyapunov equation in the canonical form -C 2 -C op(A)'*op(U)'*op(U)*op(A) - op(U)'*op(U) = -scale *op(F)'*op(F), -C -C where U and F are N-by-N upper triangular matrices, and -C -C F = R, if M >= N, or -C -C F = ( R ), if LTRANS = .FALSE., or -C ( 0 ) -C -C F = ( 0 Z ), if LTRANS = .TRUE., if M < N. -C ( 0 R ) -C -C The canonical equation is solved for U. -C -C REFERENCES -C -C [1] Bartels, R.H. and Stewart, G.W. -C Solution of the matrix equation A'X + XB = C. -C Comm. A.C.M., 15, pp. 820-826, 1972. -C -C [2] Hammarling, S.J. -C Numerical solution of the stable, non-negative definite -C Lyapunov equation. -C IMA J. Num. Anal., 2, pp. 303-325, 1982. -C -C NUMERICAL ASPECTS -C 3 -C The algorithm requires 0(N ) operations and is backward stable. -C -C FURTHER COMMENTS -C -C The Lyapunov equation may be very ill-conditioned. In particular, -C if A is only just stable (or convergent) then the Lyapunov -C equation will be ill-conditioned. "Large" elements in U relative -C to those of A and B, or a "small" value for scale, are symptoms -C of ill-conditioning. A condition estimate can be computed using -C SLICOT Library routine SB03MD. -C -C CONTRIBUTOR -C -C Release 3.0: V. Sima, Katholieke Univ. Leuven, Belgium, May 1997. -C Supersedes Release 2.0 routine SB03CZ by Sven Hammarling, -C NAG Ltd, United Kingdom. -C Partly based on routine PLYAPS by A. Varga, University of Bochum, -C May 1992. -C -C REVISIONS -C -C Dec. 1997, April 1998, May 1999. -C -C KEYWORDS -C -C Lyapunov equation, orthogonal transformation, real Schur form. -C -C ****************************************************************** -C -C .. Parameters .. - DOUBLE PRECISION ZERO, ONE - PARAMETER ( ZERO = 0.0D0, ONE = 1.0D0 ) -C .. Scalar Arguments .. - LOGICAL DISCR, LTRANS - INTEGER INFO, LDA, LDB, LDU, LDWORK, M, N - DOUBLE PRECISION SCALE -C .. Array Arguments .. - DOUBLE PRECISION A(LDA,*), B(LDB,*), DWORK(*), TAU(*), U(LDU,*) -C .. Local Scalars .. - INTEGER I, J, K, L, MN, WRKOPT -C .. External Subroutines .. - EXTERNAL DCOPY, DGEQRF, DGERQF, DLACPY, DLASET, SB03OT, - $ XERBLA -C .. Intrinsic Functions .. - INTRINSIC MAX, MIN -C .. Executable Statements .. -C - INFO = 0 -C -C Test the input scalar arguments. -C - IF( N.LT.0 ) THEN - INFO = -3 - ELSE IF( M.LT.0 ) THEN - INFO = -4 - ELSE IF( LDA.LT.MAX( 1, N ) ) THEN - INFO = -6 - ELSE IF( ( LDB.LT.MAX( 1, M ) .AND. .NOT.LTRANS ) .OR. - $ ( LDB.LT.MAX( 1, N ) .AND. LTRANS ) ) THEN - INFO = -8 - ELSE IF( LDU.LT.MAX( 1, N ) ) THEN - INFO = -11 - ELSE IF( LDWORK.LT.MAX( 1, 4*N ) ) THEN - INFO = -14 - END IF -C - IF ( INFO.NE.0 ) THEN -C -C Error return. -C - CALL XERBLA( 'SB03OU', -INFO ) - RETURN - END IF -C -C Quick return if possible. -C - MN = MIN( N, M ) - IF ( MN.EQ.0 ) THEN - SCALE = ONE - DWORK(1) = ONE - RETURN - END IF -C -C (Note: Comments in the code beginning "Workspace:" describe the -C minimal amount of real workspace needed at that point in the -C code, as well as the preferred amount for good performance. -C NB refers to the optimal block size for the immediately -C following subroutine, as returned by ILAENV.) -C - IF ( LTRANS ) THEN -C -C Case op(K) = K'. -C -C Perform the RQ factorization of B. -C Workspace: need N; -C prefer N*NB. -C - CALL DGERQF( N, M, B, LDB, TAU, DWORK, LDWORK, INFO ) -C -C The triangular matrix F is constructed in the array U so that -C U can share the same memory as B. -C - IF ( M.GE.N ) THEN - CALL DLACPY( 'Upper', MN, N, B(1,M-N+1), LDB, U, LDU ) - ELSE -C - DO 10 I = M, 1, -1 - CALL DCOPY( N-M+I, B(1,I), 1, U(1,N-M+I), 1 ) - 10 CONTINUE -C - CALL DLASET( 'Full', N, N-M, ZERO, ZERO, U, LDU ) - END IF - ELSE -C -C Case op(K) = K. -C -C Perform the QR factorization of B. -C Workspace: need N; -C prefer N*NB. -C - CALL DGEQRF( M, N, B, LDB, TAU, DWORK, LDWORK, INFO ) - CALL DLACPY( 'Upper', MN, N, B, LDB, U, LDU ) - IF ( M.LT.N ) - $ CALL DLASET( 'Upper', N-M, N-M, ZERO, ZERO, U(M+1,M+1), - $ LDU ) - END IF - WRKOPT = DWORK(1) -C -C Solve the canonical Lyapunov equation -C 2 -C op(A)'*op(U)'*op(U) + op(U)'*op(U)*op(A) = -scale *op(F)'*op(F), -C -C or -C 2 -C op(A)'*op(U)'*op(U)*op(A) - op(U)'*op(U) = -scale *op(F)'*op(F) -C -C for U. -C - CALL SB03OT( DISCR, LTRANS, N, A, LDA, U, LDU, SCALE, DWORK, - $ INFO ) - IF ( INFO.NE.0 .AND. INFO.NE.1 ) - $ RETURN -C -C Make the diagonal elements of U non-negative. -C - IF ( LTRANS ) THEN -C - DO 30 J = 1, N - IF ( U(J,J).LT.ZERO ) THEN -C - DO 20 I = 1, J - U(I,J) = -U(I,J) - 20 CONTINUE -C - END IF - 30 CONTINUE -C - ELSE - K = 1 -C - DO 50 J = 1, N - DWORK(K) = U(J,J) - L = 1 -C - DO 40 I = 1, J - IF ( DWORK(L).LT.ZERO ) U(I,J) = -U(I,J) - L = L + 1 - 40 CONTINUE -C - K = K + 1 - 50 CONTINUE -C - END IF -C - DWORK(1) = MAX( WRKOPT, 4*N ) - RETURN -C *** Last line of SB03OU *** - END diff --git a/mex/sources/libslicot/SB03OV.f b/mex/sources/libslicot/SB03OV.f deleted file mode 100644 index bd92699b8..000000000 --- a/mex/sources/libslicot/SB03OV.f +++ /dev/null @@ -1,105 +0,0 @@ - SUBROUTINE SB03OV( A, B, C, S ) -C -C SLICOT RELEASE 5.0. -C -C Copyright (c) 2002-2009 NICONET e.V. -C -C This program is free software: you can redistribute it and/or -C modify it under the terms of the GNU General Public License as -C published by the Free Software Foundation, either version 2 of -C the License, or (at your option) any later version. -C -C This program is distributed in the hope that it will be useful, -C but WITHOUT ANY WARRANTY; without even the implied warranty of -C MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the -C GNU General Public License for more details. -C -C You should have received a copy of the GNU General Public License -C along with this program. If not, see -C . -C -C PURPOSE -C -C To construct a complex plane rotation such that, for a complex -C number a and a real number b, -C -C ( conjg( c ) s )*( a ) = ( d ), -C ( -s c ) ( b ) ( 0 ) -C -C where d is always real and is overwritten on a, so that on -C return the imaginary part of a is zero. b is unaltered. -C -C This routine has A and C declared as REAL, because it is intended -C for use within a real Lyapunov solver and the REAL declarations -C mean that a standard Fortran DOUBLE PRECISION version may be -C readily constructed. However A and C could safely be declared -C COMPLEX in the calling program, although some systems may give a -C type mismatch warning. -C -C ARGUMENTS -C -C Input/Output Parameters -C -C A (input/output) DOUBLE PRECISION array, dimension (2) -C On entry, A(1) and A(2) must contain the real and -C imaginary part, respectively, of the complex number a. -C On exit, A(1) contains the real part of d, and A(2) is -C set to zero. -C -C B (input) DOUBLE PRECISION -C The real number b. -C -C C (output) DOUBLE PRECISION array, dimension (2) -C C(1) and C(2) contain the real and imaginary part, -C respectively, of the complex number c, the cosines of -C the plane rotation. -C -C S (output) DOUBLE PRECISION -C The real number s, the sines of the plane rotation. -C -C CONTRIBUTOR -C -C Release 3.0: V. Sima, Katholieke Univ. Leuven, Belgium, Aug. 1997. -C Supersedes Release 2.0 routine SB03CV by Sven Hammarling, -C NAG Ltd., United Kingdom, May 1985. -C -C REVISIONS -C -C Dec. 1997. -C -C KEYWORDS -C -C Lyapunov equation, orthogonal transformation. -C -C ***************************************************************** -C -C .. Parameters .. - DOUBLE PRECISION ONE, ZERO - PARAMETER ( ONE = 1.0D0, ZERO = 0.0D0 ) -C .. Scalar Arguments .. - DOUBLE PRECISION B, S -C .. Array Arguments .. - DOUBLE PRECISION A(2), C(2) -C .. Local Scalars .. - DOUBLE PRECISION D -C .. External Functions .. - DOUBLE PRECISION DLAPY3 - EXTERNAL DLAPY3 -C .. Executable Statements .. -C - D = DLAPY3( A(1), A(2), B ) - IF ( D.EQ.ZERO ) THEN - C(1) = ONE - C(2) = ZERO - S = ZERO - ELSE - C(1) = A(1)/D - C(2) = A(2)/D - S = B/D - A(1) = D - A(2) = ZERO - END IF -C - RETURN -C *** Last line of SB03OV *** - END diff --git a/mex/sources/libslicot/SB03OY.f b/mex/sources/libslicot/SB03OY.f deleted file mode 100644 index 44a94b979..000000000 --- a/mex/sources/libslicot/SB03OY.f +++ /dev/null @@ -1,693 +0,0 @@ - SUBROUTINE SB03OY( DISCR, LTRANS, ISGN, S, LDS, R, LDR, A, LDA, - $ SCALE, INFO ) -C -C SLICOT RELEASE 5.0. -C -C Copyright (c) 2002-2009 NICONET e.V. -C -C This program is free software: you can redistribute it and/or -C modify it under the terms of the GNU General Public License as -C published by the Free Software Foundation, either version 2 of -C the License, or (at your option) any later version. -C -C This program is distributed in the hope that it will be useful, -C but WITHOUT ANY WARRANTY; without even the implied warranty of -C MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the -C GNU General Public License for more details. -C -C You should have received a copy of the GNU General Public License -C along with this program. If not, see -C . -C -C PURPOSE -C -C To solve for the Cholesky factor U of X, -C -C op(U)'*op(U) = X, -C -C where U is a two-by-two upper triangular matrix, either the -C continuous-time two-by-two Lyapunov equation -C 2 -C op(S)'*X + X*op(S) = -ISGN*scale *op(R)'*op(R), -C -C when DISCR = .FALSE., or the discrete-time two-by-two Lyapunov -C equation -C 2 -C op(S)'*X*op(S) - X = -ISGN*scale *op(R)'*op(R), -C -C when DISCR = .TRUE., where op(K) = K or K' (i.e., the transpose of -C the matrix K), S is a two-by-two matrix with complex conjugate -C eigenvalues, R is a two-by-two upper triangular matrix, -C ISGN = -1 or 1, and scale is an output scale factor, set less -C than or equal to 1 to avoid overflow in X. The routine also -C computes two matrices, B and A, so that -C 2 -C B*U = U*S and A*U = scale *R, if LTRANS = .FALSE., or -C 2 -C U*B = S*U and U*A = scale *R, if LTRANS = .TRUE., -C which are used by the general Lyapunov solver. -C In the continuous-time case ISGN*S must be stable, so that its -C eigenvalues must have strictly negative real parts. -C In the discrete-time case S must be convergent if ISGN = 1, that -C is, its eigenvalues must have moduli less than unity, or S must -C be completely divergent if ISGN = -1, that is, its eigenvalues -C must have moduli greater than unity. -C -C ARGUMENTS -C -C Mode Parameters -C -C DISCR LOGICAL -C Specifies the equation to be solved: 2 -C = .FALSE.: op(S)'*X + X*op(S) = -ISGN*scale *op(R)'*op(R); -C 2 -C = .TRUE. : op(S)'*X*op(S) - X = -ISGN*scale *op(R)'*op(R). -C -C LTRANS LOGICAL -C Specifies the form of op(K) to be used, as follows: -C = .FALSE.: op(K) = K (No transpose); -C = .TRUE. : op(K) = K**T (Transpose). -C -C ISGN INTEGER -C Specifies the sign of the equation as described before. -C ISGN may only be 1 or -1. -C -C Input/Output Parameters -C -C S (input/output) DOUBLE PRECISION array, dimension (LDS,2) -C On entry, S must contain a 2-by-2 matrix. -C On exit, S contains a 2-by-2 matrix B such that B*U = U*S, -C if LTRANS = .FALSE., or U*B = S*U, if LTRANS = .TRUE.. -C Notice that if U is nonsingular then -C B = U*S*inv( U ), if LTRANS = .FALSE. -C B = inv( U )*S*U, if LTRANS = .TRUE.. -C -C LDS INTEGER -C The leading dimension of array S. LDS >= 2. -C -C R (input/output) DOUBLE PRECISION array, dimension (LDR,2) -C On entry, R must contain a 2-by-2 upper triangular matrix. -C The element R( 2, 1 ) is not referenced. -C On exit, R contains U, the 2-by-2 upper triangular -C Cholesky factor of the solution X, X = op(U)'*op(U). -C -C LDR INTEGER -C The leading dimension of array R. LDR >= 2. -C -C A (output) DOUBLE PRECISION array, dimension (LDA,2) -C A contains a 2-by-2 upper triangular matrix A satisfying -C A*U/scale = scale*R, if LTRANS = .FALSE., or -C U*A/scale = scale*R, if LTRANS = .TRUE.. -C Notice that if U is nonsingular then -C A = scale*scale*R*inv( U ), if LTRANS = .FALSE. -C A = scale*scale*inv( U )*R, if LTRANS = .TRUE.. -C -C LDA INTEGER -C The leading dimension of array A. LDA >= 2. -C -C SCALE (output) DOUBLE PRECISION -C The scale factor, scale, set less than or equal to 1 to -C prevent the solution overflowing. -C -C Error Indicator -C -C INFO INTEGER -C = 0: successful exit; -C = 1: if the Lyapunov equation is (nearly) singular -C (warning indicator); -C if DISCR = .FALSE., this means that while the -C matrix S has computed eigenvalues with negative real -C parts, it is only just stable in the sense that -C small perturbations in S can make one or more of the -C eigenvalues have a non-negative real part; -C if DISCR = .TRUE., this means that while the -C matrix S has computed eigenvalues inside the unit -C circle, it is nevertheless only just convergent, in -C the sense that small perturbations in S can make one -C or more of the eigenvalues lie outside the unit -C circle; -C perturbed values were used to solve the equation -C (but the matrix S is unchanged); -C = 2: if DISCR = .FALSE., and ISGN*S is not stable or -C if DISCR = .TRUE., ISGN = 1 and S is not convergent -C or if DISCR = .TRUE., ISGN = -1 and S is not -C completely divergent; -C = 4: if S has real eigenvalues. -C -C NOTE: In the interests of speed, this routine does not check all -C inputs for errors. -C -C METHOD -C -C The LAPACK scheme for solving 2-by-2 Sylvester equations is -C adapted for 2-by-2 Lyapunov equations, but directly computing the -C Cholesky factor of the solution. -C -C REFERENCES -C -C [1] Hammarling S. J. -C Numerical solution of the stable, non-negative definite -C Lyapunov equation. -C IMA J. Num. Anal., 2, pp. 303-325, 1982. -C -C NUMERICAL ASPECTS -C -C The algorithm is backward stable. -C -C CONTRIBUTOR -C -C Release 3.0: V. Sima, Katholieke Univ. Leuven, Belgium, Aug. 1997. -C Supersedes Release 2.0 routine SB03CY by Sven Hammarling, -C NAG Ltd., United Kingdom, November 1986. -C Partly based on SB03CY and PLYAP2 by A. Varga, University of -C Bochum, May 1992. -C -C REVISIONS -C -C Dec. 1997, April 1998. -C -C KEYWORDS -C -C Lyapunov equation, orthogonal transformation, real Schur form. -C -C ***************************************************************** -C -C .. Parameters .. - DOUBLE PRECISION ZERO, ONE, TWO, FOUR - PARAMETER ( ZERO = 0.0D0, ONE = 1.0D0, TWO = 2.0D0, - $ FOUR = 4.0D0 ) -C .. Scalar Arguments .. - LOGICAL DISCR, LTRANS - INTEGER INFO, ISGN, LDA, LDR, LDS - DOUBLE PRECISION SCALE -C .. Array Arguments .. - DOUBLE PRECISION A(LDA,*), R(LDR,*), S(LDS,*) -C .. Local Scalars .. - DOUBLE PRECISION ABSB, ABSG, ABST, ALPHA, BIGNUM, E1, E2, EPS, - $ ETA, P1, P3, P3I, P3R, S11, S12, S21, S22, - $ SCALOC, SGN, SMIN, SMLNUM, SNP, SNQ, SNT, TEMPI, - $ TEMPR, V1, V3 -C .. Local Arrays .. - DOUBLE PRECISION CSP(2), CSQ(2), CST(2), DELTA(2), DP(2), DT(2), - $ G(2), GAMMA(2), P2(2), T(2), TEMP(2), V2(2), - $ X11(2), X12(2), X21(2), X22(2), Y(2) -C .. External Functions .. - DOUBLE PRECISION DLAMCH, DLAPY2, DLAPY3 - EXTERNAL DLAMCH, DLAPY2, DLAPY3 -C .. External Subroutines .. - EXTERNAL DLABAD, DLANV2, SB03OV -C .. Intrinsic Functions .. - INTRINSIC ABS, MAX, SIGN, SQRT -C .. Executable Statements .. -C -C The comments in this routine refer to notation and equation -C numbers in sections 6 and 10 of [1]. -C -C Find the eigenvalue lambda = E1 - i*E2 of s11. -C - INFO = 0 - SGN = ISGN - S11 = S(1,1) - S12 = S(1,2) - S21 = S(2,1) - S22 = S(2,2) -C -C Set constants to control overflow. -C - EPS = DLAMCH( 'P' ) - SMLNUM = DLAMCH( 'S' ) - BIGNUM = ONE / SMLNUM - CALL DLABAD( SMLNUM, BIGNUM ) - SMLNUM = SMLNUM*FOUR / EPS - BIGNUM = ONE / SMLNUM -C - SMIN = MAX( SMLNUM, EPS*MAX( ABS( S11 ), ABS( S12 ), - $ ABS( S21 ), ABS( S22 ) ) ) - SCALE = ONE -C - CALL DLANV2( S11, S12, S21, S22, TEMPR, TEMPI, E1, E2, CSP, CSQ ) - IF ( TEMPI.EQ.ZERO ) THEN - INFO = 4 - RETURN - END IF - ABSB = DLAPY2( E1, E2 ) - IF ( DISCR ) THEN - IF ( SGN*( ABSB - ONE ).GE.ZERO ) THEN - INFO = 2 - RETURN - END IF - ELSE - IF ( SGN*E1.GE.ZERO ) THEN - INFO = 2 - RETURN - END IF - END IF -C -C Compute the cos and sine that define Qhat. The sine is real. -C - TEMP(1) = S(1,1) - E1 - TEMP(2) = E2 - IF ( LTRANS ) TEMP(2) = -E2 - CALL SB03OV( TEMP, S(2,1), CSQ, SNQ ) -C -C beta in (6.9) is given by beta = E1 + i*E2, compute t. -C - TEMP(1) = CSQ(1)*S(1,2) - SNQ*S(1,1) - TEMP(2) = CSQ(2)*S(1,2) - TEMPR = CSQ(1)*S(2,2) - SNQ*S(2,1) - TEMPI = CSQ(2)*S(2,2) - T(1) = CSQ(1)*TEMP(1) - CSQ(2)*TEMP(2) + SNQ*TEMPR - T(2) = CSQ(1)*TEMP(2) + CSQ(2)*TEMP(1) + SNQ*TEMPI -C - IF ( LTRANS ) THEN -C ( -- ) -C Case op(M) = M'. Note that the modified R is ( p3 p2 ). -C ( 0 p1 ) -C -C Compute the cos and sine that define Phat. -C - TEMP(1) = CSQ(1)*R(2,2) - SNQ*R(1,2) - TEMP(2) = -CSQ(2)*R(2,2) - CALL SB03OV( TEMP, -SNQ*R(1,1), CSP, SNP ) -C -C Compute p1, p2 and p3 of the relation corresponding to (6.11). -C - P1 = TEMP(1) - TEMP(1) = CSQ(1)*R(1,2) + SNQ*R(2,2) - TEMP(2) = -CSQ(2)*R(1,2) - TEMPR = CSQ(1)*R(1,1) - TEMPI = -CSQ(2)*R(1,1) - P2(1) = CSP(1)*TEMP(1) - CSP(2)*TEMP(2) + SNP*TEMPR - P2(2) = -CSP(1)*TEMP(2) - CSP(2)*TEMP(1) - SNP*TEMPI - P3R = CSP(1)*TEMPR + CSP(2)*TEMPI - SNP*TEMP(1) - P3I = CSP(1)*TEMPI - CSP(2)*TEMPR - SNP*TEMP(2) - ELSE -C -C Case op(M) = M. -C -C Compute the cos and sine that define Phat. -C - TEMP(1) = CSQ(1)*R(1,1) + SNQ*R(1,2) - TEMP(2) = CSQ(2)*R(1,1) - CALL SB03OV( TEMP, SNQ*R(2,2), CSP, SNP ) -C -C Compute p1, p2 and p3 of (6.11). -C - P1 = TEMP(1) - TEMP(1) = CSQ(1)*R(1,2) - SNQ*R(1,1) - TEMP(2) = CSQ(2)*R(1,2) - TEMPR = CSQ(1)*R(2,2) - TEMPI = CSQ(2)*R(2,2) - P2(1) = CSP(1)*TEMP(1) - CSP(2)*TEMP(2) + SNP*TEMPR - P2(2) = CSP(1)*TEMP(2) + CSP(2)*TEMP(1) + SNP*TEMPI - P3R = CSP(1)*TEMPR + CSP(2)*TEMPI - SNP*TEMP(1) - P3I = CSP(2)*TEMPR - CSP(1)*TEMPI + SNP*TEMP(2) - END IF -C -C Make p3 real by multiplying by conjg ( p3 )/abs( p3 ) to give -C -C p3 := abs( p3 ). -C - IF ( P3I.EQ.ZERO ) THEN - P3 = ABS( P3R ) - DP(1) = SIGN( ONE, P3R ) - DP(2) = ZERO - ELSE - P3 = DLAPY2( P3R, P3I ) - DP(1) = P3R/P3 - DP(2) = -P3I/P3 - END IF -C -C Now compute the quantities v1, v2, v3 and y in (6.13) - (6.15), -C or (10.23) - (10.25). Care is taken to avoid overflows. -C - IF ( DISCR ) THEN - ALPHA = SQRT( ABS( ONE - ABSB )*( ONE + ABSB ) ) - ELSE - ALPHA = SQRT( ABS( TWO*E1 ) ) - END IF -C - SCALOC = ONE - IF( ALPHA.LT.SMIN ) THEN - ALPHA = SMIN - INFO = 1 - END IF - ABST = ABS( P1 ) - IF( ALPHA.LT.ONE .AND. ABST.GT.ONE ) THEN - IF( ABST.GT.BIGNUM*ALPHA ) - $ SCALOC = ONE / ABST - END IF - IF( SCALOC.NE.ONE ) THEN - P1 = SCALOC*P1 - P2(1) = SCALOC*P2(1) - P2(2) = SCALOC*P2(2) - P3 = SCALOC*P3 - SCALE = SCALOC*SCALE - END IF - V1 = P1/ALPHA -C - IF ( DISCR ) THEN - G(1) = ( ONE - E1 )*( ONE + E1 ) + E2**2 - G(2) = -TWO*E1*E2 - ABSG = DLAPY2( G(1), G(2) ) - SCALOC = ONE - IF( ABSG.LT.SMIN ) THEN - ABSG = SMIN - INFO = 1 - END IF - TEMP(1) = SGN*ALPHA*P2(1) + V1*( E1*T(1) - E2*T(2) ) - TEMP(2) = SGN*ALPHA*P2(2) + V1*( E1*T(2) + E2*T(1) ) - ABST = MAX( ABS( TEMP(1) ), ABS( TEMP(2) ) ) - IF( ABSG.LT.ONE .AND. ABST.GT.ONE ) THEN - IF( ABST.GT.BIGNUM*ABSG ) - $ SCALOC = ONE / ABST - END IF - IF( SCALOC.NE.ONE ) THEN - V1 = SCALOC*V1 - TEMP(1) = SCALOC*TEMP(1) - TEMP(2) = SCALOC*TEMP(2) - P1 = SCALOC*P1 - P2(1) = SCALOC*P2(1) - P2(2) = SCALOC*P2(2) - P3 = SCALOC*P3 - SCALE = SCALOC*SCALE - END IF - TEMP(1) = TEMP(1)/ABSG - TEMP(2) = TEMP(2)/ABSG -C - SCALOC = ONE - V2(1) = G(1)*TEMP(1) + G(2)*TEMP(2) - V2(2) = G(1)*TEMP(2) - G(2)*TEMP(1) - ABST = MAX( ABS( V2(1) ), ABS( V2(2) ) ) - IF( ABSG.LT.ONE .AND. ABST.GT.ONE ) THEN - IF( ABST.GT.BIGNUM*ABSG ) - $ SCALOC = ONE / ABST - END IF - IF( SCALOC.NE.ONE ) THEN - V1 = SCALOC*V1 - V2(1) = SCALOC*V2(1) - V2(2) = SCALOC*V2(2) - P1 = SCALOC*P1 - P2(1) = SCALOC*P2(1) - P2(2) = SCALOC*P2(2) - P3 = SCALOC*P3 - SCALE = SCALOC*SCALE - END IF - V2(1) = V2(1)/ABSG - V2(2) = V2(2)/ABSG -C - SCALOC = ONE - TEMP(1) = P1*T(1) - TWO*E2*P2(2) - TEMP(2) = P1*T(2) + TWO*E2*P2(1) - ABST = MAX( ABS( TEMP(1) ), ABS( TEMP(2) ) ) - IF( ABSG.LT.ONE .AND. ABST.GT.ONE ) THEN - IF( ABST.GT.BIGNUM*ABSG ) - $ SCALOC = ONE / ABST - END IF - IF( SCALOC.NE.ONE ) THEN - TEMP(1) = SCALOC*TEMP(1) - TEMP(2) = SCALOC*TEMP(2) - V1 = SCALOC*V1 - V2(1) = SCALOC*V2(1) - V2(2) = SCALOC*V2(2) - P3 = SCALOC*P3 - SCALE = SCALOC*SCALE - END IF - TEMP(1) = TEMP(1)/ABSG - TEMP(2) = TEMP(2)/ABSG -C - SCALOC = ONE - Y(1) = -( G(1)*TEMP(1) + G(2)*TEMP(2) ) - Y(2) = -( G(1)*TEMP(2) - G(2)*TEMP(1) ) - ABST = MAX( ABS( Y(1) ), ABS( Y(2) ) ) - IF( ABSG.LT.ONE .AND. ABST.GT.ONE ) THEN - IF( ABST.GT.BIGNUM*ABSG ) - $ SCALOC = ONE / ABST - END IF - IF( SCALOC.NE.ONE ) THEN - Y(1) = SCALOC*Y(1) - Y(2) = SCALOC*Y(2) - V1 = SCALOC*V1 - V2(1) = SCALOC*V2(1) - V2(2) = SCALOC*V2(2) - P3 = SCALOC*P3 - SCALE = SCALOC*SCALE - END IF - Y(1) = Y(1)/ABSG - Y(2) = Y(2)/ABSG - ELSE -C - SCALOC = ONE - IF( ABSB.LT.SMIN ) THEN - ABSB = SMIN - INFO = 1 - END IF - TEMP(1) = SGN*ALPHA*P2(1) + V1*T(1) - TEMP(2) = SGN*ALPHA*P2(2) + V1*T(2) - ABST = MAX( ABS( TEMP(1) ), ABS( TEMP(2) ) ) - IF( ABSB.LT.ONE .AND. ABST.GT.ONE ) THEN - IF( ABST.GT.BIGNUM*ABSB ) - $ SCALOC = ONE / ABST - END IF - IF( SCALOC.NE.ONE ) THEN - V1 = SCALOC*V1 - TEMP(1) = SCALOC*TEMP(1) - TEMP(2) = SCALOC*TEMP(2) - P2(1) = SCALOC*P2(1) - P2(2) = SCALOC*P2(2) - P3 = SCALOC*P3 - SCALE = SCALOC*SCALE - END IF - TEMP(1) = TEMP(1)/( TWO*ABSB ) - TEMP(2) = TEMP(2)/( TWO*ABSB ) - SCALOC = ONE - V2(1) = -( E1*TEMP(1) + E2*TEMP(2) ) - V2(2) = -( E1*TEMP(2) - E2*TEMP(1) ) - ABST = MAX( ABS( V2(1) ), ABS( V2(2) ) ) - IF( ABSB.LT.ONE .AND. ABST.GT.ONE ) THEN - IF( ABST.GT.BIGNUM*ABSB ) - $ SCALOC = ONE / ABST - END IF - IF( SCALOC.NE.ONE ) THEN - V1 = SCALOC*V1 - V2(1) = SCALOC*V2(1) - V2(2) = SCALOC*V2(2) - P2(1) = SCALOC*P2(1) - P2(2) = SCALOC*P2(2) - P3 = SCALOC*P3 - SCALE = SCALOC*SCALE - END IF - V2(1) = V2(1)/ABSB - V2(2) = V2(2)/ABSB - Y(1) = P2(1) - ALPHA*V2(1) - Y(2) = P2(2) - ALPHA*V2(2) - END IF -C - SCALOC = ONE - V3 = DLAPY3( P3, Y(1), Y(2) ) - IF( ALPHA.LT.ONE .AND. V3.GT.ONE ) THEN - IF( V3.GT.BIGNUM*ALPHA ) - $ SCALOC = ONE / V3 - END IF - IF( SCALOC.NE.ONE ) THEN - V1 = SCALOC*V1 - V2(1) = SCALOC*V2(1) - V2(2) = SCALOC*V2(2) - V3 = SCALOC*V3 - P3 = SCALOC*P3 - SCALE = SCALOC*SCALE - END IF - V3 = V3/ALPHA -C - IF ( LTRANS ) THEN -C -C Case op(M) = M'. -C -C Form X = conjg( Qhat' )*v11. -C - X11(1) = CSQ(1)*V3 - X11(2) = CSQ(2)*V3 - X21(1) = SNQ*V3 - X12(1) = CSQ(1)*V2(1) + CSQ(2)*V2(2) - SNQ*V1 - X12(2) = -CSQ(1)*V2(2) + CSQ(2)*V2(1) - X22(1) = CSQ(1)*V1 + SNQ*V2(1) - X22(2) = -CSQ(2)*V1 - SNQ*V2(2) -C -C Obtain u11 from the RQ-factorization of X. The conjugate of -C X22 should be taken. -C - X22(2) = -X22(2) - CALL SB03OV( X22, X21(1), CST, SNT ) - R(2,2) = X22(1) - R(1,2) = CST(1)*X12(1) - CST(2)*X12(2) + SNT*X11(1) - TEMPR = CST(1)*X11(1) + CST(2)*X11(2) - SNT*X12(1) - TEMPI = CST(1)*X11(2) - CST(2)*X11(1) - SNT*X12(2) - IF ( TEMPI.EQ.ZERO ) THEN - R(1,1) = ABS( TEMPR ) - DT(1) = SIGN( ONE, TEMPR ) - DT(2) = ZERO - ELSE - R(1,1) = DLAPY2( TEMPR, TEMPI ) - DT(1) = TEMPR/R(1,1) - DT(2) = -TEMPI/R(1,1) - END IF - ELSE -C -C Case op(M) = M. -C -C Now form X = v11*conjg( Qhat' ). -C - X11(1) = CSQ(1)*V1 - SNQ*V2(1) - X11(2) = -CSQ(2)*V1 + SNQ*V2(2) - X21(1) = -SNQ*V3 - X12(1) = CSQ(1)*V2(1) + CSQ(2)*V2(2) + SNQ*V1 - X12(2) = -CSQ(1)*V2(2) + CSQ(2)*V2(1) - X22(1) = CSQ(1)*V3 - X22(2) = CSQ(2)*V3 -C -C Obtain u11 from the QR-factorization of X. -C - CALL SB03OV( X11, X21(1), CST, SNT ) - R(1,1) = X11(1) - R(1,2) = CST(1)*X12(1) + CST(2)*X12(2) + SNT*X22(1) - TEMPR = CST(1)*X22(1) - CST(2)*X22(2) - SNT*X12(1) - TEMPI = CST(1)*X22(2) + CST(2)*X22(1) - SNT*X12(2) - IF ( TEMPI.EQ.ZERO ) THEN - R(2,2) = ABS( TEMPR ) - DT(1) = SIGN( ONE, TEMPR ) - DT(2) = ZERO - ELSE - R(2,2) = DLAPY2( TEMPR, TEMPI ) - DT(1) = TEMPR/R(2,2) - DT(2) = -TEMPI/R(2,2) - END IF - END IF -C -C The computations below are not needed when B and A are not -C useful. Compute delta, eta and gamma as in (6.21) or (10.26). -C - IF ( ( Y(1).EQ.ZERO ).AND.( Y(2).EQ.ZERO ) ) THEN - DELTA(1) = ZERO - DELTA(2) = ZERO - GAMMA(1) = ZERO - GAMMA(2) = ZERO - ETA = ALPHA - ELSE - DELTA(1) = Y(1)/V3 - DELTA(2) = Y(2)/V3 - GAMMA(1) = -ALPHA*DELTA(1) - GAMMA(2) = -ALPHA*DELTA(2) - ETA = P3/V3 - IF ( DISCR ) THEN - TEMPR = E1*DELTA(1) - E2*DELTA(2) - DELTA(2) = E1*DELTA(2) + E2*DELTA(1) - DELTA(1) = TEMPR - END IF - END IF -C - IF ( LTRANS ) THEN -C -C Case op(M) = M'. -C -C Find X = conjg( That' )*( inv( v11 )*s11hat*v11 ). -C ( Defer the scaling.) -C - X11(1) = CST(1)*E1 + CST(2)*E2 - X11(2) = -CST(1)*E2 + CST(2)*E1 - X21(1) = SNT*E1 - X21(2) = -SNT*E2 - X12(1) = SGN*( CST(1)*GAMMA(1) + CST(2)*GAMMA(2) ) - SNT*E1 - X12(2) = SGN*( -CST(1)*GAMMA(2) + CST(2)*GAMMA(1) ) - SNT*E2 - X22(1) = CST(1)*E1 + CST(2)*E2 + SGN*SNT*GAMMA(1) - X22(2) = CST(1)*E2 - CST(2)*E1 - SGN*SNT*GAMMA(2) -C -C Now find B = X*That. ( Include the scaling here.) -C - S(1,1) = CST(1)*X11(1) + CST(2)*X11(2) - SNT*X12(1) - TEMPR = CST(1)*X21(1) + CST(2)*X21(2) - SNT*X22(1) - TEMPI = CST(1)*X21(2) - CST(2)*X21(1) - SNT*X22(2) - S(2,1) = DT(1)*TEMPR - DT(2)*TEMPI - TEMPR = CST(1)*X12(1) - CST(2)*X12(2) + SNT*X11(1) - TEMPI = CST(1)*X12(2) + CST(2)*X12(1) + SNT*X11(2) - S(1,2) = DT(1)*TEMPR + DT(2)*TEMPI - S(2,2) = CST(1)*X22(1) - CST(2)*X22(2) + SNT*X21(1) -C -C Form X = ( inv( v11 )*p11 )*conjg( Phat' ). -C - TEMPR = DP(1)*ETA - TEMPI = -DP(2)*ETA - X11(1) = CSP(1)*TEMPR - CSP(2)*TEMPI + SNP*DELTA(1) - X11(2) = CSP(1)*TEMPI + CSP(2)*TEMPR - SNP*DELTA(2) - X21(1) = SNP*ALPHA - X12(1) = -SNP*TEMPR + CSP(1)*DELTA(1) - CSP(2)*DELTA(2) - X12(2) = -SNP*TEMPI - CSP(1)*DELTA(2) - CSP(2)*DELTA(1) - X22(1) = CSP(1)*ALPHA - X22(2) = -CSP(2)*ALPHA -C -C Finally form A = conjg( That' )*X. -C - TEMPR = CST(1)*X11(1) - CST(2)*X11(2) - SNT*X21(1) - TEMPI = CST(1)*X22(2) + CST(2)*X22(1) - A(1,1) = DT(1)*TEMPR + DT(2)*TEMPI - TEMPR = CST(1)*X12(1) - CST(2)*X12(2) - SNT*X22(1) - TEMPI = CST(1)*X12(2) + CST(2)*X12(1) - SNT*X22(1) - A(1,2) = DT(1)*TEMPR + DT(2)*TEMPI - A(2,1) = ZERO - A(2,2) = CST(1)*X22(1) + CST(2)*X22(2) + SNT*X12(1) - ELSE -C -C Case op(M) = M. -C -C Find X = That*( v11*s11hat*inv( v11 ) ). ( Defer the scaling.) -C - X11(1) = CST(1)*E1 + CST(2)*E2 - X11(2) = CST(1)*E2 - CST(2)*E1 - X21(1) = -SNT*E1 - X21(2) = -SNT*E2 - X12(1) = SGN*( CST(1)*GAMMA(1) - CST(2)*GAMMA(2) ) + SNT*E1 - X12(2) = SGN*( -CST(1)*GAMMA(2) - CST(2)*GAMMA(1) ) - SNT*E2 - X22(1) = CST(1)*E1 + CST(2)*E2 - SGN*SNT*GAMMA(1) - X22(2) = -CST(1)*E2 + CST(2)*E1 + SGN*SNT*GAMMA(2) -C -C Now find B = X*conjg( That' ). ( Include the scaling here.) -C - S(1,1) = CST(1)*X11(1) - CST(2)*X11(2) + SNT*X12(1) - TEMPR = CST(1)*X21(1) - CST(2)*X21(2) + SNT*X22(1) - TEMPI = CST(1)*X21(2) + CST(2)*X21(1) + SNT*X22(2) - S(2,1) = DT(1)*TEMPR - DT(2)*TEMPI - TEMPR = CST(1)*X12(1) + CST(2)*X12(2) - SNT*X11(1) - TEMPI = CST(1)*X12(2) - CST(2)*X12(1) - SNT*X11(2) - S(1,2) = DT(1)*TEMPR + DT(2)*TEMPI - S(2,2) = CST(1)*X22(1) + CST(2)*X22(2) - SNT*X21(1) -C -C Form X = Phat*( p11*inv( v11 ) ). -C - TEMPR = DP(1)*ETA - TEMPI = -DP(2)*ETA - X11(1) = CSP(1)*ALPHA - X11(2) = CSP(2)*ALPHA - X21(1) = SNP*ALPHA - X12(1) = CSP(1)*DELTA(1) + CSP(2)*DELTA(2) - SNP*TEMPR - X12(2) = -CSP(1)*DELTA(2) + CSP(2)*DELTA(1) - SNP*TEMPI - X22(1) = CSP(1)*TEMPR + CSP(2)*TEMPI + SNP*DELTA(1) - X22(2) = CSP(1)*TEMPI - CSP(2)*TEMPR - SNP*DELTA(2) -C -C Finally form A = X*conjg( That' ). -C - A(1,1) = CST(1)*X11(1) - CST(2)*X11(2) + SNT*X12(1) - A(2,1) = ZERO - A(1,2) = CST(1)*X12(1) + CST(2)*X12(2) - SNT*X11(1) - TEMPR = CST(1)*X22(1) + CST(2)*X22(2) - SNT*X21(1) - TEMPI = CST(1)*X22(2) - CST(2)*X22(1) - A(2,2) = DT(1)*TEMPR + DT(2)*TEMPI - END IF -C - IF( SCALE.NE.ONE ) THEN - A(1,1) = SCALE*A(1,1) - A(1,2) = SCALE*A(1,2) - A(2,2) = SCALE*A(2,2) - END IF -C - RETURN -C *** Last line of SB03OY *** - END diff --git a/mex/sources/libslicot/SB03PD.f b/mex/sources/libslicot/SB03PD.f deleted file mode 100644 index 8cef1572f..000000000 --- a/mex/sources/libslicot/SB03PD.f +++ /dev/null @@ -1,410 +0,0 @@ - SUBROUTINE SB03PD( JOB, FACT, TRANA, N, A, LDA, U, LDU, C, LDC, - $ SCALE, SEPD, FERR, WR, WI, IWORK, DWORK, - $ LDWORK, INFO ) -C -C SLICOT RELEASE 5.0. -C -C Copyright (c) 2002-2009 NICONET e.V. -C -C This program is free software: you can redistribute it and/or -C modify it under the terms of the GNU General Public License as -C published by the Free Software Foundation, either version 2 of -C the License, or (at your option) any later version. -C -C This program is distributed in the hope that it will be useful, -C but WITHOUT ANY WARRANTY; without even the implied warranty of -C MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the -C GNU General Public License for more details. -C -C You should have received a copy of the GNU General Public License -C along with this program. If not, see -C . -C -C PURPOSE -C -C To solve the real discrete Lyapunov matrix equation -C -C op(A)'*X*op(A) - X = scale*C -C -C and/or estimate the quantity, called separation, -C -C sepd(op(A),op(A)') = min norm(op(A)'*X*op(A) - X)/norm(X) -C -C where op(A) = A or A' (A**T) and C is symmetric (C = C'). -C (A' denotes the transpose of the matrix A.) A is N-by-N, the right -C hand side C and the solution X are N-by-N, and scale is an output -C scale factor, set less than or equal to 1 to avoid overflow in X. -C -C ARGUMENTS -C -C Mode Parameters -C -C JOB CHARACTER*1 -C Specifies the computation to be performed, as follows: -C = 'X': Compute the solution only; -C = 'S': Compute the separation only; -C = 'B': Compute both the solution and the separation. -C -C FACT CHARACTER*1 -C Specifies whether or not the real Schur factorization -C of the matrix A is supplied on entry, as follows: -C = 'F': On entry, A and U contain the factors from the -C real Schur factorization of the matrix A; -C = 'N': The Schur factorization of A will be computed -C and the factors will be stored in A and U. -C -C TRANA CHARACTER*1 -C Specifies the form of op(A) to be used, as follows: -C = 'N': op(A) = A (No transpose); -C = 'T': op(A) = A**T (Transpose); -C = 'C': op(A) = A**T (Conjugate transpose = Transpose). -C -C Input/Output Parameters -C -C N (input) INTEGER -C The order of the matrices A, X, and C. N >= 0. -C -C A (input/output) DOUBLE PRECISION array, dimension (LDA,N) -C On entry, the leading N-by-N part of this array must -C contain the matrix A. If FACT = 'F', then A contains -C an upper quasi-triangular matrix in Schur canonical form. -C On exit, if INFO = 0 or INFO = N+1, the leading N-by-N -C part of this array contains the upper quasi-triangular -C matrix in Schur canonical form from the Shur factorization -C of A. The contents of array A is not modified if -C FACT = 'F'. -C -C LDA INTEGER -C The leading dimension of array A. LDA >= MAX(1,N). -C -C U (input or output) DOUBLE PRECISION array, dimension -C (LDU,N) -C If FACT = 'F', then U is an input argument and on entry -C it must contain the orthogonal matrix U from the real -C Schur factorization of A. -C If FACT = 'N', then U is an output argument and on exit, -C if INFO = 0 or INFO = N+1, it contains the orthogonal -C N-by-N matrix from the real Schur factorization of A. -C -C LDU INTEGER -C The leading dimension of array U. LDU >= MAX(1,N). -C -C C (input/output) DOUBLE PRECISION array, dimension (LDC,N) -C On entry with JOB = 'X' or 'B', the leading N-by-N part of -C this array must contain the symmetric matrix C. -C On exit with JOB = 'X' or 'B', if INFO = 0 or INFO = N+1, -C the leading N-by-N part of C has been overwritten by the -C symmetric solution matrix X. -C If JOB = 'S', C is not referenced. -C -C LDC INTEGER -C The leading dimension of array C. -C LDC >= 1, if JOB = 'S'; -C LDC >= MAX(1,N), otherwise. -C -C SCALE (output) DOUBLE PRECISION -C The scale factor, scale, set less than or equal to 1 to -C prevent the solution overflowing. -C -C SEPD (output) DOUBLE PRECISION -C If JOB = 'S' or JOB = 'B', and INFO = 0 or INFO = N+1, -C SEPD contains the estimate in the 1-norm of -C sepd(op(A),op(A)'). -C If JOB = 'X' or N = 0, SEPD is not referenced. -C -C FERR (output) DOUBLE PRECISION -C If JOB = 'B', and INFO = 0 or INFO = N+1, FERR contains -C an estimated forward error bound for the solution X. -C If XTRUE is the true solution, FERR bounds the relative -C error in the computed solution, measured in the Frobenius -C norm: norm(X - XTRUE)/norm(XTRUE). -C If JOB = 'X' or JOB = 'S', FERR is not referenced. -C -C WR (output) DOUBLE PRECISION array, dimension (N) -C WI (output) DOUBLE PRECISION array, dimension (N) -C If FACT = 'N', and INFO = 0 or INFO = N+1, WR and WI -C contain the real and imaginary parts, respectively, of the -C eigenvalues of A. -C If FACT = 'F', WR and WI are not referenced. -C -C Workspace -C -C IWORK INTEGER array, dimension (N*N) -C This array is not referenced if JOB = 'X'. -C -C DWORK DOUBLE PRECISION array, dimension (LDWORK) -C On exit, if INFO = 0 or INFO = N+1, DWORK(1) returns the -C optimal value of LDWORK. -C -C LDWORK INTEGER -C The length of the array DWORK. LDWORK >= 1 and -C If JOB = 'X' then -C If FACT = 'F', LDWORK >= MAX(N*N,2*N); -C If FACT = 'N', LDWORK >= MAX(N*N,3*N). -C If JOB = 'S' or JOB = 'B' then -C LDWORK >= 2*N*N + 2*N. -C For optimum performance LDWORK should be larger. -C -C Error Indicator -C -C INFO INTEGER -C = 0: successful exit; -C < 0: if INFO = -i, the i-th argument had an illegal -C value; -C > 0: if INFO = i, the QR algorithm failed to compute all -C the eigenvalues (see LAPACK Library routine DGEES); -C elements i+1:n of WR and WI contain eigenvalues -C which have converged, and A contains the partially -C converged Schur form; -C = N+1: if matrix A has almost reciprocal eigenvalues; -C perturbed values were used to solve the equation -C (but the matrix A is unchanged). -C -C METHOD -C -C After reducing matrix A to real Schur canonical form (if needed), -C a discrete-time version of the Bartels-Stewart algorithm is used. -C A set of equivalent linear algebraic systems of equations of order -C at most four are formed and solved using Gaussian elimination with -C complete pivoting. -C -C REFERENCES -C -C [1] Barraud, A.Y. T -C A numerical algorithm to solve A XA - X = Q. -C IEEE Trans. Auto. Contr., AC-22, pp. 883-885, 1977. -C -C [2] Bartels, R.H. and Stewart, G.W. T -C Solution of the matrix equation A X + XB = C. -C Comm. A.C.M., 15, pp. 820-826, 1972. -C -C NUMERICAL ASPECTS -C 3 -C The algorithm requires 0(N ) operations. -C -C FURTHER COMMENTS -C -C SEPD is defined as -C -C sepd( op(A), op(A)' ) = sigma_min( T ) -C -C where sigma_min(T) is the smallest singular value of the -C N*N-by-N*N matrix -C -C T = kprod( op(A)', op(A)' ) - I(N**2). -C -C I(N**2) is an N*N-by-N*N identity matrix, and kprod denotes the -C Kronecker product. The program estimates sigma_min(T) by the -C reciprocal of an estimate of the 1-norm of inverse(T). The true -C reciprocal 1-norm of inverse(T) cannot differ from sigma_min(T) by -C more than a factor of N. -C -C When SEPD is small, small changes in A, C can cause large changes -C in the solution of the equation. An approximate bound on the -C maximum relative error in the computed solution is -C -C EPS * norm(A)**2 / SEPD -C -C where EPS is the machine precision. -C -C CONTRIBUTOR -C -C Release 3.0: V. Sima, Katholieke Univ. Leuven, Belgium, May 1997. -C Supersedes Release 2.0 routine MB03AD by Control Systems Research -C Group, Kingston Polytechnic, United Kingdom, October 1982. -C Based on DGELPD by P. Petkov, Tech. University of Sofia, September -C 1993. -C -C REVISIONS -C -C V. Sima, Katholieke Univ. Leuven, Belgium, May 1999. -C -C KEYWORDS -C -C Lyapunov equation, orthogonal transformation, real Schur form, -C Sylvester equation. -C -C ****************************************************************** -C -C .. Parameters .. - DOUBLE PRECISION ZERO, ONE - PARAMETER ( ZERO = 0.0D+0, ONE = 1.0D+0 ) -C .. -C .. Scalar Arguments .. - CHARACTER FACT, JOB, TRANA - INTEGER INFO, LDA, LDC, LDU, LDWORK, N - DOUBLE PRECISION FERR, SCALE, SEPD -C .. -C .. Array Arguments .. - INTEGER IWORK( * ) - DOUBLE PRECISION A( LDA, * ), C( LDC, * ), DWORK( * ), - $ U( LDU, * ), WI( * ), WR( * ) -C .. -C .. Local Scalars .. - LOGICAL NOFACT, NOTA, WANTBH, WANTSP, WANTX - CHARACTER NOTRA, UPLO - INTEGER I, IERR, KASE, LWA, MINWRK, SDIM - DOUBLE PRECISION EST, SCALEF -C .. -C .. Local Arrays .. - LOGICAL BWORK( 1 ) -C .. -C .. External Functions .. - LOGICAL LSAME, SELECT - DOUBLE PRECISION DLAMCH, DLANHS - EXTERNAL DLAMCH, DLANHS, LSAME, SELECT -C .. -C .. External Subroutines .. - EXTERNAL DCOPY, DGEES, DLACON, MB01RD, SB03MX, XERBLA -C .. -C .. Intrinsic Functions .. - INTRINSIC DBLE, INT, MAX -C .. -C .. Executable Statements .. -C -C Decode and Test input parameters. -C - WANTX = LSAME( JOB, 'X' ) - WANTSP = LSAME( JOB, 'S' ) - WANTBH = LSAME( JOB, 'B' ) - NOFACT = LSAME( FACT, 'N' ) - NOTA = LSAME( TRANA, 'N' ) -C - INFO = 0 - IF( .NOT.WANTBH .AND. .NOT.WANTSP .AND. .NOT.WANTX ) THEN - INFO = -1 - ELSE IF( .NOT.NOFACT .AND. .NOT.LSAME( FACT, 'F' ) ) THEN - INFO = -2 - ELSE IF( .NOT.NOTA .AND. .NOT.LSAME( TRANA, 'T' ) .AND. - $ .NOT.LSAME( TRANA, 'C' ) ) THEN - INFO = -3 - ELSE IF( N.LT.0 ) THEN - INFO = -4 - ELSE IF( LDA.LT.MAX( 1, N ) ) THEN - INFO = -6 - ELSE IF( LDU.LT.MAX( 1, N ) ) THEN - INFO = -8 - ELSE IF( WANTSP .AND. LDC.LT.1 .OR. - $ .NOT.WANTSP .AND. LDC.LT.MAX( 1, N ) ) THEN - INFO = -10 - END IF -C -C Compute workspace. -C - IF( WANTX ) THEN - IF( NOFACT ) THEN - MINWRK = MAX( N*N, 3*N ) - ELSE - MINWRK = MAX( N*N, 2*N ) - END IF - ELSE - MINWRK = 2*N*N + 2*N - END IF - IF( LDWORK.LT.MAX( 1, MINWRK ) ) THEN - INFO = -18 - END IF - IF( INFO.NE.0 ) THEN - CALL XERBLA( 'SB03PD', -INFO ) - RETURN - END IF -C -C Quick return if possible. -C - IF( N.EQ.0 ) THEN - SCALE = ONE - IF( WANTBH ) - $ FERR = ZERO - DWORK(1) = ONE - RETURN - END IF -C - LWA = 0 -C - IF( NOFACT ) THEN -C -C Compute the Schur factorization of A. -C Workspace: need 3*N; -C prefer larger. -C - CALL DGEES( 'Vectors', 'Not ordered', SELECT, N, A, LDA, SDIM, - $ WR, WI, U, LDU, DWORK, LDWORK, BWORK, INFO ) - IF( INFO.GT.0 ) - $ RETURN - LWA = INT( DWORK( 1 ) ) - END IF -C - IF( .NOT.WANTSP ) THEN -C -C Transform the right-hand side. -C Workspace: need N*N. -C - UPLO = 'U' - CALL MB01RD( UPLO, 'Transpose', N, N, ZERO, ONE, C, LDC, U, - $ LDU, C, LDC, DWORK, LDWORK, INFO ) -C - DO 10 I = 2, N - CALL DCOPY( I-1, C(1,I), 1, C(I,1), LDC ) - 10 CONTINUE -C -C Solve the transformed equation. -C Workspace: 2*N. -C - CALL SB03MX( TRANA, N, A, LDA, C, LDC, SCALE, DWORK, INFO ) - IF( INFO.GT.0 ) - $ INFO = N + 1 -C -C Transform back the solution. -C - CALL MB01RD( UPLO, 'No transpose', N, N, ZERO, ONE, C, LDC, U, - $ LDU, C, LDC, DWORK, LDWORK, INFO ) -C - DO 20 I = 2, N - CALL DCOPY( I-1, C(1,I), 1, C(I,1), LDC ) - 20 CONTINUE -C - END IF -C - IF( .NOT.WANTX ) THEN -C -C Estimate sepd(op(A),op(A)'). -C Workspace: 2*N*N + 2*N. -C - IF( NOTA ) THEN - NOTRA = 'T' - ELSE - NOTRA = 'N' - END IF -C - EST = ZERO - KASE = 0 -C REPEAT - 30 CONTINUE - CALL DLACON( N*N, DWORK( N*N+1 ), DWORK, IWORK, EST, KASE ) - IF( KASE.NE.0 ) THEN - IF( KASE.EQ.1 ) THEN - CALL SB03MX( TRANA, N, A, LDA, DWORK, N, SCALEF, - $ DWORK( 2*N*N + 1 ), IERR ) - ELSE - CALL SB03MX( NOTRA, N, A, LDA, DWORK, N, SCALEF, - $ DWORK( 2*N*N + 1 ), IERR ) - END IF - GO TO 30 - END IF -C UNTIL KASE = 0 -C - SEPD = SCALEF / EST -C - IF( WANTBH ) THEN -C -C Compute the estimate of the relative error. -C - FERR = DLAMCH( 'Precision' )* - $ DLANHS( 'Frobenius', N, A, LDA, DWORK )**2 / SEPD - END IF - END IF -C - DWORK( 1 ) = DBLE( MAX( LWA, MINWRK ) ) -C - RETURN -C *** Last line of SB03PD *** - END diff --git a/mex/sources/libslicot/SB03QD.f b/mex/sources/libslicot/SB03QD.f deleted file mode 100644 index 5f8ccf886..000000000 --- a/mex/sources/libslicot/SB03QD.f +++ /dev/null @@ -1,676 +0,0 @@ - SUBROUTINE SB03QD( JOB, FACT, TRANA, UPLO, LYAPUN, N, SCALE, A, - $ LDA, T, LDT, U, LDU, C, LDC, X, LDX, SEP, - $ RCOND, FERR, IWORK, DWORK, LDWORK, INFO ) -C -C SLICOT RELEASE 5.0. -C -C Copyright (c) 2002-2009 NICONET e.V. -C -C This program is free software: you can redistribute it and/or -C modify it under the terms of the GNU General Public License as -C published by the Free Software Foundation, either version 2 of -C the License, or (at your option) any later version. -C -C This program is distributed in the hope that it will be useful, -C but WITHOUT ANY WARRANTY; without even the implied warranty of -C MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the -C GNU General Public License for more details. -C -C You should have received a copy of the GNU General Public License -C along with this program. If not, see -C . -C -C PURPOSE -C -C To estimate the conditioning and compute an error bound on the -C solution of the real continuous-time Lyapunov matrix equation -C -C op(A)'*X + X*op(A) = scale*C -C -C where op(A) = A or A' (A**T) and C is symmetric (C = C**T). The -C matrix A is N-by-N, the right hand side C and the solution X are -C N-by-N symmetric matrices, and scale is a given scale factor. -C -C ARGUMENTS -C -C Mode Parameters -C -C JOB CHARACTER*1 -C Specifies the computation to be performed, as follows: -C = 'C': Compute the reciprocal condition number only; -C = 'E': Compute the error bound only; -C = 'B': Compute both the reciprocal condition number and -C the error bound. -C -C FACT CHARACTER*1 -C Specifies whether or not the real Schur factorization -C of the matrix A is supplied on entry, as follows: -C = 'F': On entry, T and U (if LYAPUN = 'O') contain the -C factors from the real Schur factorization of the -C matrix A; -C = 'N': The Schur factorization of A will be computed -C and the factors will be stored in T and U (if -C LYAPUN = 'O'). -C -C TRANA CHARACTER*1 -C Specifies the form of op(A) to be used, as follows: -C = 'N': op(A) = A (No transpose); -C = 'T': op(A) = A**T (Transpose); -C = 'C': op(A) = A**T (Conjugate transpose = Transpose). -C -C UPLO CHARACTER*1 -C Specifies which part of the symmetric matrix C is to be -C used, as follows: -C = 'U': Upper triangular part; -C = 'L': Lower triangular part. -C -C LYAPUN CHARACTER*1 -C Specifies whether or not the original Lyapunov equations -C should be solved in the iterative estimation process, -C as follows: -C = 'O': Solve the original Lyapunov equations, updating -C the right-hand sides and solutions with the -C matrix U, e.g., X <-- U'*X*U; -C = 'R': Solve reduced Lyapunov equations only, without -C updating the right-hand sides and solutions. -C -C Input/Output Parameters -C -C N (input) INTEGER -C The order of the matrices A, X and C. N >= 0. -C -C SCALE (input) DOUBLE PRECISION -C The scale factor, scale, set by a Lyapunov solver. -C 0 <= SCALE <= 1. -C -C A (input) DOUBLE PRECISION array, dimension (LDA,N) -C If FACT = 'N' or LYAPUN = 'O', the leading N-by-N part of -C this array must contain the original matrix A. -C If FACT = 'F' and LYAPUN = 'R', A is not referenced. -C -C LDA INTEGER -C The leading dimension of the array A. -C LDA >= MAX(1,N), if FACT = 'N' or LYAPUN = 'O'; -C LDA >= 1, if FACT = 'F' and LYAPUN = 'R'. -C -C T (input/output) DOUBLE PRECISION array, dimension -C (LDT,N) -C If FACT = 'F', then on entry the leading N-by-N upper -C Hessenberg part of this array must contain the upper -C quasi-triangular matrix T in Schur canonical form from a -C Schur factorization of A. -C If FACT = 'N', then this array need not be set on input. -C On exit, (if INFO = 0 or INFO = N+1, for FACT = 'N') the -C leading N-by-N upper Hessenberg part of this array -C contains the upper quasi-triangular matrix T in Schur -C canonical form from a Schur factorization of A. -C -C LDT INTEGER -C The leading dimension of the array T. LDT >= MAX(1,N). -C -C U (input or output) DOUBLE PRECISION array, dimension -C (LDU,N) -C If LYAPUN = 'O' and FACT = 'F', then U is an input -C argument and on entry, the leading N-by-N part of this -C array must contain the orthogonal matrix U from a real -C Schur factorization of A. -C If LYAPUN = 'O' and FACT = 'N', then U is an output -C argument and on exit, if INFO = 0 or INFO = N+1, it -C contains the orthogonal N-by-N matrix from a real Schur -C factorization of A. -C If LYAPUN = 'R', the array U is not referenced. -C -C LDU INTEGER -C The leading dimension of the array U. -C LDU >= 1, if LYAPUN = 'R'; -C LDU >= MAX(1,N), if LYAPUN = 'O'. -C -C C (input) DOUBLE PRECISION array, dimension (LDC,N) -C If UPLO = 'U', the leading N-by-N upper triangular part of -C this array must contain the upper triangular part of the -C matrix C of the original Lyapunov equation (with -C matrix A), if LYAPUN = 'O', or of the reduced Lyapunov -C equation (with matrix T), if LYAPUN = 'R'. -C If UPLO = 'L', the leading N-by-N lower triangular part of -C this array must contain the lower triangular part of the -C matrix C of the original Lyapunov equation (with -C matrix A), if LYAPUN = 'O', or of the reduced Lyapunov -C equation (with matrix T), if LYAPUN = 'R'. -C -C LDC INTEGER -C The leading dimension of the array C. LDC >= MAX(1,N). -C -C X (input) DOUBLE PRECISION array, dimension (LDX,N) -C The leading N-by-N part of this array must contain the -C symmetric solution matrix X of the original Lyapunov -C equation (with matrix A), if LYAPUN = 'O', or of the -C reduced Lyapunov equation (with matrix T), if -C LYAPUN = 'R'. -C -C LDX INTEGER -C The leading dimension of the array X. LDX >= MAX(1,N). -C -C SEP (output) DOUBLE PRECISION -C If JOB = 'C' or JOB = 'B', the estimated quantity -C sep(op(A),-op(A)'). -C If N = 0, or X = 0, or JOB = 'E', SEP is not referenced. -C -C RCOND (output) DOUBLE PRECISION -C If JOB = 'C' or JOB = 'B', an estimate of the reciprocal -C condition number of the continuous-time Lyapunov equation. -C If N = 0 or X = 0, RCOND is set to 1 or 0, respectively. -C If JOB = 'E', RCOND is not referenced. -C -C FERR (output) DOUBLE PRECISION -C If JOB = 'E' or JOB = 'B', an estimated forward error -C bound for the solution X. If XTRUE is the true solution, -C FERR bounds the magnitude of the largest entry in -C (X - XTRUE) divided by the magnitude of the largest entry -C in X. -C If N = 0 or X = 0, FERR is set to 0. -C If JOB = 'C', FERR is not referenced. -C -C Workspace -C -C IWORK INTEGER array, dimension (N*N) -C -C DWORK DOUBLE PRECISION array, dimension (LDWORK) -C On exit, if INFO = 0 or INFO = N+1, DWORK(1) returns the -C optimal value of LDWORK. -C -C LDWORK INTEGER -C The dimension of the array DWORK. -C If JOB = 'C', then -C LDWORK >= MAX(1,2*N*N), if FACT = 'F'; -C LDWORK >= MAX(1,2*N*N,5*N), if FACT = 'N'. -C If JOB = 'E', or JOB = 'B', and LYAPUN = 'O', then -C LDWORK >= MAX(1,3*N*N), if FACT = 'F'; -C LDWORK >= MAX(1,3*N*N,5*N), if FACT = 'N'. -C If JOB = 'E', or JOB = 'B', and LYAPUN = 'R', then -C LDWORK >= MAX(1,3*N*N+N-1), if FACT = 'F'; -C LDWORK >= MAX(1,3*N*N+N-1,5*N), if FACT = 'N'. -C For optimum performance LDWORK should sometimes be larger. -C -C Error Indicator -C -C INFO INTEGER -C = 0: successful exit; -C < 0: if INFO = -i, the i-th argument had an illegal -C value; -C > 0: if INFO = i, i <= N, the QR algorithm failed to -C complete the reduction to Schur canonical form (see -C LAPACK Library routine DGEES); on exit, the matrix -C T(i+1:N,i+1:N) contains the partially converged -C Schur form, and DWORK(i+1:N) and DWORK(N+i+1:2*N) -C contain the real and imaginary parts, respectively, -C of the converged eigenvalues; this error is unlikely -C to appear; -C = N+1: if the matrices T and -T' have common or very -C close eigenvalues; perturbed values were used to -C solve Lyapunov equations, but the matrix T, if given -C (for FACT = 'F'), is unchanged. -C -C METHOD -C -C The condition number of the continuous-time Lyapunov equation is -C estimated as -C -C cond = (norm(Theta)*norm(A) + norm(inv(Omega))*norm(C))/norm(X), -C -C where Omega and Theta are linear operators defined by -C -C Omega(W) = op(A)'*W + W*op(A), -C Theta(W) = inv(Omega(op(W)'*X + X*op(W))). -C -C The routine estimates the quantities -C -C sep(op(A),-op(A)') = 1 / norm(inv(Omega)) -C -C and norm(Theta) using 1-norm condition estimators. -C -C The forward error bound is estimated using a practical error bound -C similar to the one proposed in [1]. -C -C REFERENCES -C -C [1] Higham, N.J. -C Perturbation theory and backward error for AX-XB=C. -C BIT, vol. 33, pp. 124-136, 1993. -C -C NUMERICAL ASPECTS -C 3 -C The algorithm requires 0(N ) operations. -C The accuracy of the estimates obtained depends on the solution -C accuracy and on the properties of the 1-norm estimator. -C -C FURTHER COMMENTS -C -C The option LYAPUN = 'R' may occasionally produce slightly worse -C or better estimates, and it is much faster than the option 'O'. -C When SEP is computed and it is zero, the routine returns -C immediately, with RCOND and FERR (if requested) set to 0 and 1, -C respectively. In this case, the equation is singular. -C -C CONTRIBUTORS -C -C P. Petkov, Tech. University of Sofia, December 1998. -C V. Sima, Katholieke Univ. Leuven, Belgium, February 1999. -C -C REVISIONS -C -C V. Sima, Katholieke Univ. Leuven, Belgium, March 2003. -C -C KEYWORDS -C -C Lyapunov equation, orthogonal transformation, real Schur form. -C -C ****************************************************************** -C -C .. Parameters .. - DOUBLE PRECISION ZERO, ONE, TWO, THREE - PARAMETER ( ZERO = 0.0D+0, ONE = 1.0D+0, TWO = 2.0D0, - $ THREE = 3.0D0 ) -C .. -C .. Scalar Arguments .. - CHARACTER FACT, JOB, LYAPUN, TRANA, UPLO - INTEGER INFO, LDA, LDC, LDT, LDU, LDWORK, LDX, N - DOUBLE PRECISION FERR, RCOND, SCALE, SEP -C .. -C .. Array Arguments .. - INTEGER IWORK( * ) - DOUBLE PRECISION A( LDA, * ), C( LDC, * ), DWORK( * ), - $ T( LDT, * ), U( LDU, * ), X( LDX, * ) -C .. -C .. Local Scalars .. - LOGICAL JOBB, JOBC, JOBE, LOWER, NOFACT, NOTRNA, - $ UPDATE - CHARACTER SJOB, TRANAT - INTEGER I, IABS, IRES, IWRK, IXBS, J, JJ, JX, LDW, NN, - $ SDIM, WRKOPT - DOUBLE PRECISION ANORM, CNORM, DENOM, EPS, EPSN, TEMP, THNORM, - $ TMAX, XANORM, XNORM -C .. -C .. Local Arrays .. - LOGICAL BWORK( 1 ) -C .. -C .. External Functions .. - LOGICAL LSAME, SELECT - DOUBLE PRECISION DLAMCH, DLANGE, DLANHS, DLANSY - EXTERNAL DLAMCH, DLANGE, DLANHS, DLANSY, LSAME, SELECT -C .. -C .. External Subroutines .. - EXTERNAL DAXPY, DGEES, DLACPY, DLASET, DSYR2K, MB01UD, - $ MB01UW, SB03QX, SB03QY, XERBLA -C .. -C .. Intrinsic Functions .. - INTRINSIC ABS, DBLE, INT, MAX, MIN -C .. -C .. Executable Statements .. -C -C Decode and Test input parameters. -C - JOBC = LSAME( JOB, 'C' ) - JOBE = LSAME( JOB, 'E' ) - JOBB = LSAME( JOB, 'B' ) - NOFACT = LSAME( FACT, 'N' ) - NOTRNA = LSAME( TRANA, 'N' ) - LOWER = LSAME( UPLO, 'L' ) - UPDATE = LSAME( LYAPUN, 'O' ) -C - NN = N*N - IF( JOBC ) THEN - LDW = 2*NN - ELSE - LDW = 3*NN - END IF - IF( .NOT.( JOBC .OR. UPDATE ) ) - $ LDW = LDW + N - 1 -C - INFO = 0 - IF( .NOT.( JOBB .OR. JOBC .OR. JOBE ) ) THEN - INFO = -1 - ELSE IF( .NOT.( NOFACT .OR. LSAME( FACT, 'F' ) ) ) THEN - INFO = -2 - ELSE IF( .NOT.( NOTRNA .OR. LSAME( TRANA, 'T' ) .OR. - $ LSAME( TRANA, 'C' ) ) ) THEN - INFO = -3 - ELSE IF( .NOT.( LOWER .OR. LSAME( UPLO, 'U' ) ) ) THEN - INFO = -4 - ELSE IF( .NOT.( UPDATE .OR. LSAME( LYAPUN, 'R' ) ) ) THEN - INFO = -5 - ELSE IF( N.LT.0 ) THEN - INFO = -6 - ELSE IF( SCALE.LT.ZERO .OR. SCALE.GT.ONE ) THEN - INFO = -7 - ELSE IF( LDA.LT.1 .OR. - $ ( LDA.LT.N .AND. ( UPDATE .OR. NOFACT ) ) ) THEN - INFO = -9 - ELSE IF( LDT.LT.MAX( 1, N ) ) THEN - INFO = -11 - ELSE IF( LDU.LT.1 .OR. ( LDU.LT.N .AND. UPDATE ) ) THEN - INFO = -13 - ELSE IF( LDC.LT.MAX( 1, N ) ) THEN - INFO = -15 - ELSE IF( LDX.LT.MAX( 1, N ) ) THEN - INFO = -17 - ELSE IF( LDWORK.LT.1 .OR. - $ ( LDWORK.LT.LDW .AND. .NOT.NOFACT ) .OR. - $ ( LDWORK.LT.MAX( LDW, 5*N ) .AND. NOFACT ) ) THEN - INFO = -23 - END IF -C - IF( INFO.NE.0 ) THEN - CALL XERBLA( 'SB03QD', -INFO ) - RETURN - END IF -C -C Quick return if possible. -C - IF( N.EQ.0 ) THEN - IF( .NOT.JOBE ) - $ RCOND = ONE - IF( .NOT.JOBC ) - $ FERR = ZERO - DWORK( 1 ) = ONE - RETURN - END IF -C -C Compute the 1-norm of the matrix X. -C - XNORM = DLANSY( '1-norm', UPLO, N, X, LDX, DWORK ) - IF( XNORM.EQ.ZERO ) THEN -C -C The solution is zero. -C - IF( .NOT.JOBE ) - $ RCOND = ZERO - IF( .NOT.JOBC ) - $ FERR = ZERO - DWORK( 1 ) = DBLE( N ) - RETURN - END IF -C -C Compute the 1-norm of A or T. -C - IF( NOFACT .OR. UPDATE ) THEN - ANORM = DLANGE( '1-norm', N, N, A, LDA, DWORK ) - ELSE - ANORM = DLANHS( '1-norm', N, T, LDT, DWORK ) - END IF -C -C For the special case A = 0, set SEP and RCOND to 0. -C For the special case A = I, set SEP to 2 and RCOND to 1. -C A quick test is used in general. -C - IF( ANORM.EQ.ONE ) THEN - IF( NOFACT .OR. UPDATE ) THEN - CALL DLACPY( 'Full', N, N, A, LDA, DWORK, N ) - ELSE - CALL DLACPY( 'Full', N, N, T, LDT, DWORK, N ) - IF( N.GT.2 ) - $ CALL DLASET( 'Lower', N-2, N-2, ZERO, ZERO, DWORK( 3 ), - $ N ) - END IF - DWORK( NN+1 ) = ONE - CALL DAXPY( N, -ONE, DWORK( NN+1 ), 0, DWORK, N+1 ) - IF( DLANGE( 'Max', N, N, DWORK, N, DWORK ).EQ.ZERO ) THEN - IF( .NOT.JOBE ) THEN - SEP = TWO - RCOND = ONE - END IF - IF( JOBC ) THEN - DWORK( 1 ) = DBLE( NN + 1 ) - RETURN - ELSE -C -C Set FERR for the special case A = I. -C - CALL DLACPY( UPLO, N, N, X, LDX, DWORK, N ) -C - IF( LOWER ) THEN - DO 10 J = 1, N - CALL DAXPY( N-J+1, -SCALE/TWO, C( J, J ), 1, - $ DWORK( (J-1)*N+J ), 1 ) - 10 CONTINUE - ELSE - DO 20 J = 1, N - CALL DAXPY( J, -SCALE/TWO, C( 1, J ), 1, - $ DWORK( (J-1)*N+1 ), 1 ) - 20 CONTINUE - END IF -C - FERR = MIN( ONE, DLANSY( '1-norm', UPLO, N, DWORK, N, - $ DWORK( NN+1 ) ) / XNORM ) - DWORK( 1 ) = DBLE( NN + N ) - RETURN - END IF - END IF -C - ELSE IF( ANORM.EQ.ZERO ) THEN - IF( .NOT.JOBE ) THEN - SEP = ZERO - RCOND = ZERO - END IF - IF( .NOT.JOBC ) - $ FERR = ONE - DWORK( 1 ) = DBLE( N ) - RETURN - END IF -C -C General case. -C - CNORM = DLANSY( '1-norm', UPLO, N, C, LDC, DWORK ) -C -C Workspace usage. -C - IABS = 0 - IXBS = IABS + NN - IRES = IXBS + NN - IWRK = IRES + NN - WRKOPT = 0 -C - IF( NOFACT ) THEN -C -C Compute the Schur factorization of A, A = U*T*U'. -C Workspace: need 5*N; -C prefer larger. -C (Note: Comments in the code beginning "Workspace:" describe the -C minimal amount of real workspace needed at that point in the -C code, as well as the preferred amount for good performance.) -C - CALL DLACPY( 'Full', N, N, A, LDA, T, LDT ) - IF( UPDATE ) THEN - SJOB = 'V' - ELSE - SJOB = 'N' - END IF - CALL DGEES( SJOB, 'Not ordered', SELECT, N, T, LDT, SDIM, - $ DWORK( 1 ), DWORK( N+1 ), U, LDU, DWORK( 2*N+1 ), - $ LDWORK-2*N, BWORK, INFO ) - IF( INFO.GT.0 ) - $ RETURN - WRKOPT = INT( DWORK( 2*N+1 ) ) + 2*N - END IF -C - IF( .NOT.JOBE ) THEN -C -C Estimate sep(op(A),-op(A)') = sep(op(T),-op(T)') and -C norm(Theta). -C Workspace 2*N*N. -C - CALL SB03QY( 'Both', TRANA, LYAPUN, N, T, LDT, U, LDU, X, LDX, - $ SEP, THNORM, IWORK, DWORK, LDWORK, INFO ) -C - WRKOPT = MAX( WRKOPT, 2*NN ) -C -C Return if the equation is singular. -C - IF( SEP.EQ.ZERO ) THEN - RCOND = ZERO - IF( JOBB ) - $ FERR = ONE - DWORK( 1 ) = DBLE( WRKOPT ) - RETURN - END IF -C -C Estimate the reciprocal condition number. -C - TMAX = MAX( SEP, XNORM, ANORM ) - IF( TMAX.LE.ONE ) THEN - TEMP = SEP*XNORM - DENOM = ( SCALE*CNORM ) + ( SEP*ANORM )*THNORM - ELSE - TEMP = ( SEP / TMAX )*( XNORM / TMAX ) - DENOM = ( ( SCALE / TMAX )*( CNORM / TMAX ) ) + - $ ( ( SEP / TMAX )*( ANORM / TMAX ) )*THNORM - END IF - IF( TEMP.GE.DENOM ) THEN - RCOND = ONE - ELSE - RCOND = TEMP / DENOM - END IF - END IF -C - IF( .NOT.JOBC ) THEN -C -C Form a triangle of the residual matrix -C R = op(A)'*X + X*op(A) - scale*C, or -C R = op(T)'*X + X*op(T) - scale*C, -C exploiting the symmetry. -C Workspace 3*N*N. -C - IF( NOTRNA ) THEN - TRANAT = 'T' - ELSE - TRANAT = 'N' - END IF -C - IF( UPDATE ) THEN -C - CALL DLACPY( UPLO, N, N, C, LDC, DWORK( IRES+1 ), N ) - CALL DSYR2K( UPLO, TRANAT, N, N, ONE, A, LDA, X, LDX, - $ -SCALE, DWORK( IRES+1 ), N ) - ELSE - CALL MB01UD( 'Right', TRANA, N, N, ONE, T, LDT, X, LDX, - $ DWORK( IRES+1 ), N, INFO ) - JJ = IRES + 1 - IF( LOWER ) THEN - DO 30 J = 1, N - CALL DAXPY( N-J+1, ONE, DWORK( JJ ), N, DWORK( JJ ), - $ 1 ) - CALL DAXPY( N-J+1, -SCALE, C( J, J ), 1, DWORK( JJ ), - $ 1 ) - JJ = JJ + N + 1 - 30 CONTINUE - ELSE - DO 40 J = 1, N - CALL DAXPY( J, ONE, DWORK( IRES+J ), N, DWORK( JJ ), - $ 1 ) - CALL DAXPY( J, -SCALE, C( 1, J ), 1, DWORK( JJ ), 1 ) - JJ = JJ + N - 40 CONTINUE - END IF - END IF -C - WRKOPT = MAX( WRKOPT, 3*NN ) -C -C Get the machine precision. -C - EPS = DLAMCH( 'Epsilon' ) - EPSN = EPS*DBLE( N + 3 ) - TEMP = EPS*THREE*SCALE -C -C Add to abs(R) a term that takes account of rounding errors in -C forming R: -C abs(R) := abs(R) + EPS*(3*scale*abs(C) + -C (n+3)*(abs(op(A))'*abs(X) + abs(X)*abs(op(A)))), or -C abs(R) := abs(R) + EPS*(3*scale*abs(C) + -C (n+3)*(abs(op(T))'*abs(X) + abs(X)*abs(op(T)))), -C where EPS is the machine precision. -C - DO 60 J = 1, N - DO 50 I = 1, N - DWORK( IXBS+(J-1)*N+I ) = ABS( X( I, J ) ) - 50 CONTINUE - 60 CONTINUE -C - IF( LOWER ) THEN - DO 80 J = 1, N - DO 70 I = J, N - DWORK( IRES+(J-1)*N+I ) = TEMP*ABS( C( I, J ) ) + - $ ABS( DWORK( IRES+(J-1)*N+I ) ) - 70 CONTINUE - 80 CONTINUE - ELSE - DO 100 J = 1, N - DO 90 I = 1, J - DWORK( IRES+(J-1)*N+I ) = TEMP*ABS( C( I, J ) ) + - $ ABS( DWORK( IRES+(J-1)*N+I ) ) - 90 CONTINUE - 100 CONTINUE - END IF -C - IF( UPDATE ) THEN -C -C Workspace 3*N*N. -C - DO 120 J = 1, N - DO 110 I = 1, N - DWORK( IABS+(J-1)*N+I ) = ABS( A( I, J ) ) - 110 CONTINUE - 120 CONTINUE -C - CALL DSYR2K( UPLO, TRANAT, N, N, EPSN, DWORK( IABS+1 ), N, - $ DWORK( IXBS+1 ), N, ONE, DWORK( IRES+1 ), N ) - ELSE -C -C Workspace 3*N*N + N - 1. -C - DO 140 J = 1, N - DO 130 I = 1, MIN( J+1, N ) - DWORK( IABS+(J-1)*N+I ) = ABS( T( I, J ) ) - 130 CONTINUE - 140 CONTINUE -C - CALL MB01UW( 'Left', TRANAT, N, N, EPSN, DWORK( IABS+1 ), - $ N, DWORK( IXBS+1), N, DWORK( IWRK+1 ), - $ LDWORK-IWRK, INFO ) - JJ = IRES + 1 - JX = IXBS + 1 - IF( LOWER ) THEN - DO 150 J = 1, N - CALL DAXPY( N-J+1, ONE, DWORK( JX ), N, DWORK( JX ), - $ 1 ) - CALL DAXPY( N-J+1, ONE, DWORK( JX ), 1, DWORK( JJ ), - $ 1 ) - JJ = JJ + N + 1 - JX = JX + N + 1 - 150 CONTINUE - ELSE - DO 160 J = 1, N - CALL DAXPY( J, ONE, DWORK( IXBS+J ), N, DWORK( JX ), - $ 1 ) - CALL DAXPY( J, ONE, DWORK( JX ), 1, DWORK( JJ ), 1 ) - JJ = JJ + N - JX = JX + N - 160 CONTINUE - END IF -C - WRKOPT = MAX( WRKOPT, 3*NN + N - 1 ) - END IF -C -C Compute forward error bound, using matrix norm estimator. -C Workspace 3*N*N. -C - XANORM = DLANSY( 'Max', UPLO, N, X, LDX, DWORK ) -C - CALL SB03QX( TRANA, UPLO, LYAPUN, N, XANORM, T, LDT, U, LDU, - $ DWORK( IRES+1 ), N, FERR, IWORK, DWORK, IRES, - $ INFO ) - END IF -C - DWORK( 1 ) = DBLE( WRKOPT ) - RETURN -C -C *** Last line of SB03QD *** - END diff --git a/mex/sources/libslicot/SB03QX.f b/mex/sources/libslicot/SB03QX.f deleted file mode 100644 index 255ca13a0..000000000 --- a/mex/sources/libslicot/SB03QX.f +++ /dev/null @@ -1,394 +0,0 @@ - SUBROUTINE SB03QX( TRANA, UPLO, LYAPUN, N, XANORM, T, LDT, U, LDU, - $ R, LDR, FERR, IWORK, DWORK, LDWORK, INFO ) -C -C SLICOT RELEASE 5.0. -C -C Copyright (c) 2002-2009 NICONET e.V. -C -C This program is free software: you can redistribute it and/or -C modify it under the terms of the GNU General Public License as -C published by the Free Software Foundation, either version 2 of -C the License, or (at your option) any later version. -C -C This program is distributed in the hope that it will be useful, -C but WITHOUT ANY WARRANTY; without even the implied warranty of -C MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the -C GNU General Public License for more details. -C -C You should have received a copy of the GNU General Public License -C along with this program. If not, see -C . -C -C PURPOSE -C -C To estimate a forward error bound for the solution X of a real -C continuous-time Lyapunov matrix equation, -C -C op(A)'*X + X*op(A) = C, -C -C where op(A) = A or A' (A**T) and C is symmetric (C = C**T). The -C matrix A, the right hand side C, and the solution X are N-by-N. -C An absolute residual matrix, which takes into account the rounding -C errors in forming it, is given in the array R. -C -C ARGUMENTS -C -C Mode Parameters -C -C TRANA CHARACTER*1 -C Specifies the form of op(A) to be used, as follows: -C = 'N': op(A) = A (No transpose); -C = 'T': op(A) = A**T (Transpose); -C = 'C': op(A) = A**T (Conjugate transpose = Transpose). -C -C UPLO CHARACTER*1 -C Specifies which part of the symmetric matrix R is to be -C used, as follows: -C = 'U': Upper triangular part; -C = 'L': Lower triangular part. -C -C LYAPUN CHARACTER*1 -C Specifies whether or not the original Lyapunov equations -C should be solved, as follows: -C = 'O': Solve the original Lyapunov equations, updating -C the right-hand sides and solutions with the -C matrix U, e.g., X <-- U'*X*U; -C = 'R': Solve reduced Lyapunov equations only, without -C updating the right-hand sides and solutions. -C -C Input/Output Parameters -C -C N (input) INTEGER -C The order of the matrices A and R. N >= 0. -C -C XANORM (input) DOUBLE PRECISION -C The absolute (maximal) norm of the symmetric solution -C matrix X of the Lyapunov equation. XANORM >= 0. -C -C T (input) DOUBLE PRECISION array, dimension (LDT,N) -C The leading N-by-N upper Hessenberg part of this array -C must contain the upper quasi-triangular matrix T in Schur -C canonical form from a Schur factorization of A. -C -C LDT INTEGER -C The leading dimension of array T. LDT >= MAX(1,N). -C -C U (input) DOUBLE PRECISION array, dimension (LDU,N) -C The leading N-by-N part of this array must contain the -C orthogonal matrix U from a real Schur factorization of A. -C If LYAPUN = 'R', the array U is not referenced. -C -C LDU INTEGER -C The leading dimension of array U. -C LDU >= 1, if LYAPUN = 'R'; -C LDU >= MAX(1,N), if LYAPUN = 'O'. -C -C R (input/output) DOUBLE PRECISION array, dimension (LDR,N) -C On entry, if UPLO = 'U', the leading N-by-N upper -C triangular part of this array must contain the upper -C triangular part of the absolute residual matrix R, with -C bounds on rounding errors added. -C On entry, if UPLO = 'L', the leading N-by-N lower -C triangular part of this array must contain the lower -C triangular part of the absolute residual matrix R, with -C bounds on rounding errors added. -C On exit, the leading N-by-N part of this array contains -C the symmetric absolute residual matrix R (with bounds on -C rounding errors added), fully stored. -C -C LDR INTEGER -C The leading dimension of array R. LDR >= MAX(1,N). -C -C FERR (output) DOUBLE PRECISION -C An estimated forward error bound for the solution X. -C If XTRUE is the true solution, FERR bounds the magnitude -C of the largest entry in (X - XTRUE) divided by the -C magnitude of the largest entry in X. -C If N = 0 or XANORM = 0, FERR is set to 0, without any -C calculations. -C -C Workspace -C -C IWORK INTEGER array, dimension (N*N) -C -C DWORK DOUBLE PRECISION array, dimension (LDWORK) -C -C LDWORK INTEGER -C The length of the array DWORK. LDWORK >= 2*N*N. -C -C Error Indicator -C -C INFO INTEGER -C = 0: successful exit; -C < 0: if INFO = -i, the i-th argument had an illegal -C value; -C = N+1: if the matrices T and -T' have common or very -C close eigenvalues; perturbed values were used to -C solve Lyapunov equations (but the matrix T is -C unchanged). -C -C METHOD -C -C The forward error bound is estimated using a practical error bound -C similar to the one proposed in [1], based on the 1-norm estimator -C in [2]. -C -C REFERENCES -C -C [1] Higham, N.J. -C Perturbation theory and backward error for AX-XB=C. -C BIT, vol. 33, pp. 124-136, 1993. -C -C [2] Higham, N.J. -C FORTRAN codes for estimating the one-norm of a real or -C complex matrix, with applications to condition estimation. -C ACM Trans. Math. Softw., 14, pp. 381-396, 1988. -C -C NUMERICAL ASPECTS -C 3 -C The algorithm requires 0(N ) operations. -C -C FURTHER COMMENTS -C -C The option LYAPUN = 'R' may occasionally produce slightly worse -C or better estimates, and it is much faster than the option 'O'. -C The routine can be also used as a final step in estimating a -C forward error bound for the solution of a continuous-time -C algebraic matrix Riccati equation. -C -C CONTRIBUTOR -C -C V. Sima, Research Institute for Informatics, Bucharest, Romania, -C Oct. 1998. Partly based on DGLSVX (and then SB03QD) by P. Petkov, -C Tech. University of Sofia, March 1998 (and December 1998). -C -C REVISIONS -C -C February 6, 1999, V. Sima, Katholieke Univ. Leuven, Belgium. -C V. Sima, Research Institute for Informatics, Bucharest, Oct. 2004. -C -C KEYWORDS -C -C Lyapunov equation, orthogonal transformation, real Schur form. -C -C ****************************************************************** -C -C .. Parameters .. - DOUBLE PRECISION ZERO, ONE, HALF - PARAMETER ( ZERO = 0.0D+0, ONE = 1.0D+0, HALF = 0.5D+0 ) -C .. -C .. Scalar Arguments .. - CHARACTER LYAPUN, TRANA, UPLO - INTEGER INFO, LDR, LDT, LDU, LDWORK, N - DOUBLE PRECISION FERR, XANORM -C .. -C .. Array Arguments .. - INTEGER IWORK( * ) - DOUBLE PRECISION DWORK( * ), R( LDR, * ), T( LDT, * ), - $ U( LDU, * ) -C .. -C .. Local Scalars .. - LOGICAL LOWER, NOTRNA, UPDATE - CHARACTER TRANAT, UPLOW - INTEGER I, IJ, INFO2, ITMP, J, KASE, NN - DOUBLE PRECISION EST, SCALE, TEMP -C .. -C .. External Functions .. - LOGICAL LSAME - DOUBLE PRECISION DLANSY - EXTERNAL DLANSY, LSAME -C .. -C .. External Subroutines .. - EXTERNAL DLACON, DSCAL, MA02ED, MB01RU, SB03MY, XERBLA -C .. -C .. Intrinsic Functions .. - INTRINSIC MAX -C .. -C .. Executable Statements .. -C -C Decode and Test input parameters. -C - NOTRNA = LSAME( TRANA, 'N' ) - UPDATE = LSAME( LYAPUN, 'O' ) -C - NN = N*N - INFO = 0 - IF( .NOT.( NOTRNA .OR. LSAME( TRANA, 'T' ) .OR. - $ LSAME( TRANA, 'C' ) ) ) THEN - INFO = -1 - ELSE IF( .NOT.( LSAME( UPLO, 'L' ) .OR. LSAME( UPLO, 'U' ) ) ) - $ THEN - INFO = -2 - ELSE IF( .NOT.( UPDATE .OR. LSAME( LYAPUN, 'R' ) ) ) THEN - INFO = -3 - ELSE IF( N.LT.0 ) THEN - INFO = -4 - ELSE IF( XANORM.LT.ZERO ) THEN - INFO = -5 - ELSE IF( LDT.LT.MAX( 1, N ) ) THEN - INFO = -7 - ELSE IF( LDU.LT.1 .OR. ( UPDATE .AND. LDU.LT.N ) ) THEN - INFO = -9 - ELSE IF( LDR.LT.MAX( 1, N ) ) THEN - INFO = -11 - ELSE IF( LDWORK.LT.2*NN ) THEN - INFO = -15 - END IF -C - IF( INFO.NE.0 ) THEN - CALL XERBLA( 'SB03QX', -INFO ) - RETURN - END IF -C -C Quick return if possible. -C - FERR = ZERO - IF( N.EQ.0 .OR. XANORM.EQ.ZERO ) - $ RETURN -C - ITMP = NN + 1 -C - IF( NOTRNA ) THEN - TRANAT = 'T' - ELSE - TRANAT = 'N' - END IF -C -C Fill in the remaining triangle of the symmetric residual matrix. -C - CALL MA02ED( UPLO, N, R, LDR ) -C - KASE = 0 -C -C REPEAT - 10 CONTINUE - CALL DLACON( NN, DWORK( ITMP ), DWORK, IWORK, EST, KASE ) - IF( KASE.NE.0 ) THEN -C -C Select the triangular part of symmetric matrix to be used. -C - IF( DLANSY( '1-norm', 'Upper', N, DWORK, N, DWORK( ITMP ) ) - $ .GE. - $ DLANSY( '1-norm', 'Lower', N, DWORK, N, DWORK( ITMP ) ) - $ ) THEN - UPLOW = 'U' - LOWER = .FALSE. - ELSE - UPLOW = 'L' - LOWER = .TRUE. - END IF -C - IF( KASE.EQ.2 ) THEN - IJ = 0 - IF( LOWER ) THEN -C -C Scale the lower triangular part of symmetric matrix -C by the residual matrix. -C - DO 30 J = 1, N - DO 20 I = J, N - IJ = IJ + 1 - DWORK( IJ ) = DWORK( IJ )*R( I, J ) - 20 CONTINUE - IJ = IJ + J - 30 CONTINUE - ELSE -C -C Scale the upper triangular part of symmetric matrix -C by the residual matrix. -C - DO 50 J = 1, N - DO 40 I = 1, J - IJ = IJ + 1 - DWORK( IJ ) = DWORK( IJ )*R( I, J ) - 40 CONTINUE - IJ = IJ + N - J - 50 CONTINUE - END IF - END IF -C - IF( UPDATE ) THEN -C -C Transform the right-hand side: RHS := U'*RHS*U. -C - CALL MB01RU( UPLOW, 'Transpose', N, N, ZERO, ONE, DWORK, N, - $ U, LDU, DWORK, N, DWORK( ITMP ), NN, INFO2 ) - CALL DSCAL( N, HALF, DWORK, N+1 ) - END IF - CALL MA02ED( UPLOW, N, DWORK, N ) -C - IF( KASE.EQ.2 ) THEN -C -C Solve op(T)'*Y + Y*op(T) = scale*RHS. -C - CALL SB03MY( TRANA, N, T, LDT, DWORK, N, SCALE, INFO2 ) - ELSE -C -C Solve op(T)*W + W*op(T)' = scale*RHS. -C - CALL SB03MY( TRANAT, N, T, LDT, DWORK, N, SCALE, INFO2 ) - END IF -C - IF( INFO2.GT.0 ) - $ INFO = N + 1 -C - IF( UPDATE ) THEN -C -C Transform back to obtain the solution: Z := U*Z*U', with -C Z = Y or Z = W. -C - CALL MB01RU( UPLOW, 'No transpose', N, N, ZERO, ONE, DWORK, - $ N, U, LDU, DWORK, N, DWORK( ITMP ), NN, INFO2 ) - CALL DSCAL( N, HALF, DWORK, N+1 ) - END IF -C - IF( KASE.EQ.1 ) THEN - IJ = 0 - IF( LOWER ) THEN -C -C Scale the lower triangular part of symmetric matrix -C by the residual matrix. -C - DO 70 J = 1, N - DO 60 I = J, N - IJ = IJ + 1 - DWORK( IJ ) = DWORK( IJ )*R( I, J ) - 60 CONTINUE - IJ = IJ + J - 70 CONTINUE - ELSE -C -C Scale the upper triangular part of symmetric matrix -C by the residual matrix. -C - DO 90 J = 1, N - DO 80 I = 1, J - IJ = IJ + 1 - DWORK( IJ ) = DWORK( IJ )*R( I, J ) - 80 CONTINUE - IJ = IJ + N - J - 90 CONTINUE - END IF - END IF -C -C Fill in the remaining triangle of the symmetric matrix. -C - CALL MA02ED( UPLOW, N, DWORK, N ) - GO TO 10 - END IF -C -C UNTIL KASE = 0 -C -C Compute the estimate of the relative error. -C - TEMP = XANORM*SCALE - IF( TEMP.GT.EST ) THEN - FERR = EST / TEMP - ELSE - FERR = ONE - END IF -C - RETURN -C -C *** Last line of SB03QX *** - END diff --git a/mex/sources/libslicot/SB03QY.f b/mex/sources/libslicot/SB03QY.f deleted file mode 100644 index 63f41f5b8..000000000 --- a/mex/sources/libslicot/SB03QY.f +++ /dev/null @@ -1,443 +0,0 @@ - SUBROUTINE SB03QY( JOB, TRANA, LYAPUN, N, T, LDT, U, LDU, X, LDX, - $ SEP, THNORM, IWORK, DWORK, LDWORK, INFO ) -C -C SLICOT RELEASE 5.0. -C -C Copyright (c) 2002-2009 NICONET e.V. -C -C This program is free software: you can redistribute it and/or -C modify it under the terms of the GNU General Public License as -C published by the Free Software Foundation, either version 2 of -C the License, or (at your option) any later version. -C -C This program is distributed in the hope that it will be useful, -C but WITHOUT ANY WARRANTY; without even the implied warranty of -C MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the -C GNU General Public License for more details. -C -C You should have received a copy of the GNU General Public License -C along with this program. If not, see -C . -C -C PURPOSE -C -C To estimate the separation between the matrices op(A) and -op(A)', -C -C sep(op(A),-op(A)') = min norm(op(A)'*X + X*op(A))/norm(X) -C = 1 / norm(inv(Omega)) -C -C and/or the 1-norm of Theta, where op(A) = A or A' (A**T), and -C Omega and Theta are linear operators associated to the real -C continuous-time Lyapunov matrix equation -C -C op(A)'*X + X*op(A) = C, -C -C defined by -C -C Omega(W) = op(A)'*W + W*op(A), -C Theta(W) = inv(Omega(op(W)'*X + X*op(W))). -C -C The 1-norm condition estimators are used. -C -C ARGUMENTS -C -C Mode Parameters -C -C JOB CHARACTER*1 -C Specifies the computation to be performed, as follows: -C = 'S': Compute the separation only; -C = 'T': Compute the norm of Theta only; -C = 'B': Compute both the separation and the norm of Theta. -C -C TRANA CHARACTER*1 -C Specifies the form of op(A) to be used, as follows: -C = 'N': op(A) = A (No transpose); -C = 'T': op(A) = A**T (Transpose); -C = 'C': op(A) = A**T (Conjugate transpose = Transpose). -C -C LYAPUN CHARACTER*1 -C Specifies whether or not the original Lyapunov equations -C should be solved, as follows: -C = 'O': Solve the original Lyapunov equations, updating -C the right-hand sides and solutions with the -C matrix U, e.g., X <-- U'*X*U; -C = 'R': Solve reduced Lyapunov equations only, without -C updating the right-hand sides and solutions. -C -C Input/Output Parameters -C -C N (input) INTEGER -C The order of the matrices A and X. N >= 0. -C -C T (input) DOUBLE PRECISION array, dimension (LDT,N) -C The leading N-by-N upper Hessenberg part of this array -C must contain the upper quasi-triangular matrix T in Schur -C canonical form from a Schur factorization of A. -C -C LDT INTEGER -C The leading dimension of array T. LDT >= MAX(1,N). -C -C U (input) DOUBLE PRECISION array, dimension (LDU,N) -C The leading N-by-N part of this array must contain the -C orthogonal matrix U from a real Schur factorization of A. -C If LYAPUN = 'R', the array U is not referenced. -C -C LDU INTEGER -C The leading dimension of array U. -C LDU >= 1, if LYAPUN = 'R'; -C LDU >= MAX(1,N), if LYAPUN = 'O'. -C -C X (input) DOUBLE PRECISION array, dimension (LDX,N) -C The leading N-by-N part of this array must contain the -C solution matrix X of the Lyapunov equation (reduced -C Lyapunov equation if LYAPUN = 'R'). -C If JOB = 'S', the array X is not referenced. -C -C LDX INTEGER -C The leading dimension of array X. -C LDX >= 1, if JOB = 'S'; -C LDX >= MAX(1,N), if JOB = 'T' or 'B'. -C -C SEP (output) DOUBLE PRECISION -C If JOB = 'S' or JOB = 'B', and INFO >= 0, SEP contains the -C estimated separation of the matrices op(A) and -op(A)'. -C If JOB = 'T' or N = 0, SEP is not referenced. -C -C THNORM (output) DOUBLE PRECISION -C If JOB = 'T' or JOB = 'B', and INFO >= 0, THNORM contains -C the estimated 1-norm of operator Theta. -C If JOB = 'S' or N = 0, THNORM is not referenced. -C -C Workspace -C -C IWORK INTEGER array, dimension (N*N) -C -C DWORK DOUBLE PRECISION array, dimension (LDWORK) -C -C LDWORK INTEGER -C The length of the array DWORK. LDWORK >= 2*N*N. -C -C Error Indicator -C -C INFO INTEGER -C = 0: successful exit; -C < 0: if INFO = -i, the i-th argument had an illegal -C value; -C = N+1: if the matrices T and -T' have common or very -C close eigenvalues; perturbed values were used to -C solve Lyapunov equations (but the matrix T is -C unchanged). -C -C METHOD -C -C SEP is defined as the separation of op(A) and -op(A)': -C -C sep( op(A), -op(A)' ) = sigma_min( K ) -C -C where sigma_min(K) is the smallest singular value of the -C N*N-by-N*N matrix -C -C K = kprod( I(N), op(A)' ) + kprod( op(A)', I(N) ). -C -C I(N) is an N-by-N identity matrix, and kprod denotes the Kronecker -C product. The routine estimates sigma_min(K) by the reciprocal of -C an estimate of the 1-norm of inverse(K), computed as suggested in -C [1]. This involves the solution of several continuous-time -C Lyapunov equations, either direct or transposed. The true -C reciprocal 1-norm of inverse(K) cannot differ from sigma_min(K) by -C more than a factor of N. -C The 1-norm of Theta is estimated similarly. -C -C REFERENCES -C -C [1] Higham, N.J. -C FORTRAN codes for estimating the one-norm of a real or -C complex matrix, with applications to condition estimation. -C ACM Trans. Math. Softw., 14, pp. 381-396, 1988. -C -C NUMERICAL ASPECTS -C 3 -C The algorithm requires 0(N ) operations. -C -C FURTHER COMMENTS -C -C When SEP is zero, the routine returns immediately, with THNORM -C (if requested) not set. In this case, the equation is singular. -C The option LYAPUN = 'R' may occasionally produce slightly worse -C or better estimates, and it is much faster than the option 'O'. -C -C CONTRIBUTOR -C -C V. Sima, Research Institute for Informatics, Bucharest, Romania, -C Oct. 1998. Partly based on DGLSVX (and then SB03QD) by P. Petkov, -C Tech. University of Sofia, March 1998 (and December 1998). -C -C REVISIONS -C -C February 13, 1999, V. Sima, Katholieke Univ. Leuven, Belgium. -C V. Sima, Research Institute for Informatics, Bucharest, Oct. 2004. -C -C KEYWORDS -C -C Lyapunov equation, orthogonal transformation, real Schur form. -C -C ****************************************************************** -C -C .. Parameters .. - DOUBLE PRECISION ZERO, ONE, HALF - PARAMETER ( ZERO = 0.0D+0, ONE = 1.0D+0, HALF = 0.5D+0 ) -C .. -C .. Scalar Arguments .. - CHARACTER JOB, LYAPUN, TRANA - INTEGER INFO, LDT, LDU, LDWORK, LDX, N - DOUBLE PRECISION SEP, THNORM -C .. -C .. Array Arguments .. - INTEGER IWORK( * ) - DOUBLE PRECISION DWORK( * ), T( LDT, * ), U( LDU, * ), - $ X( LDX, * ) -C .. -C .. Local Scalars .. - LOGICAL NOTRNA, UPDATE, WANTS, WANTT - CHARACTER TRANAT, UPLO - INTEGER INFO2, ITMP, KASE, NN - DOUBLE PRECISION BIGNUM, EST, SCALE -C .. -C .. External Functions .. - LOGICAL LSAME - DOUBLE PRECISION DLAMCH, DLANSY - EXTERNAL DLAMCH, DLANSY, LSAME -C .. -C .. External Subroutines .. - EXTERNAL DLACON, DLACPY, DSCAL, DSYR2K, MA02ED, MB01RU, - $ SB03MY, XERBLA -C .. -C .. Intrinsic Functions .. - INTRINSIC MAX -C .. -C .. Executable Statements .. -C -C Decode and Test input parameters. -C - WANTS = LSAME( JOB, 'S' ) - WANTT = LSAME( JOB, 'T' ) - NOTRNA = LSAME( TRANA, 'N' ) - UPDATE = LSAME( LYAPUN, 'O' ) -C - NN = N*N - INFO = 0 - IF( .NOT. ( WANTS .OR. WANTT .OR. LSAME( JOB, 'B' ) ) ) THEN - INFO = -1 - ELSE IF( .NOT.( NOTRNA .OR. LSAME( TRANA, 'T' ) .OR. - $ LSAME( TRANA, 'C' ) ) ) THEN - INFO = -2 - ELSE IF( .NOT.( UPDATE .OR. LSAME( LYAPUN, 'R' ) ) ) THEN - INFO = -3 - ELSE IF( N.LT.0 ) THEN - INFO = -4 - ELSE IF( LDT.LT.MAX( 1, N ) ) THEN - INFO = -6 - ELSE IF( LDU.LT.1 .OR. ( UPDATE .AND. LDU.LT.N ) ) THEN - INFO = -8 - ELSE IF( LDX.LT.1 .OR. ( .NOT.WANTS .AND. LDX.LT.N ) ) THEN - INFO = -10 - ELSE IF( LDWORK.LT.2*NN ) THEN - INFO = -15 - END IF -C - IF( INFO.NE.0 ) THEN - CALL XERBLA( 'SB03QY', -INFO ) - RETURN - END IF -C -C Quick return if possible. -C - IF( N.EQ.0 ) - $ RETURN -C - ITMP = NN + 1 -C - IF( NOTRNA ) THEN - TRANAT = 'T' - ELSE - TRANAT = 'N' - END IF -C - IF( .NOT.WANTT ) THEN -C -C Estimate sep(op(A),-op(A)'). -C Workspace: 2*N*N. -C - KASE = 0 -C -C REPEAT - 10 CONTINUE - CALL DLACON( NN, DWORK( ITMP ), DWORK, IWORK, EST, KASE ) - IF( KASE.NE.0 ) THEN -C -C Select the triangular part of symmetric matrix to be used. -C - IF( DLANSY( '1-norm', 'Upper', N, DWORK, N, DWORK( ITMP ) ) - $ .GE. - $ DLANSY( '1-norm', 'Lower', N, DWORK, N, DWORK( ITMP ) ) - $ ) THEN - UPLO = 'U' - ELSE - UPLO = 'L' - END IF -C - IF( UPDATE ) THEN -C -C Transform the right-hand side: RHS := U'*RHS*U. -C - CALL MB01RU( UPLO, 'Transpose', N, N, ZERO, ONE, DWORK, - $ N, U, LDU, DWORK, N, DWORK( ITMP ), NN, - $ INFO2 ) - CALL DSCAL( N, HALF, DWORK, N+1 ) - END IF - CALL MA02ED( UPLO, N, DWORK, N ) -C - IF( KASE.EQ.1 ) THEN -C -C Solve op(T)'*Y + Y*op(T) = scale*RHS. -C - CALL SB03MY( TRANA, N, T, LDT, DWORK, N, SCALE, INFO2 ) - ELSE -C -C Solve op(T)*W + W*op(T)' = scale*RHS. -C - CALL SB03MY( TRANAT, N, T, LDT, DWORK, N, SCALE, INFO2 ) - END IF -C - IF( INFO2.GT.0 ) - $ INFO = N + 1 -C - IF( UPDATE ) THEN -C -C Transform back to obtain the solution: Z := U*Z*U', with -C Z = Y or Z = W. -C - CALL MB01RU( UPLO, 'No transpose', N, N, ZERO, ONE, - $ DWORK, N, U, LDU, DWORK, N, DWORK( ITMP ), - $ NN, INFO2 ) - CALL DSCAL( N, HALF, DWORK, N+1 ) -C -C Fill in the remaining triangle of the symmetric matrix. -C - CALL MA02ED( UPLO, N, DWORK, N ) - END IF -C - GO TO 10 - END IF -C UNTIL KASE = 0 -C - IF( EST.GT.SCALE ) THEN - SEP = SCALE / EST - ELSE - BIGNUM = ONE / DLAMCH( 'Safe minimum' ) - IF( SCALE.LT.EST*BIGNUM ) THEN - SEP = SCALE / EST - ELSE - SEP = BIGNUM - END IF - END IF -C -C Return if the equation is singular. -C - IF( SEP.EQ.ZERO ) - $ RETURN - END IF -C - IF( .NOT.WANTS ) THEN -C -C Estimate norm(Theta). -C Workspace: 2*N*N. -C - KASE = 0 -C -C REPEAT - 20 CONTINUE - CALL DLACON( NN, DWORK( ITMP ), DWORK, IWORK, EST, KASE ) - IF( KASE.NE.0 ) THEN -C -C Select the triangular part of symmetric matrix to be used. -C - IF( DLANSY( '1-norm', 'Upper', N, DWORK, N, DWORK( ITMP ) ) - $ .GE. - $ DLANSY( '1-norm', 'Lower', N, DWORK, N, DWORK( ITMP ) ) - $ ) THEN - UPLO = 'U' - ELSE - UPLO = 'L' - END IF -C -C Fill in the remaining triangle of the symmetric matrix. -C - CALL MA02ED( UPLO, N, DWORK, N ) -C -C Compute RHS = op(W)'*X + X*op(W). -C - CALL DSYR2K( UPLO, TRANAT, N, N, ONE, DWORK, N, X, LDX, - $ ZERO, DWORK( ITMP ), N ) - CALL DLACPY( UPLO, N, N, DWORK( ITMP ), N, DWORK, N ) -C - IF( UPDATE ) THEN -C -C Transform the right-hand side: RHS := U'*RHS*U. -C - CALL MB01RU( UPLO, 'Transpose', N, N, ZERO, ONE, DWORK, - $ N, U, LDU, DWORK, N, DWORK( ITMP ), NN, - $ INFO2 ) - CALL DSCAL( N, HALF, DWORK, N+1 ) - END IF - CALL MA02ED( UPLO, N, DWORK, N ) -C - IF( KASE.EQ.1 ) THEN -C -C Solve op(T)'*Y + Y*op(T) = scale*RHS. -C - CALL SB03MY( TRANA, N, T, LDT, DWORK, N, SCALE, INFO2 ) - ELSE -C -C Solve op(T)*W + W*op(T)' = scale*RHS. -C - CALL SB03MY( TRANAT, N, T, LDT, DWORK, N, SCALE, INFO2 ) - END IF -C - IF( INFO2.GT.0 ) - $ INFO = N + 1 -C - IF( UPDATE ) THEN -C -C Transform back to obtain the solution: Z := U*Z*U', with -C Z = Y or Z = W. -C - CALL MB01RU( UPLO, 'No transpose', N, N, ZERO, ONE, - $ DWORK, N, U, LDU, DWORK, N, DWORK( ITMP ), - $ NN, INFO2 ) - CALL DSCAL( N, HALF, DWORK, N+1 ) -C -C Fill in the remaining triangle of the symmetric matrix. -C - CALL MA02ED( UPLO, N, DWORK, N ) - END IF -C - GO TO 20 - END IF -C UNTIL KASE = 0 -C - IF( EST.LT.SCALE ) THEN - THNORM = EST / SCALE - ELSE - BIGNUM = ONE / DLAMCH( 'Safe minimum' ) - IF( EST.LT.SCALE*BIGNUM ) THEN - THNORM = EST / SCALE - ELSE - THNORM = BIGNUM - END IF - END IF - END IF -C - RETURN -C *** Last line of SB03QY *** - END diff --git a/mex/sources/libslicot/SB03RD.f b/mex/sources/libslicot/SB03RD.f deleted file mode 100644 index 0398a3abc..000000000 --- a/mex/sources/libslicot/SB03RD.f +++ /dev/null @@ -1,404 +0,0 @@ - SUBROUTINE SB03RD( JOB, FACT, TRANA, N, A, LDA, U, LDU, C, LDC, - $ SCALE, SEP, FERR, WR, WI, IWORK, DWORK, - $ LDWORK, INFO ) -C -C SLICOT RELEASE 5.0. -C -C Copyright (c) 2002-2009 NICONET e.V. -C -C This program is free software: you can redistribute it and/or -C modify it under the terms of the GNU General Public License as -C published by the Free Software Foundation, either version 2 of -C the License, or (at your option) any later version. -C -C This program is distributed in the hope that it will be useful, -C but WITHOUT ANY WARRANTY; without even the implied warranty of -C MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the -C GNU General Public License for more details. -C -C You should have received a copy of the GNU General Public License -C along with this program. If not, see -C . -C -C PURPOSE -C -C To solve the real Lyapunov matrix equation -C -C op(A)'*X + X*op(A) = scale*C -C -C and/or estimate the separation between the matrices op(A) and -C -op(A)', where op(A) = A or A' (A**T) and C is symmetric (C = C'). -C (A' denotes the transpose of the matrix A.) A is N-by-N, the right -C hand side C and the solution X are N-by-N, and scale is an output -C scale factor, set less than or equal to 1 to avoid overflow in X. -C -C ARGUMENTS -C -C Mode Parameters -C -C JOB CHARACTER*1 -C Specifies the computation to be performed, as follows: -C = 'X': Compute the solution only; -C = 'S': Compute the separation only; -C = 'B': Compute both the solution and the separation. -C -C FACT CHARACTER*1 -C Specifies whether or not the real Schur factorization -C of the matrix A is supplied on entry, as follows: -C = 'F': On entry, A and U contain the factors from the -C real Schur factorization of the matrix A; -C = 'N': The Schur factorization of A will be computed -C and the factors will be stored in A and U. -C -C TRANA CHARACTER*1 -C Specifies the form of op(A) to be used, as follows: -C = 'N': op(A) = A (No transpose); -C = 'T': op(A) = A**T (Transpose); -C = 'C': op(A) = A**T (Conjugate transpose = Transpose). -C -C Input/Output Parameters -C -C N (input) INTEGER -C The order of the matrices A, X, and C. N >= 0. -C -C A (input/output) DOUBLE PRECISION array, dimension (LDA,N) -C On entry, the leading N-by-N part of this array must -C contain the matrix A. If FACT = 'F', then A contains -C an upper quasi-triangular matrix in Schur canonical form. -C On exit, if INFO = 0 or INFO = N+1, the leading N-by-N -C part of this array contains the upper quasi-triangular -C matrix in Schur canonical form from the Shur factorization -C of A. The contents of array A is not modified if -C FACT = 'F'. -C -C LDA INTEGER -C The leading dimension of array A. LDA >= MAX(1,N). -C -C U (input or output) DOUBLE PRECISION array, dimension -C (LDU,N) -C If FACT = 'F', then U is an input argument and on entry -C it must contain the orthogonal matrix U from the real -C Schur factorization of A. -C If FACT = 'N', then U is an output argument and on exit, -C if INFO = 0 or INFO = N+1, it contains the orthogonal -C N-by-N matrix from the real Schur factorization of A. -C -C LDU INTEGER -C The leading dimension of array U. LDU >= MAX(1,N). -C -C C (input/output) DOUBLE PRECISION array, dimension (LDC,N) -C On entry with JOB = 'X' or 'B', the leading N-by-N part of -C this array must contain the symmetric matrix C. -C On exit with JOB = 'X' or 'B', if INFO = 0 or INFO = N+1, -C the leading N-by-N part of C has been overwritten by the -C symmetric solution matrix X. -C If JOB = 'S', C is not referenced. -C -C LDC INTEGER -C The leading dimension of array C. -C LDC >= 1, if JOB = 'S'; -C LDC >= MAX(1,N), otherwise. -C -C SCALE (output) DOUBLE PRECISION -C The scale factor, scale, set less than or equal to 1 to -C prevent the solution overflowing. -C -C SEP (output) DOUBLE PRECISION -C If JOB = 'S' or JOB = 'B', and INFO = 0 or INFO = N+1, SEP -C contains the estimated separation of the matrices op(A) -C and -op(A)'. -C If JOB = 'X' or N = 0, SEP is not referenced. -C -C FERR (output) DOUBLE PRECISION -C If JOB = 'B', and INFO = 0 or INFO = N+1, FERR contains -C an estimated forward error bound for the solution X. -C If XTRUE is the true solution, FERR bounds the relative -C error in the computed solution, measured in the Frobenius -C norm: norm(X - XTRUE)/norm(XTRUE). -C If JOB = 'X' or JOB = 'S', FERR is not referenced. -C -C WR (output) DOUBLE PRECISION array, dimension (N) -C WI (output) DOUBLE PRECISION array, dimension (N) -C If FACT = 'N', and INFO = 0 or INFO = N+1, WR and WI -C contain the real and imaginary parts, respectively, of the -C eigenvalues of A. -C If FACT = 'F', WR and WI are not referenced. -C -C Workspace -C -C IWORK INTEGER array, dimension (N*N) -C This array is not referenced if JOB = 'X'. -C -C DWORK DOUBLE PRECISION array, dimension (LDWORK) -C On exit, if INFO = 0 or INFO = N+1, DWORK(1) returns the -C optimal value of LDWORK. -C -C LDWORK INTEGER -C The length of the array DWORK. LDWORK >= 1 and -C If JOB = 'X' then -C If FACT = 'F', LDWORK >= N*N; -C If FACT = 'N', LDWORK >= MAX(N*N,3*N). -C If JOB = 'S' or JOB = 'B' then -C If FACT = 'F', LDWORK >= 2*N*N; -C If FACT = 'N', LDWORK >= MAX(2*N*N,3*N). -C For optimum performance LDWORK should be larger. -C -C Error Indicator -C -C INFO INTEGER -C = 0: successful exit; -C < 0: if INFO = -i, the i-th argument had an illegal -C value; -C > 0: if INFO = i, the QR algorithm failed to compute all -C the eigenvalues (see LAPACK Library routine DGEES); -C elements i+1:n of WR and WI contain eigenvalues -C which have converged, and A contains the partially -C converged Schur form; -C = N+1: if the matrices A and -A' have common or very -C close eigenvalues; perturbed values were used to -C solve the equation (but the matrix A is unchanged). -C -C METHOD -C -C After reducing matrix A to real Schur canonical form (if needed), -C the Bartels-Stewart algorithm is used. A set of equivalent linear -C algebraic systems of equations of order at most four are formed -C and solved using Gaussian elimination with complete pivoting. -C -C REFERENCES -C -C [1] Bartels, R.H. and Stewart, G.W. T -C Solution of the matrix equation A X + XB = C. -C Comm. A.C.M., 15, pp. 820-826, 1972. -C -C NUMERICAL ASPECTS -C 3 -C The algorithm requires 0(N ) operations. -C -C FURTHER COMMENTS -C -C SEP is defined as the separation of op(A) and -op(A)': -C -C sep( op(A), -op(A)' ) = sigma_min( T ) -C -C where sigma_min(T) is the smallest singular value of the -C N*N-by-N*N matrix -C -C T = kprod( I(N), op(A)' ) + kprod( op(A), I(N) ). -C -C I(N) is an N-by-N identity matrix, and kprod denotes the Kronecker -C product. The program estimates sigma_min(T) by the reciprocal of -C an estimate of the 1-norm of inverse(T). The true reciprocal -C 1-norm of inverse(T) cannot differ from sigma_min(T) by more -C than a factor of N. -C -C When SEP is small, small changes in A, C can cause large changes -C in the solution of the equation. An approximate bound on the -C maximum relative error in the computed solution is -C -C EPS * norm(A) / SEP -C -C where EPS is the machine precision. -C -C CONTRIBUTOR -C -C Release 3.0: V. Sima, Katholieke Univ. Leuven, Belgium, May 1997. -C Supersedes Release 2.0 routine MB03AD by Control Systems Research -C Group, Kingston Polytechnic, United Kingdom, October 1982. -C Based on DGELYP by P. Petkov, Tech. University of Sofia, September -C 1993. -C -C REVISIONS -C -C V. Sima, Katholieke Univ. Leuven, Belgium, May 1999. -C -C KEYWORDS -C -C Lyapunov equation, orthogonal transformation, real Schur form. -C -C ****************************************************************** -C -C .. Parameters .. - DOUBLE PRECISION ZERO, ONE - PARAMETER ( ZERO = 0.0D+0, ONE = 1.0D+0 ) -C .. -C .. Scalar Arguments .. - CHARACTER FACT, JOB, TRANA - INTEGER INFO, LDA, LDC, LDU, LDWORK, N - DOUBLE PRECISION FERR, SCALE, SEP -C .. -C .. Array Arguments .. - INTEGER IWORK( * ) - DOUBLE PRECISION A( LDA, * ), C( LDC, * ), DWORK( * ), - $ U( LDU, * ), WI( * ), WR( * ) -C .. -C .. Local Scalars .. - LOGICAL NOFACT, NOTA, WANTBH, WANTSP, WANTX - CHARACTER NOTRA, UPLO - INTEGER I, IERR, KASE, LWA, MINWRK, SDIM - DOUBLE PRECISION EST, SCALEF -C .. -C .. Local Arrays .. - LOGICAL BWORK( 1 ) -C .. -C .. External Functions .. - LOGICAL LSAME, SELECT - DOUBLE PRECISION DLAMCH, DLANHS - EXTERNAL DLAMCH, DLANHS, LSAME, SELECT -C .. -C .. External Subroutines .. - EXTERNAL DCOPY, DGEES, DLACON, MB01RD, SB03MY, XERBLA -C .. -C .. Intrinsic Functions .. - INTRINSIC DBLE, INT, MAX -C .. -C .. Executable Statements .. -C -C Decode and Test input parameters. -C - WANTX = LSAME( JOB, 'X' ) - WANTSP = LSAME( JOB, 'S' ) - WANTBH = LSAME( JOB, 'B' ) - NOFACT = LSAME( FACT, 'N' ) - NOTA = LSAME( TRANA, 'N' ) -C - INFO = 0 - IF( .NOT.WANTSP .AND. .NOT.WANTBH .AND. .NOT.WANTX ) THEN - INFO = -1 - ELSE IF( .NOT.NOFACT .AND. .NOT.LSAME( FACT, 'F' ) ) THEN - INFO = -2 - ELSE IF( .NOT.NOTA .AND. .NOT.LSAME( TRANA, 'T' ) .AND. - $ .NOT.LSAME( TRANA, 'C' ) ) THEN - INFO = -3 - ELSE IF( N.LT.0 ) THEN - INFO = -4 - ELSE IF( LDA.LT.MAX( 1, N ) ) THEN - INFO = -6 - ELSE IF( LDU.LT.MAX( 1, N ) ) THEN - INFO = -8 - ELSE IF( WANTSP .AND. LDC.LT.1 .OR. - $ .NOT.WANTSP .AND. LDC.LT.MAX( 1, N ) ) THEN - INFO = -10 - END IF -C -C Compute workspace. -C - IF( WANTX ) THEN - IF( NOFACT ) THEN - MINWRK = MAX( N*N, 3*N ) - ELSE - MINWRK = N*N - END IF - ELSE - IF( NOFACT ) THEN - MINWRK = MAX( 2*N*N, 3*N ) - ELSE - MINWRK = 2*N*N - END IF - END IF - IF( LDWORK.LT.MAX( 1, MINWRK ) ) THEN - INFO = -18 - END IF -C - IF( INFO.NE.0 ) THEN - CALL XERBLA( 'SB03RD', -INFO ) - RETURN - END IF -C -C Quick return if possible. -C - IF( N.EQ.0 ) THEN - SCALE = ONE - IF( WANTBH ) - $ FERR = ZERO - DWORK(1) = ONE - RETURN - END IF -C - LWA = 0 -C - IF( NOFACT ) THEN -C -C Compute the Schur factorization of A. -C Workspace: need 3*N; -C prefer larger. -C - CALL DGEES( 'Vectors', 'Not ordered', SELECT, N, A, LDA, SDIM, - $ WR, WI, U, LDU, DWORK, LDWORK, BWORK, INFO ) - IF( INFO.GT.0 ) - $ RETURN - LWA = INT( DWORK( 1 ) ) - END IF -C - IF( .NOT.WANTSP ) THEN -C -C Transform the right-hand side. -C Workspace: need N*N. -C - UPLO = 'U' - CALL MB01RD( UPLO, 'Transpose', N, N, ZERO, ONE, C, LDC, U, - $ LDU, C, LDC, DWORK, LDWORK, INFO ) -C - DO 10 I = 2, N - CALL DCOPY( I-1, C(1,I), 1, C(I,1), LDC ) - 10 CONTINUE -C -C Solve the transformed equation. -C - CALL SB03MY( TRANA, N, A, LDA, C, LDC, SCALE, INFO ) - IF( INFO.GT.0 ) - $ INFO = N + 1 -C -C Transform back the solution. -C - CALL MB01RD( UPLO, 'No transpose', N, N, ZERO, ONE, C, LDC, U, - $ LDU, C, LDC, DWORK, LDWORK, INFO ) -C - DO 20 I = 2, N - CALL DCOPY( I-1, C(1,I), 1, C(I,1), LDC ) - 20 CONTINUE -C - END IF -C - IF( .NOT.WANTX ) THEN -C -C Estimate sep(op(A),-op(A)'). -C Workspace: 2*N*N. -C - IF( NOTA ) THEN - NOTRA = 'T' - ELSE - NOTRA = 'N' - END IF -C - EST = ZERO - KASE = 0 -C REPEAT - 30 CONTINUE - CALL DLACON( N*N, DWORK( N*N+1 ), DWORK, IWORK, EST, KASE ) - IF( KASE.NE.0 ) THEN - IF( KASE.EQ.1 ) THEN - CALL SB03MY( TRANA, N, A, LDA, DWORK, N, SCALEF, IERR ) - ELSE - CALL SB03MY( NOTRA, N, A, LDA, DWORK, N, SCALEF, IERR ) - END IF - GO TO 30 - END IF -C UNTIL KASE = 0 -C - SEP = SCALEF / EST -C - IF( WANTBH ) THEN -C -C Compute the estimate of the relative error. -C - FERR = DLAMCH( 'Precision' )* - $ DLANHS( 'Frobenius', N, A, LDA, DWORK ) / SEP - END IF - END IF -C - DWORK( 1 ) = DBLE( MAX( LWA, MINWRK ) ) -C - RETURN -C *** Last line of SB03RD *** - END diff --git a/mex/sources/libslicot/SB03SD.f b/mex/sources/libslicot/SB03SD.f deleted file mode 100644 index bcf122954..000000000 --- a/mex/sources/libslicot/SB03SD.f +++ /dev/null @@ -1,674 +0,0 @@ - SUBROUTINE SB03SD( JOB, FACT, TRANA, UPLO, LYAPUN, N, SCALE, A, - $ LDA, T, LDT, U, LDU, C, LDC, X, LDX, SEPD, - $ RCOND, FERR, IWORK, DWORK, LDWORK, INFO ) -C -C SLICOT RELEASE 5.0. -C -C Copyright (c) 2002-2009 NICONET e.V. -C -C This program is free software: you can redistribute it and/or -C modify it under the terms of the GNU General Public License as -C published by the Free Software Foundation, either version 2 of -C the License, or (at your option) any later version. -C -C This program is distributed in the hope that it will be useful, -C but WITHOUT ANY WARRANTY; without even the implied warranty of -C MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the -C GNU General Public License for more details. -C -C You should have received a copy of the GNU General Public License -C along with this program. If not, see -C . -C -C PURPOSE -C -C To estimate the conditioning and compute an error bound on the -C solution of the real discrete-time Lyapunov matrix equation -C -C op(A)'*X*op(A) - X = scale*C -C -C where op(A) = A or A' (A**T) and C is symmetric (C = C**T). The -C matrix A is N-by-N, the right hand side C and the solution X are -C N-by-N symmetric matrices, and scale is a given scale factor. -C -C ARGUMENTS -C -C Mode Parameters -C -C JOB CHARACTER*1 -C Specifies the computation to be performed, as follows: -C = 'C': Compute the reciprocal condition number only; -C = 'E': Compute the error bound only; -C = 'B': Compute both the reciprocal condition number and -C the error bound. -C -C FACT CHARACTER*1 -C Specifies whether or not the real Schur factorization -C of the matrix A is supplied on entry, as follows: -C = 'F': On entry, T and U (if LYAPUN = 'O') contain the -C factors from the real Schur factorization of the -C matrix A; -C = 'N': The Schur factorization of A will be computed -C and the factors will be stored in T and U (if -C LYAPUN = 'O'). -C -C TRANA CHARACTER*1 -C Specifies the form of op(A) to be used, as follows: -C = 'N': op(A) = A (No transpose); -C = 'T': op(A) = A**T (Transpose); -C = 'C': op(A) = A**T (Conjugate transpose = Transpose). -C -C UPLO CHARACTER*1 -C Specifies which part of the symmetric matrix C is to be -C used, as follows: -C = 'U': Upper triangular part; -C = 'L': Lower triangular part. -C -C LYAPUN CHARACTER*1 -C Specifies whether or not the original Lyapunov equations -C should be solved in the iterative estimation process, -C as follows: -C = 'O': Solve the original Lyapunov equations, updating -C the right-hand sides and solutions with the -C matrix U, e.g., X <-- U'*X*U; -C = 'R': Solve reduced Lyapunov equations only, without -C updating the right-hand sides and solutions. -C -C Input/Output Parameters -C -C N (input) INTEGER -C The order of the matrices A, X and C. N >= 0. -C -C SCALE (input) DOUBLE PRECISION -C The scale factor, scale, set by a Lyapunov solver. -C 0 <= SCALE <= 1. -C -C A (input) DOUBLE PRECISION array, dimension (LDA,N) -C If FACT = 'N' or LYAPUN = 'O', the leading N-by-N part of -C this array must contain the original matrix A. -C If FACT = 'F' and LYAPUN = 'R', A is not referenced. -C -C LDA INTEGER -C The leading dimension of the array A. -C LDA >= MAX(1,N), if FACT = 'N' or LYAPUN = 'O'; -C LDA >= 1, if FACT = 'F' and LYAPUN = 'R'. -C -C T (input/output) DOUBLE PRECISION array, dimension -C (LDT,N) -C If FACT = 'F', then on entry the leading N-by-N upper -C Hessenberg part of this array must contain the upper -C quasi-triangular matrix T in Schur canonical form from a -C Schur factorization of A. -C If FACT = 'N', then this array need not be set on input. -C On exit, (if INFO = 0 or INFO = N+1, for FACT = 'N') the -C leading N-by-N upper Hessenberg part of this array -C contains the upper quasi-triangular matrix T in Schur -C canonical form from a Schur factorization of A. -C -C LDT INTEGER -C The leading dimension of the array T. LDT >= MAX(1,N). -C -C U (input or output) DOUBLE PRECISION array, dimension -C (LDU,N) -C If LYAPUN = 'O' and FACT = 'F', then U is an input -C argument and on entry, the leading N-by-N part of this -C array must contain the orthogonal matrix U from a real -C Schur factorization of A. -C If LYAPUN = 'O' and FACT = 'N', then U is an output -C argument and on exit, if INFO = 0 or INFO = N+1, it -C contains the orthogonal N-by-N matrix from a real Schur -C factorization of A. -C If LYAPUN = 'R', the array U is not referenced. -C -C LDU INTEGER -C The leading dimension of the array U. -C LDU >= 1, if LYAPUN = 'R'; -C LDU >= MAX(1,N), if LYAPUN = 'O'. -C -C C (input) DOUBLE PRECISION array, dimension (LDC,N) -C If UPLO = 'U', the leading N-by-N upper triangular part of -C this array must contain the upper triangular part of the -C matrix C of the original Lyapunov equation (with -C matrix A), if LYAPUN = 'O', or of the reduced Lyapunov -C equation (with matrix T), if LYAPUN = 'R'. -C If UPLO = 'L', the leading N-by-N lower triangular part of -C this array must contain the lower triangular part of the -C matrix C of the original Lyapunov equation (with -C matrix A), if LYAPUN = 'O', or of the reduced Lyapunov -C equation (with matrix T), if LYAPUN = 'R'. -C -C LDC INTEGER -C The leading dimension of the array C. LDC >= MAX(1,N). -C -C X (input) DOUBLE PRECISION array, dimension (LDX,N) -C The leading N-by-N part of this array must contain the -C symmetric solution matrix X of the original Lyapunov -C equation (with matrix A), if LYAPUN = 'O', or of the -C reduced Lyapunov equation (with matrix T), if -C LYAPUN = 'R'. -C The array X is modified internally, but restored on exit. -C -C LDX INTEGER -C The leading dimension of the array X. LDX >= MAX(1,N). -C -C SEPD (output) DOUBLE PRECISION -C If JOB = 'C' or JOB = 'B', the estimated quantity -C sepd(op(A),op(A)'). -C If N = 0, or X = 0, or JOB = 'E', SEPD is not referenced. -C -C RCOND (output) DOUBLE PRECISION -C If JOB = 'C' or JOB = 'B', an estimate of the reciprocal -C condition number of the discrete-time Lyapunov equation. -C If N = 0 or X = 0, RCOND is set to 1 or 0, respectively. -C If JOB = 'E', RCOND is not referenced. -C -C FERR (output) DOUBLE PRECISION -C If JOB = 'E' or JOB = 'B', an estimated forward error -C bound for the solution X. If XTRUE is the true solution, -C FERR bounds the magnitude of the largest entry in -C (X - XTRUE) divided by the magnitude of the largest entry -C in X. -C If N = 0 or X = 0, FERR is set to 0. -C If JOB = 'C', FERR is not referenced. -C -C Workspace -C -C IWORK INTEGER array, dimension (N*N) -C -C DWORK DOUBLE PRECISION array, dimension (LDWORK) -C On exit, if INFO = 0 or INFO = N+1, DWORK(1) returns the -C optimal value of LDWORK. -C -C LDWORK INTEGER -C The dimension of the array DWORK. -C LDWORK >= 1, if N = 0; else, -C LDWORK >= MAX(3,2*N*N) + N*N, if JOB = 'C', -C FACT = 'F'; -C LDWORK >= MAX(MAX(3,2*N*N) + N*N, 5*N), if JOB = 'C', -C FACT = 'N'; -C LDWORK >= MAX(3,2*N*N) + N*N + 2*N, if JOB = 'E', or -C JOB = 'B'. -C For optimum performance LDWORK should sometimes be larger. -C -C Error Indicator -C -C INFO INTEGER -C = 0: successful exit; -C < 0: if INFO = -i, the i-th argument had an illegal -C value; -C > 0: if INFO = i, i <= N, the QR algorithm failed to -C complete the reduction to Schur canonical form (see -C LAPACK Library routine DGEES); on exit, the matrix -C T(i+1:N,i+1:N) contains the partially converged -C Schur form, and DWORK(i+1:N) and DWORK(N+i+1:2*N) -C contain the real and imaginary parts, respectively, -C of the converged eigenvalues; this error is unlikely -C to appear; -C = N+1: if the matrix T has almost reciprocal eigenvalues; -C perturbed values were used to solve Lyapunov -C equations, but the matrix T, if given (for -C FACT = 'F'), is unchanged. -C -C METHOD -C -C The condition number of the discrete-time Lyapunov equation is -C estimated as -C -C cond = (norm(Theta)*norm(A) + norm(inv(Omega))*norm(C))/norm(X), -C -C where Omega and Theta are linear operators defined by -C -C Omega(W) = op(A)'*W*op(A) - W, -C Theta(W) = inv(Omega(op(W)'*X*op(A) + op(A)'*X*op(W))). -C -C The routine estimates the quantities -C -C sepd(op(A),op(A)') = 1 / norm(inv(Omega)) -C -C and norm(Theta) using 1-norm condition estimators. -C -C The forward error bound is estimated using a practical error bound -C similar to the one proposed in [1]. -C -C REFERENCES -C -C [1] Higham, N.J. -C Perturbation theory and backward error for AX-XB=C. -C BIT, vol. 33, pp. 124-136, 1993. -C -C NUMERICAL ASPECTS -C 3 -C The algorithm requires 0(N ) operations. -C The accuracy of the estimates obtained depends on the solution -C accuracy and on the properties of the 1-norm estimator. -C -C FURTHER COMMENTS -C -C The option LYAPUN = 'R' may occasionally produce slightly worse -C or better estimates, and it is much faster than the option 'O'. -C When SEPD is computed and it is zero, the routine returns -C immediately, with RCOND and FERR (if requested) set to 0 and 1, -C respectively. In this case, the equation is singular. -C -C CONTRIBUTORS -C -C P. Petkov, Tech. University of Sofia, December 1998. -C V. Sima, Katholieke Univ. Leuven, Belgium, February 1999. -C -C REVISIONS -C -C V. Sima, Katholieke Univ. Leuven, Belgium, March 2003. -C -C KEYWORDS -C -C Lyapunov equation, orthogonal transformation, real Schur form. -C -C ****************************************************************** -C -C .. Parameters .. - DOUBLE PRECISION ZERO, ONE, THREE - PARAMETER ( ZERO = 0.0D+0, ONE = 1.0D+0, THREE = 3.0D0 ) -C .. -C .. Scalar Arguments .. - CHARACTER FACT, JOB, LYAPUN, TRANA, UPLO - INTEGER INFO, LDA, LDC, LDT, LDU, LDWORK, LDX, N - DOUBLE PRECISION FERR, RCOND, SCALE, SEPD -C .. -C .. Array Arguments .. - INTEGER IWORK( * ) - DOUBLE PRECISION A( LDA, * ), C( LDC, * ), DWORK( * ), - $ T( LDT, * ), U( LDU, * ), X( LDX, * ) -C .. -C .. Local Scalars .. - LOGICAL JOBB, JOBC, JOBE, LOWER, NOFACT, NOTRNA, - $ UPDATE - CHARACTER SJOB, TRANAT - INTEGER I, IABS, IRES, IWRK, IXMA, J, LDW, NN, SDIM, - $ WRKOPT - DOUBLE PRECISION ANORM, CNORM, DENOM, EPS, EPSN, TEMP, THNORM, - $ TMAX, XANORM, XNORM -C .. -C .. Local Arrays .. - LOGICAL BWORK( 1 ) -C .. -C .. External Functions .. - LOGICAL LSAME, SELECT - DOUBLE PRECISION DLAMCH, DLANGE, DLANHS, DLANSY - EXTERNAL DLAMCH, DLANGE, DLANHS, DLANSY, LSAME, SELECT -C .. -C .. External Subroutines .. - EXTERNAL DAXPY, DCOPY, DGEES, DGEMM, DLACPY, DLASET, - $ MA02ED, MB01RU, MB01RX, MB01RY, MB01UD, SB03SX, - $ SB03SY, XERBLA -C .. -C .. Intrinsic Functions .. - INTRINSIC ABS, DBLE, INT, MAX, MIN -C .. -C .. Executable Statements .. -C -C Decode and Test input parameters. -C - JOBC = LSAME( JOB, 'C' ) - JOBE = LSAME( JOB, 'E' ) - JOBB = LSAME( JOB, 'B' ) - NOFACT = LSAME( FACT, 'N' ) - NOTRNA = LSAME( TRANA, 'N' ) - LOWER = LSAME( UPLO, 'L' ) - UPDATE = LSAME( LYAPUN, 'O' ) -C - NN = N*N - LDW = MAX( 3, 2*NN ) + NN -C - INFO = 0 - IF( .NOT.( JOBB .OR. JOBC .OR. JOBE ) ) THEN - INFO = -1 - ELSE IF( .NOT.( NOFACT .OR. LSAME( FACT, 'F' ) ) ) THEN - INFO = -2 - ELSE IF( .NOT.( NOTRNA .OR. LSAME( TRANA, 'T' ) .OR. - $ LSAME( TRANA, 'C' ) ) ) THEN - INFO = -3 - ELSE IF( .NOT.( LOWER .OR. LSAME( UPLO, 'U' ) ) ) THEN - INFO = -4 - ELSE IF( .NOT.( UPDATE .OR. LSAME( LYAPUN, 'R' ) ) ) THEN - INFO = -5 - ELSE IF( N.LT.0 ) THEN - INFO = -6 - ELSE IF( SCALE.LT.ZERO .OR. SCALE.GT.ONE ) THEN - INFO = -7 - ELSE IF( LDA.LT.1 .OR. - $ ( LDA.LT.N .AND. ( UPDATE .OR. NOFACT ) ) ) THEN - INFO = -9 - ELSE IF( LDT.LT.MAX( 1, N ) ) THEN - INFO = -11 - ELSE IF( LDU.LT.1 .OR. ( LDU.LT.N .AND. UPDATE ) ) THEN - INFO = -13 - ELSE IF( LDC.LT.MAX( 1, N ) ) THEN - INFO = -15 - ELSE IF( LDX.LT.MAX( 1, N ) ) THEN - INFO = -17 - ELSE IF( LDWORK.LT.1 .OR. - $ ( LDWORK.LT.LDW .AND. JOBC .AND. .NOT.NOFACT ) .OR. - $ ( LDWORK.LT.MAX( LDW, 5*N ) .AND. JOBC .AND. NOFACT ) .OR. - $ ( LDWORK.LT.( LDW + 2*N ) .AND. .NOT.JOBC ) ) THEN - INFO = -23 - END IF -C - IF( INFO.NE.0 ) THEN - CALL XERBLA( 'SB03SD', -INFO ) - RETURN - END IF -C -C Quick return if possible. -C - IF( N.EQ.0 ) THEN - IF( .NOT.JOBE ) - $ RCOND = ONE - IF( .NOT.JOBC ) - $ FERR = ZERO - DWORK( 1 ) = ONE - RETURN - END IF -C -C Compute the 1-norm of the matrix X. -C - XNORM = DLANSY( '1-norm', UPLO, N, X, LDX, DWORK ) - IF( XNORM.EQ.ZERO ) THEN -C -C The solution is zero. -C - IF( .NOT.JOBE ) - $ RCOND = ZERO - IF( .NOT.JOBC ) - $ FERR = ZERO - DWORK( 1 ) = DBLE( N ) - RETURN - END IF -C -C Compute the 1-norm of A or T. -C - IF( NOFACT .OR. UPDATE ) THEN - ANORM = DLANGE( '1-norm', N, N, A, LDA, DWORK ) - ELSE - ANORM = DLANHS( '1-norm', N, T, LDT, DWORK ) - END IF -C -C For the special case A = I, set SEPD and RCOND to 0. -C For the special case A = 0, set SEPD and RCOND to 1. -C A quick test is used in general. -C - IF( ANORM.EQ.ONE ) THEN - IF( NOFACT .OR. UPDATE ) THEN - CALL DLACPY( 'Full', N, N, A, LDA, DWORK, N ) - ELSE - CALL DLACPY( 'Full', N, N, T, LDT, DWORK, N ) - IF( N.GT.2 ) - $ CALL DLASET( 'Lower', N-2, N-2, ZERO, ZERO, DWORK( 3 ), - $ N ) - END IF - DWORK( NN+1 ) = ONE - CALL DAXPY( N, -ONE, DWORK( NN+1 ), 0, DWORK, N+1 ) - IF( DLANGE( 'Max', N, N, DWORK, N, DWORK ).EQ.ZERO ) THEN - IF( .NOT.JOBE ) THEN - SEPD = ZERO - RCOND = ZERO - END IF - IF( .NOT.JOBC ) - $ FERR = ONE - DWORK( 1 ) = DBLE( NN + 1 ) - RETURN - END IF -C - ELSE IF( ANORM.EQ.ZERO ) THEN - IF( .NOT.JOBE ) THEN - SEPD = ONE - RCOND = ONE - END IF - IF( JOBC ) THEN - DWORK( 1 ) = DBLE( N ) - RETURN - ELSE -C -C Set FERR for the special case A = 0. -C - CALL DLACPY( UPLO, N, N, X, LDX, DWORK, N ) -C - IF( LOWER ) THEN - DO 10 J = 1, N - CALL DAXPY( N-J+1, SCALE, C( J, J ), 1, - $ DWORK( (J-1)*N+J ), 1 ) - 10 CONTINUE - ELSE - DO 20 J = 1, N - CALL DAXPY( J, SCALE, C( 1, J ), 1, - $ DWORK( (J-1)*N+1 ), 1 ) - 20 CONTINUE - END IF -C - FERR = MIN( ONE, DLANSY( '1-norm', UPLO, N, DWORK, N, - $ DWORK( NN+1 ) ) / XNORM ) - DWORK( 1 ) = DBLE( NN + N ) - RETURN - END IF - END IF -C -C General case. -C - CNORM = DLANSY( '1-norm', UPLO, N, C, LDC, DWORK ) -C -C Workspace usage. -C - IABS = NN - IXMA = MAX( 3, 2*NN ) - IRES = IXMA - IWRK = IXMA + NN - WRKOPT = 0 -C - IF( NOFACT ) THEN -C -C Compute the Schur factorization of A, A = U*T*U'. -C Workspace: need 5*N; -C prefer larger. -C (Note: Comments in the code beginning "Workspace:" describe the -C minimal amount of real workspace needed at that point in the -C code, as well as the preferred amount for good performance.) -C - CALL DLACPY( 'Full', N, N, A, LDA, T, LDT ) - IF( UPDATE ) THEN - SJOB = 'V' - ELSE - SJOB = 'N' - END IF - CALL DGEES( SJOB, 'Not ordered', SELECT, N, T, LDT, SDIM, - $ DWORK( 1 ), DWORK( N+1 ), U, LDU, DWORK( 2*N+1 ), - $ LDWORK-2*N, BWORK, INFO ) - IF( INFO.GT.0 ) - $ RETURN - WRKOPT = INT( DWORK( 2*N+1 ) ) + 2*N - END IF -C -C Compute X*op(A) or X*op(T). -C - IF( UPDATE ) THEN - CALL DGEMM( 'NoTranspose', TRANA, N, N, N, ONE, X, LDX, A, LDA, - $ ZERO, DWORK( IXMA+1 ), N ) - ELSE - CALL MB01UD( 'Right', TRANA, N, N, ONE, T, LDT, X, LDX, - $ DWORK( IXMA+1 ), N, INFO ) - END IF -C - IF( .NOT.JOBE ) THEN -C -C Estimate sepd(op(A),op(A)') = sepd(op(T),op(T)') and -C norm(Theta). -C Workspace max(3,2*N*N) + N*N. -C - CALL SB03SY( 'Both', TRANA, LYAPUN, N, T, LDT, U, LDU, - $ DWORK( IXMA+1 ), N, SEPD, THNORM, IWORK, DWORK, - $ IXMA, INFO ) -C - WRKOPT = MAX( WRKOPT, MAX( 3, 2*NN ) + NN ) -C -C Return if the equation is singular. -C - IF( SEPD.EQ.ZERO ) THEN - RCOND = ZERO - IF( JOBB ) - $ FERR = ONE - DWORK( 1 ) = DBLE( WRKOPT ) - RETURN - END IF -C -C Estimate the reciprocal condition number. -C - TMAX = MAX( SEPD, XNORM, ANORM ) - IF( TMAX.LE.ONE ) THEN - TEMP = SEPD*XNORM - DENOM = ( SCALE*CNORM ) + ( SEPD*ANORM )*THNORM - ELSE - TEMP = ( SEPD / TMAX )*( XNORM / TMAX ) - DENOM = ( ( SCALE / TMAX )*( CNORM / TMAX ) ) + - $ ( ( SEPD / TMAX )*( ANORM / TMAX ) )*THNORM - END IF - IF( TEMP.GE.DENOM ) THEN - RCOND = ONE - ELSE - RCOND = TEMP / DENOM - END IF - END IF -C - IF( .NOT.JOBC ) THEN -C -C Form a triangle of the residual matrix -C R = scale*C + X - op(A)'*X*op(A), or -C R = scale*C + X - op(T)'*X*op(T), -C exploiting the symmetry. For memory savings, R is formed in the -C leading N-by-N upper/lower triangular part of DWORK, and it is -C finally moved in the location where X*op(A) or X*op(T) was -C stored, freeing workspace for the SB03SX call. -C - IF( NOTRNA ) THEN - TRANAT = 'T' - ELSE - TRANAT = 'N' - END IF -C - CALL DLACPY( UPLO, N, N, C, LDC, DWORK, N ) -C - IF( UPDATE ) THEN - CALL MB01RX( 'Left', UPLO, TRANAT, N, N, SCALE, -ONE, DWORK, - $ N, A, LDA, DWORK( IXMA+1 ), N, INFO ) - ELSE - CALL MB01RY( 'Left', UPLO, TRANAT, N, SCALE, -ONE, DWORK, N, - $ T, LDT, DWORK( IXMA+1 ), N, DWORK( IWRK+1 ), - $ INFO ) - END IF -C - IF( LOWER ) THEN - DO 30 J = 1, N - CALL DAXPY( N-J+1, ONE, X( J, J ), 1, DWORK( (J-1)*N+J ), - $ 1 ) - 30 CONTINUE - ELSE - DO 40 J = 1, N - CALL DAXPY( J, ONE, X( 1, J ), 1, DWORK( (J-1)*N+1 ), 1 ) - 40 CONTINUE - END IF -C - CALL DLACPY( UPLO, N, N, DWORK, N, DWORK( IRES+1 ), N ) -C -C Get the machine precision. -C - EPS = DLAMCH( 'Epsilon' ) - EPSN = EPS*DBLE( 2*N + 2 ) -C -C Add to abs(R) a term that takes account of rounding errors in -C forming R: -C abs(R) := abs(R) + EPS*(3*scale*abs(C) + 3*abs(X) + -C 2*(n+1)*abs(op(A))'*abs(X)*abs(op(A))), or -C abs(R) := abs(R) + EPS*(3*scale*abs(C) + 3*abs(X) + -C 2*(n+1)*abs(op(T))'*abs(X)*abs(op(T))), -C where EPS is the machine precision. -C Workspace max(3,2*N*N) + N*N + 2*N. -C Note that the lower or upper triangular part of X specified by -C UPLO is used as workspace, but it is finally restored. -C - IF( UPDATE ) THEN - DO 60 J = 1, N - DO 50 I = 1, N - DWORK( IABS+(J-1)*N+I ) = ABS( A( I, J ) ) - 50 CONTINUE - 60 CONTINUE - ELSE - DO 80 J = 1, N - DO 70 I = 1, MIN( J+1, N ) - DWORK( IABS+(J-1)*N+I ) = ABS( T( I, J ) ) - 70 CONTINUE - 80 CONTINUE - END IF -C - CALL DCOPY( N, X, LDX+1, DWORK( IWRK+1 ), 1 ) -C - IF( LOWER ) THEN - DO 100 J = 1, N - DO 90 I = J, N - TEMP = ABS( X( I, J ) ) - X( I, J ) = TEMP - DWORK( IRES+(J-1)*N+I ) = - $ ABS( DWORK( IRES+(J-1)*N+I ) ) + - $ EPS*THREE*( SCALE*ABS( C( I, J ) ) + TEMP ) - 90 CONTINUE - 100 CONTINUE - ELSE - DO 120 J = 1, N - DO 110 I = 1, J - TEMP = ABS( X( I, J ) ) - X( I, J ) = TEMP - DWORK( IRES+(J-1)*N+I ) = - $ ABS( DWORK( IRES+(J-1)*N+I ) ) + - $ EPS*THREE*( SCALE*ABS( C( I, J ) ) + TEMP ) - 110 CONTINUE - 120 CONTINUE - END IF -C - IF( UPDATE ) THEN - CALL MB01RU( UPLO, TRANAT, N, N, ONE, EPSN, DWORK( IRES+1 ), - $ N, DWORK( IABS+1 ), N, X, LDX, DWORK, NN, - $ INFO ) - ELSE -C -C Compute W = abs(X)*abs(op(T)), and then premultiply by -C abs(T)' and add in the result. -C - CALL MB01UD( 'Right', TRANA, N, N, ONE, DWORK( IABS+1 ), N, - $ X, LDX, DWORK, N, INFO ) - CALL MB01RY( 'Left', UPLO, TRANAT, N, ONE, EPSN, - $ DWORK( IRES+1 ), N, DWORK( IABS+1 ), N, DWORK, - $ N, DWORK( IWRK+N+1 ), INFO ) - END IF -C - WRKOPT = MAX( WRKOPT, MAX( 3, 2*NN ) + NN + 2*N ) -C -C Restore X. -C - CALL DCOPY( N, DWORK( IWRK+1 ), 1, X, LDX+1 ) - IF( LOWER ) THEN - CALL MA02ED( 'Upper', N, X, LDX ) - ELSE - CALL MA02ED( 'Lower', N, X, LDX ) - END IF -C -C Compute forward error bound, using matrix norm estimator. -C Workspace max(3,2*N*N) + N*N. -C - XANORM = DLANSY( 'Max', UPLO, N, X, LDX, DWORK ) -C - CALL SB03SX( TRANA, UPLO, LYAPUN, N, XANORM, T, LDT, U, LDU, - $ DWORK( IRES+1 ), N, FERR, IWORK, DWORK, IRES, - $ INFO ) - END IF -C - DWORK( 1 ) = DBLE( WRKOPT ) - RETURN -C -C *** Last line of SB03SD *** - END diff --git a/mex/sources/libslicot/SB03SX.f b/mex/sources/libslicot/SB03SX.f deleted file mode 100644 index 58078b80d..000000000 --- a/mex/sources/libslicot/SB03SX.f +++ /dev/null @@ -1,398 +0,0 @@ - SUBROUTINE SB03SX( TRANA, UPLO, LYAPUN, N, XANORM, T, LDT, U, LDU, - $ R, LDR, FERR, IWORK, DWORK, LDWORK, INFO ) -C -C SLICOT RELEASE 5.0. -C -C Copyright (c) 2002-2009 NICONET e.V. -C -C This program is free software: you can redistribute it and/or -C modify it under the terms of the GNU General Public License as -C published by the Free Software Foundation, either version 2 of -C the License, or (at your option) any later version. -C -C This program is distributed in the hope that it will be useful, -C but WITHOUT ANY WARRANTY; without even the implied warranty of -C MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the -C GNU General Public License for more details. -C -C You should have received a copy of the GNU General Public License -C along with this program. If not, see -C . -C -C PURPOSE -C -C To estimate a forward error bound for the solution X of a real -C discrete-time Lyapunov matrix equation, -C -C op(A)'*X*op(A) - X = C, -C -C where op(A) = A or A' (A**T) and C is symmetric (C = C**T). The -C matrix A, the right hand side C, and the solution X are N-by-N. -C An absolute residual matrix, which takes into account the rounding -C errors in forming it, is given in the array R. -C -C ARGUMENTS -C -C Mode Parameters -C -C TRANA CHARACTER*1 -C Specifies the form of op(A) to be used, as follows: -C = 'N': op(A) = A (No transpose); -C = 'T': op(A) = A**T (Transpose); -C = 'C': op(A) = A**T (Conjugate transpose = Transpose). -C -C UPLO CHARACTER*1 -C Specifies which part of the symmetric matrix R is to be -C used, as follows: -C = 'U': Upper triangular part; -C = 'L': Lower triangular part. -C -C LYAPUN CHARACTER*1 -C Specifies whether or not the original Lyapunov equations -C should be solved, as follows: -C = 'O': Solve the original Lyapunov equations, updating -C the right-hand sides and solutions with the -C matrix U, e.g., X <-- U'*X*U; -C = 'R': Solve reduced Lyapunov equations only, without -C updating the right-hand sides and solutions. -C -C Input/Output Parameters -C -C N (input) INTEGER -C The order of the matrices A and R. N >= 0. -C -C XANORM (input) DOUBLE PRECISION -C The absolute (maximal) norm of the symmetric solution -C matrix X of the Lyapunov equation. XANORM >= 0. -C -C T (input) DOUBLE PRECISION array, dimension (LDT,N) -C The leading N-by-N upper Hessenberg part of this array -C must contain the upper quasi-triangular matrix T in Schur -C canonical form from a Schur factorization of A. -C -C LDT INTEGER -C The leading dimension of array T. LDT >= MAX(1,N). -C -C U (input) DOUBLE PRECISION array, dimension (LDU,N) -C The leading N-by-N part of this array must contain the -C orthogonal matrix U from a real Schur factorization of A. -C If LYAPUN = 'R', the array U is not referenced. -C -C LDU INTEGER -C The leading dimension of array U. -C LDU >= 1, if LYAPUN = 'R'; -C LDU >= MAX(1,N), if LYAPUN = 'O'. -C -C R (input/output) DOUBLE PRECISION array, dimension (LDR,N) -C On entry, if UPLO = 'U', the leading N-by-N upper -C triangular part of this array must contain the upper -C triangular part of the absolute residual matrix R, with -C bounds on rounding errors added. -C On entry, if UPLO = 'L', the leading N-by-N lower -C triangular part of this array must contain the lower -C triangular part of the absolute residual matrix R, with -C bounds on rounding errors added. -C On exit, the leading N-by-N part of this array contains -C the symmetric absolute residual matrix R (with bounds on -C rounding errors added), fully stored. -C -C LDR INTEGER -C The leading dimension of array R. LDR >= MAX(1,N). -C -C FERR (output) DOUBLE PRECISION -C An estimated forward error bound for the solution X. -C If XTRUE is the true solution, FERR bounds the magnitude -C of the largest entry in (X - XTRUE) divided by the -C magnitude of the largest entry in X. -C If N = 0 or XANORM = 0, FERR is set to 0, without any -C calculations. -C -C Workspace -C -C IWORK INTEGER array, dimension (N*N) -C -C DWORK DOUBLE PRECISION array, dimension (LDWORK) -C -C LDWORK INTEGER -C The length of the array DWORK. -C LDWORK >= 0, if N = 0; -C LDWORK >= MAX(3,2*N*N), if N > 0. -C -C Error Indicator -C -C INFO INTEGER -C = 0: successful exit; -C < 0: if INFO = -i, the i-th argument had an illegal -C value; -C = N+1: if T has almost reciprocal eigenvalues; perturbed -C values were used to solve Lyapunov equations (but -C the matrix T is unchanged). -C -C METHOD -C -C The forward error bound is estimated using a practical error bound -C similar to the one proposed in [1], based on the 1-norm estimator -C in [2]. -C -C REFERENCES -C -C [1] Higham, N.J. -C Perturbation theory and backward error for AX-XB=C. -C BIT, vol. 33, pp. 124-136, 1993. -C -C [2] Higham, N.J. -C FORTRAN codes for estimating the one-norm of a real or -C complex matrix, with applications to condition estimation. -C ACM Trans. Math. Softw., 14, pp. 381-396, 1988. -C -C NUMERICAL ASPECTS -C 3 -C The algorithm requires 0(N ) operations. -C -C FURTHER COMMENTS -C -C The option LYAPUN = 'R' may occasionally produce slightly worse -C or better estimates, and it is much faster than the option 'O'. -C The routine can be also used as a final step in estimating a -C forward error bound for the solution of a discrete-time algebraic -C matrix Riccati equation. -C -C CONTRIBUTOR -C -C V. Sima, Research Institute for Informatics, Bucharest, Romania, -C Oct. 1998. Partly based on DDLSVX (and then SB03SD) by P. Petkov, -C Tech. University of Sofia, March 1998 (and December 1998). -C -C REVISIONS -C -C February 6, 1999, V. Sima, Katholieke Univ. Leuven, Belgium. -C V. Sima, Research Institute for Informatics, Bucharest, Oct. 2004. -C -C KEYWORDS -C -C Lyapunov equation, orthogonal transformation, real Schur form. -C -C ****************************************************************** -C -C .. Parameters .. - DOUBLE PRECISION ZERO, ONE, HALF - PARAMETER ( ZERO = 0.0D+0, ONE = 1.0D+0, HALF = 0.5D+0 ) -C .. -C .. Scalar Arguments .. - CHARACTER LYAPUN, TRANA, UPLO - INTEGER INFO, LDR, LDT, LDU, LDWORK, N - DOUBLE PRECISION FERR, XANORM -C .. -C .. Array Arguments .. - INTEGER IWORK( * ) - DOUBLE PRECISION DWORK( * ), R( LDR, * ), T( LDT, * ), - $ U( LDU, * ) -C .. -C .. Local Scalars .. - LOGICAL LOWER, NOTRNA, UPDATE - CHARACTER TRANAT, UPLOW - INTEGER I, IJ, INFO2, ITMP, J, KASE, NN - DOUBLE PRECISION EST, SCALE, TEMP -C .. -C .. External Functions .. - LOGICAL LSAME - DOUBLE PRECISION DLANSY - EXTERNAL DLANSY, LSAME -C .. -C .. External Subroutines .. - EXTERNAL DLACON, DSCAL, MA02ED, MB01RU, SB03MX, XERBLA -C .. -C .. Intrinsic Functions .. - INTRINSIC MAX -C .. -C .. Executable Statements .. -C -C Decode and Test input parameters. -C - NOTRNA = LSAME( TRANA, 'N' ) - UPDATE = LSAME( LYAPUN, 'O' ) -C - NN = N*N - INFO = 0 - IF( .NOT.( NOTRNA .OR. LSAME( TRANA, 'T' ) .OR. - $ LSAME( TRANA, 'C' ) ) ) THEN - INFO = -1 - ELSE IF( .NOT.( LSAME( UPLO, 'L' ) .OR. LSAME( UPLO, 'U' ) ) ) - $ THEN - INFO = -2 - ELSE IF( .NOT.( UPDATE .OR. LSAME( LYAPUN, 'R' ) ) ) THEN - INFO = -3 - ELSE IF( N.LT.0 ) THEN - INFO = -4 - ELSE IF( XANORM.LT.ZERO ) THEN - INFO = -5 - ELSE IF( LDT.LT.MAX( 1, N ) ) THEN - INFO = -7 - ELSE IF( LDU.LT.1 .OR. ( UPDATE .AND. LDU.LT.N ) ) THEN - INFO = -9 - ELSE IF( LDR.LT.MAX( 1, N ) ) THEN - INFO = -11 - ELSE IF( LDWORK.LT.0 .OR. - $ ( LDWORK.LT.MAX( 3, 2*NN ) .AND. N.GT.0 ) ) THEN - INFO = -15 - END IF -C - IF( INFO.NE.0 ) THEN - CALL XERBLA( 'SB03SX', -INFO ) - RETURN - END IF -C -C Quick return if possible. -C - FERR = ZERO - IF( N.EQ.0 .OR. XANORM.EQ.ZERO ) - $ RETURN -C - ITMP = NN + 1 -C - IF( NOTRNA ) THEN - TRANAT = 'T' - ELSE - TRANAT = 'N' - END IF -C -C Fill in the remaining triangle of the symmetric residual matrix. -C - CALL MA02ED( UPLO, N, R, LDR ) -C - KASE = 0 -C -C REPEAT - 10 CONTINUE - CALL DLACON( NN, DWORK( ITMP ), DWORK, IWORK, EST, KASE ) - IF( KASE.NE.0 ) THEN -C -C Select the triangular part of symmetric matrix to be used. -C - IF( DLANSY( '1-norm', 'Upper', N, DWORK, N, DWORK( ITMP ) ) - $ .GE. - $ DLANSY( '1-norm', 'Lower', N, DWORK, N, DWORK( ITMP ) ) - $ ) THEN - UPLOW = 'U' - LOWER = .FALSE. - ELSE - UPLOW = 'L' - LOWER = .TRUE. - END IF -C - IF( KASE.EQ.2 ) THEN - IJ = 0 - IF( LOWER ) THEN -C -C Scale the lower triangular part of symmetric matrix -C by the residual matrix. -C - DO 30 J = 1, N - DO 20 I = J, N - IJ = IJ + 1 - DWORK( IJ ) = DWORK( IJ )*R( I, J ) - 20 CONTINUE - IJ = IJ + J - 30 CONTINUE - ELSE -C -C Scale the upper triangular part of symmetric matrix -C by the residual matrix. -C - DO 50 J = 1, N - DO 40 I = 1, J - IJ = IJ + 1 - DWORK( IJ ) = DWORK( IJ )*R( I, J ) - 40 CONTINUE - IJ = IJ + N - J - 50 CONTINUE - END IF - END IF -C - IF( UPDATE ) THEN -C -C Transform the right-hand side: RHS := U'*RHS*U. -C - CALL MB01RU( UPLOW, 'Transpose', N, N, ZERO, ONE, DWORK, N, - $ U, LDU, DWORK, N, DWORK( ITMP ), NN, INFO2 ) - CALL DSCAL( N, HALF, DWORK, N+1 ) - END IF - CALL MA02ED( UPLOW, N, DWORK, N ) -C - IF( KASE.EQ.2 ) THEN -C -C Solve op(T)'*Y*op(T) - Y = scale*RHS. -C - CALL SB03MX( TRANA, N, T, LDT, DWORK, N, SCALE, - $ DWORK( ITMP ), INFO2 ) - ELSE -C -C Solve op(T)*W*op(T)' - W = scale*RHS. -C - CALL SB03MX( TRANAT, N, T, LDT, DWORK, N, SCALE, - $ DWORK( ITMP ), INFO2 ) - END IF -C - IF( INFO2.GT.0 ) - $ INFO = N + 1 -C - IF( UPDATE ) THEN -C -C Transform back to obtain the solution: Z := U*Z*U', with -C Z = Y or Z = W. -C - CALL MB01RU( UPLOW, 'No transpose', N, N, ZERO, ONE, DWORK, - $ N, U, LDU, DWORK, N, DWORK( ITMP ), NN, INFO2 ) - CALL DSCAL( N, HALF, DWORK, N+1 ) - END IF -C - IF( KASE.EQ.1 ) THEN - IJ = 0 - IF( LOWER ) THEN -C -C Scale the lower triangular part of symmetric matrix -C by the residual matrix. -C - DO 70 J = 1, N - DO 60 I = J, N - IJ = IJ + 1 - DWORK( IJ ) = DWORK( IJ )*R( I, J ) - 60 CONTINUE - IJ = IJ + J - 70 CONTINUE - ELSE -C -C Scale the upper triangular part of symmetric matrix -C by the residual matrix. -C - DO 90 J = 1, N - DO 80 I = 1, J - IJ = IJ + 1 - DWORK( IJ ) = DWORK( IJ )*R( I, J ) - 80 CONTINUE - IJ = IJ + N - J - 90 CONTINUE - END IF - END IF -C -C Fill in the remaining triangle of the symmetric matrix. -C - CALL MA02ED( UPLOW, N, DWORK, N ) - GO TO 10 - END IF -C -C UNTIL KASE = 0 -C -C Compute the estimate of the relative error. -C - TEMP = XANORM*SCALE - IF( TEMP.GT.EST ) THEN - FERR = EST / TEMP - ELSE - FERR = ONE - END IF -C - RETURN -C -C *** Last line of SB03SX *** - END diff --git a/mex/sources/libslicot/SB03SY.f b/mex/sources/libslicot/SB03SY.f deleted file mode 100644 index 8cdc0c9bb..000000000 --- a/mex/sources/libslicot/SB03SY.f +++ /dev/null @@ -1,451 +0,0 @@ - SUBROUTINE SB03SY( JOB, TRANA, LYAPUN, N, T, LDT, U, LDU, XA, - $ LDXA, SEPD, THNORM, IWORK, DWORK, LDWORK, - $ INFO ) -C -C SLICOT RELEASE 5.0. -C -C Copyright (c) 2002-2009 NICONET e.V. -C -C This program is free software: you can redistribute it and/or -C modify it under the terms of the GNU General Public License as -C published by the Free Software Foundation, either version 2 of -C the License, or (at your option) any later version. -C -C This program is distributed in the hope that it will be useful, -C but WITHOUT ANY WARRANTY; without even the implied warranty of -C MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the -C GNU General Public License for more details. -C -C You should have received a copy of the GNU General Public License -C along with this program. If not, see -C . -C -C PURPOSE -C -C To estimate the "separation" between the matrices op(A) and -C op(A)', -C -C sepd(op(A),op(A)') = min norm(op(A)'*X*op(A) - X)/norm(X) -C = 1 / norm(inv(Omega)) -C -C and/or the 1-norm of Theta, where op(A) = A or A' (A**T), and -C Omega and Theta are linear operators associated to the real -C discrete-time Lyapunov matrix equation -C -C op(A)'*X*op(A) - X = C, -C -C defined by -C -C Omega(W) = op(A)'*W*op(A) - W, -C Theta(W) = inv(Omega(op(W)'*X*op(A) + op(A)'*X*op(W))). -C -C The 1-norm condition estimators are used. -C -C ARGUMENTS -C -C Mode Parameters -C -C JOB CHARACTER*1 -C Specifies the computation to be performed, as follows: -C = 'S': Compute the separation only; -C = 'T': Compute the norm of Theta only; -C = 'B': Compute both the separation and the norm of Theta. -C -C TRANA CHARACTER*1 -C Specifies the form of op(A) to be used, as follows: -C = 'N': op(A) = A (No transpose); -C = 'T': op(A) = A**T (Transpose); -C = 'C': op(A) = A**T (Conjugate transpose = Transpose). -C -C LYAPUN CHARACTER*1 -C Specifies whether or not the original Lyapunov equations -C should be solved, as follows: -C = 'O': Solve the original Lyapunov equations, updating -C the right-hand sides and solutions with the -C matrix U, e.g., X <-- U'*X*U; -C = 'R': Solve reduced Lyapunov equations only, without -C updating the right-hand sides and solutions. -C -C Input/Output Parameters -C -C N (input) INTEGER -C The order of the matrices A and X. N >= 0. -C -C T (input) DOUBLE PRECISION array, dimension (LDT,N) -C The leading N-by-N upper Hessenberg part of this array -C must contain the upper quasi-triangular matrix T in Schur -C canonical form from a Schur factorization of A. -C -C LDT INTEGER -C The leading dimension of array T. LDT >= MAX(1,N). -C -C U (input) DOUBLE PRECISION array, dimension (LDU,N) -C The leading N-by-N part of this array must contain the -C orthogonal matrix U from a real Schur factorization of A. -C If LYAPUN = 'R', the array U is not referenced. -C -C LDU INTEGER -C The leading dimension of array U. -C LDU >= 1, if LYAPUN = 'R'; -C LDU >= MAX(1,N), if LYAPUN = 'O'. -C -C XA (input) DOUBLE PRECISION array, dimension (LDXA,N) -C The leading N-by-N part of this array must contain the -C matrix product X*op(A), if LYAPUN = 'O', or U'*X*U*op(T), -C if LYAPUN = 'R', in the Lyapunov equation. -C If JOB = 'S', the array XA is not referenced. -C -C LDXA INTEGER -C The leading dimension of array XA. -C LDXA >= 1, if JOB = 'S'; -C LDXA >= MAX(1,N), if JOB = 'T' or 'B'. -C -C SEPD (output) DOUBLE PRECISION -C If JOB = 'S' or JOB = 'B', and INFO >= 0, SEPD contains -C the estimated quantity sepd(op(A),op(A)'). -C If JOB = 'T' or N = 0, SEPD is not referenced. -C -C THNORM (output) DOUBLE PRECISION -C If JOB = 'T' or JOB = 'B', and INFO >= 0, THNORM contains -C the estimated 1-norm of operator Theta. -C If JOB = 'S' or N = 0, THNORM is not referenced. -C -C Workspace -C -C IWORK INTEGER array, dimension (N*N) -C -C DWORK DOUBLE PRECISION array, dimension (LDWORK) -C -C LDWORK INTEGER -C The length of the array DWORK. -C LDWORK >= 0, if N = 0; -C LDWORK >= MAX(3,2*N*N), if N > 0. -C -C Error Indicator -C -C INFO INTEGER -C = 0: successful exit; -C < 0: if INFO = -i, the i-th argument had an illegal -C value; -C = N+1: if T has (almost) reciprocal eigenvalues; -C perturbed values were used to solve Lyapunov -C equations (but the matrix T is unchanged). -C -C METHOD -C -C SEPD is defined as -C -C sepd( op(A), op(A)' ) = sigma_min( K ) -C -C where sigma_min(K) is the smallest singular value of the -C N*N-by-N*N matrix -C -C K = kprod( op(A)', op(A)' ) - I(N**2). -C -C I(N**2) is an N*N-by-N*N identity matrix, and kprod denotes the -C Kronecker product. The routine estimates sigma_min(K) by the -C reciprocal of an estimate of the 1-norm of inverse(K), computed as -C suggested in [1]. This involves the solution of several discrete- -C time Lyapunov equations, either direct or transposed. The true -C reciprocal 1-norm of inverse(K) cannot differ from sigma_min(K) by -C more than a factor of N. -C The 1-norm of Theta is estimated similarly. -C -C REFERENCES -C -C [1] Higham, N.J. -C FORTRAN codes for estimating the one-norm of a real or -C complex matrix, with applications to condition estimation. -C ACM Trans. Math. Softw., 14, pp. 381-396, 1988. -C -C NUMERICAL ASPECTS -C 3 -C The algorithm requires 0(N ) operations. -C -C FURTHER COMMENTS -C -C When SEPD is zero, the routine returns immediately, with THNORM -C (if requested) not set. In this case, the equation is singular. -C The option LYAPUN = 'R' may occasionally produce slightly worse -C or better estimates, and it is much faster than the option 'O'. -C -C CONTRIBUTOR -C -C V. Sima, Research Institute for Informatics, Bucharest, Romania, -C Oct. 1998. Partly based on DDLSVX (and then SB03SD) by P. Petkov, -C Tech. University of Sofia, March 1998 (and December 1998). -C -C REVISIONS -C -C February 6, 1999, V. Sima, Katholieke Univ. Leuven, Belgium. -C V. Sima, Research Institute for Informatics, Bucharest, Oct. 2004. -C -C KEYWORDS -C -C Lyapunov equation, orthogonal transformation, real Schur form. -C -C ****************************************************************** -C -C .. Parameters .. - DOUBLE PRECISION ZERO, ONE, HALF - PARAMETER ( ZERO = 0.0D+0, ONE = 1.0D+0, HALF = 0.5D+0 ) -C .. -C .. Scalar Arguments .. - CHARACTER JOB, LYAPUN, TRANA - INTEGER INFO, LDT, LDU, LDWORK, LDXA, N - DOUBLE PRECISION SEPD, THNORM -C .. -C .. Array Arguments .. - INTEGER IWORK( * ) - DOUBLE PRECISION DWORK( * ), T( LDT, * ), U( LDU, * ), - $ XA( LDXA, * ) -C .. -C .. Local Scalars .. - LOGICAL NOTRNA, UPDATE, WANTS, WANTT - CHARACTER TRANAT, UPLO - INTEGER INFO2, ITMP, KASE, NN - DOUBLE PRECISION BIGNUM, EST, SCALE -C .. -C .. External Functions .. - LOGICAL LSAME - DOUBLE PRECISION DLAMCH, DLANSY - EXTERNAL DLAMCH, DLANSY, LSAME -C .. -C .. External Subroutines .. - EXTERNAL DLACON, DLACPY, DSCAL, DSYR2K, MA02ED, MB01RU, - $ SB03MX, XERBLA -C .. -C .. Intrinsic Functions .. - INTRINSIC MAX -C .. -C .. Executable Statements .. -C -C Decode and Test input parameters. -C - WANTS = LSAME( JOB, 'S' ) - WANTT = LSAME( JOB, 'T' ) - NOTRNA = LSAME( TRANA, 'N' ) - UPDATE = LSAME( LYAPUN, 'O' ) -C - NN = N*N - INFO = 0 - IF( .NOT. ( WANTS .OR. WANTT .OR. LSAME( JOB, 'B' ) ) ) THEN - INFO = -1 - ELSE IF( .NOT.( NOTRNA .OR. LSAME( TRANA, 'T' ) .OR. - $ LSAME( TRANA, 'C' ) ) ) THEN - INFO = -2 - ELSE IF( .NOT.( UPDATE .OR. LSAME( LYAPUN, 'R' ) ) ) THEN - INFO = -3 - ELSE IF( N.LT.0 ) THEN - INFO = -4 - ELSE IF( LDT.LT.MAX( 1, N ) ) THEN - INFO = -6 - ELSE IF( LDU.LT.1 .OR. ( UPDATE .AND. LDU.LT.N ) ) THEN - INFO = -8 - ELSE IF( LDXA.LT.1 .OR. ( .NOT.WANTS .AND. LDXA.LT.N ) ) THEN - INFO = -10 - ELSE IF( LDWORK.LT.0 .OR. - $ ( LDWORK.LT.MAX( 3, 2*NN ) .AND. N.GT.0 ) ) THEN - INFO = -15 - END IF -C - IF( INFO.NE.0 ) THEN - CALL XERBLA( 'SB03SY', -INFO ) - RETURN - END IF -C -C Quick return if possible. -C - IF( N.EQ.0 ) - $ RETURN -C - ITMP = NN + 1 -C - IF( NOTRNA ) THEN - TRANAT = 'T' - ELSE - TRANAT = 'N' - END IF -C - IF( .NOT.WANTT ) THEN -C -C Estimate sepd(op(A),op(A)'). -C Workspace: max(3,2*N*N). -C - KASE = 0 -C -C REPEAT - 10 CONTINUE - CALL DLACON( NN, DWORK( ITMP ), DWORK, IWORK, EST, KASE ) - IF( KASE.NE.0 ) THEN -C -C Select the triangular part of symmetric matrix to be used. -C - IF( DLANSY( '1-norm', 'Upper', N, DWORK, N, DWORK( ITMP ) ) - $ .GE. - $ DLANSY( '1-norm', 'Lower', N, DWORK, N, DWORK( ITMP ) ) - $ ) THEN - UPLO = 'U' - ELSE - UPLO = 'L' - END IF -C - IF( UPDATE ) THEN -C -C Transform the right-hand side: RHS := U'*RHS*U. -C - CALL MB01RU( UPLO, 'Transpose', N, N, ZERO, ONE, DWORK, - $ N, U, LDU, DWORK, N, DWORK( ITMP ), NN, - $ INFO2 ) - CALL DSCAL( N, HALF, DWORK, N+1 ) - END IF - CALL MA02ED( UPLO, N, DWORK, N ) -C - IF( KASE.EQ.1 ) THEN -C -C Solve op(T)'*Y*op(T) - Y = scale*RHS. -C - CALL SB03MX( TRANA, N, T, LDT, DWORK, N, SCALE, - $ DWORK( ITMP ), INFO2 ) - ELSE -C -C Solve op(T)*W*op(T)' - W = scale*RHS. -C - CALL SB03MX( TRANAT, N, T, LDT, DWORK, N, SCALE, - $ DWORK( ITMP ), INFO2 ) - END IF -C - IF( INFO2.GT.0 ) - $ INFO = N + 1 -C - IF( UPDATE ) THEN -C -C Transform back to obtain the solution: Z := U*Z*U', with -C Z = Y or Z = W. -C - CALL MB01RU( UPLO, 'No transpose', N, N, ZERO, ONE, - $ DWORK, N, U, LDU, DWORK, N, DWORK( ITMP ), - $ NN, INFO2 ) - CALL DSCAL( N, HALF, DWORK, N+1 ) -C -C Fill in the remaining triangle of the symmetric matrix. -C - CALL MA02ED( UPLO, N, DWORK, N ) - END IF -C - GO TO 10 - END IF -C UNTIL KASE = 0 -C - IF( EST.GT.SCALE ) THEN - SEPD = SCALE / EST - ELSE - BIGNUM = ONE / DLAMCH( 'Safe minimum' ) - IF( SCALE.LT.EST*BIGNUM ) THEN - SEPD = SCALE / EST - ELSE - SEPD = BIGNUM - END IF - END IF -C -C Return if the equation is singular. -C - IF( SEPD.EQ.ZERO ) - $ RETURN - END IF -C - IF( .NOT.WANTS ) THEN -C -C Estimate norm(Theta). -C Workspace: max(3,2*N*N). -C - KASE = 0 -C -C REPEAT - 20 CONTINUE - CALL DLACON( NN, DWORK( ITMP ), DWORK, IWORK, EST, KASE ) - IF( KASE.NE.0 ) THEN -C -C Select the triangular part of symmetric matrix to be used. -C - IF( DLANSY( '1-norm', 'Upper', N, DWORK, N, DWORK( ITMP ) ) - $ .GE. - $ DLANSY( '1-norm', 'Lower', N, DWORK, N, DWORK( ITMP ) ) - $ ) THEN - UPLO = 'U' - ELSE - UPLO = 'L' - END IF -C -C Fill in the remaining triangle of the symmetric matrix. -C - CALL MA02ED( UPLO, N, DWORK, N ) -C -C Compute RHS = op(W)'*X*op(A) + op(A)'*X*op(W). -C - CALL DSYR2K( UPLO, TRANAT, N, N, ONE, DWORK, N, XA, LDXA, - $ ZERO, DWORK( ITMP ), N ) - CALL DLACPY( UPLO, N, N, DWORK( ITMP ), N, DWORK, N ) -C - IF( UPDATE ) THEN -C -C Transform the right-hand side: RHS := U'*RHS*U. -C - CALL MB01RU( UPLO, 'Transpose', N, N, ZERO, ONE, DWORK, - $ N, U, LDU, DWORK, N, DWORK( ITMP ), NN, - $ INFO2 ) - CALL DSCAL( N, HALF, DWORK, N+1 ) - END IF - CALL MA02ED( UPLO, N, DWORK, N ) -C - IF( KASE.EQ.1 ) THEN -C -C Solve op(T)'*Y*op(T) - Y = scale*RHS. -C - CALL SB03MX( TRANA, N, T, LDT, DWORK, N, SCALE, - $ DWORK( ITMP ), INFO2 ) - ELSE -C -C Solve op(T)*W*op(T)' - W = scale*RHS. -C - CALL SB03MX( TRANAT, N, T, LDT, DWORK, N, SCALE, - $ DWORK( ITMP ), INFO2 ) - END IF -C - IF( INFO2.GT.0 ) - $ INFO = N + 1 -C - IF( UPDATE ) THEN -C -C Transform back to obtain the solution: Z := U*Z*U', with -C Z = Y or Z = W. -C - CALL MB01RU( UPLO, 'No transpose', N, N, ZERO, ONE, - $ DWORK, N, U, LDU, DWORK, N, DWORK( ITMP ), - $ NN, INFO2 ) - CALL DSCAL( N, HALF, DWORK, N+1 ) -C -C Fill in the remaining triangle of the symmetric matrix. -C - CALL MA02ED( UPLO, N, DWORK, N ) - END IF -C - GO TO 20 - END IF -C UNTIL KASE = 0 -C - IF( EST.LT.SCALE ) THEN - THNORM = EST / SCALE - ELSE - BIGNUM = ONE / DLAMCH( 'Safe minimum' ) - IF( EST.LT.SCALE*BIGNUM ) THEN - THNORM = EST / SCALE - ELSE - THNORM = BIGNUM - END IF - END IF - END IF -C - RETURN -C *** Last line of SB03SY *** - END diff --git a/mex/sources/libslicot/SB03TD.f b/mex/sources/libslicot/SB03TD.f deleted file mode 100644 index a1a81961f..000000000 --- a/mex/sources/libslicot/SB03TD.f +++ /dev/null @@ -1,545 +0,0 @@ - SUBROUTINE SB03TD( JOB, FACT, TRANA, UPLO, LYAPUN, N, SCALE, A, - $ LDA, T, LDT, U, LDU, C, LDC, X, LDX, SEP, - $ RCOND, FERR, WR, WI, IWORK, DWORK, LDWORK, - $ INFO ) -C -C SLICOT RELEASE 5.0. -C -C Copyright (c) 2002-2009 NICONET e.V. -C -C This program is free software: you can redistribute it and/or -C modify it under the terms of the GNU General Public License as -C published by the Free Software Foundation, either version 2 of -C the License, or (at your option) any later version. -C -C This program is distributed in the hope that it will be useful, -C but WITHOUT ANY WARRANTY; without even the implied warranty of -C MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the -C GNU General Public License for more details. -C -C You should have received a copy of the GNU General Public License -C along with this program. If not, see -C . -C -C PURPOSE -C -C To solve the real continuous-time Lyapunov matrix equation -C -C op(A)'*X + X*op(A) = scale*C, -C -C estimate the conditioning, and compute an error bound on the -C solution X, where op(A) = A or A' (A**T), the matrix A is N-by-N, -C the right hand side C and the solution X are N-by-N symmetric -C matrices (C = C', X = X'), and scale is an output scale factor, -C set less than or equal to 1 to avoid overflow in X. -C -C ARGUMENTS -C -C Mode Parameters -C -C JOB CHARACTER*1 -C Specifies the computation to be performed, as follows: -C = 'X': Compute the solution only; -C = 'S': Compute the separation only; -C = 'C': Compute the reciprocal condition number only; -C = 'E': Compute the error bound only; -C = 'A': Compute all: the solution, separation, reciprocal -C condition number, and the error bound. -C -C FACT CHARACTER*1 -C Specifies whether or not the real Schur factorization -C of the matrix A is supplied on entry, as follows: -C = 'F': On entry, T and U (if LYAPUN = 'O') contain the -C factors from the real Schur factorization of the -C matrix A; -C = 'N': The Schur factorization of A will be computed -C and the factors will be stored in T and U (if -C LYAPUN = 'O'). -C -C TRANA CHARACTER*1 -C Specifies the form of op(A) to be used, as follows: -C = 'N': op(A) = A (No transpose); -C = 'T': op(A) = A**T (Transpose); -C = 'C': op(A) = A**T (Conjugate transpose = Transpose). -C -C UPLO CHARACTER*1 -C Specifies which part of the symmetric matrix C is to be -C used, as follows: -C = 'U': Upper triangular part; -C = 'L': Lower triangular part. -C -C LYAPUN CHARACTER*1 -C Specifies whether or not the original or "reduced" -C Lyapunov equations should be solved, as follows: -C = 'O': Solve the original Lyapunov equations, updating -C the right-hand sides and solutions with the -C matrix U, e.g., X <-- U'*X*U; -C = 'R': Solve reduced Lyapunov equations only, without -C updating the right-hand sides and solutions. -C This means that a real Schur form T of A appears -C in the equation, instead of A. -C -C Input/Output Parameters -C -C N (input) INTEGER -C The order of the matrices A, X, and C. N >= 0. -C -C SCALE (input or output) DOUBLE PRECISION -C If JOB = 'C' or JOB = 'E', SCALE is an input argument: -C the scale factor, set by a Lyapunov solver. -C 0 <= SCALE <= 1. -C If JOB = 'X' or JOB = 'A', SCALE is an output argument: -C the scale factor, scale, set less than or equal to 1 to -C prevent the solution overflowing. -C If JOB = 'S', this argument is not used. -C -C A (input) DOUBLE PRECISION array, dimension (LDA,N) -C If FACT = 'N' or (LYAPUN = 'O' and JOB <> 'X'), the -C leading N-by-N part of this array must contain the -C original matrix A. -C If FACT = 'F' and (LYAPUN = 'R' or JOB = 'X'), A is -C not referenced. -C -C LDA INTEGER -C The leading dimension of the array A. -C LDA >= MAX(1,N), if FACT = 'N' or LYAPUN = 'O' and -C JOB <> 'X'; -C LDA >= 1, otherwise. -C -C T (input/output) DOUBLE PRECISION array, dimension -C (LDT,N) -C If FACT = 'F', then on entry the leading N-by-N upper -C Hessenberg part of this array must contain the upper -C quasi-triangular matrix T in Schur canonical form from a -C Schur factorization of A. -C If FACT = 'N', then this array need not be set on input. -C On exit, (if INFO = 0 or INFO = N+1, for FACT = 'N') the -C leading N-by-N upper Hessenberg part of this array -C contains the upper quasi-triangular matrix T in Schur -C canonical form from a Schur factorization of A. -C The contents of array T is not modified if FACT = 'F'. -C -C LDT INTEGER -C The leading dimension of the array T. LDT >= MAX(1,N). -C -C U (input or output) DOUBLE PRECISION array, dimension -C (LDU,N) -C If LYAPUN = 'O' and FACT = 'F', then U is an input -C argument and on entry, the leading N-by-N part of this -C array must contain the orthogonal matrix U from a real -C Schur factorization of A. -C If LYAPUN = 'O' and FACT = 'N', then U is an output -C argument and on exit, if INFO = 0 or INFO = N+1, it -C contains the orthogonal N-by-N matrix from a real Schur -C factorization of A. -C If LYAPUN = 'R', the array U is not referenced. -C -C LDU INTEGER -C The leading dimension of the array U. -C LDU >= 1, if LYAPUN = 'R'; -C LDU >= MAX(1,N), if LYAPUN = 'O'. -C -C C (input) DOUBLE PRECISION array, dimension (LDC,N) -C If JOB <> 'S' and UPLO = 'U', the leading N-by-N upper -C triangular part of this array must contain the upper -C triangular part of the matrix C of the original Lyapunov -C equation (with matrix A), if LYAPUN = 'O', or of the -C reduced Lyapunov equation (with matrix T), if -C LYAPUN = 'R'. -C If JOB <> 'S' and UPLO = 'L', the leading N-by-N lower -C triangular part of this array must contain the lower -C triangular part of the matrix C of the original Lyapunov -C equation (with matrix A), if LYAPUN = 'O', or of the -C reduced Lyapunov equation (with matrix T), if -C LYAPUN = 'R'. -C The remaining strictly triangular part of this array is -C used as workspace. -C If JOB = 'X', then this array may be identified with X -C in the call of this routine. -C If JOB = 'S', the array C is not referenced. -C -C LDC INTEGER -C The leading dimension of the array C. -C LDC >= 1, if JOB = 'S'; -C LDC >= MAX(1,N), otherwise. -C -C X (input or output) DOUBLE PRECISION array, dimension -C (LDX,N) -C If JOB = 'C' or 'E', then X is an input argument and on -C entry, the leading N-by-N part of this array must contain -C the symmetric solution matrix X of the original Lyapunov -C equation (with matrix A), if LYAPUN = 'O', or of the -C reduced Lyapunov equation (with matrix T), if -C LYAPUN = 'R'. -C If JOB = 'X' or 'A', then X is an output argument and on -C exit, if INFO = 0 or INFO = N+1, the leading N-by-N part -C of this array contains the symmetric solution matrix X of -C of the original Lyapunov equation (with matrix A), if -C LYAPUN = 'O', or of the reduced Lyapunov equation (with -C matrix T), if LYAPUN = 'R'. -C If JOB = 'S', the array X is not referenced. -C -C LDX INTEGER -C The leading dimension of the array X. -C LDX >= 1, if JOB = 'S'; -C LDX >= MAX(1,N), otherwise. -C -C SEP (output) DOUBLE PRECISION -C If JOB = 'S' or JOB = 'C' or JOB = 'A', and INFO = 0 or -C INFO = N+1, SEP contains the estimated separation of the -C matrices op(A) and -op(A)', sep(op(A),-op(A)'). -C If N = 0, or X = 0, or JOB = 'X' or JOB = 'E', SEP is not -C referenced. -C -C RCOND (output) DOUBLE PRECISION -C If JOB = 'C' or JOB = 'A', an estimate of the reciprocal -C condition number of the continuous-time Lyapunov equation. -C If N = 0 or X = 0, RCOND is set to 1 or 0, respectively. -C If JOB = 'X' or JOB = 'S' or JOB = 'E', RCOND is not -C referenced. -C -C FERR (output) DOUBLE PRECISION -C If JOB = 'E' or JOB = 'A', and INFO = 0 or INFO = N+1, -C FERR contains an estimated forward error bound for the -C solution X. If XTRUE is the true solution, FERR bounds the -C relative error in the computed solution, measured in the -C Frobenius norm: norm(X - XTRUE)/norm(XTRUE). -C If N = 0 or X = 0, FERR is set to 0. -C If JOB = 'X' or JOB = 'S' or JOB = 'C', FERR is not -C referenced. -C -C WR (output) DOUBLE PRECISION array, dimension (N) -C WI (output) DOUBLE PRECISION array, dimension (N) -C If FACT = 'N', and INFO = 0 or INFO = N+1, WR and WI -C contain the real and imaginary parts, respectively, of the -C eigenvalues of A. -C If FACT = 'F', WR and WI are not referenced. -C -C Workspace -C -C IWORK INTEGER array, dimension (N*N) -C This array is not referenced if JOB = 'X'. -C -C DWORK DOUBLE PRECISION array, dimension (LDWORK) -C On exit, if INFO = 0 or INFO = N+1, DWORK(1) returns the -C optimal value of LDWORK. -C -C LDWORK INTEGER -C The length of the array DWORK. -C If JOB = 'X', then -C LDWORK >= MAX(1,N*N), if FACT = 'F'; -C LDWORK >= MAX(1,MAX(N*N,3*N)), if FACT = 'N'. -C If JOB = 'S' or JOB = 'C', then -C LDWORK >= MAX(1,2*N*N), if FACT = 'F'; -C LDWORK >= MAX(1,2*N*N,3*N), if FACT = 'N'. -C If JOB = 'E', or JOB = 'A', and LYAPUN = 'O', then -C LDWORK >= MAX(1,3*N*N); -C If JOB = 'E', or JOB = 'A', and LYAPUN = 'R', then -C LDWORK >= MAX(1,3*N*N+N-1). -C For optimum performance LDWORK should sometimes be larger. -C -C Error Indicator -C -C INFO INTEGER -C = 0: successful exit; -C < 0: if INFO = -i, the i-th argument had an illegal -C value; -C > 0: if INFO = i, i <= N, the QR algorithm failed to -C complete the reduction to Schur canonical form (see -C LAPACK Library routine DGEES); on exit, the matrix -C T(i+1:N,i+1:N) contains the partially converged -C Schur form, and the elements i+1:n of WR and WI -C contain the real and imaginary parts, respectively, -C of the converged eigenvalues; this error is unlikely -C to appear; -C = N+1: if the matrices T and -T' have common or very -C close eigenvalues; perturbed values were used to -C solve Lyapunov equations, but the matrix T, if given -C (for FACT = 'F'), is unchanged. -C -C METHOD -C -C After reducing matrix A to real Schur canonical form (if needed), -C the Bartels-Stewart algorithm is used. A set of equivalent linear -C algebraic systems of equations of order at most four are formed -C and solved using Gaussian elimination with complete pivoting. -C -C The condition number of the continuous-time Lyapunov equation is -C estimated as -C -C cond = (norm(Theta)*norm(A) + norm(inv(Omega))*norm(C))/norm(X), -C -C where Omega and Theta are linear operators defined by -C -C Omega(W) = op(A)'*W + W*op(A), -C Theta(W) = inv(Omega(op(W)'*X + X*op(W))). -C -C The routine estimates the quantities -C -C sep(op(A),-op(A)') = 1 / norm(inv(Omega)) -C -C and norm(Theta) using 1-norm condition estimators. -C -C The forward error bound is estimated using a practical error bound -C similar to the one proposed in [2]. -C -C REFERENCES -C -C [1] Bartels, R.H. and Stewart, G.W. T -C Solution of the matrix equation A X + XB = C. -C Comm. A.C.M., 15, pp. 820-826, 1972. -C -C [2] Higham, N.J. -C Perturbation theory and backward error for AX-XB=C. -C BIT, vol. 33, pp. 124-136, 1993. -C -C NUMERICAL ASPECTS -C 3 -C The algorithm requires 0(N ) operations. -C The accuracy of the estimates obtained depends on the solution -C accuracy and on the properties of the 1-norm estimator. -C -C FURTHER COMMENTS -C -C The separation of op(A) and -op(A)' can also be defined as -C -C sep( op(A), -op(A)' ) = sigma_min( T ), -C -C where sigma_min(T) is the smallest singular value of the -C N*N-by-N*N matrix -C -C T = kprod( I(N), op(A)' ) + kprod( op(A)', I(N) ). -C -C I(N) is an N-by-N identity matrix, and kprod denotes the Kronecker -C product. The routine estimates sigma_min(T) by the reciprocal of -C an estimate of the 1-norm of inverse(T). The true reciprocal -C 1-norm of inverse(T) cannot differ from sigma_min(T) by more -C than a factor of N. -C -C CONTRIBUTOR -C -C V. Sima, Katholieke Univ. Leuven, Belgium, February 1999. -C This is an extended and improved version of Release 3.0 routine -C SB03RD. -C -C REVISIONS -C -C V. Sima, Research Institute for Informatics, Bucharest, Oct. 2004. -C -C KEYWORDS -C -C Lyapunov equation, orthogonal transformation, real Schur form. -C -C ****************************************************************** -C -C .. Parameters .. - DOUBLE PRECISION ZERO, ONE, HALF - PARAMETER ( ZERO = 0.0D+0, ONE = 1.0D+0, HALF = 0.5D+0 ) -C .. -C .. Scalar Arguments .. - CHARACTER FACT, JOB, LYAPUN, TRANA, UPLO - INTEGER INFO, LDA, LDC, LDT, LDU, LDWORK, LDX, N - DOUBLE PRECISION FERR, RCOND, SCALE, SEP -C .. -C .. Array Arguments .. - INTEGER IWORK( * ) - DOUBLE PRECISION A( LDA, * ), C( LDC, * ), DWORK( * ), - $ T( LDT, * ), U( LDU, * ), WI( * ), WR( * ), - $ X( LDX, * ) -C .. -C .. Local Scalars .. - LOGICAL JOBA, JOBC, JOBE, JOBS, JOBX, LOWER, NOFACT, - $ NOTRNA, UPDATE - CHARACTER CFACT, JOBL, SJOB - INTEGER LDW, NN, SDIM - DOUBLE PRECISION THNORM -C .. -C .. Local Arrays .. - LOGICAL BWORK( 1 ) -C .. -C .. External Functions .. - LOGICAL LSAME, SELECT - EXTERNAL LSAME, SELECT -C .. -C .. External Subroutines .. - EXTERNAL DGEES, DLACPY, DSCAL, MA02ED, MB01RU, SB03MY, - $ SB03QD, SB03QY, XERBLA -C .. -C .. Intrinsic Functions .. - INTRINSIC DBLE, INT, MAX -C .. -C .. Executable Statements .. -C -C Decode option parameters. -C - JOBX = LSAME( JOB, 'X' ) - JOBS = LSAME( JOB, 'S' ) - JOBC = LSAME( JOB, 'C' ) - JOBE = LSAME( JOB, 'E' ) - JOBA = LSAME( JOB, 'A' ) - NOFACT = LSAME( FACT, 'N' ) - NOTRNA = LSAME( TRANA, 'N' ) - LOWER = LSAME( UPLO, 'L' ) - UPDATE = LSAME( LYAPUN, 'O' ) -C -C Compute workspace. -C - NN = N*N - IF( JOBX ) THEN - LDW = NN - ELSE IF( JOBS .OR. JOBC ) THEN - LDW = 2*NN - ELSE - LDW = 3*NN - END IF - IF( ( JOBE .OR. JOBA ).AND. .NOT.UPDATE ) - $ LDW = LDW + N - 1 - IF( NOFACT ) - $ LDW = MAX( LDW, 3*N ) -C -C Test the scalar input parameters. -C - INFO = 0 - IF( .NOT.( JOBX .OR. JOBS .OR. JOBC .OR. JOBE .OR. JOBA ) ) THEN - INFO = -1 - ELSE IF( .NOT.( NOFACT .OR. LSAME( FACT, 'F' ) ) ) THEN - INFO = -2 - ELSE IF( .NOT.( NOTRNA .OR. LSAME( TRANA, 'T' ) .OR. - $ LSAME( TRANA, 'C' ) ) ) THEN - INFO = -3 - ELSE IF( .NOT.( LOWER .OR. LSAME( UPLO, 'U' ) ) ) THEN - INFO = -4 - ELSE IF( .NOT.( UPDATE .OR. LSAME( LYAPUN, 'R' ) ) ) THEN - INFO = -5 - ELSE IF( N.LT.0 ) THEN - INFO = -6 - ELSE IF( ( JOBC .OR. JOBE ) .AND. - $ ( SCALE.LT.ZERO .OR. SCALE.GT.ONE ) )THEN - INFO = -7 - ELSE IF( LDA.LT.1 .OR. - $ ( LDA.LT.N .AND. ( ( UPDATE .AND. .NOT.JOBX ) .OR. - $ NOFACT ) ) ) THEN - INFO = -9 - ELSE IF( LDT.LT.MAX( 1, N ) ) THEN - INFO = -11 - ELSE IF( LDU.LT.1 .OR. ( LDU.LT.N .AND. UPDATE ) ) THEN - INFO = -13 - ELSE IF( LDC.LT.1 .OR. ( .NOT.JOBS .AND. LDC.LT.N ) ) THEN - INFO = -15 - ELSE IF( LDX.LT.1 .OR. ( .NOT.JOBS .AND. LDX.LT.N ) ) THEN - INFO = -17 - ELSE IF( LDWORK.LT.1 .OR. ( LDWORK.LT.LDW ) ) THEN - INFO = -25 - END IF -C - IF( INFO.NE.0 ) THEN - CALL XERBLA( 'SB03TD', -INFO ) - RETURN - END IF -C -C Quick return if possible. -C - IF( N.EQ.0 ) THEN - IF( JOBX .OR. JOBA ) - $ SCALE = ONE - IF( JOBC .OR. JOBA ) - $ RCOND = ONE - IF( JOBE .OR. JOBA ) - $ FERR = ZERO - DWORK( 1 ) = ONE - RETURN - END IF -C - IF( NOFACT ) THEN -C -C Compute the Schur factorization of A. -C Workspace: need 3*N; -C prefer larger. -C - CALL DLACPY( 'Full', N, N, A, LDA, T, LDT ) - IF( UPDATE ) THEN - SJOB = 'V' - ELSE - SJOB = 'N' - END IF - CALL DGEES( SJOB, 'Not ordered', SELECT, N, T, LDT, SDIM, WR, - $ WI, U, LDU, DWORK, LDWORK, BWORK, INFO ) - IF( INFO.GT.0 ) - $ RETURN - CFACT = 'F' - ELSE - CFACT = FACT - END IF -C - IF( JOBX .OR. JOBA ) THEN -C -C Copy the right-hand side in X. -C - CALL DLACPY( UPLO, N, N, C, LDC, X, LDX ) -C - IF( UPDATE ) THEN -C -C Transform the right-hand side. -C Workspace: need N*N. -C - CALL MB01RU( UPLO, 'Transpose', N, N, ZERO, ONE, X, LDX, U, - $ LDU, X, LDX, DWORK, LDWORK, INFO ) - CALL DSCAL( N, HALF, X, LDX+1 ) - END IF -C -C Fill in the remaining triangle of X. -C - CALL MA02ED( UPLO, N, X, LDX ) -C -C Solve the transformed equation. -C - CALL SB03MY( TRANA, N, T, LDT, X, LDX, SCALE, INFO ) - IF( INFO.GT.0 ) - $ INFO = N + 1 -C - IF( UPDATE ) THEN -C -C Transform back the solution. -C - CALL MB01RU( UPLO, 'No transpose', N, N, ZERO, ONE, X, LDX, - $ U, LDU, X, LDX, DWORK, LDWORK, INFO ) - CALL DSCAL( N, HALF, X, LDX+1 ) -C -C Fill in the remaining triangle of X. -C - CALL MA02ED( UPLO, N, X, LDX ) - END IF - END IF -C - IF( JOBS ) THEN -C -C Estimate sep(op(A),-op(A)'). -C Workspace: 2*N*N. -C - CALL SB03QY( 'Separation', TRANA, LYAPUN, N, T, LDT, U, LDU, X, - $ LDX, SEP, THNORM, IWORK, DWORK, LDWORK, INFO ) -C - ELSE IF( .NOT.JOBX ) THEN -C -C Estimate the reciprocal condition and/or the error bound. -C Workspace: 2*N*N, if JOB = 'C'; -C 3*N*N + a*(N-1), where: -C a = 1, if JOB = 'E' or JOB = 'A', and LYAPUN = 'R'; -C a = 0, otherwise. -C - IF( JOBA ) THEN - JOBL = 'B' - ELSE - JOBL = JOB - END IF - CALL SB03QD( JOBL, CFACT, TRANA, UPLO, LYAPUN, N, SCALE, A, - $ LDA, T, LDT, U, LDU, C, LDC, X, LDX, SEP, RCOND, - $ FERR, IWORK, DWORK, LDWORK, INFO ) - LDW = MAX( LDW, INT( DWORK( 1 ) ) ) - END IF -C - DWORK( 1 ) = DBLE( LDW ) -C - RETURN -C *** Last line of SB03TD *** - END diff --git a/mex/sources/libslicot/SB03UD.f b/mex/sources/libslicot/SB03UD.f deleted file mode 100644 index f09443eb7..000000000 --- a/mex/sources/libslicot/SB03UD.f +++ /dev/null @@ -1,554 +0,0 @@ - SUBROUTINE SB03UD( JOB, FACT, TRANA, UPLO, LYAPUN, N, SCALE, A, - $ LDA, T, LDT, U, LDU, C, LDC, X, LDX, SEPD, - $ RCOND, FERR, WR, WI, IWORK, DWORK, LDWORK, - $ INFO ) -C -C SLICOT RELEASE 5.0. -C -C Copyright (c) 2002-2009 NICONET e.V. -C -C This program is free software: you can redistribute it and/or -C modify it under the terms of the GNU General Public License as -C published by the Free Software Foundation, either version 2 of -C the License, or (at your option) any later version. -C -C This program is distributed in the hope that it will be useful, -C but WITHOUT ANY WARRANTY; without even the implied warranty of -C MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the -C GNU General Public License for more details. -C -C You should have received a copy of the GNU General Public License -C along with this program. If not, see -C . -C -C PURPOSE -C -C To solve the real discrete-time Lyapunov matrix equation -C -C op(A)'*X*op(A) - X = scale*C, -C -C estimate the conditioning, and compute an error bound on the -C solution X, where op(A) = A or A' (A**T), the matrix A is N-by-N, -C the right hand side C and the solution X are N-by-N symmetric -C matrices (C = C', X = X'), and scale is an output scale factor, -C set less than or equal to 1 to avoid overflow in X. -C -C ARGUMENTS -C -C Mode Parameters -C -C JOB CHARACTER*1 -C Specifies the computation to be performed, as follows: -C = 'X': Compute the solution only; -C = 'S': Compute the separation only; -C = 'C': Compute the reciprocal condition number only; -C = 'E': Compute the error bound only; -C = 'A': Compute all: the solution, separation, reciprocal -C condition number, and the error bound. -C -C FACT CHARACTER*1 -C Specifies whether or not the real Schur factorization -C of the matrix A is supplied on entry, as follows: -C = 'F': On entry, T and U (if LYAPUN = 'O') contain the -C factors from the real Schur factorization of the -C matrix A; -C = 'N': The Schur factorization of A will be computed -C and the factors will be stored in T and U (if -C LYAPUN = 'O'). -C -C TRANA CHARACTER*1 -C Specifies the form of op(A) to be used, as follows: -C = 'N': op(A) = A (No transpose); -C = 'T': op(A) = A**T (Transpose); -C = 'C': op(A) = A**T (Conjugate transpose = Transpose). -C -C UPLO CHARACTER*1 -C Specifies which part of the symmetric matrix C is to be -C used, as follows: -C = 'U': Upper triangular part; -C = 'L': Lower triangular part. -C -C LYAPUN CHARACTER*1 -C Specifies whether or not the original or "reduced" -C Lyapunov equations should be solved, as follows: -C = 'O': Solve the original Lyapunov equations, updating -C the right-hand sides and solutions with the -C matrix U, e.g., X <-- U'*X*U; -C = 'R': Solve reduced Lyapunov equations only, without -C updating the right-hand sides and solutions. -C This means that a real Schur form T of A appears -C in the equation, instead of A. -C -C Input/Output Parameters -C -C N (input) INTEGER -C The order of the matrices A, X, and C. N >= 0. -C -C SCALE (input or output) DOUBLE PRECISION -C If JOB = 'C' or JOB = 'E', SCALE is an input argument: -C the scale factor, set by a Lyapunov solver. -C 0 <= SCALE <= 1. -C If JOB = 'X' or JOB = 'A', SCALE is an output argument: -C the scale factor, scale, set less than or equal to 1 to -C prevent the solution overflowing. -C If JOB = 'S', this argument is not used. -C -C A (input) DOUBLE PRECISION array, dimension (LDA,N) -C If FACT = 'N' or (LYAPUN = 'O' and JOB <> 'X'), the -C leading N-by-N part of this array must contain the -C original matrix A. -C If FACT = 'F' and (LYAPUN = 'R' or JOB = 'X'), A is -C not referenced. -C -C LDA INTEGER -C The leading dimension of the array A. -C LDA >= MAX(1,N), if FACT = 'N' or LYAPUN = 'O' and -C JOB <> 'X'; -C LDA >= 1, otherwise. -C -C T (input/output) DOUBLE PRECISION array, dimension -C (LDT,N) -C If FACT = 'F', then on entry the leading N-by-N upper -C Hessenberg part of this array must contain the upper -C quasi-triangular matrix T in Schur canonical form from a -C Schur factorization of A. -C If FACT = 'N', then this array need not be set on input. -C On exit, (if INFO = 0 or INFO = N+1, for FACT = 'N') the -C leading N-by-N upper Hessenberg part of this array -C contains the upper quasi-triangular matrix T in Schur -C canonical form from a Schur factorization of A. -C The contents of array T is not modified if FACT = 'F'. -C -C LDT INTEGER -C The leading dimension of the array T. LDT >= MAX(1,N). -C -C U (input or output) DOUBLE PRECISION array, dimension -C (LDU,N) -C If LYAPUN = 'O' and FACT = 'F', then U is an input -C argument and on entry, the leading N-by-N part of this -C array must contain the orthogonal matrix U from a real -C Schur factorization of A. -C If LYAPUN = 'O' and FACT = 'N', then U is an output -C argument and on exit, if INFO = 0 or INFO = N+1, it -C contains the orthogonal N-by-N matrix from a real Schur -C factorization of A. -C If LYAPUN = 'R', the array U is not referenced. -C -C LDU INTEGER -C The leading dimension of the array U. -C LDU >= 1, if LYAPUN = 'R'; -C LDU >= MAX(1,N), if LYAPUN = 'O'. -C -C C (input) DOUBLE PRECISION array, dimension (LDC,N) -C If JOB <> 'S' and UPLO = 'U', the leading N-by-N upper -C triangular part of this array must contain the upper -C triangular part of the matrix C of the original Lyapunov -C equation (with matrix A), if LYAPUN = 'O', or of the -C reduced Lyapunov equation (with matrix T), if -C LYAPUN = 'R'. -C If JOB <> 'S' and UPLO = 'L', the leading N-by-N lower -C triangular part of this array must contain the lower -C triangular part of the matrix C of the original Lyapunov -C equation (with matrix A), if LYAPUN = 'O', or of the -C reduced Lyapunov equation (with matrix T), if -C LYAPUN = 'R'. -C The remaining strictly triangular part of this array is -C used as workspace. -C If JOB = 'X', then this array may be identified with X -C in the call of this routine. -C If JOB = 'S', the array C is not referenced. -C -C LDC INTEGER -C The leading dimension of the array C. -C LDC >= 1, if JOB = 'S'; -C LDC >= MAX(1,N), otherwise. -C -C X (input or output) DOUBLE PRECISION array, dimension -C (LDX,N) -C If JOB = 'C' or 'E', then X is an input argument and on -C entry, the leading N-by-N part of this array must contain -C the symmetric solution matrix X of the original Lyapunov -C equation (with matrix A), if LYAPUN = 'O', or of the -C reduced Lyapunov equation (with matrix T), if -C LYAPUN = 'R'. -C If JOB = 'X' or 'A', then X is an output argument and on -C exit, if INFO = 0 or INFO = N+1, the leading N-by-N part -C of this array contains the symmetric solution matrix X of -C of the original Lyapunov equation (with matrix A), if -C LYAPUN = 'O', or of the reduced Lyapunov equation (with -C matrix T), if LYAPUN = 'R'. -C If JOB = 'S', the array X is not referenced. -C -C LDX INTEGER -C The leading dimension of the array X. -C LDX >= 1, if JOB = 'S'; -C LDX >= MAX(1,N), otherwise. -C -C SEPD (output) DOUBLE PRECISION -C If JOB = 'S' or JOB = 'C' or JOB = 'A', and INFO = 0 or -C INFO = N+1, SEPD contains the estimated separation of the -C matrices op(A) and op(A)', sepd(op(A),op(A)'). -C If N = 0, or X = 0, or JOB = 'X' or JOB = 'E', SEPD is not -C referenced. -C -C RCOND (output) DOUBLE PRECISION -C If JOB = 'C' or JOB = 'A', an estimate of the reciprocal -C condition number of the continuous-time Lyapunov equation. -C If N = 0 or X = 0, RCOND is set to 1 or 0, respectively. -C If JOB = 'X' or JOB = 'S' or JOB = 'E', RCOND is not -C referenced. -C -C FERR (output) DOUBLE PRECISION -C If JOB = 'E' or JOB = 'A', and INFO = 0 or INFO = N+1, -C FERR contains an estimated forward error bound for the -C solution X. If XTRUE is the true solution, FERR bounds the -C relative error in the computed solution, measured in the -C Frobenius norm: norm(X - XTRUE)/norm(XTRUE). -C If N = 0 or X = 0, FERR is set to 0. -C If JOB = 'X' or JOB = 'S' or JOB = 'C', FERR is not -C referenced. -C -C WR (output) DOUBLE PRECISION array, dimension (N) -C WI (output) DOUBLE PRECISION array, dimension (N) -C If FACT = 'N', and INFO = 0 or INFO = N+1, WR and WI -C contain the real and imaginary parts, respectively, of the -C eigenvalues of A. -C If FACT = 'F', WR and WI are not referenced. -C -C Workspace -C -C IWORK INTEGER array, dimension (N*N) -C This array is not referenced if JOB = 'X'. -C -C DWORK DOUBLE PRECISION array, dimension (LDWORK) -C On exit, if INFO = 0 or INFO = N+1, DWORK(1) returns the -C optimal value of LDWORK. -C -C LDWORK INTEGER -C The length of the array DWORK. -C If JOB = 'X', then -C LDWORK >= MAX(1,N*N,2*N), if FACT = 'F'; -C LDWORK >= MAX(1,N*N,3*N), if FACT = 'N'. -C If JOB = 'S', then -C LDWORK >= MAX(3,2*N*N). -C If JOB = 'C', then -C LDWORK >= MAX(3,2*N*N) + N*N. -C If JOB = 'E', or JOB = 'A', then -C LDWORK >= MAX(3,2*N*N) + N*N + 2*N. -C For optimum performance LDWORK should sometimes be larger. -C -C Error Indicator -C -C INFO INTEGER -C = 0: successful exit; -C < 0: if INFO = -i, the i-th argument had an illegal -C value; -C > 0: if INFO = i, i <= N, the QR algorithm failed to -C complete the reduction to Schur canonical form (see -C LAPACK Library routine DGEES); on exit, the matrix -C T(i+1:N,i+1:N) contains the partially converged -C Schur form, and the elements i+1:n of WR and WI -C contain the real and imaginary parts, respectively, -C of the converged eigenvalues; this error is unlikely -C to appear; -C = N+1: if the matrix T has almost reciprocal eigenvalues; -C perturbed values were used to solve Lyapunov -C equations, but the matrix T, if given (for -C FACT = 'F'), is unchanged. -C -C METHOD -C -C After reducing matrix A to real Schur canonical form (if needed), -C a discrete-time version of the Bartels-Stewart algorithm is used. -C A set of equivalent linear algebraic systems of equations of order -C at most four are formed and solved using Gaussian elimination with -C complete pivoting. -C -C The condition number of the discrete-time Lyapunov equation is -C estimated as -C -C cond = (norm(Theta)*norm(A) + norm(inv(Omega))*norm(C))/norm(X), -C -C where Omega and Theta are linear operators defined by -C -C Omega(W) = op(A)'*W*op(A) - W, -C Theta(W) = inv(Omega(op(W)'*X*op(A) + op(A)'*X*op(W))). -C -C The routine estimates the quantities -C -C sepd(op(A),op(A)') = 1 / norm(inv(Omega)) -C -C and norm(Theta) using 1-norm condition estimators. -C -C The forward error bound is estimated using a practical error bound -C similar to the one proposed in [3]. -C -C REFERENCES -C -C [1] Barraud, A.Y. T -C A numerical algorithm to solve A XA - X = Q. -C IEEE Trans. Auto. Contr., AC-22, pp. 883-885, 1977. -C -C [2] Bartels, R.H. and Stewart, G.W. T -C Solution of the matrix equation A X + XB = C. -C Comm. A.C.M., 15, pp. 820-826, 1972. -C -C [3] Higham, N.J. -C Perturbation theory and backward error for AX-XB=C. -C BIT, vol. 33, pp. 124-136, 1993. -C -C NUMERICAL ASPECTS -C 3 -C The algorithm requires 0(N ) operations. -C The accuracy of the estimates obtained depends on the solution -C accuracy and on the properties of the 1-norm estimator. -C -C FURTHER COMMENTS -C -C The "separation" sepd of op(A) and op(A)' can also be defined as -C -C sepd( op(A), op(A)' ) = sigma_min( T ), -C -C where sigma_min(T) is the smallest singular value of the -C N*N-by-N*N matrix -C -C T = kprod( op(A)', op(A)' ) - I(N**2). -C -C I(N**2) is an N*N-by-N*N identity matrix, and kprod denotes the -C Kronecker product. The routine estimates sigma_min(T) by the -C reciprocal of an estimate of the 1-norm of inverse(T). The true -C reciprocal 1-norm of inverse(T) cannot differ from sigma_min(T) by -C more than a factor of N. -C -C CONTRIBUTOR -C -C V. Sima, Katholieke Univ. Leuven, Belgium, February 1999. -C This is an extended and improved version of Release 3.0 routine -C SB03PD. -C -C REVISIONS -C -C V. Sima, Research Institute for Informatics, Bucharest, Oct. 2004. -C -C KEYWORDS -C -C Lyapunov equation, orthogonal transformation, real Schur form, -C Sylvester equation. -C -C ****************************************************************** -C -C .. Parameters .. - DOUBLE PRECISION ZERO, ONE, HALF - PARAMETER ( ZERO = 0.0D+0, ONE = 1.0D+0, HALF = 0.5D+0 ) -C .. -C .. Scalar Arguments .. - CHARACTER FACT, JOB, LYAPUN, TRANA, UPLO - INTEGER INFO, LDA, LDC, LDT, LDU, LDWORK, LDX, N - DOUBLE PRECISION FERR, RCOND, SCALE, SEPD -C .. -C .. Array Arguments .. - INTEGER IWORK( * ) - DOUBLE PRECISION A( LDA, * ), C( LDC, * ), DWORK( * ), - $ T( LDT, * ), U( LDU, * ), WI( * ), WR( * ), - $ X( LDX, * ) -C .. -C .. Local Scalars .. - LOGICAL JOBA, JOBC, JOBE, JOBS, JOBX, LOWER, NOFACT, - $ NOTRNA, UPDATE - CHARACTER CFACT, JOBL, SJOB - INTEGER LDW, NN, SDIM - DOUBLE PRECISION THNORM -C .. -C .. Local Arrays .. - LOGICAL BWORK( 1 ) -C .. -C .. External Functions .. - LOGICAL LSAME, SELECT - EXTERNAL LSAME, SELECT -C .. -C .. External Subroutines .. - EXTERNAL DGEES, DLACPY, DSCAL, MA02ED, MB01RU, SB03MX, - $ SB03SD, SB03SY, XERBLA -C .. -C .. Intrinsic Functions .. - INTRINSIC DBLE, INT, MAX -C .. -C .. Executable Statements .. -C -C Decode option parameters. -C - JOBX = LSAME( JOB, 'X' ) - JOBS = LSAME( JOB, 'S' ) - JOBC = LSAME( JOB, 'C' ) - JOBE = LSAME( JOB, 'E' ) - JOBA = LSAME( JOB, 'A' ) - NOFACT = LSAME( FACT, 'N' ) - NOTRNA = LSAME( TRANA, 'N' ) - LOWER = LSAME( UPLO, 'L' ) - UPDATE = LSAME( LYAPUN, 'O' ) -C -C Compute workspace. -C - NN = N*N - IF( JOBX ) THEN - IF( NOFACT ) THEN - LDW = MAX( 1, NN, 3*N ) - ELSE - LDW = MAX( 1, NN, 2*N ) - END IF - ELSE IF( JOBS ) THEN - LDW = MAX( 3, 2*NN ) - ELSE IF( JOBC ) THEN - LDW = MAX( 3, 2*NN ) + NN - ELSE - LDW = MAX( 3, 2*NN ) + NN + 2*N - END IF -C -C Test the scalar input parameters. -C - INFO = 0 - IF( .NOT.( JOBX .OR. JOBS .OR. JOBC .OR. JOBE .OR. JOBA ) ) THEN - INFO = -1 - ELSE IF( .NOT.( NOFACT .OR. LSAME( FACT, 'F' ) ) ) THEN - INFO = -2 - ELSE IF( .NOT.( NOTRNA .OR. LSAME( TRANA, 'T' ) .OR. - $ LSAME( TRANA, 'C' ) ) ) THEN - INFO = -3 - ELSE IF( .NOT.( LOWER .OR. LSAME( UPLO, 'U' ) ) ) THEN - INFO = -4 - ELSE IF( .NOT.( UPDATE .OR. LSAME( LYAPUN, 'R' ) ) ) THEN - INFO = -5 - ELSE IF( N.LT.0 ) THEN - INFO = -6 - ELSE IF( ( JOBC .OR. JOBE ) .AND. - $ ( SCALE.LT.ZERO .OR. SCALE.GT.ONE ) )THEN - INFO = -7 - ELSE IF( LDA.LT.1 .OR. - $ ( LDA.LT.N .AND. ( ( UPDATE .AND. .NOT.JOBX ) .OR. - $ NOFACT ) ) ) THEN - INFO = -9 - ELSE IF( LDT.LT.MAX( 1, N ) ) THEN - INFO = -11 - ELSE IF( LDU.LT.1 .OR. ( LDU.LT.N .AND. UPDATE ) ) THEN - INFO = -13 - ELSE IF( LDC.LT.1 .OR. ( .NOT.JOBS .AND. LDC.LT.N ) ) THEN - INFO = -15 - ELSE IF( LDX.LT.1 .OR. ( .NOT.JOBS .AND. LDX.LT.N ) ) THEN - INFO = -17 - ELSE IF( LDWORK.LT.LDW ) THEN - INFO = -25 - END IF -C - IF( INFO.NE.0 ) THEN - CALL XERBLA( 'SB03UD', -INFO ) - RETURN - END IF -C -C Quick return if possible. -C - IF( N.EQ.0 ) THEN - IF( JOBX .OR. JOBA ) - $ SCALE = ONE - IF( JOBC .OR. JOBA ) - $ RCOND = ONE - IF( JOBE .OR. JOBA ) - $ FERR = ZERO - DWORK( 1 ) = ONE - RETURN - END IF -C - IF( NOFACT ) THEN -C -C Compute the Schur factorization of A. -C Workspace: need 3*N; -C prefer larger. -C - CALL DLACPY( 'Full', N, N, A, LDA, T, LDT ) - IF( UPDATE ) THEN - SJOB = 'V' - ELSE - SJOB = 'N' - END IF - CALL DGEES( SJOB, 'Not ordered', SELECT, N, T, LDT, SDIM, WR, - $ WI, U, LDU, DWORK, LDWORK, BWORK, INFO ) - IF( INFO.GT.0 ) - $ RETURN - LDW = MAX( LDW, INT( DWORK( 1 ) ) ) - CFACT = 'F' - ELSE - CFACT = FACT - END IF -C - IF( JOBX .OR. JOBA ) THEN -C -C Copy the right-hand side in X. -C - CALL DLACPY( UPLO, N, N, C, LDC, X, LDX ) -C - IF( UPDATE ) THEN -C -C Transform the right-hand side. -C Workspace: need N*N. -C - CALL MB01RU( UPLO, 'Transpose', N, N, ZERO, ONE, X, LDX, U, - $ LDU, X, LDX, DWORK, LDWORK, INFO ) - CALL DSCAL( N, HALF, X, LDX+1 ) - END IF -C -C Fill in the remaining triangle of X. -C - CALL MA02ED( UPLO, N, X, LDX ) -C -C Solve the transformed equation. -C Workspace: 2*N. -C - CALL SB03MX( TRANA, N, T, LDT, X, LDX, SCALE, DWORK, INFO ) - IF( INFO.GT.0 ) - $ INFO = N + 1 -C - IF( UPDATE ) THEN -C -C Transform back the solution. -C - CALL MB01RU( UPLO, 'No transpose', N, N, ZERO, ONE, X, LDX, - $ U, LDU, X, LDX, DWORK, LDWORK, INFO ) - CALL DSCAL( N, HALF, X, LDX+1 ) -C -C Fill in the remaining triangle of X. -C - CALL MA02ED( UPLO, N, X, LDX ) - END IF - END IF -C - IF( JOBS ) THEN -C -C Estimate sepd(op(A),op(A)'). -C Workspace: MAX(3,2*N*N). -C - CALL SB03SY( 'Separation', TRANA, LYAPUN, N, T, LDT, U, LDU, - $ DWORK, 1, SEPD, THNORM, IWORK, DWORK, LDWORK, - $ INFO ) -C - ELSE IF( .NOT.JOBX ) THEN -C -C Estimate the reciprocal condition and/or the error bound. -C Workspace: MAX(3,2*N*N) + N*N + a*N, where: -C a = 2, if JOB = 'E' or JOB = 'A'; -C a = 0, otherwise. -C - IF( JOBA ) THEN - JOBL = 'B' - ELSE - JOBL = JOB - END IF - CALL SB03SD( JOBL, CFACT, TRANA, UPLO, LYAPUN, N, SCALE, A, - $ LDA, T, LDT, U, LDU, C, LDC, X, LDX, SEPD, RCOND, - $ FERR, IWORK, DWORK, LDWORK, INFO ) - LDW = MAX( LDW, INT( DWORK( 1 ) ) ) - END IF -C - DWORK( 1 ) = DBLE( LDW ) -C - RETURN -C *** Last line of SB03UD *** - END diff --git a/mex/sources/libslicot/SB04MD.f b/mex/sources/libslicot/SB04MD.f deleted file mode 100644 index c618c8ac7..000000000 --- a/mex/sources/libslicot/SB04MD.f +++ /dev/null @@ -1,347 +0,0 @@ - SUBROUTINE SB04MD( N, M, A, LDA, B, LDB, C, LDC, Z, LDZ, IWORK, - $ DWORK, LDWORK, INFO ) -C -C SLICOT RELEASE 5.0. -C -C Copyright (c) 2002-2009 NICONET e.V. -C -C This program is free software: you can redistribute it and/or -C modify it under the terms of the GNU General Public License as -C published by the Free Software Foundation, either version 2 of -C the License, or (at your option) any later version. -C -C This program is distributed in the hope that it will be useful, -C but WITHOUT ANY WARRANTY; without even the implied warranty of -C MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the -C GNU General Public License for more details. -C -C You should have received a copy of the GNU General Public License -C along with this program. If not, see -C . -C -C PURPOSE -C -C To solve for X the continuous-time Sylvester equation -C -C AX + XB = C -C -C where A, B, C and X are general N-by-N, M-by-M, N-by-M and -C N-by-M matrices respectively. -C -C ARGUMENTS -C -C Input/Output Parameters -C -C N (input) INTEGER -C The order of the matrix A. N >= 0. -C -C M (input) INTEGER -C The order of the matrix B. M >= 0. -C -C A (input/output) DOUBLE PRECISION array, dimension (LDA,N) -C On entry, the leading N-by-N part of this array must -C contain the coefficient matrix A of the equation. -C On exit, the leading N-by-N upper Hessenberg part of this -C array contains the matrix H, and the remainder of the -C leading N-by-N part, together with the elements 2,3,...,N -C of array DWORK, contain the orthogonal transformation -C matrix U (stored in factored form). -C -C LDA INTEGER -C The leading dimension of array A. LDA >= MAX(1,N). -C -C B (input/output) DOUBLE PRECISION array, dimension (LDB,M) -C On entry, the leading M-by-M part of this array must -C contain the coefficient matrix B of the equation. -C On exit, the leading M-by-M part of this array contains -C the quasi-triangular Schur factor S of the matrix B'. -C -C LDB INTEGER -C The leading dimension of array B. LDB >= MAX(1,M). -C -C C (input/output) DOUBLE PRECISION array, dimension (LDC,M) -C On entry, the leading N-by-M part of this array must -C contain the coefficient matrix C of the equation. -C On exit, the leading N-by-M part of this array contains -C the solution matrix X of the problem. -C -C LDC INTEGER -C The leading dimension of array C. LDC >= MAX(1,N). -C -C Z (output) DOUBLE PRECISION array, dimension (LDZ,M) -C The leading M-by-M part of this array contains the -C orthogonal matrix Z used to transform B' to real upper -C Schur form. -C -C LDZ INTEGER -C The leading dimension of array Z. LDZ >= MAX(1,M). -C -C Workspace -C -C IWORK INTEGER array, dimension (4*N) -C -C DWORK DOUBLE PRECISION array, dimension (LDWORK) -C On exit, if INFO = 0, DWORK(1) returns the optimal value -C of LDWORK, and DWORK(2), DWORK(3),..., DWORK(N) contain -C the scalar factors of the elementary reflectors used to -C reduce A to upper Hessenberg form, as returned by LAPACK -C Library routine DGEHRD. -C -C LDWORK INTEGER -C The length of the array DWORK. -C LDWORK = MAX(1, 2*N*N + 8*N, 5*M, N + M). -C For optimum performance LDWORK should be larger. -C -C Error Indicator -C -C INFO INTEGER -C = 0: successful exit; -C < 0: if INFO = -i, the i-th argument had an illegal -C value; -C > 0: if INFO = i, 1 <= i <= M, the QR algorithm failed to -C compute all the eigenvalues (see LAPACK Library -C routine DGEES); -C > M: if a singular matrix was encountered whilst solving -C for the (INFO-M)-th column of matrix X. -C -C METHOD -C -C The matrix A is transformed to upper Hessenberg form H = U'AU by -C the orthogonal transformation matrix U; matrix B' is transformed -C to real upper Schur form S = Z'B'Z using the orthogonal -C transformation matrix Z. The matrix C is also multiplied by the -C transformations, F = U'CZ, and the solution matrix Y of the -C transformed system -C -C HY + YS' = F -C -C is computed by back substitution. Finally, the matrix Y is then -C multiplied by the orthogonal transformation matrices, X = UYZ', in -C order to obtain the solution matrix X to the original problem. -C -C REFERENCES -C -C [1] Golub, G.H., Nash, S. and Van Loan, C.F. -C A Hessenberg-Schur method for the problem AX + XB = C. -C IEEE Trans. Auto. Contr., AC-24, pp. 909-913, 1979. -C -C NUMERICAL ASPECTS -C 3 3 2 2 -C The algorithm requires about (5/3) N + 10 M + 5 N M + 2.5 M N -C operations and is backward stable. -C -C CONTRIBUTORS -C -C Release 3.0: V. Sima, Katholieke Univ. Leuven, Belgium, Aug. 1997. -C Supersedes Release 2.0 routine SB04AD by G. Golub, S. Nash, and -C C. Van Loan, Stanford University, California, United States of -C America, January 1982. -C -C REVISIONS -C -C V. Sima, Katholieke Univ. Leuven, Belgium, June 2000, Aug. 2000. -C -C KEYWORDS -C -C Hessenberg form, orthogonal transformation, real Schur form, -C Sylvester equation. -C -C ****************************************************************** -C -C .. Parameters .. - DOUBLE PRECISION ZERO, ONE - PARAMETER ( ZERO = 0.0D0, ONE = 1.0D0 ) -C .. Scalar Arguments .. - INTEGER INFO, LDA, LDB, LDC, LDWORK, LDZ, M, N -C .. Array Arguments .. - INTEGER IWORK(*) - DOUBLE PRECISION A(LDA,*), B(LDB,*), C(LDC,*), DWORK(*), Z(LDZ,*) -C .. Local Scalars .. - INTEGER I, IEIG, IFAIL, IHI, ILO, IND, ITAU, JWORK, - $ SDIM, WRKOPT -C .. Local Scalars .. - LOGICAL SELECT -C .. Local Arrays .. - LOGICAL BWORK(1) -C .. External Subroutines .. - EXTERNAL DCOPY, DGEES, DGEHRD, DGEMM, DGEMV, DLACPY, - $ DORMHR, DSWAP, SB04MU, SB04MY, XERBLA -C .. Intrinsic Functions .. - INTRINSIC INT, MAX -C .. Executable Statements .. -C - INFO = 0 -C -C Test the input scalar arguments. -C - IF( N.LT.0 ) THEN - INFO = -1 - ELSE IF( M.LT.0 ) THEN - INFO = -2 - ELSE IF( LDA.LT.MAX( 1, N ) ) THEN - INFO = -4 - ELSE IF( LDB.LT.MAX( 1, M ) ) THEN - INFO = -6 - ELSE IF( LDC.LT.MAX( 1, N ) ) THEN - INFO = -8 - ELSE IF( LDZ.LT.MAX( 1, M ) ) THEN - INFO = -10 - ELSE IF( LDWORK.LT.MAX( 1, 2*N*N + 8*N, 5*M, N + M ) ) THEN - INFO = -13 - END IF -C - IF ( INFO.NE.0 ) THEN -C -C Error return. -C - CALL XERBLA( 'SB04MD', -INFO ) - RETURN - END IF -C -C Quick return if possible. -C - IF ( N.EQ.0 .OR. M.EQ.0 ) THEN - DWORK(1) = ONE - RETURN - END IF -C - ILO = 1 - IHI = N - WRKOPT = 1 -C -C Step 1 : Reduce A to upper Hessenberg and B' to quasi-upper -C triangular. That is, H = U' * A * U (store U in factored -C form) and S = Z' * B' * Z (save Z). -C -C (Note: Comments in the code beginning "Workspace:" describe the -C minimal amount of real workspace needed at that point in the -C code, as well as the preferred amount for good performance. -C NB refers to the optimal block size for the immediately -C following subroutine, as returned by ILAENV.) -C - DO 20 I = 2, M - CALL DSWAP( I-1, B(1,I), 1, B(I,1), LDB ) - 20 CONTINUE -C -C Workspace: need 5*M; -C prefer larger. -C - IEIG = M + 1 - JWORK = IEIG + M - CALL DGEES( 'Vectors', 'Not ordered', SELECT, M, B, LDB, - $ SDIM, DWORK, DWORK(IEIG), Z, LDZ, DWORK(JWORK), - $ LDWORK-JWORK+1, BWORK, INFO ) - IF ( INFO.NE.0 ) - $ RETURN - WRKOPT = MAX( WRKOPT, INT( DWORK(JWORK) )+JWORK-1 ) -C -C Workspace: need 2*N; -C prefer N + N*NB. -C - ITAU = 2 - JWORK = ITAU + N - 1 - CALL DGEHRD( N, ILO, IHI, A, LDA, DWORK(ITAU), DWORK(JWORK), - $ LDWORK-JWORK+1, IFAIL ) - WRKOPT = MAX( WRKOPT, INT( DWORK(JWORK) )+JWORK-1 ) -C -C Step 2 : Form F = ( U' * C ) * Z. Use BLAS 3, if enough space. -C -C Workspace: need N + M; -C prefer N + M*NB. -C - CALL DORMHR( 'Left', 'Transpose', N, M, ILO, IHI, A, LDA, - $ DWORK(ITAU), C, LDC, DWORK(JWORK), LDWORK-JWORK+1, - $ IFAIL ) - WRKOPT = MAX( WRKOPT, INT( DWORK(JWORK) )+JWORK-1 ) -C - IF ( LDWORK.GE.JWORK - 1 + N*M ) THEN - CALL DGEMM( 'No transpose', 'No transpose', N, M, M, ONE, C, - $ LDC, Z, LDZ, ZERO, DWORK(JWORK), N ) - CALL DLACPY( 'Full', N, M, DWORK(JWORK), N, C, LDC ) - WRKOPT = MAX( WRKOPT, JWORK - 1 + N*M ) - ELSE -C - DO 40 I = 1, N - CALL DGEMV( 'Transpose', M, M, ONE, Z, LDZ, C(I,1), LDC, - $ ZERO, DWORK(JWORK), 1 ) - CALL DCOPY( M, DWORK(JWORK), 1, C(I,1), LDC ) - 40 CONTINUE -C - END IF -C - IND = M - 60 CONTINUE - IF ( IND.GT.1 ) THEN -C -C Step 3 : Solve H * Y + Y * S' = F for Y. -C - IF ( B(IND,IND-1).EQ.ZERO ) THEN -C -C Solve a special linear algebraic system of order N. -C Workspace: N*(N+1)/2 + 3*N. -C - CALL SB04MY( M, N, IND, A, LDA, B, LDB, C, LDC, - $ DWORK(JWORK), IWORK, INFO ) -C - IF ( INFO.NE.0 ) THEN - INFO = INFO + M - RETURN - END IF - WRKOPT = MAX( WRKOPT, JWORK + N*( N + 1 )/2 + 2*N - 1 ) - IND = IND - 1 - ELSE -C -C Solve a special linear algebraic system of order 2*N. -C Workspace: 2*N*N + 8*N; -C - CALL SB04MU( M, N, IND, A, LDA, B, LDB, C, LDC, - $ DWORK(JWORK), IWORK, INFO ) -C - IF ( INFO.NE.0 ) THEN - INFO = INFO + M - RETURN - END IF - WRKOPT = MAX( WRKOPT, JWORK + 2*N*N + 7*N - 1 ) - IND = IND - 2 - END IF - GO TO 60 - ELSE IF ( IND.EQ.1 ) THEN -C -C Solve a special linear algebraic system of order N. -C Workspace: N*(N+1)/2 + 3*N; -C - CALL SB04MY( M, N, IND, A, LDA, B, LDB, C, LDC, - $ DWORK(JWORK), IWORK, INFO ) - IF ( INFO.NE.0 ) THEN - INFO = INFO + M - RETURN - END IF - WRKOPT = MAX( WRKOPT, JWORK + N*( N + 1 )/2 + 2*N - 1 ) - END IF -C -C Step 4 : Form C = ( U * Y ) * Z'. Use BLAS 3, if enough space. -C -C Workspace: need N + M; -C prefer N + M*NB. -C - CALL DORMHR( 'Left', 'No transpose', N, M, ILO, IHI, A, LDA, - $ DWORK(ITAU), C, LDC, DWORK(JWORK), LDWORK-JWORK+1, - $ IFAIL ) - WRKOPT = MAX( WRKOPT, INT( DWORK(JWORK) )+JWORK-1 ) -C - IF ( LDWORK.GE.JWORK - 1 + N*M ) THEN - CALL DGEMM( 'No transpose', 'Transpose', N, M, M, ONE, C, LDC, - $ Z, LDZ, ZERO, DWORK(JWORK), N ) - CALL DLACPY( 'Full', N, M, DWORK(JWORK), N, C, LDC ) - ELSE -C - DO 80 I = 1, N - CALL DGEMV( 'No transpose', M, M, ONE, Z, LDZ, C(I,1), LDC, - $ ZERO, DWORK(JWORK), 1 ) - CALL DCOPY( M, DWORK(JWORK), 1, C(I,1), LDC ) - 80 CONTINUE - END IF -C - RETURN -C *** Last line of SB04MD *** - END diff --git a/mex/sources/libslicot/SB04MR.f b/mex/sources/libslicot/SB04MR.f deleted file mode 100644 index a8aa560cd..000000000 --- a/mex/sources/libslicot/SB04MR.f +++ /dev/null @@ -1,222 +0,0 @@ - SUBROUTINE SB04MR( M, D, IPR, INFO ) -C -C SLICOT RELEASE 5.0. -C -C Copyright (c) 2002-2009 NICONET e.V. -C -C This program is free software: you can redistribute it and/or -C modify it under the terms of the GNU General Public License as -C published by the Free Software Foundation, either version 2 of -C the License, or (at your option) any later version. -C -C This program is distributed in the hope that it will be useful, -C but WITHOUT ANY WARRANTY; without even the implied warranty of -C MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the -C GNU General Public License for more details. -C -C You should have received a copy of the GNU General Public License -C along with this program. If not, see -C . -C -C PURPOSE -C -C To solve a linear algebraic system of order M whose coefficient -C matrix has zeros below the second subdiagonal. The matrix is -C stored compactly, row-wise. -C -C ARGUMENTS -C -C Input/Output Parameters -C -C M (input) INTEGER -C The order of the system. M >= 0. -C Note that parameter M should have twice the value in the -C original problem (see SLICOT Library routine SB04MU). -C -C D (input/output) DOUBLE PRECISION array, dimension -C (M*(M+1)/2+3*M) -C On entry, the first M*(M+1)/2 + 2*M elements of this array -C must contain the coefficient matrix, stored compactly, -C row-wise, and the next M elements must contain the right -C hand side of the linear system, as set by SLICOT Library -C routine SB04MU. -C On exit, the content of this array is updated, the last M -C elements containing the solution with components -C interchanged (see IPR). -C -C IPR (output) INTEGER array, dimension (2*M) -C The leading M elements contain information about the -C row interchanges performed for solving the system. -C Specifically, the i-th component of the solution is -C specified by IPR(i). -C -C Error Indicator -C -C INFO INTEGER -C = 0: successful exit; -C = 1: if a singular matrix was encountered. -C -C METHOD -C -C Gaussian elimination with partial pivoting is used. The rows of -C the matrix are not actually permuted, only their indices are -C interchanged in array IPR. -C -C REFERENCES -C -C [1] Golub, G.H., Nash, S. and Van Loan, C.F. -C A Hessenberg-Schur method for the problem AX + XB = C. -C IEEE Trans. Auto. Contr., AC-24, pp. 909-913, 1979. -C -C NUMERICAL ASPECTS -C -C None. -C -C CONTRIBUTORS -C -C Release 3.0: V. Sima, Katholieke Univ. Leuven, Belgium, Sep. 1997. -C Supersedes Release 2.0 routine SB04AR by G. Golub, S. Nash, and -C C. Van Loan, Stanford University, California, United States of -C America, January 1982. -C -C REVISIONS -C -C - -C -C KEYWORDS -C -C Hessenberg form, orthogonal transformation, real Schur form, -C Sylvester equation. -C -C ****************************************************************** -C - DOUBLE PRECISION ZERO - PARAMETER ( ZERO = 0.0D0 ) -C .. Scalar Arguments .. - INTEGER INFO, M -C .. Array Arguments .. - INTEGER IPR(*) - DOUBLE PRECISION D(*) -C .. Local Scalars .. - INTEGER I, I1, I2, IPRM, IPRM1, J, K, L, M1, MPI, MPI1, - $ MPI2 - DOUBLE PRECISION D1, D2, D3, DMAX -C .. External Subroutines .. - EXTERNAL DAXPY -C .. Intrinsic Functions .. - INTRINSIC ABS -C .. Executable Statements .. -C - INFO = 0 - I2 = ( M*( M + 5 ) )/2 - MPI = M - IPRM = I2 - M1 = M - I1 = 1 -C - DO 20 I = 1, M - MPI = MPI + 1 - IPRM = IPRM + 1 - IPR(MPI) = I1 - IPR(I) = IPRM - I1 = I1 + M1 - IF ( I.GE.3 ) M1 = M1 - 1 - 20 CONTINUE -C - M1 = M - 1 - MPI1 = M + 1 -C -C Reduce to upper triangular form. -C - DO 80 I = 1, M1 - MPI = MPI1 - MPI1 = MPI1 + 1 - IPRM = IPR(MPI) - D1 = D(IPRM) - I1 = 2 - IF ( I.EQ.M1 ) I1 = 1 - MPI2 = MPI + I1 - L = 0 - DMAX = ABS( D1 ) -C - DO 40 J = MPI1, MPI2 - D2 = D(IPR(J)) - D3 = ABS( D2 ) - IF ( D3.GT.DMAX ) THEN - DMAX = D3 - D1 = D2 - L = J - MPI - END IF - 40 CONTINUE -C -C Check singularity. -C - IF ( DMAX.EQ.ZERO ) THEN - INFO = 1 - RETURN - END IF -C - IF ( L.GT.0 ) THEN -C -C Permute the row indices. -C - K = IPRM - J = MPI + L - IPRM = IPR(J) - IPR(J) = K - IPR(MPI) = IPRM - K = IPR(I) - I2 = I + L - IPR(I) = IPR(I2) - IPR(I2) = K - END IF - IPRM = IPRM + 1 -C -C Annihilate the subdiagonal elements of the matrix. -C - I2 = I - D3 = D(IPR(I)) -C - DO 60 J = MPI1, MPI2 - I2 = I2 + 1 - IPRM1 = IPR(J) - DMAX = -D(IPRM1)/D1 - D(IPR(I2)) = D(IPR(I2)) + DMAX*D3 - CALL DAXPY( M-I, DMAX, D(IPRM), 1, D(IPRM1+1), 1 ) - 60 CONTINUE -C - IPR(MPI1) = IPR(MPI1) + 1 - IF ( I.NE.M1 ) IPR(MPI2) = IPR(MPI2) + 1 - 80 CONTINUE -C - MPI = M + M - IPRM = IPR(MPI) -C -C Check singularity. -C - IF ( D(IPRM).EQ.ZERO ) THEN - INFO = 1 - RETURN - END IF -C -C Back substitution. -C - D(IPR(M)) = D(IPR(M))/D(IPRM) -C - DO 120 I = M1, 1, -1 - MPI = MPI - 1 - IPRM = IPR(MPI) - IPRM1 = IPRM - DMAX = ZERO -C - DO 100 K = I+1, M - IPRM1 = IPRM1 + 1 - DMAX = DMAX + D(IPR(K))*D(IPRM1) - 100 CONTINUE -C - D(IPR(I)) = ( D(IPR(I)) - DMAX )/D(IPRM) - 120 CONTINUE -C - RETURN -C *** Last line of SB04MR *** - END diff --git a/mex/sources/libslicot/SB04MU.f b/mex/sources/libslicot/SB04MU.f deleted file mode 100644 index ed3879eca..000000000 --- a/mex/sources/libslicot/SB04MU.f +++ /dev/null @@ -1,190 +0,0 @@ - SUBROUTINE SB04MU( N, M, IND, A, LDA, B, LDB, C, LDC, D, IPR, - $ INFO ) -C -C SLICOT RELEASE 5.0. -C -C Copyright (c) 2002-2009 NICONET e.V. -C -C This program is free software: you can redistribute it and/or -C modify it under the terms of the GNU General Public License as -C published by the Free Software Foundation, either version 2 of -C the License, or (at your option) any later version. -C -C This program is distributed in the hope that it will be useful, -C but WITHOUT ANY WARRANTY; without even the implied warranty of -C MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the -C GNU General Public License for more details. -C -C You should have received a copy of the GNU General Public License -C along with this program. If not, see -C . -C -C PURPOSE -C -C To construct and solve a linear algebraic system of order 2*M -C whose coefficient matrix has zeros below the second subdiagonal. -C Such systems appear when solving continuous-time Sylvester -C equations using the Hessenberg-Schur method. -C -C ARGUMENTS -C -C Input/Output Parameters -C -C N (input) INTEGER -C The order of the matrix B. N >= 0. -C -C M (input) INTEGER -C The order of the matrix A. M >= 0. -C -C IND (input) INTEGER -C IND and IND - 1 specify the indices of the columns in C -C to be computed. IND > 1. -C -C A (input) DOUBLE PRECISION array, dimension (LDA,M) -C The leading M-by-M part of this array must contain an -C upper Hessenberg matrix. -C -C LDA INTEGER -C The leading dimension of array A. LDA >= MAX(1,M). -C -C B (input) DOUBLE PRECISION array, dimension (LDB,N) -C The leading N-by-N part of this array must contain a -C matrix in real Schur form. -C -C LDB INTEGER -C The leading dimension of array B. LDB >= MAX(1,N). -C -C C (input/output) DOUBLE PRECISION array, dimension (LDC,N) -C On entry, the leading M-by-N part of this array must -C contain the coefficient matrix C of the equation. -C On exit, the leading M-by-N part of this array contains -C the matrix C with columns IND-1 and IND updated. -C -C LDC INTEGER -C The leading dimension of array C. LDC >= MAX(1,M). -C -C Workspace -C -C D DOUBLE PRECISION array, dimension (2*M*M+7*M) -C -C IPR INTEGER array, dimension (4*M) -C -C Error Indicator -C -C INFO INTEGER -C = 0: successful exit; -C > 0: if INFO = IND, a singular matrix was encountered. -C -C METHOD -C -C A special linear algebraic system of order 2*M, whose coefficient -C matrix has zeros below the second subdiagonal is constructed and -C solved. The coefficient matrix is stored compactly, row-wise. -C -C REFERENCES -C -C [1] Golub, G.H., Nash, S. and Van Loan, C.F. -C A Hessenberg-Schur method for the problem AX + XB = C. -C IEEE Trans. Auto. Contr., AC-24, pp. 909-913, 1979. -C -C NUMERICAL ASPECTS -C -C None. -C -C CONTRIBUTORS -C -C Release 3.0: V. Sima, Katholieke Univ. Leuven, Belgium, Sep. 1997. -C Supersedes Release 2.0 routine SB04AU by G. Golub, S. Nash, and -C C. Van Loan, Stanford University, California, United States of -C America, January 1982. -C -C REVISIONS -C -C - -C -C KEYWORDS -C -C Hessenberg form, orthogonal transformation, real Schur form, -C Sylvester equation. -C -C ****************************************************************** -C - DOUBLE PRECISION ZERO - PARAMETER ( ZERO = 0.0D0 ) -C .. Scalar Arguments .. - INTEGER INFO, IND, LDA, LDB, LDC, M, N -C .. Array Arguments .. - INTEGER IPR(*) - DOUBLE PRECISION A(LDA,*), B(LDB,*), C(LDC,*), D(*) -C .. Local Scalars .. - INTEGER I, I2, IND1, J, K, K1, K2, M2 - DOUBLE PRECISION TEMP -C .. External Subroutines .. - EXTERNAL DAXPY, SB04MR -C .. Intrinsic Functions .. - INTRINSIC MAX, MIN -C .. Executable Statements .. -C - IND1 = IND - 1 -C - DO 20 I = IND + 1, N - CALL DAXPY( M, -B(IND1,I), C(1,I), 1, C(1,IND1), 1 ) - CALL DAXPY( M, -B(IND,I), C(1,I), 1, C(1,IND), 1 ) - 20 CONTINUE -C -C Construct the linear algebraic system of order 2*M. -C - K1 = -1 - M2 = 2*M - I2 = M*(M2 + 5) - K = M2 -C - DO 60 I = 1, M -C - DO 40 J = MAX( 1, I - 1 ), M - K1 = K1 + 2 - K2 = K1 + K - TEMP = A(I,J) - IF ( I.NE.J ) THEN - D(K1) = TEMP - D(K1+1) = ZERO - IF ( J.GT.I ) D(K2) = ZERO - D(K2+1) = TEMP - ELSE - D(K1) = TEMP + B(IND1,IND1) - D(K1+1) = B(IND1,IND) - D(K2) = B(IND,IND1) - D(K2+1) = TEMP + B(IND,IND) - END IF - 40 CONTINUE -C - K1 = K2 - K = K - MIN( 2, I ) -C -C Store the right hand side. -C - I2 = I2 + 2 - D(I2) = C(I,IND) - D(I2-1) = C(I,IND1) - 60 CONTINUE -C -C Solve the linear algebraic system and store the solution in C. -C - CALL SB04MR( M2, D, IPR, INFO ) -C - IF ( INFO.NE.0 ) THEN - INFO = IND - ELSE - I2 = 0 -C - DO 80 I = 1, M - I2 = I2 + 2 - C(I,IND1) = D(IPR(I2-1)) - C(I,IND) = D(IPR(I2)) - 80 CONTINUE -C - END IF -C - RETURN -C *** Last line of SB04MU *** - END diff --git a/mex/sources/libslicot/SB04MW.f b/mex/sources/libslicot/SB04MW.f deleted file mode 100644 index 9a56f4658..000000000 --- a/mex/sources/libslicot/SB04MW.f +++ /dev/null @@ -1,194 +0,0 @@ - SUBROUTINE SB04MW( M, D, IPR, INFO ) -C -C SLICOT RELEASE 5.0. -C -C Copyright (c) 2002-2009 NICONET e.V. -C -C This program is free software: you can redistribute it and/or -C modify it under the terms of the GNU General Public License as -C published by the Free Software Foundation, either version 2 of -C the License, or (at your option) any later version. -C -C This program is distributed in the hope that it will be useful, -C but WITHOUT ANY WARRANTY; without even the implied warranty of -C MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the -C GNU General Public License for more details. -C -C You should have received a copy of the GNU General Public License -C along with this program. If not, see -C . -C -C PURPOSE -C -C To solve a linear algebraic system of order M whose coefficient -C matrix is in upper Hessenberg form, stored compactly, row-wise. -C -C ARGUMENTS -C -C Input/Output Parameters -C -C M (input) INTEGER -C The order of the system. M >= 0. -C -C D (input/output) DOUBLE PRECISION array, dimension -C (M*(M+1)/2+2*M) -C On entry, the first M*(M+1)/2 + M elements of this array -C must contain an upper Hessenberg matrix, stored compactly, -C row-wise, and the next M elements must contain the right -C hand side of the linear system, as set by SLICOT Library -C routine SB04MY. -C On exit, the content of this array is updated, the last M -C elements containing the solution with components -C interchanged (see IPR). -C -C IPR (output) INTEGER array, dimension (2*M) -C The leading M elements contain information about the -C row interchanges performed for solving the system. -C Specifically, the i-th component of the solution is -C specified by IPR(i). -C -C Error Indicator -C -C INFO INTEGER -C = 0: successful exit; -C = 1: if a singular matrix was encountered. -C -C METHOD -C -C Gaussian elimination with partial pivoting is used. The rows of -C the matrix are not actually permuted, only their indices are -C interchanged in array IPR. -C -C REFERENCES -C -C [1] Golub, G.H., Nash, S. and Van Loan, C.F. -C A Hessenberg-Schur method for the problem AX + XB = C. -C IEEE Trans. Auto. Contr., AC-24, pp. 909-913, 1979. -C -C NUMERICAL ASPECTS -C -C None. -C -C CONTRIBUTORS -C -C Release 3.0: V. Sima, Katholieke Univ. Leuven, Belgium, Sep. 1997. -C Supersedes Release 2.0 routine SB04AW by G. Golub, S. Nash, and -C C. Van Loan, Stanford University, California, United States of -C America, January 1982. -C -C REVISIONS -C -C - -C -C KEYWORDS -C -C Hessenberg form, orthogonal transformation, real Schur form, -C Sylvester equation. -C -C ****************************************************************** -C - DOUBLE PRECISION ZERO - PARAMETER ( ZERO = 0.0D0 ) -C .. Scalar Arguments .. - INTEGER INFO, M -C .. Array Arguments .. - INTEGER IPR(*) - DOUBLE PRECISION D(*) -C .. Local Scalars .. - INTEGER I, I1, IPRM, IPRM1, K, M1, M2, MPI - DOUBLE PRECISION D1, D2, MULT -C .. External Subroutines .. - EXTERNAL DAXPY -C .. Intrinsic Functions .. - INTRINSIC ABS -C .. Executable Statements .. -C - INFO = 0 - M1 = ( M*( M + 3 ) )/2 - M2 = M + M - MPI = M - IPRM = M1 - M1 = M - I1 = 1 -C - DO 20 I = 1, M - MPI = MPI + 1 - IPRM = IPRM + 1 - IPR(MPI) = I1 - IPR(I) = IPRM - I1 = I1 + M1 - IF ( I.GT.1 ) M1 = M1 - 1 - 20 CONTINUE -C - M1 = M - 1 - MPI = M -C -C Reduce to upper triangular form. -C - DO 40 I = 1, M1 - I1 = I + 1 - MPI = MPI + 1 - IPRM = IPR(MPI) - IPRM1 = IPR(MPI+1) - D1 = D(IPRM) - D2 = D(IPRM1) - IF ( ABS( D1 ).LE.ABS( D2 ) ) THEN -C -C Permute the row indices. -C - K = IPRM - IPR(MPI) = IPRM1 - IPRM = IPRM1 - IPRM1 = K - K = IPR(I) - IPR(I) = IPR(I1) - IPR(I1) = K - D1 = D2 - END IF -C -C Check singularity. -C - IF ( D1.EQ.ZERO ) THEN - INFO = 1 - RETURN - END IF -C - MULT = -D(IPRM1)/D1 - IPRM1 = IPRM1 + 1 - IPR(MPI+1) = IPRM1 -C -C Annihilate the subdiagonal elements of the matrix. -C - D(IPR(I1)) = D(IPR(I1)) + MULT*D(IPR(I)) - CALL DAXPY( M-I, MULT, D(IPRM+1), 1, D(IPRM1), 1 ) - 40 CONTINUE -C -C Check singularity. -C - IF ( D(IPR(M2)).EQ.ZERO ) THEN - INFO = 1 - RETURN - END IF -C -C Back substitution. -C - D(IPR(M)) = D(IPR(M))/D(IPR(M2)) - MPI = M2 -C - DO 80 I = M1, 1, -1 - MPI = MPI - 1 - IPRM = IPR(MPI) - IPRM1 = IPRM - MULT = ZERO -C - DO 60 I1 = I + 1, M - IPRM1 = IPRM1 + 1 - MULT = MULT + D(IPR(I1))*D(IPRM1) - 60 CONTINUE -C - D(IPR(I)) = ( D(IPR(I)) - MULT )/D(IPRM) - 80 CONTINUE -C - RETURN -C *** Last line of SB04MW *** - END diff --git a/mex/sources/libslicot/SB04MY.f b/mex/sources/libslicot/SB04MY.f deleted file mode 100644 index d8e568e7d..000000000 --- a/mex/sources/libslicot/SB04MY.f +++ /dev/null @@ -1,168 +0,0 @@ - SUBROUTINE SB04MY( N, M, IND, A, LDA, B, LDB, C, LDC, D, IPR, - $ INFO ) -C -C SLICOT RELEASE 5.0. -C -C Copyright (c) 2002-2009 NICONET e.V. -C -C This program is free software: you can redistribute it and/or -C modify it under the terms of the GNU General Public License as -C published by the Free Software Foundation, either version 2 of -C the License, or (at your option) any later version. -C -C This program is distributed in the hope that it will be useful, -C but WITHOUT ANY WARRANTY; without even the implied warranty of -C MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the -C GNU General Public License for more details. -C -C You should have received a copy of the GNU General Public License -C along with this program. If not, see -C . -C -C PURPOSE -C -C To construct and solve a linear algebraic system of order M whose -C coefficient matrix is in upper Hessenberg form. Such systems -C appear when solving Sylvester equations using the Hessenberg-Schur -C method. -C -C ARGUMENTS -C -C Input/Output Parameters -C -C N (input) INTEGER -C The order of the matrix B. N >= 0. -C -C M (input) INTEGER -C The order of the matrix A. M >= 0. -C -C IND (input) INTEGER -C The index of the column in C to be computed. IND >= 1. -C -C A (input) DOUBLE PRECISION array, dimension (LDA,M) -C The leading M-by-M part of this array must contain an -C upper Hessenberg matrix. -C -C LDA INTEGER -C The leading dimension of array A. LDA >= MAX(1,M). -C -C B (input) DOUBLE PRECISION array, dimension (LDB,N) -C The leading N-by-N part of this array must contain a -C matrix in real Schur form. -C -C LDB INTEGER -C The leading dimension of array B. LDB >= MAX(1,N). -C -C C (input/output) DOUBLE PRECISION array, dimension (LDC,N) -C On entry, the leading M-by-N part of this array must -C contain the coefficient matrix C of the equation. -C On exit, the leading M-by-N part of this array contains -C the matrix C with column IND updated. -C -C LDC INTEGER -C The leading dimension of array C. LDC >= MAX(1,M). -C -C Workspace -C -C D DOUBLE PRECISION array, dimension (M*(M+1)/2+2*M) -C -C IPR INTEGER array, dimension (2*M) -C -C Error Indicator -C -C INFO INTEGER -C = 0: successful exit; -C > 0: if INFO = IND, a singular matrix was encountered. -C -C METHOD -C -C A special linear algebraic system of order M, with coefficient -C matrix in upper Hessenberg form is constructed and solved. The -C coefficient matrix is stored compactly, row-wise. -C -C REFERENCES -C -C [1] Golub, G.H., Nash, S. and Van Loan, C.F. -C A Hessenberg-Schur method for the problem AX + XB = C. -C IEEE Trans. Auto. Contr., AC-24, pp. 909-913, 1979. -C -C NUMERICAL ASPECTS -C -C None. -C -C CONTRIBUTORS -C -C Release 3.0: V. Sima, Katholieke Univ. Leuven, Belgium, Sep. 1997. -C Supersedes Release 2.0 routine SB04AY by G. Golub, S. Nash, and -C C. Van Loan, Stanford University, California, United States of -C America, January 1982. -C -C REVISIONS -C -C - -C -C KEYWORDS -C -C Hessenberg form, orthogonal transformation, real Schur form, -C Sylvester equation. -C -C ****************************************************************** -C -C .. Scalar Arguments .. - INTEGER INFO, IND, LDA, LDB, LDC, M, N -C .. Array Arguments .. - INTEGER IPR(*) - DOUBLE PRECISION A(LDA,*), B(LDB,*), C(LDC,*), D(*) -C .. Local Scalars .. - INTEGER I, I2, J, K, K1, K2, M1 -C .. External Subroutines .. - EXTERNAL DAXPY, DCOPY, SB04MW -C .. Intrinsic Functions .. - INTRINSIC MAX -C .. Executable Statements .. -C - DO 20 I = IND + 1, N - CALL DAXPY( M, -B(IND,I), C(1,I), 1, C(1,IND), 1 ) - 20 CONTINUE -C - M1 = M + 1 - I2 = ( M*M1 )/2 + M1 - K2 = 1 - K = M -C -C Construct the linear algebraic system of order M. -C - DO 40 I = 1, M - J = M1 - K - CALL DCOPY ( K, A(I,J), LDA, D(K2), 1 ) - K1 = K2 - K2 = K2 + K - IF ( I.GT.1 ) THEN - K1 = K1 + 1 - K = K - 1 - END IF - D(K1) = D(K1) + B(IND,IND) -C -C Store the right hand side. -C - D(I2) = C(I,IND) - I2 = I2 + 1 - 40 CONTINUE -C -C Solve the linear algebraic system and store the solution in C. -C - CALL SB04MW( M, D, IPR, INFO ) -C - IF ( INFO.NE.0 ) THEN - INFO = IND - ELSE -C - DO 60 I = 1, M - C(I,IND) = D(IPR(I)) - 60 CONTINUE -C - END IF -C - RETURN -C *** Last line of SB04MY *** - END diff --git a/mex/sources/libslicot/SB04ND.f b/mex/sources/libslicot/SB04ND.f deleted file mode 100644 index b567088ac..000000000 --- a/mex/sources/libslicot/SB04ND.f +++ /dev/null @@ -1,405 +0,0 @@ - SUBROUTINE SB04ND( ABSCHU, ULA, ULB, N, M, A, LDA, B, LDB, C, - $ LDC, TOL, IWORK, DWORK, LDWORK, INFO ) -C -C SLICOT RELEASE 5.0. -C -C Copyright (c) 2002-2009 NICONET e.V. -C -C This program is free software: you can redistribute it and/or -C modify it under the terms of the GNU General Public License as -C published by the Free Software Foundation, either version 2 of -C the License, or (at your option) any later version. -C -C This program is distributed in the hope that it will be useful, -C but WITHOUT ANY WARRANTY; without even the implied warranty of -C MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the -C GNU General Public License for more details. -C -C You should have received a copy of the GNU General Public License -C along with this program. If not, see -C . -C -C PURPOSE -C -C To solve for X the continuous-time Sylvester equation -C -C AX + XB = C, -C -C with at least one of the matrices A or B in Schur form and the -C other in Hessenberg or Schur form (both either upper or lower); -C A, B, C and X are N-by-N, M-by-M, N-by-M, and N-by-M matrices, -C respectively. -C -C ARGUMENTS -C -C Mode Parameters -C -C ABSCHU CHARACTER*1 -C Indicates whether A and/or B is/are in Schur or -C Hessenberg form as follows: -C = 'A': A is in Schur form, B is in Hessenberg form; -C = 'B': B is in Schur form, A is in Hessenberg form; -C = 'S': Both A and B are in Schur form. -C -C ULA CHARACTER*1 -C Indicates whether A is in upper or lower Schur form or -C upper or lower Hessenberg form as follows: -C = 'U': A is in upper Hessenberg form if ABSCHU = 'B' and -C upper Schur form otherwise; -C = 'L': A is in lower Hessenberg form if ABSCHU = 'B' and -C lower Schur form otherwise. -C -C ULB CHARACTER*1 -C Indicates whether B is in upper or lower Schur form or -C upper or lower Hessenberg form as follows: -C = 'U': B is in upper Hessenberg form if ABSCHU = 'A' and -C upper Schur form otherwise; -C = 'L': B is in lower Hessenberg form if ABSCHU = 'A' and -C lower Schur form otherwise. -C -C Input/Output Parameters -C -C N (input) INTEGER -C The order of the matrix A. N >= 0. -C -C M (input) INTEGER -C The order of the matrix B. M >= 0. -C -C A (input) DOUBLE PRECISION array, dimension (LDA,N) -C The leading N-by-N part of this array must contain the -C coefficient matrix A of the equation. -C -C LDA INTEGER -C The leading dimension of array A. LDA >= MAX(1,N). -C -C B (input) DOUBLE PRECISION array, dimension (LDB,M) -C The leading M-by-M part of this array must contain the -C coefficient matrix B of the equation. -C -C LDB INTEGER -C The leading dimension of array B. LDB >= MAX(1,M). -C -C C (input/output) DOUBLE PRECISION array, dimension (LDC,M) -C On entry, the leading N-by-M part of this array must -C contain the coefficient matrix C of the equation. -C On exit, if INFO = 0, the leading N-by-M part of this -C array contains the solution matrix X of the problem. -C -C LDC INTEGER -C The leading dimension of array C. LDC >= MAX(1,N). -C -C Tolerances -C -C TOL DOUBLE PRECISION -C The tolerance to be used to test for near singularity in -C the Sylvester equation. If the user sets TOL > 0, then the -C given value of TOL is used as a lower bound for the -C reciprocal condition number; a matrix whose estimated -C condition number is less than 1/TOL is considered to be -C nonsingular. If the user sets TOL <= 0, then a default -C tolerance, defined by TOLDEF = EPS, is used instead, where -C EPS is the machine precision (see LAPACK Library routine -C DLAMCH). -C This parameter is not referenced if ABSCHU = 'S', -C ULA = 'U', and ULB = 'U'. -C -C Workspace -C -C IWORK INTEGER array, dimension (2*MAX(M,N)) -C This parameter is not referenced if ABSCHU = 'S', -C ULA = 'U', and ULB = 'U'. -C -C DWORK DOUBLE PRECISION array, dimension (LDWORK) -C This parameter is not referenced if ABSCHU = 'S', -C ULA = 'U', and ULB = 'U'. -C -C LDWORK INTEGER -C The length of the array DWORK. -C LDWORK = 0, if ABSCHU = 'S', ULA = 'U', and ULB = 'U'; -C LDWORK = 2*MAX(M,N)*(4 + 2*MAX(M,N)), otherwise. -C -C Error Indicator -C -C INFO INTEGER -C = 0: successful exit; -C < 0: if INFO = -i, the i-th argument had an illegal -C value; -C = 1: if a (numerically) singular matrix T was encountered -C during the computation of the solution matrix X. -C That is, the estimated reciprocal condition number -C of T is less than or equal to TOL. -C -C METHOD -C -C Matrices A and B are assumed to be in (upper or lower) Hessenberg -C or Schur form (with at least one of them in Schur form). The -C solution matrix X is then computed by rows or columns via the back -C substitution scheme proposed by Golub, Nash and Van Loan (see -C [1]), which involves the solution of triangular systems of -C equations that are constructed recursively and which may be nearly -C singular if A and -B have close eigenvalues. If near singularity -C is detected, then the routine returns with the Error Indicator -C (INFO) set to 1. -C -C REFERENCES -C -C [1] Golub, G.H., Nash, S. and Van Loan, C.F. -C A Hessenberg-Schur method for the problem AX + XB = C. -C IEEE Trans. Auto. Contr., AC-24, pp. 909-913, 1979. -C -C NUMERICAL ASPECTS -C 2 2 -C The algorithm requires approximately 5M N + 0.5MN operations in -C 2 2 -C the worst case and 2.5M N + 0.5MN operations in the best case -C (where M is the order of the matrix in Hessenberg form and N is -C the order of the matrix in Schur form) and is mixed stable (see -C [1]). -C -C CONTRIBUTORS -C -C Release 3.0: V. Sima, Katholieke Univ. Leuven, Belgium, Aug. 1997. -C Supersedes Release 2.0 routine SB04BD by M. Vanbegin, and -C P. Van Dooren, Philips Research Laboratory, Brussels, Belgium. -C -C REVISIONS -C -C V. Sima, Research Institute for Informatics, Bucharest, Apr. 2000. -C -C KEYWORDS -C -C Hessenberg form, orthogonal transformation, real Schur form, -C Sylvester equation. -C -C ****************************************************************** -C -C .. Parameters .. - DOUBLE PRECISION ONE, ZERO - PARAMETER ( ONE = 1.0D0, ZERO = 0.0D0 ) -C .. Scalar Arguments .. - CHARACTER ABSCHU, ULA, ULB - INTEGER INFO, LDA, LDB, LDC, LDWORK, M, N - DOUBLE PRECISION TOL -C .. Array Arguments .. - INTEGER IWORK(*) - DOUBLE PRECISION A(LDA,*), B(LDB,*), C(LDC,*), DWORK(*) -C .. Local Scalars .. - CHARACTER ABSCHR - LOGICAL LABSCB, LABSCS, LULA, LULB - INTEGER FWD, I, IBEG, IEND, INCR, IPINCR, ISTEP, JWORK, - $ LDW, MAXMN - DOUBLE PRECISION SCALE, TOL1 -C .. External Functions .. - LOGICAL LSAME - DOUBLE PRECISION DLAMCH - EXTERNAL DLAMCH, LSAME -C .. External Subroutines .. - EXTERNAL DCOPY, DTRSYL, SB04NV, SB04NW, SB04NX, SB04NY, - $ XERBLA -C .. Intrinsic Functions .. - INTRINSIC MAX -C .. Executable Statements .. -C - INFO = 0 - MAXMN = MAX( M, N ) - LABSCB = LSAME( ABSCHU, 'B' ) - LABSCS = LSAME( ABSCHU, 'S' ) - LULA = LSAME( ULA, 'U' ) - LULB = LSAME( ULB, 'U' ) -C -C Test the input scalar arguments. -C - IF( .NOT.LABSCB .AND. .NOT.LABSCS .AND. - $ .NOT.LSAME( ABSCHU, 'A' ) ) THEN - INFO = -1 - ELSE IF( .NOT.LULA .AND. .NOT.LSAME( ULA, 'L' ) ) THEN - INFO = -2 - ELSE IF( .NOT.LULB .AND. .NOT.LSAME( ULB, 'L' ) ) THEN - INFO = -3 - ELSE IF( N.LT.0 ) THEN - INFO = -4 - ELSE IF( M.LT.0 ) THEN - INFO = -5 - ELSE IF( LDA.LT.MAX( 1, N ) ) THEN - INFO = -7 - ELSE IF( LDB.LT.MAX( 1, M ) ) THEN - INFO = -9 - ELSE IF( LDC.LT.MAX( 1, N ) ) THEN - INFO = -11 - ELSE IF( LDWORK.LT.0 .OR. ( .NOT.( LABSCS .AND. LULA .AND. LULB ) - $ .AND. LDWORK.LT.2*MAXMN*( 4 + 2*MAXMN ) ) ) THEN - INFO = -15 - END IF -C - IF ( INFO.NE.0 ) THEN -C -C Error return. -C - CALL XERBLA( 'SB04ND', -INFO ) - RETURN - END IF -C -C Quick return if possible. -C - IF ( MAXMN.EQ.0 ) - $ RETURN -C - IF ( LABSCS .AND. LULA .AND. LULB ) THEN -C -C If both matrices are in a real Schur form, use DTRSYL. -C - CALL DTRSYL( 'NoTranspose', 'NoTranspose', 1, N, M, A, LDA, B, - $ LDB, C, LDC, SCALE, INFO ) - IF ( SCALE.NE.ONE ) - $ INFO = 1 - RETURN - END IF -C - LDW = 2*MAXMN - JWORK = LDW*LDW + 3*LDW + 1 - TOL1 = TOL - IF ( TOL1.LE.ZERO ) - $ TOL1 = DLAMCH( 'Epsilon' ) -C -C Choose the smallest of both matrices as the one in Hessenberg -C form when possible. -C - ABSCHR = ABSCHU - IF ( LABSCS ) THEN - IF ( N.GT.M ) THEN - ABSCHR = 'A' - ELSE - ABSCHR = 'B' - END IF - END IF - IF ( LSAME( ABSCHR, 'B' ) ) THEN -C -C B is in Schur form: recursion on the columns of B. -C - IF ( LULB ) THEN -C -C B is upper: forward recursion. -C - IBEG = 1 - IEND = M - FWD = 1 - INCR = 0 - ELSE -C -C B is lower: backward recursion. -C - IBEG = M - IEND = 1 - FWD = -1 - INCR = -1 - END IF - I = IBEG -C WHILE ( ( IEND - I ) * FWD .GE. 0 ) DO - 20 IF ( ( IEND - I )*FWD.GE.0 ) THEN -C -C Test for 1-by-1 or 2-by-2 diagonal block in the Schur -C form. -C - IF ( I.EQ.IEND ) THEN - ISTEP = 1 - ELSE - IF ( B(I+FWD,I).EQ.ZERO ) THEN - ISTEP = 1 - ELSE - ISTEP = 2 - END IF - END IF -C - IF ( ISTEP.EQ.1 ) THEN - CALL SB04NW( ABSCHR, ULB, N, M, C, LDC, I, B, LDB, - $ DWORK(JWORK) ) - CALL SB04NY( 'R', ULA, N, A, LDA, B(I,I), DWORK(JWORK), - $ TOL1, IWORK, DWORK, LDW, INFO ) - IF ( INFO.EQ.1 ) - $ RETURN - CALL DCOPY( N, DWORK(JWORK), 1, C(1,I), 1 ) - ELSE - IPINCR = I + INCR - CALL SB04NV( ABSCHR, ULB, N, M, C, LDC, IPINCR, B, LDB, - $ DWORK(JWORK) ) - CALL SB04NX( 'R', ULA, N, A, LDA, B(IPINCR,IPINCR), - $ B(IPINCR+1,IPINCR), B(IPINCR,IPINCR+1), - $ B(IPINCR+1,IPINCR+1), DWORK(JWORK), TOL1, - $ IWORK, DWORK, LDW, INFO ) - IF ( INFO.EQ.1 ) - $ RETURN - CALL DCOPY( N, DWORK(JWORK), 2, C(1,IPINCR), 1 ) - CALL DCOPY( N, DWORK(JWORK+1), 2, C(1,IPINCR+1), 1 ) - END IF - I = I + FWD*ISTEP - GO TO 20 - END IF -C END WHILE 20 - ELSE -C -C A is in Schur form: recursion on the rows of A. -C - IF ( LULA ) THEN -C -C A is upper: backward recursion. -C - IBEG = N - IEND = 1 - FWD = -1 - INCR = -1 - ELSE -C -C A is lower: forward recursion. -C - IBEG = 1 - IEND = N - FWD = 1 - INCR = 0 - END IF - I = IBEG -C WHILE ( ( IEND - I ) * FWD .GE. 0 ) DO - 40 IF ( ( IEND - I )*FWD.GE.0 ) THEN -C -C Test for 1-by-1 or 2-by-2 diagonal block in the Schur -C form. -C - IF ( I.EQ.IEND ) THEN - ISTEP = 1 - ELSE - IF ( A(I,I+FWD).EQ.ZERO ) THEN - ISTEP = 1 - ELSE - ISTEP = 2 - END IF - END IF -C - IF ( ISTEP.EQ.1 ) THEN - CALL SB04NW( ABSCHR, ULA, N, M, C, LDC, I, A, LDA, - $ DWORK(JWORK) ) - CALL SB04NY( 'C', ULB, M, B, LDB, A(I,I), DWORK(JWORK), - $ TOL1, IWORK, DWORK, LDW, INFO ) - IF ( INFO.EQ.1 ) - $ RETURN - CALL DCOPY( M, DWORK(JWORK), 1, C(I,1), LDC ) - ELSE - IPINCR = I + INCR - CALL SB04NV( ABSCHR, ULA, N, M, C, LDC, IPINCR, A, LDA, - $ DWORK(JWORK) ) - CALL SB04NX( 'C', ULB, M, B, LDB, A(IPINCR,IPINCR), - $ A(IPINCR+1,IPINCR), A(IPINCR,IPINCR+1), - $ A(IPINCR+1,IPINCR+1), DWORK(JWORK), TOL1, - $ IWORK, DWORK, LDW, INFO ) - IF ( INFO.EQ.1 ) - $ RETURN - CALL DCOPY( M, DWORK(JWORK), 2, C(IPINCR,1), LDC ) - CALL DCOPY( M, DWORK(JWORK+1), 2, C(IPINCR+1,1), LDC ) - END IF - I = I + FWD*ISTEP - GO TO 40 - END IF -C END WHILE 40 - END IF -C - RETURN -C *** Last line of SB04ND *** - END diff --git a/mex/sources/libslicot/SB04NV.f b/mex/sources/libslicot/SB04NV.f deleted file mode 100644 index bb09f2778..000000000 --- a/mex/sources/libslicot/SB04NV.f +++ /dev/null @@ -1,165 +0,0 @@ - SUBROUTINE SB04NV( ABSCHR, UL, N, M, C, LDC, INDX, AB, LDAB, D ) -C -C SLICOT RELEASE 5.0. -C -C Copyright (c) 2002-2009 NICONET e.V. -C -C This program is free software: you can redistribute it and/or -C modify it under the terms of the GNU General Public License as -C published by the Free Software Foundation, either version 2 of -C the License, or (at your option) any later version. -C -C This program is distributed in the hope that it will be useful, -C but WITHOUT ANY WARRANTY; without even the implied warranty of -C MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the -C GNU General Public License for more details. -C -C You should have received a copy of the GNU General Public License -C along with this program. If not, see -C . -C -C PURPOSE -C -C To construct the right-hand sides D for a system of equations in -C Hessenberg form solved via SB04NX (case with 2 right-hand sides). -C -C ARGUMENTS -C -C Mode Parameters -C -C ABSCHR CHARACTER*1 -C Indicates whether AB contains A or B, as follows: -C = 'A': AB contains A; -C = 'B': AB contains B. -C -C UL CHARACTER*1 -C Indicates whether AB is upper or lower Hessenberg matrix, -C as follows: -C = 'U': AB is upper Hessenberg; -C = 'L': AB is lower Hessenberg. -C -C Input/Output Parameters -C -C N (input) INTEGER -C The order of the matrix A. N >= 0. -C -C M (input) INTEGER -C The order of the matrix B. M >= 0. -C -C C (input) DOUBLE PRECISION array, dimension (LDC,M) -C The leading N-by-M part of this array must contain both -C the not yet modified part of the coefficient matrix C of -C the Sylvester equation AX + XB = C, and both the currently -C computed part of the solution of the Sylvester equation. -C -C LDC INTEGER -C The leading dimension of array C. LDC >= MAX(1,N). -C -C INDX (input) INTEGER -C The position of the first column/row of C to be used in -C the construction of the right-hand side D. -C -C AB (input) DOUBLE PRECISION array, dimension (LDAB,*) -C The leading N-by-N or M-by-M part of this array must -C contain either A or B of the Sylvester equation -C AX + XB = C. -C -C LDAB INTEGER -C The leading dimension of array AB. -C LDAB >= MAX(1,N) or LDAB >= MAX(1,M) (depending on -C ABSCHR = 'A' or ABSCHR = 'B', respectively). -C -C D (output) DOUBLE PRECISION array, dimension (*) -C The leading 2*N or 2*M part of this array (depending on -C ABSCHR = 'B' or ABSCHR = 'A', respectively) contains the -C right-hand side stored as a matrix with two rows. -C -C NUMERICAL ASPECTS -C -C None. -C -C CONTRIBUTORS -C -C Release 3.0: V. Sima, Katholieke Univ. Leuven, Belgium, Aug. 1997. -C Supersedes Release 2.0 routine SB04BV by M. Vanbegin, and -C P. Van Dooren, Philips Research Laboratory, Brussels, Belgium. -C -C REVISIONS -C -C - -C -C KEYWORDS -C -C Hessenberg form, orthogonal transformation, real Schur form, -C Sylvester equation. -C -C ****************************************************************** -C -C .. Parameters .. - DOUBLE PRECISION ONE - PARAMETER ( ONE = 1.0D0 ) -C .. Scalar Arguments .. - CHARACTER ABSCHR, UL - INTEGER INDX, LDAB, LDC, M, N -C .. Array Arguments .. - DOUBLE PRECISION AB(LDAB,*), C(LDC,*), D(*) -C .. External Functions .. - LOGICAL LSAME - EXTERNAL LSAME -C .. External Subroutines .. - EXTERNAL DCOPY, DGEMV -C .. Executable Statements .. -C -C For speed, no tests on the input scalar arguments are made. -C Quick return if possible. -C - IF ( N.EQ.0 .OR. M.EQ.0 ) - $ RETURN -C - IF ( LSAME( ABSCHR, 'B' ) ) THEN -C -C Construct the 2 columns of the right-hand side. -C - CALL DCOPY( N, C(1,INDX), 1, D(1), 2 ) - CALL DCOPY( N, C(1,INDX+1), 1, D(2), 2 ) - IF ( LSAME( UL, 'U' ) ) THEN - IF ( INDX.GT.1 ) THEN - CALL DGEMV( 'N', N, INDX-1, -ONE, C, LDC, AB(1,INDX), 1, - $ ONE, D(1), 2 ) - CALL DGEMV( 'N', N, INDX-1, -ONE, C, LDC, AB(1,INDX+1), - $ 1, ONE, D(2), 2 ) - END IF - ELSE - IF ( INDX.LT.M-1 ) THEN - CALL DGEMV( 'N', N, M-INDX-1, -ONE, C(1,INDX+2), LDC, - $ AB(INDX+2,INDX), 1, ONE, D(1), 2 ) - CALL DGEMV( 'N', N, M-INDX-1, -ONE, C(1,INDX+2), LDC, - $ AB(INDX+2,INDX+1), 1, ONE, D(2), 2 ) - END IF - END IF - ELSE -C -C Construct the 2 rows of the right-hand side. -C - CALL DCOPY( M, C(INDX,1), LDC, D(1), 2 ) - CALL DCOPY( M, C(INDX+1,1), LDC, D(2), 2 ) - IF ( LSAME( UL, 'U' ) ) THEN - IF ( INDX.LT.N-1 ) THEN - CALL DGEMV( 'T', N-INDX-1, M, -ONE, C(INDX+2,1), LDC, - $ AB(INDX,INDX+2), LDAB, ONE, D(1), 2 ) - CALL DGEMV( 'T', N-INDX-1, M, -ONE, C(INDX+2,1), LDC, - $ AB(INDX+1,INDX+2), LDAB, ONE, D(2), 2 ) - END IF - ELSE - IF ( INDX.GT.1 ) THEN - CALL DGEMV( 'T', INDX-1, M, -ONE, C, LDC, AB(INDX,1), - $ LDAB, ONE, D(1), 2 ) - CALL DGEMV( 'T', INDX-1, M, -ONE, C, LDC, AB(INDX+1,1), - $ LDAB, ONE, D(2), 2 ) - END IF - END IF - END IF -C - RETURN -C *** Last line of SB04NV *** - END diff --git a/mex/sources/libslicot/SB04NW.f b/mex/sources/libslicot/SB04NW.f deleted file mode 100644 index a2a52aa82..000000000 --- a/mex/sources/libslicot/SB04NW.f +++ /dev/null @@ -1,155 +0,0 @@ - SUBROUTINE SB04NW( ABSCHR, UL, N, M, C, LDC, INDX, AB, LDAB, D ) -C -C SLICOT RELEASE 5.0. -C -C Copyright (c) 2002-2009 NICONET e.V. -C -C This program is free software: you can redistribute it and/or -C modify it under the terms of the GNU General Public License as -C published by the Free Software Foundation, either version 2 of -C the License, or (at your option) any later version. -C -C This program is distributed in the hope that it will be useful, -C but WITHOUT ANY WARRANTY; without even the implied warranty of -C MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the -C GNU General Public License for more details. -C -C You should have received a copy of the GNU General Public License -C along with this program. If not, see -C . -C -C PURPOSE -C -C To construct the right-hand side D for a system of equations in -C Hessenberg form solved via SB04NY (case with 1 right-hand side). -C -C ARGUMENTS -C -C Mode Parameters -C -C ABSCHR CHARACTER*1 -C Indicates whether AB contains A or B, as follows: -C = 'A': AB contains A; -C = 'B': AB contains B. -C -C UL CHARACTER*1 -C Indicates whether AB is upper or lower Hessenberg matrix, -C as follows: -C = 'U': AB is upper Hessenberg; -C = 'L': AB is lower Hessenberg. -C -C Input/Output Parameters -C -C N (input) INTEGER -C The order of the matrix A. N >= 0. -C -C M (input) INTEGER -C The order of the matrix B. M >= 0. -C -C C (input) DOUBLE PRECISION array, dimension (LDC,M) -C The leading N-by-M part of this array must contain both -C the not yet modified part of the coefficient matrix C of -C the Sylvester equation AX + XB = C, and both the currently -C computed part of the solution of the Sylvester equation. -C -C LDC INTEGER -C The leading dimension of array C. LDC >= MAX(1,N). -C -C INDX (input) INTEGER -C The position of the column/row of C to be used in the -C construction of the right-hand side D. -C -C AB (input) DOUBLE PRECISION array, dimension (LDAB,*) -C The leading N-by-N or M-by-M part of this array must -C contain either A or B of the Sylvester equation -C AX + XB = C. -C -C LDAB INTEGER -C The leading dimension of array AB. -C LDAB >= MAX(1,N) or LDAB >= MAX(1,M) (depending on -C ABSCHR = 'A' or ABSCHR = 'B', respectively). -C -C D (output) DOUBLE PRECISION array, dimension (*) -C The leading N or M part of this array (depending on -C ABSCHR = 'B' or ABSCHR = 'A', respectively) contains the -C right-hand side. -C -C NUMERICAL ASPECTS -C -C None. -C -C CONTRIBUTORS -C -C Release 3.0: V. Sima, Katholieke Univ. Leuven, Belgium, Aug. 1997. -C Supersedes Release 2.0 routine SB04BW by M. Vanbegin, and -C P. Van Dooren, Philips Research Laboratory, Brussels, Belgium. -C -C REVISIONS -C -C - -C -C KEYWORDS -C -C Hessenberg form, orthogonal transformation, real Schur form, -C Sylvester equation. -C -C ****************************************************************** -C -C .. Parameters .. - DOUBLE PRECISION ONE - PARAMETER ( ONE = 1.0D0 ) -C .. Scalar Arguments .. - CHARACTER ABSCHR, UL - INTEGER INDX, LDAB, LDC, M, N -C .. Array Arguments .. - DOUBLE PRECISION AB(LDAB,*), C(LDC,*), D(*) -C .. External Functions .. - LOGICAL LSAME - EXTERNAL LSAME -C .. External Subroutines .. - EXTERNAL DCOPY, DGEMV -C .. Executable Statements .. -C -C For speed, no tests on the input scalar arguments are made. -C Quick return if possible. -C - IF ( N.EQ.0 .OR. M.EQ.0 ) - $ RETURN -C - IF ( LSAME( ABSCHR, 'B' ) ) THEN -C -C Construct the column of the right-hand side. -C - CALL DCOPY( N, C(1,INDX), 1, D, 1 ) - IF ( LSAME( UL, 'U' ) ) THEN - IF ( INDX.GT.1 ) THEN - CALL DGEMV( 'N', N, INDX-1, -ONE, C, LDC, AB(1,INDX), 1, - $ ONE, D, 1 ) - END IF - ELSE - IF ( INDX.LT.M ) THEN - CALL DGEMV( 'N', N, M-INDX, -ONE, C(1,INDX+1), LDC, - $ AB(INDX+1,INDX), 1, ONE, D, 1 ) - END IF - END IF - ELSE -C -C Construct the row of the right-hand side. -C - CALL DCOPY( M, C(INDX,1), LDC, D, 1 ) - IF ( LSAME( UL, 'U' ) ) THEN - IF ( INDX.LT.N ) THEN - CALL DGEMV( 'T', N-INDX, M, -ONE, C(INDX+1,1), LDC, - $ AB(INDX,INDX+1), LDAB, ONE, D, 1 ) - END IF - ELSE - IF ( INDX.GT.1 ) THEN - CALL DGEMV( 'T', INDX-1, M, -ONE, C, LDC, AB(INDX,1), - $ LDAB, ONE, D, 1 ) - END IF - END IF - END IF -C - RETURN -C *** Last line of SB04NW *** - END diff --git a/mex/sources/libslicot/SB04NX.f b/mex/sources/libslicot/SB04NX.f deleted file mode 100644 index ac9ecf524..000000000 --- a/mex/sources/libslicot/SB04NX.f +++ /dev/null @@ -1,320 +0,0 @@ - SUBROUTINE SB04NX( RC, UL, M, A, LDA, LAMBD1, LAMBD2, LAMBD3, - $ LAMBD4, D, TOL, IWORK, DWORK, LDDWOR, INFO ) -C -C SLICOT RELEASE 5.0. -C -C Copyright (c) 2002-2009 NICONET e.V. -C -C This program is free software: you can redistribute it and/or -C modify it under the terms of the GNU General Public License as -C published by the Free Software Foundation, either version 2 of -C the License, or (at your option) any later version. -C -C This program is distributed in the hope that it will be useful, -C but WITHOUT ANY WARRANTY; without even the implied warranty of -C MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the -C GNU General Public License for more details. -C -C You should have received a copy of the GNU General Public License -C along with this program. If not, see -C . -C -C PURPOSE -C -C To solve a system of equations in Hessenberg form with two -C consecutive offdiagonals and two right-hand sides. -C -C ARGUMENTS -C -C Mode Parameters -C -C RC CHARACTER*1 -C Indicates processing by columns or rows, as follows: -C = 'R': Row transformations are applied; -C = 'C': Column transformations are applied. -C -C UL CHARACTER*1 -C Indicates whether AB is upper or lower Hessenberg matrix, -C as follows: -C = 'U': AB is upper Hessenberg; -C = 'L': AB is lower Hessenberg. -C -C Input/Output Parameters -C -C M (input) INTEGER -C The order of the matrix A. M >= 0. -C -C A (input) DOUBLE PRECISION array, dimension (LDA,M) -C The leading M-by-M part of this array must contain a -C matrix A in Hessenberg form. -C -C LDA INTEGER -C The leading dimension of array A. LDA >= MAX(1,M). -C -C LAMBD1, (input) DOUBLE PRECISION -C LAMBD2, These variables must contain the 2-by-2 block to be added -C LAMBD3, to the diagonal blocks of A. -C LAMBD4 -C -C D (input/output) DOUBLE PRECISION array, dimension (2*M) -C On entry, this array must contain the two right-hand -C side vectors of the Hessenberg system, stored row-wise. -C On exit, if INFO = 0, this array contains the two solution -C vectors of the Hessenberg system, stored row-wise. -C -C Tolerances -C -C TOL DOUBLE PRECISION -C The tolerance to be used to test for near singularity of -C the triangular factor R of the Hessenberg matrix. A matrix -C whose estimated condition number is less than 1/TOL is -C considered to be nonsingular. -C -C Workspace -C -C IWORK INTEGER array, dimension (2*M) -C -C DWORK DOUBLE PRECISION array, dimension (LDDWOR,2*M+3) -C The leading 2*M-by-2*M part of this array is used for -C computing the triangular factor of the QR decomposition -C of the Hessenberg matrix. The remaining 6*M elements are -C used as workspace for the computation of the reciprocal -C condition estimate. -C -C LDDWOR INTEGER -C The leading dimension of array DWORK. -C LDDWOR >= MAX(1,2*M). -C -C Error Indicator -C -C INFO INTEGER -C = 0: successful exit; -C = 1: if the Hessenberg matrix is (numerically) singular. -C That is, its estimated reciprocal condition number -C is less than or equal to TOL. -C -C NUMERICAL ASPECTS -C -C None. -C -C CONTRIBUTORS -C -C Release 3.0: V. Sima, Katholieke Univ. Leuven, Belgium, Aug. 1997. -C Supersedes Release 2.0 routine SB04BX by M. Vanbegin, and -C P. Van Dooren, Philips Research Laboratory, Brussels, Belgium. -C -C REVISIONS -C -C - -C -C Note that RC, UL, M and LDA must be such that the value of the -C LOGICAL variable OK in the following statement is true. -C -C OK = ( ( UL.EQ.'U' ) .OR. ( UL.EQ.'u' ) .OR. -C ( UL.EQ.'L' ) .OR. ( UL.EQ.'l' ) ) -C .AND. -C ( ( RC.EQ.'R' ) .OR. ( RC.EQ.'r' ) .OR. -C ( RC.EQ.'C' ) .OR. ( RC.EQ.'c' ) ) -C .AND. -C ( M.GE.0 ) -C .AND. -C ( LDA.GE.MAX( 1, M ) ) -C .AND. -C ( LDDWOR.GE.MAX( 1, 2*M ) ) -C -C KEYWORDS -C -C Hessenberg form, orthogonal transformation, real Schur form, -C Sylvester equation. -C -C ****************************************************************** -C - DOUBLE PRECISION ZERO - PARAMETER ( ZERO = 0.0D0 ) -C .. Scalar Arguments .. - CHARACTER RC, UL - INTEGER INFO, LDA, LDDWOR, M - DOUBLE PRECISION LAMBD1, LAMBD2, LAMBD3, LAMBD4, TOL -C .. Array Arguments .. - INTEGER IWORK(*) - DOUBLE PRECISION A(LDA,*), D(*), DWORK(LDDWOR,*) -C .. Local Scalars .. - CHARACTER TRANS - INTEGER J, J1, J2, M2, MJ, ML - DOUBLE PRECISION C, R, RCOND, S -C .. External Functions .. - LOGICAL LSAME - EXTERNAL LSAME -C .. External Subroutines .. - EXTERNAL DCOPY, DLARTG, DLASET, DROT, DTRCON, DTRSV -C .. Intrinsic Functions .. - INTRINSIC ABS, MAX, MIN -C .. Executable Statements .. -C - INFO = 0 -C -C For speed, no tests on the input scalar arguments are made. -C Quick return if possible. -C - IF ( M.EQ.0 ) - $ RETURN -C - M2 = M*2 - IF ( LSAME( UL, 'U' ) ) THEN -C - DO 20 J = 1, M - J2 = J*2 - ML = MIN( M, J + 1 ) - CALL DLASET( 'Full', M2, 2, ZERO, ZERO, DWORK(1,J2-1), - $ LDDWOR ) - CALL DCOPY( ML, A(1,J), 1, DWORK(1,J2-1), 2 ) - CALL DCOPY( ML, A(1,J), 1, DWORK(2,J2), 2 ) - DWORK(J2-1,J2-1) = DWORK(J2-1,J2-1) + LAMBD1 - DWORK(J2,J2-1) = LAMBD3 - DWORK(J2-1,J2) = LAMBD2 - DWORK(J2,J2) = DWORK(J2,J2) + LAMBD4 - 20 CONTINUE -C - IF ( LSAME( RC, 'R' ) ) THEN - TRANS = 'N' -C -C A is an upper Hessenberg matrix, row transformations. -C - DO 40 J = 1, M2 - 1 - MJ = M2 - J - IF ( J.LT.M2-1 ) THEN - IF ( DWORK(J+2,J).NE.ZERO ) THEN - CALL DLARTG( DWORK(J+1,J), DWORK(J+2,J), C, S, R ) - DWORK(J+1,J) = R - DWORK(J+2,J) = ZERO - CALL DROT( MJ, DWORK(J+1,J+1), LDDWOR, - $ DWORK(J+2,J+1), LDDWOR, C, S ) - CALL DROT( 1, D(J+1), 1, D(J+2), 1, C, S ) - END IF - END IF - IF ( DWORK(J+1,J).NE.ZERO ) THEN - CALL DLARTG( DWORK(J,J), DWORK(J+1,J), C, S, R ) - DWORK(J,J) = R - DWORK(J+1,J) = ZERO - CALL DROT( MJ, DWORK(J,J+1), LDDWOR, DWORK(J+1,J+1), - $ LDDWOR, C, S ) - CALL DROT( 1, D(J), 1, D(J+1), 1, C, S ) - END IF - 40 CONTINUE -C - ELSE - TRANS = 'T' -C -C A is an upper Hessenberg matrix, column transformations. -C - DO 60 J = 1, M2 - 1 - MJ = M2 - J - IF ( J.LT.M2-1 ) THEN - IF ( DWORK(MJ+1,MJ-1).NE.ZERO ) THEN - CALL DLARTG( DWORK(MJ+1,MJ), DWORK(MJ+1,MJ-1), C, - $ S, R ) - DWORK(MJ+1,MJ) = R - DWORK(MJ+1,MJ-1) = ZERO - CALL DROT( MJ, DWORK(1,MJ), 1, DWORK(1,MJ-1), 1, C, - $ S ) - CALL DROT( 1, D(MJ), 1, D(MJ-1), 1, C, S ) - END IF - END IF - IF ( DWORK(MJ+1,MJ).NE.ZERO ) THEN - CALL DLARTG( DWORK(MJ+1,MJ+1), DWORK(MJ+1,MJ), C, S, - $ R ) - DWORK(MJ+1,MJ+1) = R - DWORK(MJ+1,MJ) = ZERO - CALL DROT( MJ, DWORK(1,MJ+1), 1, DWORK(1,MJ), 1, C, - $ S ) - CALL DROT( 1, D(MJ+1), 1, D(MJ), 1, C, S ) - END IF - 60 CONTINUE -C - END IF - ELSE -C - DO 80 J = 1, M - J2 = J*2 - J1 = MAX( J - 1, 1 ) - ML = MIN( M - J + 2, M ) - CALL DLASET( 'Full', M2, 2, ZERO, ZERO, DWORK(1,J2-1), - $ LDDWOR ) - CALL DCOPY( ML, A(J1,J), 1, DWORK(J1*2-1,J2-1), 2 ) - CALL DCOPY( ML, A(J1,J), 1, DWORK(J1*2,J2), 2 ) - DWORK(J2-1,J2-1) = DWORK(J2-1,J2-1) + LAMBD1 - DWORK(J2,J2-1) = LAMBD3 - DWORK(J2-1,J2) = LAMBD2 - DWORK(J2,J2) = DWORK(J2,J2) + LAMBD4 - 80 CONTINUE -C - IF ( LSAME( RC, 'R' ) ) THEN - TRANS = 'N' -C -C A is a lower Hessenberg matrix, row transformations. -C - DO 100 J = 1, M2 - 1 - MJ = M2 - J - IF ( J.LT.M2-1 ) THEN - IF ( DWORK(MJ-1,MJ+1).NE.ZERO ) THEN - CALL DLARTG( DWORK(MJ,MJ+1), DWORK(MJ-1,MJ+1), C, - $ S, R ) - DWORK(MJ,MJ+1) = R - DWORK(MJ-1,MJ+1) = ZERO - CALL DROT( MJ, DWORK(MJ,1), LDDWOR, DWORK(MJ-1,1), - $ LDDWOR, C, S ) - CALL DROT( 1, D(MJ), 1, D(MJ-1), 1, C, S ) - END IF - END IF - IF ( DWORK(MJ,MJ+1).NE.ZERO ) THEN - CALL DLARTG( DWORK(MJ+1,MJ+1), DWORK(MJ,MJ+1), C, S, - $ R ) - DWORK(MJ+1,MJ+1) = R - DWORK(MJ,MJ+1) = ZERO - CALL DROT( MJ, DWORK(MJ+1,1), LDDWOR, DWORK(MJ,1), - $ LDDWOR, C, S) - CALL DROT( 1, D(MJ+1), 1, D(MJ), 1, C, S ) - END IF - 100 CONTINUE -C - ELSE - TRANS = 'T' -C -C A is a lower Hessenberg matrix, column transformations. -C - DO 120 J = 1, M2 - 1 - MJ = M2 - J - IF ( J.LT.M2-1 ) THEN - IF ( DWORK(J,J+2).NE.ZERO ) THEN - CALL DLARTG( DWORK(J,J+1), DWORK(J,J+2), C, S, R ) - DWORK(J,J+1) = R - DWORK(J,J+2) = ZERO - CALL DROT( MJ, DWORK(J+1,J+1), 1, DWORK(J+1,J+2), - $ 1, C, S ) - CALL DROT( 1, D(J+1), 1, D(J+2), 1, C, S ) - END IF - END IF - IF ( DWORK(J,J+1).NE.ZERO ) THEN - CALL DLARTG( DWORK(J,J), DWORK(J,J+1), C, S, R ) - DWORK(J,J) = R - DWORK(J,J+1) = ZERO - CALL DROT( MJ, DWORK(J+1,J), 1, DWORK(J+1,J+1), 1, C, - $ S ) - CALL DROT( 1, D(J), 1, D(J+1), 1, C, S ) - END IF - 120 CONTINUE -C - END IF - END IF -C - CALL DTRCON( '1-norm', UL, 'Non-unit', M2, DWORK, LDDWOR, RCOND, - $ DWORK(1,M2+1), IWORK, INFO ) - IF ( RCOND.LE.TOL ) THEN - INFO = 1 - ELSE - CALL DTRSV( UL, TRANS, 'Non-unit', M2, DWORK, LDDWOR, D, 1 ) - END IF -C - RETURN -C *** Last line of SB04NX *** - END diff --git a/mex/sources/libslicot/SB04NY.f b/mex/sources/libslicot/SB04NY.f deleted file mode 100644 index 5a0b9c62b..000000000 --- a/mex/sources/libslicot/SB04NY.f +++ /dev/null @@ -1,260 +0,0 @@ - SUBROUTINE SB04NY( RC, UL, M, A, LDA, LAMBDA, D, TOL, IWORK, - $ DWORK, LDDWOR, INFO ) -C -C SLICOT RELEASE 5.0. -C -C Copyright (c) 2002-2009 NICONET e.V. -C -C This program is free software: you can redistribute it and/or -C modify it under the terms of the GNU General Public License as -C published by the Free Software Foundation, either version 2 of -C the License, or (at your option) any later version. -C -C This program is distributed in the hope that it will be useful, -C but WITHOUT ANY WARRANTY; without even the implied warranty of -C MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the -C GNU General Public License for more details. -C -C You should have received a copy of the GNU General Public License -C along with this program. If not, see -C . -C -C PURPOSE -C -C To solve a system of equations in Hessenberg form with one -C offdiagonal and one right-hand side. -C -C ARGUMENTS -C -C Mode Parameters -C -C RC CHARACTER*1 -C Indicates processing by columns or rows, as follows: -C = 'R': Row transformations are applied; -C = 'C': Column transformations are applied. -C -C UL CHARACTER*1 -C Indicates whether AB is upper or lower Hessenberg matrix, -C as follows: -C = 'U': AB is upper Hessenberg; -C = 'L': AB is lower Hessenberg. -C -C Input/Output Parameters -C -C M (input) INTEGER -C The order of the matrix A. M >= 0. -C -C A (input) DOUBLE PRECISION array, dimension (LDA,M) -C The leading M-by-M part of this array must contain a -C matrix A in Hessenberg form. -C -C LDA INTEGER -C The leading dimension of array A. LDA >= MAX(1,M). -C -C LAMBDA (input) DOUBLE PRECISION -C This variable must contain the value to be added to the -C diagonal elements of A. -C -C D (input/output) DOUBLE PRECISION array, dimension (M) -C On entry, this array must contain the right-hand side -C vector of the Hessenberg system. -C On exit, if INFO = 0, this array contains the solution -C vector of the Hessenberg system. -C -C Tolerances -C -C TOL DOUBLE PRECISION -C The tolerance to be used to test for near singularity of -C the triangular factor R of the Hessenberg matrix. A matrix -C whose estimated condition number is less than 1/TOL is -C considered to be nonsingular. -C -C Workspace -C -C IWORK INTEGER array, dimension (M) -C -C DWORK DOUBLE PRECISION array, dimension (LDDWOR,M+3) -C The leading M-by-M part of this array is used for -C computing the triangular factor of the QR decomposition -C of the Hessenberg matrix. The remaining 3*M elements are -C used as workspace for the computation of the reciprocal -C condition estimate. -C -C LDDWOR INTEGER -C The leading dimension of array DWORK. LDDWOR >= MAX(1,M). -C -C Error Indicator -C -C INFO INTEGER -C = 0: successful exit; -C = 1: if the Hessenberg matrix is (numerically) singular. -C That is, its estimated reciprocal condition number -C is less than or equal to TOL. -C -C NUMERICAL ASPECTS -C -C None. -C -C CONTRIBUTORS -C -C Release 3.0: V. Sima, Katholieke Univ. Leuven, Belgium, Aug. 1997. -C Supersedes Release 2.0 routine SB04BY by M. Vanbegin, and -C P. Van Dooren, Philips Research Laboratory, Brussels, Belgium. -C -C REVISIONS -C -C - -C -C Note that RC, UL, M and LDA must be such that the value of the -C LOGICAL variable OK in the following statement is true. -C -C OK = ( ( UL.EQ.'U' ) .OR. ( UL.EQ.'u' ) .OR. -C ( UL.EQ.'L' ) .OR. ( UL.EQ.'l' ) ) -C .AND. -C ( ( RC.EQ.'R' ) .OR. ( RC.EQ.'r' ) .OR. -C ( RC.EQ.'C' ) .OR. ( RC.EQ.'c' ) ) -C .AND. -C ( M.GE.0 ) -C .AND. -C ( LDA.GE.MAX( 1, M ) ) -C .AND. -C ( LDDWOR.GE.MAX( 1, M ) ) -C -C KEYWORDS -C -C Hessenberg form, orthogonal transformation, real Schur form, -C Sylvester equation. -C -C ****************************************************************** -C - DOUBLE PRECISION ZERO - PARAMETER ( ZERO = 0.0D0 ) -C .. Scalar Arguments .. - CHARACTER RC, UL - INTEGER INFO, LDA, LDDWOR, M - DOUBLE PRECISION LAMBDA, TOL -C .. Array Arguments .. - INTEGER IWORK(*) - DOUBLE PRECISION A(LDA,*), D(*), DWORK(LDDWOR,*) -C .. Local Scalars .. - CHARACTER TRANS - INTEGER J, J1, MJ - DOUBLE PRECISION C, R, RCOND, S -C .. External Functions .. - LOGICAL LSAME - EXTERNAL LSAME -C .. External Subroutines .. - EXTERNAL DCOPY, DLARTG, DROT, DTRCON, DTRSV -C .. Intrinsic Functions .. - INTRINSIC ABS, MAX, MIN -C .. Executable Statements .. -C - INFO = 0 -C -C For speed, no tests on the input scalar arguments are made. -C Quick return if possible. -C - IF ( M.EQ.0 ) - $ RETURN -C - IF ( LSAME( UL, 'U' ) ) THEN -C - DO 20 J = 1, M - CALL DCOPY( MIN( J+1, M ), A(1,J), 1, DWORK(1,J), 1 ) - DWORK(J,J) = DWORK(J,J) + LAMBDA - 20 CONTINUE -C - IF ( LSAME( RC, 'R' ) ) THEN - TRANS = 'N' -C -C A is an upper Hessenberg matrix, row transformations. -C - DO 40 J = 1, M - 1 - MJ = M - J - IF ( DWORK(J+1,J).NE.ZERO ) THEN - CALL DLARTG( DWORK(J,J), DWORK(J+1,J), C, S, R ) - DWORK(J,J) = R - DWORK(J+1,J) = ZERO - CALL DROT( MJ, DWORK(J,J+1), LDDWOR, DWORK(J+1,J+1), - $ LDDWOR, C, S ) - CALL DROT( 1, D(J), 1, D(J+1), 1, C, S ) - END IF - 40 CONTINUE -C - ELSE - TRANS = 'T' -C -C A is an upper Hessenberg matrix, column transformations. -C - DO 60 J = 1, M - 1 - MJ = M - J - IF ( DWORK(MJ+1,MJ).NE.ZERO ) THEN - CALL DLARTG( DWORK(MJ+1,MJ+1), DWORK(MJ+1,MJ), C, S, - $ R ) - DWORK(MJ+1,MJ+1) = R - DWORK(MJ+1,MJ) = ZERO - CALL DROT( MJ, DWORK(1,MJ+1), 1, DWORK(1,MJ), 1, C, - $ S ) - CALL DROT( 1, D(MJ+1), 1, D(MJ), 1, C, S ) - END IF - 60 CONTINUE -C - END IF - ELSE -C - DO 80 J = 1, M - J1 = MAX( J - 1, 1 ) - CALL DCOPY( M-J1+1, A(J1,J), 1, DWORK(J1,J), 1 ) - DWORK(J,J) = DWORK(J,J) + LAMBDA - 80 CONTINUE -C - IF ( LSAME( RC, 'R' ) ) THEN - TRANS = 'N' -C -C A is a lower Hessenberg matrix, row transformations. -C - DO 100 J = 1, M - 1 - MJ = M - J - IF ( DWORK(MJ,MJ+1).NE.ZERO ) THEN - CALL DLARTG( DWORK(MJ+1,MJ+1), DWORK(MJ,MJ+1), C, S, - $ R ) - DWORK(MJ+1,MJ+1) = R - DWORK(MJ,MJ+1) = ZERO - CALL DROT( MJ, DWORK(MJ+1,1), LDDWOR, DWORK(MJ,1), - $ LDDWOR, C, S ) - CALL DROT( 1, D(MJ+1), 1, D(MJ), 1, C, S ) - END IF - 100 CONTINUE -C - ELSE - TRANS = 'T' -C -C A is a lower Hessenberg matrix, column transformations. -C - DO 120 J = 1, M - 1 - MJ = M - J - IF ( DWORK(J,J+1).NE.ZERO ) THEN - CALL DLARTG( DWORK(J,J), DWORK(J,J+1), C, S, R ) - DWORK(J,J) = R - DWORK(J,J+1) = ZERO - CALL DROT( MJ, DWORK(J+1,J), 1, DWORK(J+1,J+1), 1, C, - $ S ) -C - CALL DROT( 1, D(J), 1, D(J+1), 1, C, S ) - END IF - 120 CONTINUE -C - END IF - END IF -C - CALL DTRCON( '1-norm', UL, 'Non-unit', M, DWORK, LDDWOR, RCOND, - $ DWORK(1,M+1), IWORK, INFO ) - IF ( RCOND.LE.TOL ) THEN - INFO = 1 - ELSE - CALL DTRSV( UL, TRANS, 'Non-unit', M, DWORK, LDDWOR, D, 1 ) - END IF -C - RETURN -C *** Last line of SB04NY *** - END diff --git a/mex/sources/libslicot/SB04OD.f b/mex/sources/libslicot/SB04OD.f deleted file mode 100644 index 6a11ffa76..000000000 --- a/mex/sources/libslicot/SB04OD.f +++ /dev/null @@ -1,1028 +0,0 @@ - SUBROUTINE SB04OD( REDUCE, TRANS, JOBD, M, N, A, LDA, B, LDB, C, - $ LDC, D, LDD, E, LDE, F, LDF, SCALE, DIF, P, - $ LDP, Q, LDQ, U, LDU, V, LDV, IWORK, DWORK, - $ LDWORK, INFO ) -C -C SLICOT RELEASE 5.0. -C -C Copyright (c) 2002-2009 NICONET e.V. -C -C This program is free software: you can redistribute it and/or -C modify it under the terms of the GNU General Public License as -C published by the Free Software Foundation, either version 2 of -C the License, or (at your option) any later version. -C -C This program is distributed in the hope that it will be useful, -C but WITHOUT ANY WARRANTY; without even the implied warranty of -C MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the -C GNU General Public License for more details. -C -C You should have received a copy of the GNU General Public License -C along with this program. If not, see -C . -C -C PURPOSE -C -C To solve for R and L one of the generalized Sylvester equations -C -C A * R - L * B = scale * C ) -C ) (1) -C D * R - L * E = scale * F ) -C -C or -C -C A' * R + D' * L = scale * C ) -C ) (2) -C R * B' + L * E' = scale * (-F) ) -C -C where A and D are M-by-M matrices, B and E are N-by-N matrices and -C C, F, R and L are M-by-N matrices. -C -C The solution (R, L) overwrites (C, F). 0 <= SCALE <= 1 is an -C output scaling factor chosen to avoid overflow. -C -C The routine also optionally computes a Dif estimate, which -C measures the separation of the spectrum of the matrix pair (A,D) -C from the spectrum of the matrix pair (B,E), Dif[(A,D),(B,E)]. -C -C ARGUMENTS -C -C MODE PARAMETERS -C -C REDUCE CHARACTER*1 -C Indicates whether the matrix pairs (A,D) and/or (B,E) are -C to be reduced to generalized Schur form as follows: -C = 'R': The matrix pairs (A,D) and (B,E) are to be reduced -C to generalized (real) Schur canonical form; -C = 'A': The matrix pair (A,D) only is to be reduced -C to generalized (real) Schur canonical form, -C and the matrix pair (B,E) already is in this form; -C = 'B': The matrix pair (B,E) only is to be reduced -C to generalized (real) Schur canonical form, -C and the matrix pair (A,D) already is in this form; -C = 'N': The matrix pairs (A,D) and (B,E) are already in -C generalized (real) Schur canonical form, as -C produced by LAPACK routine DGEES. -C -C TRANS CHARACTER*1 -C Indicates which of the equations, (1) or (2), is to be -C solved as follows: -C = 'N': The generalized Sylvester equation (1) is to be -C solved; -C = 'T': The "transposed" generalized Sylvester equation -C (2) is to be solved. -C -C JOBD CHARACTER*1 -C Indicates whether the Dif estimator is to be computed as -C follows: -C = '1': Only the one-norm-based Dif estimate is computed -C and stored in DIF; -C = '2': Only the Frobenius norm-based Dif estimate is -C computed and stored in DIF; -C = 'D': The equation (1) is solved and the one-norm-based -C Dif estimate is computed and stored in DIF; -C = 'F': The equation (1) is solved and the Frobenius norm- -C based Dif estimate is computed and stored in DIF; -C = 'N': The Dif estimator is not required and hence DIF is -C not referenced. (Solve either (1) or (2) only.) -C JOBD is not referenced if TRANS = 'T'. -C -C Input/Output Parameters -C -C M (input) INTEGER -C The order of the matrices A and D and the number of rows -C of the matrices C, F, R and L. M >= 0. -C -C N (input) INTEGER -C The order of the matrices B and E and the number of -C columns of the matrices C, F, R and L. N >= 0. -C -C A (input/output) DOUBLE PRECISION array, dimension (LDA,M) -C On entry, the leading M-by-M part of this array must -C contain the coefficient matrix A of the equation; A must -C be in upper quasi-triangular form if REDUCE = 'B' or 'N'. -C On exit, the leading M-by-M part of this array contains -C the upper quasi-triangular form of A. -C -C LDA INTEGER -C The leading dimension of array A. LDA >= MAX(1,M). -C -C B (input/output) DOUBLE PRECISION array, dimension (LDB,N) -C On entry, the leading N-by-N part of this array must -C contain the coefficient matrix B of the equation; B must -C be in upper quasi-triangular form if REDUCE = 'A' or 'N'. -C On exit, the leading N-by-N part of this array contains -C the upper quasi-triangular form of B. -C -C LDB INTEGER -C The leading dimension of array B. LDB >= MAX(1,N). -C -C C (input/output) DOUBLE PRECISION array, dimension (LDC,N) -C On entry, the leading M-by-N part of this array must -C contain the right-hand side matrix C of the first equation -C in (1) or (2). -C On exit, if JOBD = 'N', 'D' or 'F', the leading M-by-N -C part of this array contains the solution matrix R of the -C problem; if JOBD = '1' or '2' and TRANS = 'N', the leading -C M-by-N part of this array contains the solution matrix R -C achieved during the computation of the Dif estimate. -C -C LDC INTEGER -C The leading dimension of array C. LDC >= MAX(1,M). -C -C D (input/output) DOUBLE PRECISION array, dimension (LDD,M) -C On entry, the leading M-by-M part of this array must -C contain the coefficient matrix D of the equation; D must -C be in upper triangular form if REDUCE = 'B' or 'N'. -C On exit, the leading M-by-M part of this array contains -C the upper triangular form of D. -C -C LDD INTEGER -C The leading dimension of array D. LDD >= MAX(1,M). -C -C E (input/output) DOUBLE PRECISION array, dimension (LDE,N) -C On entry, the leading N-by-N part of this array must -C contain the coefficient matrix E of the equation; E must -C be in upper triangular form if REDUCE = 'A' or 'N'. -C On exit, the leading N-by-N part of this array contains -C the upper triangular form of E. -C -C LDE INTEGER -C The leading dimension of array E. LDE >= MAX(1,N). -C -C F (input/output) DOUBLE PRECISION array, dimension (LDF,N) -C On entry, the leading M-by-N part of this array must -C contain the right-hand side matrix F of the second -C equation in (1) or (2). -C On exit, if JOBD = 'N', 'D' or 'F', the leading M-by-N -C part of this array contains the solution matrix L of the -C problem; if JOBD = '1' or '2' and TRANS = 'N', the leading -C M-by-N part of this array contains the solution matrix L -C achieved during the computation of the Dif estimate. -C -C LDF INTEGER -C The leading dimension of array F. LDF >= MAX(1,M). -C -C SCALE (output) DOUBLE PRECISION -C The scaling factor in (1) or (2). If 0 < SCALE < 1, C and -C F hold the solutions R and L, respectively, to a slightly -C perturbed system (but the input or computed generalized -C (real) Schur canonical form matrices A, B, D, and E -C have not been changed). If SCALE = 0, C and F hold the -C solutions R and L, respectively, to the homogeneous system -C with C = F = 0. Normally, SCALE = 1. -C -C DIF (output) DOUBLE PRECISION -C If TRANS = 'N' and JOBD <> 'N', then DIF contains the -C value of the Dif estimator, which is an upper bound of -C -1 -C Dif[(A,D),(B,E)] = sigma_min(Z) = 1/||Z ||, in either the -C one-norm, or Frobenius norm, respectively (see METHOD). -C Otherwise, DIF is not referenced. -C -C P (output) DOUBLE PRECISION array, dimension (LDP,*) -C If REDUCE = 'R' or 'A', then the leading M-by-M part of -C this array contains the (left) transformation matrix used -C to reduce (A,D) to generalized Schur form. -C Otherwise, P is not referenced and can be supplied as a -C dummy array (i.e. set parameter LDP = 1 and declare this -C array to be P(1,1) in the calling program). -C -C LDP INTEGER -C The leading dimension of array P. -C LDP >= MAX(1,M) if REDUCE = 'R' or 'A', -C LDP >= 1 if REDUCE = 'B' or 'N'. -C -C Q (output) DOUBLE PRECISION array, dimension (LDQ,*) -C If REDUCE = 'R' or 'A', then the leading M-by-M part of -C this array contains the (right) transformation matrix used -C to reduce (A,D) to generalized Schur form. -C Otherwise, Q is not referenced and can be supplied as a -C dummy array (i.e. set parameter LDQ = 1 and declare this -C array to be Q(1,1) in the calling program). -C -C LDQ INTEGER -C The leading dimension of array Q. -C LDQ >= MAX(1,M) if REDUCE = 'R' or 'A', -C LDQ >= 1 if REDUCE = 'B' or 'N'. -C -C U (output) DOUBLE PRECISION array, dimension (LDU,*) -C If REDUCE = 'R' or 'B', then the leading N-by-N part of -C this array contains the (left) transformation matrix used -C to reduce (B,E) to generalized Schur form. -C Otherwise, U is not referenced and can be supplied as a -C dummy array (i.e. set parameter LDU = 1 and declare this -C array to be U(1,1) in the calling program). -C -C LDU INTEGER -C The leading dimension of array U. -C LDU >= MAX(1,N) if REDUCE = 'R' or 'B', -C LDU >= 1 if REDUCE = 'A' or 'N'. -C -C V (output) DOUBLE PRECISION array, dimension (LDV,*) -C If REDUCE = 'R' or 'B', then the leading N-by-N part of -C this array contains the (right) transformation matrix used -C to reduce (B,E) to generalized Schur form. -C Otherwise, V is not referenced and can be supplied as a -C dummy array (i.e. set parameter LDV = 1 and declare this -C array to be V(1,1) in the calling program). -C -C LDV INTEGER -C The leading dimension of array V. -C LDV >= MAX(1,N) if REDUCE = 'R' or 'B', -C LDV >= 1 if REDUCE = 'A' or 'N'. -C -C Workspace -C -C IWORK INTEGER array, dimension (M+N+6) -C -C DWORK DOUBLE PRECISION array, dimension (LDWORK) -C On exit, if INFO = 0, DWORK(1) returns the optimal value -C of LDWORK. -C -C LDWORK INTEGER -C The length of the array DWORK. -C If TRANS = 'N' and JOBD = 'D' or 'F', then -C LDWORK = MAX(1,7*M,7*N,2*M*N) if REDUCE = 'R'; -C LDWORK = MAX(1,7*M,2*M*N) if REDUCE = 'A'; -C LDWORK = MAX(1,7*N,2*M*N) if REDUCE = 'B'; -C LDWORK = MAX(1,2*M*N) if REDUCE = 'N'. -C Otherwise, the term 2*M*N above should be omitted. -C For optimum performance LDWORK should be larger. -C -C Error Indicator -C -C INFO INTEGER -C = 0: successful exit; -C < 0: if INFO = -i, the i-th argument had an illegal -C value; -C = 1: if REDUCE <> 'N' and either (A,D) and/or (B,E) -C cannot be reduced to generalized Schur form; -C = 2: if REDUCE = 'N' and either A or B is not in -C upper quasi-triangular form; -C = 3: if a singular matrix was encountered during the -C computation of the solution matrices R and L, that -C is (A,D) and (B,E) have common or close eigenvalues. -C -C METHOD -C -C For the case TRANS = 'N', and REDUCE = 'R' or 'N', the algorithm -C used by the routine consists of four steps (see [1] and [2]) as -C follows: -C -C (a) if REDUCE = 'R', then the matrix pairs (A,D) and (B,E) are -C transformed to generalized Schur form, i.e. orthogonal -C matrices P, Q, U and V are computed such that P' * A * Q -C and U' * B * V are in upper quasi-triangular form and -C P' * D * Q and U' * E * V are in upper triangular form; -C (b) if REDUCE = 'R', then the matrices C and F are transformed -C to give P' * C * V and P' * F * V respectively; -C (c) if REDUCE = 'R', then the transformed system -C -C P' * A * Q * R1 - L1 * U' * B * V = scale * P' * C * V -C P' * D * Q * R1 - L1 * U' * E * V = scale * P' * F * V -C -C is solved to give R1 and L1; otherwise, equation (1) is -C solved to give R and L directly. The Dif estimator -C is also computed if JOBD <> 'N'. -C (d) if REDUCE = 'R', then the solution is transformed back -C to give R = Q * R1 * V' and L = P * L1 * U'. -C -C By using Kronecker products, equation (1) can also be written as -C the system of linear equations Z * x = scale*y (see [1]), where -C -C | I*A I*D | -C Z = | |. -C |-B'*I -E'*I | -C -C -1 -C If JOBD <> 'N', then a lower bound on ||Z ||, in either the one- -C norm or Frobenius norm, is computed, which in most cases is -C a reliable estimate of the true value. Notice that since Z is a -C matrix of order 2 * M * N, the exact value of Dif (i.e., in the -C Frobenius norm case, the smallest singular value of Z) may be very -C expensive to compute. -C -C The case TRANS = 'N', and REDUCE = 'A' or 'B', is similar, but -C only one of the matrix pairs should be reduced and the -C calculations simplify. -C -C For the case TRANS = 'T', and REDUCE = 'R' or 'N', the algorithm -C is similar, but the steps (b), (c), and (d) are as follows: -C -C (b) if REDUCE = 'R', then the matrices C and F are transformed -C to give Q' * C * V and P' * F * U respectively; -C (c) if REDUCE = 'R', then the transformed system -C -C Q' * A' * P * R1 + Q' * D' * P * L1 = scale * Q' * C * V -C R1 * V' * B' * U + L1 * V' * E' * U = -scale * P' * F * U -C -C is solved to give R1 and L1; otherwise, equation (2) is -C solved to give R and L directly. -C (d) if REDUCE = 'R', then the solution is transformed back -C to give R = P * R1 * V' and L = P * L1 * V'. -C -C REFERENCES -C -C [1] Kagstrom, B. and Westin, L. -C Generalized Schur Methods with Condition Estimators for -C Solving the Generalized Sylvester Equation. -C IEEE Trans. Auto. Contr., 34, pp. 745-751, 1989. -C [2] Kagstrom, B. and Westin, L. -C GSYLV - Fortran Routines for the Generalized Schur Method with -C Dif Estimators for Solving the Generalized Sylvester -C Equation. -C Report UMINF-132.86, Institute of Information Processing, -C Univ. of Umea, Sweden, July 1987. -C [3] Golub, G.H., Nash, S. and Van Loan, C.F. -C A Hessenberg-Schur Method for the Problem AX + XB = C. -C IEEE Trans. Auto. Contr., AC-24, pp. 909-913, 1979. -C [4] Kagstrom, B. and Van Dooren, P. -C Additive Decomposition of a Transfer Function with respect to -C a Specified Region. -C In: "Signal Processing, Scattering and Operator Theory, and -C Numerical Methods" (Eds. M.A. Kaashoek et al.). -C Proceedings of MTNS-89, Vol. 3, pp. 469-477, Birkhauser Boston -C Inc., 1990. -C [5] Kagstrom, B. and Van Dooren, P. -C A Generalized State-space Approach for the Additive -C Decomposition of a Transfer Matrix. -C Report UMINF-91.12, Institute of Information Processing, Univ. -C of Umea, Sweden, April 1991. -C -C NUMERICAL ASPECTS -C -C The algorithm is backward stable. A reliable estimate for the -C condition number of Z in the Frobenius norm, is (see [1]) -C -C K(Z) = SQRT( ||A||**2 + ||B||**2 + ||C||**2 + ||D||**2 )/DIF. -C -C If mu is an upper bound on the relative error of the elements of -C the matrices A, B, C, D, E and F, then the relative error in the -C actual solution is approximately mu * K(Z). -C -C The relative error in the computed solution (due to rounding -C errors) is approximately EPS * K(Z), where EPS is the machine -C precision (see LAPACK Library routine DLAMCH). -C -C FURTHER COMMENTS -C -C For applications of the generalized Sylvester equation in control -C theory, see [4] and [5]. -C -C CONTRIBUTORS -C -C Release 3.0: V. Sima, Katholieke Univ. Leuven, Belgium, Aug. 1997. -C Supersedes Release 2.0 routine SB04CD by Bo Kagstrom and Lars -C Westin. -C -C REVISIONS -C -C V. Sima, Katholieke Univ. Leuven, Belgium, May 1999, Dec. 1999, -C May 2009. -C -C KEYWORDS -C -C Generalized eigenvalue problem, orthogonal transformation, real -C Schur form, Sylvester equation. -C -C ****************************************************************** -C -C .. Parameters .. - DOUBLE PRECISION ZERO, ONE - PARAMETER ( ZERO = 0.0D0, ONE = 1.0D0 ) -C .. Scalar Arguments .. - CHARACTER JOBD, REDUCE, TRANS - INTEGER INFO, LDA, LDB, LDC, LDD, LDE, LDF, LDP, LDQ, - $ LDU, LDV, LDWORK, M, N - DOUBLE PRECISION DIF, SCALE -C .. Array Arguments .. - INTEGER IWORK(*) - DOUBLE PRECISION A(LDA,*), B(LDB,*), C(LDC,*), D(LDD,*), - $ DWORK(*), E(LDE,*), F(LDF,*), P(LDP,*), - $ Q(LDQ,*), U(LDU,*), V(LDV,*) -C .. Local Scalars .. - LOGICAL ILASCL, ILBSCL, ILDSCL, ILESCL, LJOB1, LJOB2, - $ LJOBD, LJOBDF, LJOBF, LREDRA, LREDRB, LREDUA, - $ LREDUB, LREDUC, LREDUR, LTRANN, SUFWRK - INTEGER I, IERR, IJOB, MINWRK, MN, WRKOPT - DOUBLE PRECISION ANRM, ANRMTO, BIGNUM, BNRM, BNRMTO, DNRM, - $ DNRMTO, ENRM, ENRMTO, SAFMAX, SAFMIN, SMLNUM -C .. External Functions .. - LOGICAL LSAME - DOUBLE PRECISION DLAMCH, DLANGE - EXTERNAL DLAMCH, DLANGE, LSAME -C .. External Subroutines .. - EXTERNAL DCOPY, DGEGS, DGEMM, DGEMV, DLABAD, DLACPY, - $ DLASCL, DTGSYL, XERBLA -C .. Intrinsic Functions .. - INTRINSIC INT, MAX, SQRT -C .. Executable Statements .. -C - INFO = 0 - MN = MAX( M, N ) - LREDUR = LSAME( REDUCE, 'R' ) - LREDUA = LSAME( REDUCE, 'A' ) - LREDUB = LSAME( REDUCE, 'B' ) - LREDRA = LREDUR.OR.LREDUA - LREDRB = LREDUR.OR.LREDUB - LREDUC = LREDRA.OR.LREDUB - IF ( LREDUR ) THEN - MINWRK = MAX( 1, 7*MN ) - ELSE IF ( LREDUA ) THEN - MINWRK = MAX( 1, 7*M ) - ELSE IF ( LREDUB ) THEN - MINWRK = MAX( 1, 7*N ) - ELSE - MINWRK = 1 - END IF - LTRANN = LSAME( TRANS, 'N' ) - IF ( LTRANN ) THEN - LJOB1 = LSAME( JOBD, '1' ) - LJOB2 = LSAME( JOBD, '2' ) - LJOBD = LSAME( JOBD, 'D' ) - LJOBF = LSAME( JOBD, 'F' ) - LJOBDF = LJOB1.OR.LJOB2.OR.LJOBD.OR.LJOBF - IF ( LJOBD.OR.LJOBF ) MINWRK = MAX( MINWRK, 2*M*N ) - END IF -C -C Test the input scalar arguments. -C - IF( .NOT.LREDUC .AND. .NOT.LSAME( REDUCE, 'N' ) ) THEN - INFO = -1 - ELSE IF( .NOT.LTRANN .AND. .NOT.LSAME( TRANS, 'T' ) ) THEN - INFO = -2 - ELSE IF( LTRANN ) THEN - IF( .NOT.LJOBDF .AND. .NOT.LSAME( JOBD, 'N' ) ) - $ INFO = -3 - END IF - IF( M.LT.0 ) THEN - INFO = -4 - ELSE IF( N.LT.0 ) THEN - INFO = -5 - ELSE IF( LDA.LT.MAX( 1, M ) ) THEN - INFO = -7 - ELSE IF( LDB.LT.MAX( 1, N ) ) THEN - INFO = -9 - ELSE IF( LDC.LT.MAX( 1, M ) ) THEN - INFO = -11 - ELSE IF( LDD.LT.MAX( 1, M ) ) THEN - INFO = -13 - ELSE IF( LDE.LT.MAX( 1, N ) ) THEN - INFO = -15 - ELSE IF( LDF.LT.MAX( 1, M ) ) THEN - INFO = -17 - ELSE IF( ( .NOT.LREDRA .AND. LDP.LT.1 ) .OR. - $ ( LREDRA .AND. LDP.LT.MAX( 1, M ) ) ) THEN - INFO = -21 - ELSE IF( ( .NOT.LREDRA .AND. LDQ.LT.1 ) .OR. - $ ( LREDRA .AND. LDQ.LT.MAX( 1, M ) ) ) THEN - INFO = -23 - ELSE IF( ( .NOT.LREDRB .AND. LDU.LT.1 ) .OR. - $ ( LREDRB .AND. LDU.LT.MAX( 1, N ) ) ) THEN - INFO = -25 - ELSE IF( ( .NOT.LREDRB .AND. LDV.LT.1 ) .OR. - $ ( LREDRB .AND. LDV.LT.MAX( 1, N ) ) ) THEN - INFO = -27 - ELSE IF( LDWORK.LT.MINWRK ) THEN - INFO = -30 - END IF -C - IF ( INFO.NE.0 ) THEN -C -C Error return. -C - CALL XERBLA( 'SB04OD', -INFO ) - RETURN - END IF -C -C Quick return if possible. -C - IF ( N.EQ.0 .OR. M.EQ.0 ) THEN - SCALE = ONE - DWORK(1) = ONE - IF ( LTRANN ) THEN - IF ( LJOBDF ) DIF = ONE - END IF - RETURN - END IF - WRKOPT = 1 - SUFWRK = LDWORK.GE.M*N -C -C STEP 1: Reduce (A,D) and/or (B,E) to generalized Schur form. -C -C (Note: Comments in the code beginning "Workspace:" describe the -C minimal amount of real workspace needed at that point in the -C code, as well as the preferred amount for good performance. -C NB refers to the optimal block size for the immediately -C following subroutine, as returned by ILAENV.) -C - IF ( LREDUC ) THEN -C -C Get machine constants. -C - SAFMIN = DLAMCH( 'Safe minimum' ) - SAFMAX = ONE / SAFMIN - CALL DLABAD( SAFMIN, SAFMAX ) - SMLNUM = SQRT( SAFMIN ) / DLAMCH( 'Precision' ) - BIGNUM = ONE / SMLNUM -C - IF ( .NOT.LREDUB ) THEN -C -C Scale A if max element outside range [SMLNUM,BIGNUM]. -C - ANRM = DLANGE( 'M', M, M, A, LDA, DWORK ) - ILASCL = .FALSE. - IF( ANRM.GT.ZERO .AND. ANRM.LT.SMLNUM ) THEN - ANRMTO = SMLNUM - ILASCL = .TRUE. - ELSE IF( ANRM.GT.BIGNUM ) THEN - ANRMTO = BIGNUM - ILASCL = .TRUE. - END IF - IF( ILASCL ) - $ CALL DLASCL( 'G', 0, 0, ANRM, ANRMTO, M, M, A, LDA, - $ IERR ) -C -C Scale D if max element outside range [SMLNUM,BIGNUM] -C - DNRM = DLANGE( 'M', M, M, D, LDD, DWORK ) - ILDSCL = .FALSE. - IF( DNRM.GT.ZERO .AND. DNRM.LT.SMLNUM ) THEN - DNRMTO = SMLNUM - ILDSCL = .TRUE. - ELSE IF( DNRM.GT.BIGNUM ) THEN - DNRMTO = BIGNUM - ILDSCL = .TRUE. - END IF - IF( ILDSCL ) - $ CALL DLASCL( 'G', 0, 0, DNRM, DNRMTO, M, M, D, LDD, - $ IERR ) -C -C Reduce (A,D) to generalized Schur form. -C Workspace: need 7*M; -C prefer 5*M + M*(NB+1). -C - CALL DGEGS( 'Vectors left', 'Vectors right', M, A, LDA, D, - $ LDD, DWORK, DWORK(M+1), DWORK(2*M+1), P, LDP, Q, - $ LDQ, DWORK(3*M+1), LDWORK-3*M, INFO ) -C -C Undo scaling -C - IF( ILASCL ) - $ CALL DLASCL( 'H', 0, 0, ANRMTO, ANRM, M, M, A, LDA, - $ IERR ) -C - IF( ILDSCL ) - $ CALL DLASCL( 'U', 0, 0, DNRMTO, DNRM, M, M, D, LDD, - $ IERR ) -C - IF ( INFO.NE.0 ) THEN - INFO = 1 - RETURN - END IF - WRKOPT = MAX( WRKOPT, INT( DWORK(3*M+1) ) + 3*M ) - END IF - IF ( .NOT.LREDUA ) THEN -C -C Scale B if max element outside range [SMLNUM,BIGNUM] -C - BNRM = DLANGE( 'M', N, N, B, LDB, DWORK ) - ILBSCL = .FALSE. - IF( BNRM.GT.ZERO .AND. BNRM.LT.SMLNUM ) THEN - BNRMTO = SMLNUM - ILBSCL = .TRUE. - ELSE IF( BNRM.GT.BIGNUM ) THEN - BNRMTO = BIGNUM - ILBSCL = .TRUE. - END IF - IF( ILBSCL ) - $ CALL DLASCL( 'G', 0, 0, BNRM, BNRMTO, N, N, B, LDB, - $ IERR ) -C -C Scale E if max element outside range [SMLNUM,BIGNUM] -C - ENRM = DLANGE( 'M', N, N, E, LDE, DWORK ) - ILESCL = .FALSE. - IF( ENRM.GT.ZERO .AND. ENRM.LT.SMLNUM ) THEN - ENRMTO = SMLNUM - ILESCL = .TRUE. - ELSE IF( ENRM.GT.BIGNUM ) THEN - ENRMTO = BIGNUM - ILESCL = .TRUE. - END IF - IF( ILESCL ) - $ CALL DLASCL( 'G', 0, 0, ENRM, ENRMTO, N, N, E, LDE, - $ IERR ) -C -C Reduce (B,E) to generalized Schur form. -C Workspace: need 7*N; -C prefer 5*N + N*(NB+1). -C - CALL DGEGS( 'Vectors left', 'Vectors right', N, B, LDB, E, - $ LDE, DWORK, DWORK(N+1), DWORK(2*N+1), U, LDU, V, - $ LDV, DWORK(3*N+1), LDWORK-3*N, INFO ) -C -C Undo scaling -C - IF( ILBSCL ) - $ CALL DLASCL( 'H', 0, 0, BNRMTO, BNRM, N, N, B, LDB, - $ IERR ) -C - IF( ILESCL ) - $ CALL DLASCL( 'U', 0, 0, ENRMTO, ENRM, N, N, E, LDE, - $ IERR ) -C - IF ( INFO.NE.0 ) THEN - INFO = 1 - RETURN - END IF - WRKOPT = MAX( WRKOPT, INT( DWORK(3*N+1) ) + 3*N ) - END IF - END IF -C - IF (.NOT.LREDUR ) THEN -C -C Set INFO = 2 if A and/or B are/is not in quasi-triangular form. -C - IF (.NOT.LREDUA ) THEN - I = 1 -C - 20 CONTINUE - IF ( I.LE.M-2 ) THEN - IF ( A(I+1,I).NE.ZERO ) THEN - IF ( A(I+2,I+1).NE.ZERO ) THEN - INFO = 2 - RETURN - ELSE - I = I + 1 - END IF - END IF - I = I + 1 - GO TO 20 - END IF - END IF -C - IF (.NOT.LREDUB ) THEN - I = 1 -C - 40 CONTINUE - IF ( I.LE.N-2 ) THEN - IF ( B(I+1,I).NE.ZERO ) THEN - IF ( B(I+2,I+1).NE.ZERO ) THEN - INFO = 2 - RETURN - ELSE - I = I + 1 - END IF - END IF - I = I + 1 - GO TO 40 - END IF - END IF - END IF -C -C STEP 2: Modify right hand sides (C,F). -C - IF ( LREDUC ) THEN - WRKOPT = MAX( WRKOPT, M*N ) - IF ( SUFWRK ) THEN -C -C Enough workspace for a BLAS 3 calculation. -C - IF ( LTRANN ) THEN -C -C Equation (1). -C - IF ( .NOT.LREDUB ) THEN - CALL DGEMM( 'Transpose', 'No transpose', M, N, M, ONE, - $ P, LDP, C, LDC, ZERO, DWORK, M ) - ELSE - CALL DLACPY( 'Full', M, N, C, LDC, DWORK, M ) - END IF - IF ( .NOT.LREDUA ) THEN - CALL DGEMM( 'No transpose', 'No transpose', M, N, N, - $ ONE, DWORK, M, V, LDV, ZERO, C, LDC ) - ELSE - CALL DLACPY( 'Full', M, N, DWORK, M, C, LDC ) - END IF - IF ( .NOT.LREDUB ) THEN - CALL DGEMM( 'Transpose', 'No transpose', M, N, M, ONE, - $ P, LDP, F, LDF, ZERO, DWORK, M ) - ELSE - CALL DLACPY( 'Full', M, N, F, LDF, DWORK, M ) - END IF - IF ( .NOT.LREDUA ) THEN - CALL DGEMM( 'No transpose', 'No transpose', M, N, N, - $ ONE, DWORK, M, V, LDV, ZERO, F, LDF ) - ELSE - CALL DLACPY( 'Full', M, N, DWORK, M, F, LDF ) - END IF - ELSE -C -C Equation (2). -C - IF ( .NOT.LREDUB ) THEN - CALL DGEMM( 'Transpose', 'No transpose', M, N, M, ONE, - $ Q, LDQ, C, LDC, ZERO, DWORK, M ) - ELSE - CALL DLACPY( 'Full', M, N, C, LDC, DWORK, M ) - END IF - IF ( .NOT.LREDUA ) THEN - CALL DGEMM( 'No transpose', 'No transpose', M, N, N, - $ ONE, DWORK, M, V, LDV, ZERO, C, LDC ) - ELSE - CALL DLACPY( 'Full', M, N, DWORK, M, C, LDC ) - END IF - IF ( .NOT.LREDUB ) THEN - CALL DGEMM( 'Transpose', 'No transpose', M, N, M, ONE, - $ P, LDP, F, LDF, ZERO, DWORK, M ) - ELSE - CALL DLACPY( 'Full', M, N, F, LDF, DWORK, M ) - END IF - IF ( .NOT.LREDUA ) THEN - CALL DGEMM( 'No transpose', 'No transpose', M, N, N, - $ ONE, DWORK, M, U, LDU, ZERO, F, LDF ) - ELSE - CALL DLACPY( 'Full', M, N, DWORK, M, F, LDF ) - END IF - END IF - ELSE -C -C Use a BLAS 2 calculation. -C - IF ( LTRANN ) THEN -C -C Equation (1). -C - IF ( .NOT.LREDUB ) THEN -C - DO 60 I = 1, N - CALL DGEMV( 'Transpose', M, M, ONE, P, LDP, C(1,I), - $ 1, ZERO, DWORK, 1 ) - CALL DCOPY( M, DWORK, 1, C(1,I), 1 ) - 60 CONTINUE -C - END IF - IF ( .NOT.LREDUA ) THEN -C - DO 80 I = 1, M - CALL DGEMV( 'Transpose', N, N, ONE, V, LDV, C(I,1), - $ LDC, ZERO, DWORK, 1 ) - CALL DCOPY( N, DWORK, 1, C(I,1), LDC ) - 80 CONTINUE -C - END IF - IF ( .NOT.LREDUB ) THEN -C - DO 100 I = 1, N - CALL DGEMV( 'Transpose', M, M, ONE, P, LDP, F(1,I), - $ 1, ZERO, DWORK, 1 ) - CALL DCOPY( M, DWORK, 1, F(1,I), 1 ) - 100 CONTINUE -C - END IF - IF ( .NOT.LREDUA ) THEN -C - DO 120 I = 1, M - CALL DGEMV( 'Transpose', N, N, ONE, V, LDV, F(I,1), - $ LDF, ZERO, DWORK, 1 ) - CALL DCOPY( N, DWORK, 1, F(I,1), LDF ) - 120 CONTINUE -C - END IF - ELSE -C -C Equation (2). -C - IF ( .NOT.LREDUB ) THEN -C - DO 140 I = 1, N - CALL DGEMV( 'Transpose', M, M, ONE, Q, LDQ, C(1,I), - $ 1, ZERO, DWORK, 1 ) - CALL DCOPY( M, DWORK, 1, C(1,I), 1 ) - 140 CONTINUE -C - END IF - IF ( .NOT.LREDUA ) THEN -C - DO 160 I = 1, M - CALL DGEMV( 'Transpose', N, N, ONE, V, LDV, C(I,1), - $ LDC, ZERO, DWORK, 1 ) - CALL DCOPY( N, DWORK, 1, C(I,1), LDC ) - 160 CONTINUE -C - END IF - IF ( .NOT.LREDUB ) THEN -C - DO 180 I = 1, N - CALL DGEMV( 'Transpose', M, M, ONE, P, LDP, F(1,I), - $ 1, ZERO, DWORK, 1 ) - CALL DCOPY( M, DWORK, 1, F(1,I), 1 ) - 180 CONTINUE -C - END IF - IF ( .NOT.LREDUA ) THEN -C - DO 200 I = 1, M - CALL DGEMV( 'Transpose', N, N, ONE, U, LDU, F(I,1), - $ LDF, ZERO, DWORK, 1 ) - CALL DCOPY( N, DWORK, 1, F(I,1), LDF ) - 200 CONTINUE -C - END IF - END IF - END IF - END IF -C -C STEP 3: Solve the transformed system and compute the Dif -C estimator. -C - IF ( LTRANN ) THEN - IF ( LJOBD ) THEN - IJOB = 1 - ELSE IF ( LJOBF ) THEN - IJOB = 2 - ELSE IF ( LJOB1 ) THEN - IJOB = 3 - ELSE IF ( LJOB2 ) THEN - IJOB = 4 - ELSE - IJOB = 0 - END IF - ELSE - IJOB = 0 - END IF -C -C Workspace: need 2*M*N if TRANS = 'N' and JOBD = 'D' or 'F'; -C 1, otherwise. -C - CALL DTGSYL( TRANS, IJOB, M, N, A, LDA, B, LDB, C, LDC, D, LDD, - $ E, LDE, F, LDF, SCALE, DIF, DWORK, LDWORK, IWORK, - $ INFO ) - IF ( INFO.NE.0 ) THEN - INFO = 3 - RETURN - END IF - IF ( LTRANN ) THEN - IF ( LJOBD.OR.LJOBF ) - $ WRKOPT = MAX( WRKOPT, 2*M*N ) - END IF -C -C STEP 4: Back transformation of the solution. -C - IF ( LREDUC ) THEN - IF (SUFWRK ) THEN -C -C Enough workspace for a BLAS 3 calculation. -C - IF ( LTRANN ) THEN -C -C Equation (1). -C - IF ( .NOT.LREDUB ) THEN - CALL DGEMM( 'No transpose', 'No transpose', M, N, M, - $ ONE, Q, LDQ, C, LDC, ZERO, DWORK, M ) - ELSE - CALL DLACPY( 'Full', M, N, C, LDC, DWORK, M ) - END IF - IF ( .NOT.LREDUA ) THEN - CALL DGEMM( 'No transpose', 'Transpose', M, N, N, ONE, - $ DWORK, M, V, LDV, ZERO, C, LDC ) - ELSE - CALL DLACPY( 'Full', M, N, DWORK, M, C, LDC ) - END IF - IF ( .NOT.LREDUB ) THEN - CALL DGEMM( 'No transpose', 'No transpose', M, N, M, - $ ONE, P, LDP, F, LDF, ZERO, DWORK, M ) - ELSE - CALL DLACPY( 'Full', M, N, F, LDF, DWORK, M ) - END IF - IF ( .NOT.LREDUA ) THEN - CALL DGEMM( 'No transpose', 'Transpose', M, N, N, ONE, - $ DWORK, M, U, LDU, ZERO, F, LDF ) - ELSE - CALL DLACPY( 'Full', M, N, DWORK, M, F, LDF ) - END IF - ELSE -C -C Equation (2). -C - IF ( .NOT.LREDUB ) THEN - CALL DGEMM( 'No transpose', 'No transpose', M, N, M, - $ ONE, P, LDP, C, LDC, ZERO, DWORK, M ) - ELSE - CALL DLACPY( 'Full', M, N, C, LDC, DWORK, M ) - END IF - IF ( .NOT.LREDUA ) THEN - CALL DGEMM( 'No transpose', 'Transpose', M, N, N, - $ ONE, DWORK, M, V, LDV, ZERO, C, LDC ) - ELSE - CALL DLACPY( 'Full', M, N, DWORK, M, C, LDC ) - END IF - IF ( .NOT.LREDUB ) THEN - CALL DGEMM( 'No transpose', 'No transpose', M, N, M, - $ ONE, P, LDP, F, LDF, ZERO, DWORK, M ) - ELSE - CALL DLACPY( 'Full', M, N, F, LDF, DWORK, M ) - END IF - IF ( .NOT.LREDUA ) THEN - CALL DGEMM( 'No transpose', 'Transpose', M, N, N, - $ ONE, DWORK, M, V, LDV, ZERO, F, LDF ) - ELSE - CALL DLACPY( 'Full', M, N, DWORK, M, F, LDF ) - END IF - END IF - ELSE -C -C Use a BLAS 2 calculation. -C - IF ( LTRANN ) THEN -C -C Equation (1). -C - IF ( .NOT.LREDUB ) THEN -C - DO 220 I = 1, N - CALL DGEMV( 'No transpose', M, M, ONE, Q, LDQ, - $ C(1,I), 1, ZERO, DWORK, 1 ) - CALL DCOPY( M, DWORK, 1, C(1,I), 1 ) - 220 CONTINUE -C - END IF - IF ( .NOT.LREDUA ) THEN -C - DO 240 I = 1, M - CALL DGEMV( 'No transpose', N, N, ONE, V, LDV, - $ C(I,1), LDC, ZERO, DWORK, 1 ) - CALL DCOPY( N, DWORK, 1, C(I,1), LDC ) - 240 CONTINUE -C - END IF - IF ( .NOT.LREDUB ) THEN -C - DO 260 I = 1, N - CALL DGEMV( 'No transpose', M, M, ONE, P, LDP, - $ F(1,I), 1, ZERO, DWORK, 1 ) - CALL DCOPY( M, DWORK, 1, F(1,I), 1 ) - 260 CONTINUE -C - END IF - IF ( .NOT.LREDUA ) THEN -C - DO 280 I = 1, M - CALL DGEMV( 'No transpose', N, N, ONE, U, LDU, - $ F(I,1), LDF, ZERO, DWORK, 1 ) - CALL DCOPY( N, DWORK, 1, F(I,1), LDF ) - 280 CONTINUE -C - END IF - ELSE -C -C Equation (2). -C - IF ( .NOT.LREDUB ) THEN -C - DO 300 I = 1, N - CALL DGEMV( 'No transpose', M, M, ONE, P, LDP, - $ C(1,I), 1, ZERO, DWORK, 1 ) - CALL DCOPY( M, DWORK, 1, C(1,I), 1 ) - 300 CONTINUE -C - END IF - IF ( .NOT.LREDUA ) THEN -C - DO 320 I = 1, M - CALL DGEMV( 'No transpose', N, N, ONE, V, LDV, - $ C(I,1), LDC, ZERO, DWORK, 1 ) - CALL DCOPY( N, DWORK, 1, C(I,1), LDC ) - 320 CONTINUE -C - END IF - IF ( .NOT.LREDUB ) THEN -C - DO 340 I = 1, N - CALL DGEMV( 'No transpose', M, M, ONE, P, LDP, - $ F(1,I), 1, ZERO, DWORK, 1 ) - CALL DCOPY( M, DWORK, 1, F(1,I), 1 ) - 340 CONTINUE -C - END IF - IF ( .NOT.LREDUA ) THEN -C - DO 360 I = 1, M - CALL DGEMV( 'No transpose', N, N, ONE, V, LDV, - $ F(I,1), LDF, ZERO, DWORK, 1 ) - CALL DCOPY( N, DWORK, 1, F(I,1), LDF ) - 360 CONTINUE -C - END IF - END IF - END IF - END IF -C - DWORK(1) = WRKOPT -C - RETURN -C *** Last line of SB04OD *** - END diff --git a/mex/sources/libslicot/SB04OW.f b/mex/sources/libslicot/SB04OW.f deleted file mode 100644 index c3d613afd..000000000 --- a/mex/sources/libslicot/SB04OW.f +++ /dev/null @@ -1,568 +0,0 @@ - SUBROUTINE SB04OW( M, N, A, LDA, B, LDB, C, LDC, D, LDD, E, LDE, - $ F, LDF, SCALE, IWORK, INFO ) -C -C SLICOT RELEASE 5.0. -C -C Copyright (c) 2002-2009 NICONET e.V. -C -C This program is free software: you can redistribute it and/or -C modify it under the terms of the GNU General Public License as -C published by the Free Software Foundation, either version 2 of -C the License, or (at your option) any later version. -C -C This program is distributed in the hope that it will be useful, -C but WITHOUT ANY WARRANTY; without even the implied warranty of -C MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the -C GNU General Public License for more details. -C -C You should have received a copy of the GNU General Public License -C along with this program. If not, see -C . -C -C PURPOSE -C -C To solve a periodic Sylvester equation -C -C A * R - L * B = scale * C (1) -C D * L - R * E = scale * F, -C -C using Level 1 and 2 BLAS, where R and L are unknown M-by-N -C matrices, (A, D), (B, E) and (C, F) are given matrix pairs of -C size M-by-M, N-by-N and M-by-N, respectively, with real entries. -C (A, D) and (B, E) must be in periodic Schur form, i.e. A, B are -C upper quasi triangular and D, E are upper triangular. The solution -C (R, L) overwrites (C, F). 0 <= SCALE <= 1 is an output scaling -C factor chosen to avoid overflow. -C -C This routine is largely based on the LAPACK routine DTGSY2 -C developed by Bo Kagstrom and Peter Poromaa. -C -C ARGUMENTS -C -C Input/Output Parameters -C -C M (input) INTEGER -C The order of A and D, and the row dimension of C, F, R -C and L. M >= 0. -C -C N (input) INTEGER -C The order of B and E, and the column dimension of C, F, R -C and L. N >= 0. -C -C A (input) DOUBLE PRECISION array, dimension (LDA,M) -C On entry, the leading M-by-M part of this array must -C contain the upper quasi triangular matrix A. -C -C LDA INTEGER -C The leading dimension of the array A. LDA >= MAX(1,M). -C -C B (input) DOUBLE PRECISION array, dimension (LDB,N) -C On entry, the leading N-by-N part of this array must -C contain the upper quasi triangular matrix B. -C -C LDB INTEGER -C The leading dimension of the array B. LDB >= MAX(1,N). -C -C C (input/output) DOUBLE PRECISION array, dimension (LDC,N) -C On entry, the leading M-by-N part of this array must -C contain the right-hand-side of the first matrix equation -C in (1). -C On exit, the leading M-by-N part of this array contains -C the solution R. -C -C LDC INTEGER -C The leading dimension of the array C. LDC >= MAX(1,M). -C -C D (input) DOUBLE PRECISION array, dimension (LDD,M) -C On entry, the leading M-by-M part of this array must -C contain the upper triangular matrix D. -C -C LDD INTEGER -C The leading dimension of the array D. LDD >= MAX(1,M). -C -C E (input) DOUBLE PRECISION array, dimension (LDE,N) -C On entry, the leading N-by-N part of this array must -C contain the upper triangular matrix E. -C -C LDE INTEGER -C The leading dimension of the array E. LDE >= MAX(1,N). -C -C F (input/output) DOUBLE PRECISION array, dimension (LDF,N) -C On entry, the leading M-by-N part of this array must -C contain the right-hand-side of the second matrix equation -C in (1). -C On exit, the leading M-by-N part of this array contains -C the solution L. -C -C LDF INTEGER -C The leading dimension of the array F. LDF >= MAX(1,M). -C -C SCALE (output) DOUBLE PRECISION -C On exit, 0 <= SCALE <= 1. If 0 < SCALE < 1, the arrays -C C and F will hold the solutions R and L, respectively, to -C a slightly perturbed system but the input matrices A, B, D -C and E have not been changed. If SCALE = 0, C and F will -C hold solutions to the homogeneous system with C = F = 0. -C Normally, SCALE = 1. -C -C Workspace -C -C IWORK INTEGER array, dimension (M+N+2) -C -C Error Indicator -C -C INFO INTEGER -C = 0: successful exit; -C < 0: if INFO = -i, the i-th argument had an illegal -C value; -C > 0: the matrix products A*D and B*E have common or very -C close eigenvalues. -C -C METHOD -C -C In matrix notation solving equation (1) corresponds to solving -C Z*x = scale*b, where Z is defined as -C -C Z = [ kron(In, A) -kron(B', Im) ] (2) -C [ -kron(E', Im) kron(In, D) ], -C -C Ik is the identity matrix of size k and X' is the transpose of X. -C kron(X, Y) is the Kronecker product between the matrices X and Y. -C In the process of solving (1), we solve a number of such systems -C where Dim(Im), Dim(In) = 1 or 2. -C -C REFERENCES -C -C [1] Kagstrom, B. -C A Direct Method for Reordering Eigenvalues in the Generalized -C Real Schur Form of a Regular Matrix Pair (A,B). M.S. Moonen -C et al (eds.), Linear Algebra for Large Scale and Real-Time -C Applications, Kluwer Academic Publ., pp. 195-218, 1993. -C -C [2] Sreedhar, J. and Van Dooren, P. -C A Schur approach for solving some periodic matrix equations. -C U. Helmke et al (eds.), Systems and Networks: Mathematical -C Theory and Applications, Akademie Verlag, Berlin, vol. 77, -C pp. 339-362, 1994. -C -C CONTRIBUTORS -C -C D. Kressner, Technical Univ. Berlin, Germany, and -C P. Benner, Technical Univ. Chemnitz, Germany, December 2003. -C -C REVISIONS -C -C V. Sima, June 2008 (SLICOT version of the HAPACK routine DTGPY2). -C -C KEYWORDS -C -C Matrix equation, periodic Sylvester equation. -C -C ****************************************************************** -C -C .. Parameters .. - INTEGER LDZ - PARAMETER ( LDZ = 8 ) - DOUBLE PRECISION ZERO, ONE - PARAMETER ( ZERO = 0.0D0, ONE = 1.0D0 ) -C .. Scalar Arguments .. - INTEGER INFO, LDA, LDB, LDC, LDD, LDE, LDF, M, N - DOUBLE PRECISION SCALE -C .. Array Arguments .. - INTEGER IWORK(*) - DOUBLE PRECISION A(LDA,*), B(LDB,*), C(LDC,*), D(LDD,*), - $ E(LDE,*), F(LDF,*) -C .. Local Scalars .. - INTEGER I, IE, IERR, II, IS, ISP1, J, JE, JJ, JS, JSP1, - $ K, MB, NB, P, Q, ZDIM - DOUBLE PRECISION SCALOC -C .. Local Arrays .. - INTEGER IPIV(LDZ), JPIV(LDZ) - DOUBLE PRECISION RHS(LDZ), Z(LDZ,LDZ) -C .. External Subroutines .. - EXTERNAL DAXPY, DCOPY, DGEMM, DGEMV, DGER, DGESC2, - $ DGETC2, DLASET, DSCAL, XERBLA -C .. Intrinsic Functions .. - INTRINSIC MAX -C -C .. Executable Statements .. -C -C Check the scalar input parameters. -C - INFO = 0 - IERR = 0 - IF ( M.LE.0 ) THEN - INFO = -1 - ELSE IF ( N.LE.0 ) THEN - INFO = -2 - ELSE IF ( LDA.LT.MAX( 1, M ) ) THEN - INFO = -4 - ELSE IF ( LDB.LT.MAX( 1, N ) ) THEN - INFO = -6 - ELSE IF ( LDC.LT.MAX( 1, M ) ) THEN - INFO = -8 - ELSE IF ( LDD.LT.MAX( 1, M ) ) THEN - INFO = -10 - ELSE IF ( LDE.LT.MAX( 1, N ) ) THEN - INFO = -12 - ELSE IF ( LDF.LT.MAX( 1, M ) ) THEN - INFO = -14 - END IF -C -C Return if there were illegal values. -C - IF ( INFO.NE.0 ) THEN - CALL XERBLA( 'SB04OW', -INFO ) - RETURN - END IF -C -C Determine block structure of A. -C - P = 0 - I = 1 - 10 CONTINUE - IF ( I.GT.M ) - $ GO TO 20 - P = P + 1 - IWORK(P) = I - IF( I.EQ.M ) - $ GO TO 20 - IF ( A(I+1,I).NE.ZERO ) THEN - I = I + 2 - ELSE - I = I + 1 - END IF - GO TO 10 - 20 CONTINUE - IWORK(P+1) = M + 1 -C -C Determine block structure of B. -C - Q = P + 1 - J = 1 - 30 CONTINUE - IF ( J.GT.N ) - $ GO TO 40 - Q = Q + 1 - IWORK(Q) = J - IF( J.EQ.N ) - $ GO TO 40 - IF ( B(J+1,J).NE.ZERO ) THEN - J = J + 2 - ELSE - J = J + 1 - END IF - GO TO 30 - 40 CONTINUE - IWORK(Q+1) = N + 1 -C -C Solve (I, J) - subsystem -C A(I,I) * R(I,J) - L(I,J) * B(J,J) = C(I,J) -C D(I,I) * L(I,J) - R(I,J) * E(J,J) = F(I,J) -C for I = P, P - 1, ..., 1; J = 1, 2, ..., Q. -C - SCALE = ONE - SCALOC = ONE - DO 120 J = P + 2, Q - JS = IWORK(J) - JSP1 = JS + 1 - JE = IWORK(J+1) - 1 - NB = JE - JS + 1 - DO 110 I = P, 1, -1 -C - IS = IWORK(I) - ISP1 = IS + 1 - IE = IWORK(I+1) - 1 - MB = IE - IS + 1 - ZDIM = MB*NB*2 -C - IF ( ( MB.EQ.1 ).AND.( NB.EQ.1 ) ) THEN -C -C Build a 2-by-2 system Z * x = RHS. -C - Z(1,1) = A(IS,IS) - Z(2,1) = -E(JS,JS) - Z(1,2) = -B(JS,JS) - Z(2,2) = D(IS,IS) -C -C Set up right hand side(s). -C - RHS(1) = C(IS,JS) - RHS(2) = F(IS,JS) -C -C Solve Z * x = RHS. -C - CALL DGETC2( ZDIM, Z, LDZ, IPIV, JPIV, IERR ) - IF ( IERR.GT.0 ) - $ INFO = IERR -C - CALL DGESC2( ZDIM, Z, LDZ, RHS, IPIV, JPIV, SCALOC ) - IF ( SCALOC.NE.ONE ) THEN - DO 50 K = 1, N - CALL DSCAL( M, SCALOC, C(1,K), 1 ) - CALL DSCAL( M, SCALOC, F(1,K), 1 ) - 50 CONTINUE - SCALE = SCALE*SCALOC - END IF -C -C Unpack solution vector(s). -C - C(IS,JS) = RHS(1) - F(IS,JS) = RHS(2) -C -C Substitute R(I,J) and L(I,J) into remaining equation. -C - IF ( I.GT.1 ) THEN - CALL DAXPY( IS-1, -RHS(1), A(1,IS), 1, C(1,JS), 1 ) - CALL DAXPY( IS-1, -RHS(2), D(1,IS), 1, F(1,JS), 1 ) - END IF - IF ( J.LT.Q ) THEN - CALL DAXPY( N-JE, RHS(2), B(JS,JE+1), LDB, C(IS,JE+1), - $ LDC ) - CALL DAXPY( N-JE, RHS(1), E(JS,JE+1), LDE, F(IS,JE+1), - $ LDF ) - END IF -C - ELSE IF ( ( MB.EQ.1 ).AND.( NB.EQ.2 ) ) THEN -C -C Build a 4-by-4 system Z * x = RHS. -C - Z(1,1) = A(IS,IS) - Z(2,1) = ZERO - Z(3,1) = -E(JS,JS) - Z(4,1) = -E(JS,JSP1) -C - Z(1,2) = ZERO - Z(2,2) = A(IS,IS) - Z(3,2) = ZERO - Z(4,2) = -E(JSP1,JSP1) -C - Z(1,3) = -B(JS,JS) - Z(2,3) = -B(JS,JSP1) - Z(3,3) = D(IS,IS) - Z(4,3) = ZERO -C - Z(1,4) = -B(JSP1,JS) - Z(2,4) = -B(JSP1,JSP1) - Z(3,4) = ZERO - Z(4,4) = D(IS,IS) -C -C Set up right hand side(s). -C - RHS(1) = C(IS,JS) - RHS(2) = C(IS,JSP1) - RHS(3) = F(IS,JS) - RHS(4) = F(IS,JSP1) -C -C Solve Z * x = RHS. -C - CALL DGETC2( ZDIM, Z, LDZ, IPIV, JPIV, IERR ) - IF ( IERR.GT.0 ) - $ INFO = IERR -C - CALL DGESC2( ZDIM, Z, LDZ, RHS, IPIV, JPIV, SCALOC ) - IF ( SCALOC.NE.ONE ) THEN - DO 60 K = 1, N - CALL DSCAL( M, SCALOC, C(1,K), 1 ) - CALL DSCAL( M, SCALOC, F(1,K), 1 ) - 60 CONTINUE - SCALE = SCALE*SCALOC - END IF -C -C Unpack solution vector(s). -C - C(IS,JS) = RHS(1) - C(IS,JSP1) = RHS(2) - F(IS,JS) = RHS(3) - F(IS,JSP1) = RHS(4) -C -C Substitute R(I,J) and L(I,J) into remaining equation. -C - IF ( I.GT.1 ) THEN - CALL DGER( IS-1, NB, -ONE, A(1,IS), 1, RHS(1), 1, - $ C(1,JS), LDC ) - CALL DGER( IS-1, NB, -ONE, D(1,IS), 1, RHS(3), 1, - $ F(1,JS), LDF ) - END IF - IF ( J.LT.Q ) THEN - CALL DAXPY( N-JE, RHS(3), B(JS,JE+1), LDB, C(IS,JE+1), - $ LDC ) - CALL DAXPY( N-JE, RHS(1), E(JS,JE+1), LDE, F(IS,JE+1), - $ LDF ) - CALL DAXPY( N-JE, RHS(4), B(JSP1,JE+1), LDB, - $ C(IS,JE+1), LDC ) - CALL DAXPY( N-JE, RHS(2), E(JSP1,JE+1), LDE, - $ F(IS,JE+1), LDF ) - END IF -C - ELSE IF( ( MB.EQ.2 ) .AND. ( NB.EQ.1 ) ) THEN -C -C Build a 4-by-4 system Z * x = RHS. -C - Z(1,1) = A(IS,IS) - Z(2,1) = A(ISP1,IS) - Z(3,1) = -E(JS,JS) - Z(4,1) = ZERO -C - Z(1,2) = A(IS,ISP1) - Z(2,2) = A(ISP1,ISP1) - Z(3,2) = ZERO - Z(4,2) = -E(JS,JS) -C - Z(1,3) = -B(JS,JS) - Z(2,3) = ZERO - Z(3,3) = D(IS,IS) - Z(4,3) = ZERO -C - Z(1,4) = ZERO - Z(2,4) = -B(JS,JS) - Z(3,4) = D(IS,ISP1) - Z(4,4) = D(ISP1,ISP1) -C -C Set up right hand side(s). -C - RHS(1) = C(IS,JS) - RHS(2) = C(ISP1,JS) - RHS(3) = F(IS,JS) - RHS(4) = F(ISP1,JS) -C -C Solve Z * x = RHS. -C - CALL DGETC2( ZDIM, Z, LDZ, IPIV, JPIV, IERR ) - IF ( IERR.GT.0 ) - $ INFO = IERR -C - CALL DGESC2( ZDIM, Z, LDZ, RHS, IPIV, JPIV, SCALOC ) - IF ( SCALOC.NE.ONE ) THEN - DO 70 K = 1, N - CALL DSCAL( M, SCALOC, C(1,K), 1 ) - CALL DSCAL( M, SCALOC, F(1,K), 1 ) - 70 CONTINUE - SCALE = SCALE*SCALOC - END IF -C -C Unpack solution vector(s). -C - C(IS,JS) = RHS(1) - C(ISP1,JS) = RHS(2) - F(IS,JS) = RHS(3) - F(ISP1,JS) = RHS(4) -C -C Substitute R(I,J) and L(I,J) into remaining equation. -C - IF ( I.GT.1 ) THEN - CALL DGEMV( 'N', IS-1, MB, -ONE, A(1,IS), LDA, RHS(1), - $ 1, ONE, C(1,JS), 1 ) - CALL DGEMV( 'N', IS-1, MB, -ONE, D(1,IS), LDD, RHS(3), - $ 1, ONE, F(1,JS), 1 ) - END IF - IF ( J.LT.Q ) THEN - CALL DGER( MB, N-JE, ONE, RHS(3), 1, B(JS,JE+1), LDB, - $ C(IS,JE+1), LDC ) - CALL DGER( MB, N-JE, ONE, RHS(1), 1, E(JS,JE+1), LDE, - $ F(IS,JE+1), LDF ) - END IF -C - ELSE IF ( ( MB.EQ.2 ).AND.( NB.EQ.2 ) ) THEN -C -C Build an 8-by-8 system Z * x = RHS. -C - CALL DLASET( 'All', LDZ, LDZ, ZERO, ZERO, Z, LDZ ) -C - Z(1,1) = A(IS,IS) - Z(2,1) = A(ISP1,IS) - Z(5,1) = -E(JS,JS) - Z(7,1) = -E(JS,JSP1) -C - Z(1,2) = A(IS,ISP1) - Z(2,2) = A(ISP1,ISP1) - Z(6,2) = -E(JS,JS) - Z(8,2) = -E(JS,JSP1) -C - Z(3,3) = A(IS,IS) - Z(4,3) = A(ISP1,IS) - Z(7,3) = -E(JSP1,JSP1) -C - Z(3,4) = A(IS,ISP1) - Z(4,4) = A(ISP1,ISP1) - Z(8,4) = -E(JSP1,JSP1) -C - Z(1,5) = -B(JS,JS) - Z(3,5) = -B(JS,JSP1) - Z(5,5) = D(IS,IS) -C - Z(2,6) = -B(JS,JS) - Z(4,6) = -B(JS,JSP1) - Z(5,6) = D(IS,ISP1) - Z(6,6) = D(ISP1,ISP1) -C - Z(1,7) = -B(JSP1,JS) - Z(3,7) = -B(JSP1,JSP1) - Z(7,7) = D(IS,IS) -C - Z(2,8) = -B(JSP1,JS) - Z(4,8) = -B(JSP1,JSP1) -C - Z(7,8) = D(IS,ISP1) - Z(8,8) = D(ISP1,ISP1) -C -C Set up right hand side(s). -C - K = 1 - II = MB*NB + 1 - DO 80 JJ = 0, NB - 1 - CALL DCOPY( MB, C(IS,JS+JJ), 1, RHS(K), 1 ) - CALL DCOPY( MB, F(IS,JS+JJ), 1, RHS(II), 1 ) - K = K + MB - II = II + MB - 80 CONTINUE -C -C Solve Z * x = RHS. -C - CALL DGETC2( ZDIM, Z, LDZ, IPIV, JPIV, IERR ) - IF ( IERR.GT.0 ) - $ INFO = IERR -C - CALL DGESC2( ZDIM, Z, LDZ, RHS, IPIV, JPIV, SCALOC ) - IF ( SCALOC.NE.ONE ) THEN - DO 90 K = 1, N - CALL DSCAL( M, SCALOC, C(1,K), 1 ) - CALL DSCAL( M, SCALOC, F(1,K), 1 ) - 90 CONTINUE - SCALE = SCALE*SCALOC - END IF -C -C Unpack solution vector(s). -C - K = 1 - II = MB*NB + 1 - DO 100 JJ = 0, NB - 1 - CALL DCOPY( MB, RHS(K), 1, C(IS,JS+JJ), 1 ) - CALL DCOPY( MB, RHS(II), 1, F(IS,JS+JJ), 1 ) - K = K + MB - II = II + MB - 100 CONTINUE -C -C Substitute R(I,J) and L(I,J) into remaining equation. -C - K = MB*NB + 1 - IF ( I.GT.1 ) THEN - CALL DGEMM( 'N', 'N', IS-1, NB, MB, -ONE, A(1,IS), - $ LDA, RHS(1), MB, ONE, C(1,JS), LDC ) - CALL DGEMM( 'N', 'N', IS-1, NB, MB, -ONE, D(1,IS), - $ LDD, RHS(K), MB, ONE, F(1,JS), LDF ) - END IF - IF ( J.LT.Q ) THEN - CALL DGEMM( 'N', 'N', MB, N-JE, NB, ONE, RHS(K), MB, - $ B(JS,JE+1), LDB, ONE, C(IS,JE+1), LDC ) - CALL DGEMM( 'N', 'N', MB, N-JE, NB, ONE, RHS(1), MB, - $ E(JS,JE+1), LDE, ONE, F(IS,JE+1), LDF ) - END IF -C - END IF -C - 110 CONTINUE - 120 CONTINUE - RETURN -C *** Last line of SB04OW *** - END diff --git a/mex/sources/libslicot/SB04PD.f b/mex/sources/libslicot/SB04PD.f deleted file mode 100644 index a2e5899a4..000000000 --- a/mex/sources/libslicot/SB04PD.f +++ /dev/null @@ -1,672 +0,0 @@ - SUBROUTINE SB04PD( DICO, FACTA, FACTB, TRANA, TRANB, ISGN, M, N, - $ A, LDA, U, LDU, B, LDB, V, LDV, C, LDC, SCALE, - $ DWORK, LDWORK, INFO ) -C -C SLICOT RELEASE 5.0. -C -C Copyright (c) 2002-2009 NICONET e.V. -C -C This program is free software: you can redistribute it and/or -C modify it under the terms of the GNU General Public License as -C published by the Free Software Foundation, either version 2 of -C the License, or (at your option) any later version. -C -C This program is distributed in the hope that it will be useful, -C but WITHOUT ANY WARRANTY; without even the implied warranty of -C MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the -C GNU General Public License for more details. -C -C You should have received a copy of the GNU General Public License -C along with this program. If not, see -C . -C -C PURPOSE -C -C To solve for X either the real continuous-time Sylvester equation -C -C op(A)*X + ISGN*X*op(B) = scale*C, (1) -C -C or the real discrete-time Sylvester equation -C -C op(A)*X*op(B) + ISGN*X = scale*C, (2) -C -C where op(M) = M or M**T, and ISGN = 1 or -1. A is M-by-M and -C B is N-by-N; the right hand side C and the solution X are M-by-N; -C and scale is an output scale factor, set less than or equal to 1 -C to avoid overflow in X. The solution matrix X is overwritten -C onto C. -C -C If A and/or B are not (upper) quasi-triangular, that is, block -C upper triangular with 1-by-1 and 2-by-2 diagonal blocks, they are -C reduced to Schur canonical form, that is, quasi-triangular with -C each 2-by-2 diagonal block having its diagonal elements equal and -C its off-diagonal elements of opposite sign. -C -C ARGUMENTS -C -C Mode Parameters -C -C DICO CHARACTER*1 -C Specifies the equation from which X is to be determined -C as follows: -C = 'C': Equation (1), continuous-time case; -C = 'D': Equation (2), discrete-time case. -C -C FACTA CHARACTER*1 -C Specifies whether or not the real Schur factorization -C of the matrix A is supplied on entry, as follows: -C = 'F': On entry, A and U contain the factors from the -C real Schur factorization of the matrix A; -C = 'N': The Schur factorization of A will be computed -C and the factors will be stored in A and U; -C = 'S': The matrix A is quasi-triangular (or Schur). -C -C FACTB CHARACTER*1 -C Specifies whether or not the real Schur factorization -C of the matrix B is supplied on entry, as follows: -C = 'F': On entry, B and V contain the factors from the -C real Schur factorization of the matrix B; -C = 'N': The Schur factorization of B will be computed -C and the factors will be stored in B and V; -C = 'S': The matrix B is quasi-triangular (or Schur). -C -C TRANA CHARACTER*1 -C Specifies the form of op(A) to be used, as follows: -C = 'N': op(A) = A (No transpose); -C = 'T': op(A) = A**T (Transpose); -C = 'C': op(A) = A**T (Conjugate transpose = Transpose). -C -C TRANB CHARACTER*1 -C Specifies the form of op(B) to be used, as follows: -C = 'N': op(B) = B (No transpose); -C = 'T': op(B) = B**T (Transpose); -C = 'C': op(B) = B**T (Conjugate transpose = Transpose). -C -C ISGN INTEGER -C Specifies the sign of the equation as described before. -C ISGN may only be 1 or -1. -C -C Input/Output Parameters -C -C M (input) INTEGER -C The order of the matrix A, and the number of rows in the -C matrices X and C. M >= 0. -C -C N (input) INTEGER -C The order of the matrix B, and the number of columns in -C the matrices X and C. N >= 0. -C -C A (input or input/output) DOUBLE PRECISION array, -C dimension (LDA,M) -C On entry, the leading M-by-M part of this array must -C contain the matrix A. If FACTA = 'S', then A contains -C a quasi-triangular matrix, and if FACTA = 'F', then A -C is in Schur canonical form; the elements below the upper -C Hessenberg part of the array A are not referenced. -C On exit, if FACTA = 'N', and INFO = 0 or INFO >= M+1, the -C leading M-by-M upper Hessenberg part of this array -C contains the upper quasi-triangular matrix in Schur -C canonical form from the Schur factorization of A. The -C contents of array A is not modified if FACTA = 'F' or 'S'. -C -C LDA INTEGER -C The leading dimension of array A. LDA >= MAX(1,M). -C -C U (input or output) DOUBLE PRECISION array, dimension -C (LDU,M) -C If FACTA = 'F', then U is an input argument and on entry -C the leading M-by-M part of this array must contain the -C orthogonal matrix U of the real Schur factorization of A. -C If FACTA = 'N', then U is an output argument and on exit, -C if INFO = 0 or INFO >= M+1, it contains the orthogonal -C M-by-M matrix from the real Schur factorization of A. -C If FACTA = 'S', the array U is not referenced. -C -C LDU INTEGER -C The leading dimension of array U. -C LDU >= MAX(1,M), if FACTA = 'F' or 'N'; -C LDU >= 1, if FACTA = 'S'. -C -C B (input or input/output) DOUBLE PRECISION array, -C dimension (LDB,N) -C On entry, the leading N-by-N part of this array must -C contain the matrix B. If FACTB = 'S', then B contains -C a quasi-triangular matrix, and if FACTB = 'F', then B -C is in Schur canonical form; the elements below the upper -C Hessenberg part of the array B are not referenced. -C On exit, if FACTB = 'N', and INFO = 0 or INFO = M+N+1, -C the leading N-by-N upper Hessenberg part of this array -C contains the upper quasi-triangular matrix in Schur -C canonical form from the Schur factorization of B. The -C contents of array B is not modified if FACTB = 'F' or 'S'. -C -C LDB (input) INTEGER -C The leading dimension of the array B. LDB >= max(1,N). -C -C V (input or output) DOUBLE PRECISION array, dimension -C (LDV,N) -C If FACTB = 'F', then V is an input argument and on entry -C the leading N-by-N part of this array must contain the -C orthogonal matrix V of the real Schur factorization of B. -C If FACTB = 'N', then V is an output argument and on exit, -C if INFO = 0 or INFO = M+N+1, it contains the orthogonal -C N-by-N matrix from the real Schur factorization of B. -C If FACTB = 'S', the array V is not referenced. -C -C LDV INTEGER -C The leading dimension of array V. -C LDV >= MAX(1,N), if FACTB = 'F' or 'N'; -C LDV >= 1, if FACTB = 'S'. -C -C C (input/output) DOUBLE PRECISION array, dimension (LDC,N) -C On entry, the leading M-by-N part of this array must -C contain the right hand side matrix C. -C On exit, if INFO = 0 or INFO = M+N+1, the leading M-by-N -C part of this array contains the solution matrix X. -C -C LDC INTEGER -C The leading dimension of array C. LDC >= MAX(1,M). -C -C SCALE (output) DOUBLE PRECISION -C The scale factor, scale, set less than or equal to 1 to -C prevent the solution overflowing. -C -C Workspace -C -C DWORK DOUBLE PRECISION array, dimension (LDWORK) -C On exit, if INFO = 0 or M+N+1, then: DWORK(1) returns the -C optimal value of LDWORK; if FACTA = 'N', DWORK(1+i) and -C DWORK(1+M+i), i = 1,...,M, contain the real and imaginary -C parts, respectively, of the eigenvalues of A; and, if -C FACTB = 'N', DWORK(1+f+j) and DWORK(1+f+N+j), j = 1,...,N, -C with f = 2*M if FACTA = 'N', and f = 0, otherwise, contain -C the real and imaginary parts, respectively, of the -C eigenvalues of B. -C -C LDWORK INTEGER -C The length of the array DWORK. -C LDWORK >= MAX( 1, a+MAX( c, b+d, b+e ) ), -C where a = 1+2*M, if FACTA = 'N', -C a = 0, if FACTA <> 'N', -C b = 2*N, if FACTB = 'N', FACTA = 'N', -C b = 1+2*N, if FACTB = 'N', FACTA <> 'N', -C b = 0, if FACTB <> 'N', -C c = 3*M, if FACTA = 'N', -C c = M, if FACTA = 'F', -C c = 0, if FACTA = 'S', -C d = 3*N, if FACTB = 'N', -C d = N, if FACTB = 'F', -C d = 0, if FACTB = 'S', -C e = M, if DICO = 'C', FACTA <> 'S', -C e = 0, if DICO = 'C', FACTA = 'S', -C e = 2*M, if DICO = 'D'. -C An upper bound is -C LDWORK = 1+2*M+MAX( 3*M, 5*N, 2*N+2*M ). -C For good performance, LDWORK should be larger, e.g., -C LDWORK = 1+2*M+MAX( 3*M, 5*N, 2*N+2*M, 2*N+M*N ). -C -C Error Indicator -C -C INFO INTEGER -C = 0: successful exit; -C < 0: if INFO = -i, the i-th argument had an illegal -C value; -C = i: if INFO = i, i = 1,...,M, the QR algorithm failed -C to compute all the eigenvalues of the matrix A -C (see LAPACK Library routine DGEES); the elements -C 2+i:1+M and 2+i+M:1+2*M of DWORK contain the real -C and imaginary parts, respectively, of the -C eigenvalues of A which have converged, and the -C array A contains the partially converged Schur form; -C = M+j: if INFO = M+j, j = 1,...,N, the QR algorithm -C failed to compute all the eigenvalues of the matrix -C B (see LAPACK Library routine DGEES); the elements -C 2+f+j:1+f+N and 2+f+j+N:1+f+2*N of DWORK contain the -C real and imaginary parts, respectively, of the -C eigenvalues of B which have converged, and the -C array B contains the partially converged Schur form; -C as defined for the parameter DWORK, -C f = 2*M, if FACTA = 'N', -C f = 0, if FACTA <> 'N'; -C = M+N+1: if DICO = 'C', and the matrices A and -ISGN*B -C have common or very close eigenvalues, or -C if DICO = 'D', and the matrices A and -ISGN*B have -C almost reciprocal eigenvalues (that is, if lambda(i) -C and mu(j) are eigenvalues of A and -ISGN*B, then -C lambda(i) = 1/mu(j) for some i and j); -C perturbed values were used to solve the equation -C (but the matrices A and B are unchanged). -C -C METHOD -C -C An extension and refinement of the algorithms in [1,2] is used. -C If the matrices A and/or B are not quasi-triangular (see PURPOSE), -C they are reduced to Schur canonical form -C -C A = U*S*U', B = V*T*V', -C -C where U, V are orthogonal, and S, T are block upper triangular -C with 1-by-1 and 2-by-2 blocks on their diagonal. The right hand -C side matrix C is updated accordingly, -C -C C = U'*C*V; -C -C then, the solution matrix X of the "reduced" Sylvester equation -C (with A and B in (1) or (2) replaced by S and T, respectively), -C is computed column-wise via a back substitution scheme. A set of -C equivalent linear algebraic systems of equations of order at most -C four are formed and solved using Gaussian elimination with -C complete pivoting. Finally, the solution X of the original -C equation is obtained from the updating formula -C -C X = U*X*V'. -C -C If A and/or B are already quasi-triangular (or in Schur form), the -C initial factorizations and the corresponding updating steps are -C omitted. -C -C REFERENCES -C -C [1] Bartels, R.H. and Stewart, G.W. T -C Solution of the matrix equation A X + XB = C. -C Comm. A.C.M., 15, pp. 820-826, 1972. -C -C [2] Anderson, E., Bai, Z., Bischof, C., Demmel, J., Dongarra, J., -C Du Croz, J., Greenbaum, A., Hammarling, S., McKenney, A., -C Ostrouchov, S., and Sorensen, D. -C LAPACK Users' Guide: Second Edition. -C SIAM, Philadelphia, 1995. -C -C NUMERICAL ASPECTS -C -C The algorithm is stable and reliable, since orthogonal -C transformations and Gaussian elimination with complete pivoting -C are used. If INFO = M+N+1, the Sylvester equation is numerically -C singular. -C -C CONTRIBUTORS -C -C D. Sima, University of Bucharest, April 2000. -C V. Sima, Research Institute for Informatics, Bucharest, Apr. 2000. -C -C REVISIONS -C -C - -C -C KEYWORDS -C -C Matrix algebra, orthogonal transformation, real Schur form, -C Sylvester equation. -C -C ****************************************************************** -C -C .. Parameters .. - DOUBLE PRECISION ZERO, ONE - PARAMETER ( ZERO = 0.0D+0, ONE = 1.0D+0 ) -C .. -C .. Scalar Arguments .. - CHARACTER DICO, FACTA, FACTB, TRANA, TRANB - INTEGER INFO, ISGN, LDA, LDB, LDC, LDU, LDV, LDWORK, M, - $ N - DOUBLE PRECISION SCALE -C .. -C .. Array Arguments .. - DOUBLE PRECISION A( LDA, * ), B( LDB, * ), C( LDC, * ), - $ DWORK( * ), U( LDU, * ), V( LDV, * ) -C .. -C .. Local Scalars .. - LOGICAL BLAS3A, BLAS3B, BLOCKA, BLOCKB, CONT, NOFACA, - $ NOFACB, NOTRNA, NOTRNB, SCHURA, SCHURB - INTEGER AVAILW, BL, CHUNKA, CHUNKB, I, IA, IB, IERR, J, - $ JWORK, MAXWRK, MINWRK, SDIM -C .. -C .. Local Arrays .. - LOGICAL BWORK( 1 ) -C .. -C .. External Functions .. - LOGICAL LSAME, SELECT - EXTERNAL LSAME, SELECT -C .. -C .. External Subroutines .. - EXTERNAL DCOPY, DGEES, DGEMM, DGEMV, DLACPY, DTRSYL, - $ SB04PY, XERBLA -C .. -C .. Intrinsic Functions .. - INTRINSIC DBLE, INT, MAX, MIN -C .. -C .. Executable Statements .. -C -C Decode and Test input parameters -C - CONT = LSAME( DICO, 'C' ) - NOFACA = LSAME( FACTA, 'N' ) - NOFACB = LSAME( FACTB, 'N' ) - SCHURA = LSAME( FACTA, 'S' ) - SCHURB = LSAME( FACTB, 'S' ) - NOTRNA = LSAME( TRANA, 'N' ) - NOTRNB = LSAME( TRANB, 'N' ) -C - INFO = 0 - IF( .NOT.CONT .AND. .NOT.LSAME( DICO, 'D' ) ) THEN - INFO = -1 - ELSE IF( .NOT.NOFACA .AND. .NOT.LSAME( FACTA, 'F' ) .AND. - $ .NOT.SCHURA ) THEN - INFO = -2 - ELSE IF( .NOT.NOFACB .AND. .NOT.LSAME( FACTB, 'F' ) .AND. - $ .NOT.SCHURB ) THEN - INFO = -3 - ELSE IF( .NOT.NOTRNA .AND. .NOT.LSAME( TRANA, 'T' ) .AND. - $ .NOT.LSAME( TRANA, 'C' ) ) THEN - INFO = -4 - ELSE IF( .NOT.NOTRNB .AND. .NOT.LSAME( TRANB, 'T' ) .AND. - $ .NOT.LSAME( TRANB, 'C' ) ) THEN - INFO = -5 - ELSE IF( ISGN.NE.1 .AND. ISGN.NE.-1 ) THEN - INFO = -6 - ELSE IF( M.LT.0 ) THEN - INFO = -7 - ELSE IF( N.LT.0 ) THEN - INFO = -8 - ELSE IF( LDA.LT.MAX( 1, M ) ) THEN - INFO = -10 - ELSE IF( LDU.LT.1 .OR. ( .NOT.SCHURA .AND. LDU.LT.M ) ) THEN - INFO = -12 - ELSE IF( LDB.LT.MAX( 1, N ) ) THEN - INFO = -14 - ELSE IF( LDV.LT.1 .OR. ( .NOT.SCHURB .AND. LDV.LT.N ) ) THEN - INFO = -16 - ELSE IF( LDC.LT.MAX( 1, M ) ) THEN - INFO = -18 - ELSE - IF ( NOFACA ) THEN - IA = 1 + 2*M - MINWRK = 3*M - ELSE - IA = 0 - END IF - IF ( SCHURA ) THEN - MINWRK = 0 - ELSE IF ( .NOT.NOFACA ) THEN - MINWRK = M - END IF - IB = 0 - IF ( NOFACB ) THEN - IB = 2*N - IF ( .NOT.NOFACA ) - $ IB = IB + 1 - MINWRK = MAX( MINWRK, IB + 3*N ) - ELSE IF ( .NOT.SCHURB ) THEN - MINWRK = MAX( MINWRK, N ) - END IF - IF ( CONT ) THEN - IF ( .NOT.SCHURA ) - $ MINWRK = MAX( MINWRK, IB + M ) - ELSE - MINWRK = MAX( MINWRK, IB + 2*M ) - END IF - MINWRK = MAX( 1, IA + MINWRK ) - IF( LDWORK.LT.MINWRK ) - $ INFO = -21 - END IF -C - IF( INFO.NE.0 ) THEN - CALL XERBLA( 'SB04PD', -INFO ) - RETURN - END IF -C -C Quick return if possible. -C - IF( M.EQ.0 .OR. N.EQ.0 ) THEN - SCALE = ONE - DWORK( 1 ) = ONE - RETURN - END IF - MAXWRK = MINWRK -C - IF( NOFACA ) THEN -C -C Compute the Schur factorization of A. -C Workspace: need 1+5*M; -C prefer larger. -C (Note: Comments in the code beginning "Workspace:" describe the -C minimal amount of real workspace needed at that point in the -C code, as well as the preferred amount for good performance. -C NB refers to the optimal block size for the immediately -C following subroutine, as returned by ILAENV.) -C - JWORK = 2*M + 2 - IA = JWORK - AVAILW = LDWORK - JWORK + 1 - CALL DGEES( 'Vectors', 'Not ordered', SELECT, M, A, LDA, SDIM, - $ DWORK( 2 ), DWORK( M+2 ), U, LDU, DWORK( JWORK ), - $ AVAILW, BWORK, IERR ) - IF( IERR.GT.0 ) THEN - INFO = IERR - RETURN - END IF - MAXWRK = MAX( MAXWRK, INT( DWORK( JWORK ) ) + JWORK - 1 ) - ELSE - JWORK = 1 - IA = 2 - AVAILW = LDWORK - END IF -C - IF( .NOT.SCHURA ) THEN -C -C Transform the right-hand side: C <-- U'*C. -C Workspace: need a+M, -C prefer a+M*N, -C where a = 1+2*M, if FACTA = 'N', -C a = 0, if FACTA <> 'N'. -C - CHUNKA = AVAILW / M - BLOCKA = MIN( CHUNKA, N ).GT.1 - BLAS3A = CHUNKA.GE.N .AND. BLOCKA -C - IF ( BLAS3A ) THEN -C -C Enough workspace for a fast BLAS 3 algorithm. -C - CALL DLACPY( 'Full', M, N, C, LDC, DWORK( JWORK ), M ) - CALL DGEMM( 'Transpose', 'NoTranspose', M, N, M, ONE, - $ U, LDU, DWORK( JWORK ), M, ZERO, C, LDC ) - ELSE IF ( BLOCKA ) THEN -C -C Use as many columns of C as possible. -C - DO 10 J = 1, N, CHUNKA - BL = MIN( N-J+1, CHUNKA ) - CALL DLACPY( 'Full', M, BL, C( 1, J ), LDC, - $ DWORK( JWORK ), M ) - CALL DGEMM( 'Transpose', 'NoTranspose', M, BL, M, ONE, - $ U, LDU, DWORK( JWORK ), M, ZERO, C( 1, J ), - $ LDC ) - 10 CONTINUE -C - ELSE -C -C Use a BLAS 2 algorithm. -C - DO 20 J = 1, N - CALL DCOPY( M, C( 1, J ), 1, DWORK( JWORK ), 1 ) - CALL DGEMV( 'Transpose', M, M, ONE, U, LDU, - $ DWORK( JWORK ), 1, ZERO, C( 1, J ), 1 ) - 20 CONTINUE -C - END IF - MAXWRK = MAX( MAXWRK, JWORK + M*N - 1 ) - END IF -C - IF( NOFACB ) THEN -C -C Compute the Schur factorization of B. -C Workspace: need 1+MAX(a-1,0)+5*N, -C prefer larger. -C - JWORK = IA + 2*N - AVAILW = LDWORK - JWORK + 1 - CALL DGEES( 'Vectors', 'Not ordered', SELECT, N, B, LDB, SDIM, - $ DWORK( IA ), DWORK( N+IA ), V, LDV, DWORK( JWORK ), - $ AVAILW, BWORK, IERR ) - IF( IERR.GT.0 ) THEN - INFO = IERR + M - RETURN - END IF - MAXWRK = MAX( MAXWRK, INT( DWORK( JWORK ) ) + JWORK - 1 ) -C - IF( .NOT.SCHURA ) THEN -C -C Recompute the blocking parameters. -C - CHUNKA = AVAILW / M - BLOCKA = MIN( CHUNKA, N ).GT.1 - BLAS3A = CHUNKA.GE.N .AND. BLOCKA - END IF - END IF -C - IF( .NOT.SCHURB ) THEN -C -C Transform the right-hand side: C <-- C*V. -C Workspace: need a+b+N, -C prefer a+b+M*N, -C where b = 2*N, if FACTB = 'N', FACTA = 'N', -C b = 1+2*N, if FACTB = 'N', FACTA <> 'N', -C b = 0, if FACTB <> 'N'. -C - CHUNKB = AVAILW / N - BLOCKB = MIN( CHUNKB, M ).GT.1 - BLAS3B = CHUNKB.GE.M .AND. BLOCKB -C - IF ( BLAS3B ) THEN -C -C Enough workspace for a fast BLAS 3 algorithm. -C - CALL DLACPY( 'Full', M, N, C, LDC, DWORK( JWORK ), M ) - CALL DGEMM( 'NoTranspose', 'NoTranspose', M, N, N, ONE, - $ DWORK( JWORK ), M, V, LDV, ZERO, C, LDC ) - ELSE IF ( BLOCKB ) THEN -C -C Use as many rows of C as possible. -C - DO 30 I = 1, M, CHUNKB - BL = MIN( M-I+1, CHUNKB ) - CALL DLACPY( 'Full', BL, N, C( I, 1 ), LDC, - $ DWORK( JWORK ), BL ) - CALL DGEMM( 'NoTranspose', 'NoTranspose', BL, N, N, ONE, - $ DWORK( JWORK ), BL, V, LDV, ZERO, C( I, 1 ), - $ LDC ) - 30 CONTINUE -C - ELSE -C -C Use a BLAS 2 algorithm. -C - DO 40 I = 1, M - CALL DCOPY( N, C( I, 1 ), LDC, DWORK( JWORK ), 1 ) - CALL DGEMV( 'Transpose', N, N, ONE, V, LDV, - $ DWORK( JWORK ), 1, ZERO, C( I, 1 ), LDC ) - 40 CONTINUE -C - END IF - MAXWRK = MAX( MAXWRK, JWORK + M*N - 1 ) - END IF -C -C Solve the (transformed) equation. -C Workspace for DICO = 'D': a+b+2*M. -C - IF ( CONT ) THEN - CALL DTRSYL( TRANA, TRANB, ISGN, M, N, A, LDA, B, LDB, C, LDC, - $ SCALE, IERR ) - ELSE - CALL SB04PY( TRANA, TRANB, ISGN, M, N, A, LDA, B, LDB, C, LDC, - $ SCALE, DWORK( JWORK ), IERR ) - MAXWRK = MAX( MAXWRK, JWORK + 2*M - 1 ) - END IF - IF( IERR.GT.0 ) - $ INFO = M + N + 1 -C -C Transform back the solution, if needed. -C - IF( .NOT.SCHURA ) THEN -C -C Transform the right-hand side: C <-- U*C. -C Workspace: need a+b+M; -C prefer a+b+M*N. -C - IF ( BLAS3A ) THEN -C -C Enough workspace for a fast BLAS 3 algorithm. -C - CALL DLACPY( 'Full', M, N, C, LDC, DWORK( JWORK ), M ) - CALL DGEMM( 'NoTranspose', 'NoTranspose', M, N, M, ONE, - $ U, LDU, DWORK( JWORK ), M, ZERO, C, LDC ) - ELSE IF ( BLOCKA ) THEN -C -C Use as many columns of C as possible. -C - DO 50 J = 1, N, CHUNKA - BL = MIN( N-J+1, CHUNKA ) - CALL DLACPY( 'Full', M, BL, C( 1, J ), LDC, - $ DWORK( JWORK ), M ) - CALL DGEMM( 'NoTranspose', 'NoTranspose', M, BL, M, ONE, - $ U, LDU, DWORK( JWORK ), M, ZERO, C( 1, J ), - $ LDC ) - 50 CONTINUE -C - ELSE -C -C Use a BLAS 2 algorithm. -C - DO 60 J = 1, N - CALL DCOPY( M, C( 1, J ), 1, DWORK( JWORK ), 1 ) - CALL DGEMV( 'NoTranspose', M, M, ONE, U, LDU, - $ DWORK( JWORK ), 1, ZERO, C( 1, J ), 1 ) - 60 CONTINUE -C - END IF - END IF -C - IF( .NOT.SCHURB ) THEN -C -C Transform the right-hand side: C <-- C*V'. -C Workspace: need a+b+N; -C prefer a+b+M*N. -C - IF ( BLAS3B ) THEN -C -C Enough workspace for a fast BLAS 3 algorithm. -C - CALL DLACPY( 'Full', M, N, C, LDC, DWORK( JWORK ), M ) - CALL DGEMM( 'NoTranspose', 'Transpose', M, N, N, ONE, - $ DWORK( JWORK ), M, V, LDV, ZERO, C, LDC ) - ELSE IF ( BLOCKB ) THEN -C -C Use as many rows of C as possible. -C - DO 70 I = 1, M, CHUNKB - BL = MIN( M-I+1, CHUNKB ) - CALL DLACPY( 'Full', BL, N, C( I, 1 ), LDC, - $ DWORK( JWORK ), BL ) - CALL DGEMM( 'NoTranspose', 'Transpose', BL, N, N, ONE, - $ DWORK( JWORK ), BL, V, LDV, ZERO, C( I, 1 ), - $ LDC ) - 70 CONTINUE -C - ELSE -C -C Use a BLAS 2 algorithm. -C - DO 80 I = 1, M - CALL DCOPY( N, C( I, 1 ), LDC, DWORK( JWORK ), 1 ) - CALL DGEMV( 'NoTranspose', N, N, ONE, V, LDV, - $ DWORK( JWORK ), 1, ZERO, C( I, 1 ), LDC ) - 80 CONTINUE -C - END IF - END IF -C - DWORK( 1 ) = DBLE( MAXWRK ) -C - RETURN -C *** Last line of SB04PD *** - END diff --git a/mex/sources/libslicot/SB04PX.f b/mex/sources/libslicot/SB04PX.f deleted file mode 100644 index 99bd63d3b..000000000 --- a/mex/sources/libslicot/SB04PX.f +++ /dev/null @@ -1,468 +0,0 @@ - SUBROUTINE SB04PX( LTRANL, LTRANR, ISGN, N1, N2, TL, LDTL, TR, - $ LDTR, B, LDB, SCALE, X, LDX, XNORM, INFO ) -C -C SLICOT RELEASE 5.0. -C -C Copyright (c) 2002-2009 NICONET e.V. -C -C This program is free software: you can redistribute it and/or -C modify it under the terms of the GNU General Public License as -C published by the Free Software Foundation, either version 2 of -C the License, or (at your option) any later version. -C -C This program is distributed in the hope that it will be useful, -C but WITHOUT ANY WARRANTY; without even the implied warranty of -C MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the -C GNU General Public License for more details. -C -C You should have received a copy of the GNU General Public License -C along with this program. If not, see -C . -C -C PURPOSE -C -C To solve for the N1-by-N2 matrix X, 1 <= N1,N2 <= 2, in -C -C op(TL)*X*op(TR) + ISGN*X = SCALE*B, -C -C where TL is N1-by-N1, TR is N2-by-N2, B is N1-by-N2, and ISGN = 1 -C or -1. op(T) = T or T', where T' denotes the transpose of T. -C -C ARGUMENTS -C -C Mode Parameters -C -C LTRANL LOGICAL -C Specifies the form of op(TL) to be used, as follows: -C = .FALSE.: op(TL) = TL, -C = .TRUE. : op(TL) = TL'. -C -C LTRANR LOGICAL -C Specifies the form of op(TR) to be used, as follows: -C = .FALSE.: op(TR) = TR, -C = .TRUE. : op(TR) = TR'. -C -C ISGN INTEGER -C Specifies the sign of the equation as described before. -C ISGN may only be 1 or -1. -C -C Input/Output Parameters -C -C N1 (input) INTEGER -C The order of matrix TL. N1 may only be 0, 1 or 2. -C -C N2 (input) INTEGER -C The order of matrix TR. N2 may only be 0, 1 or 2. -C -C TL (input) DOUBLE PRECISION array, dimension (LDTL,N1) -C The leading N1-by-N1 part of this array must contain the -C matrix TL. -C -C LDTL INTEGER -C The leading dimension of array TL. LDTL >= MAX(1,N1). -C -C TR (input) DOUBLE PRECISION array, dimension (LDTR,N2) -C The leading N2-by-N2 part of this array must contain the -C matrix TR. -C -C LDTR INTEGER -C The leading dimension of array TR. LDTR >= MAX(1,N2). -C -C B (input) DOUBLE PRECISION array, dimension (LDB,N2) -C The leading N1-by-N2 part of this array must contain the -C right-hand side of the equation. -C -C LDB INTEGER -C The leading dimension of array B. LDB >= MAX(1,N1). -C -C SCALE (output) DOUBLE PRECISION -C The scale factor. SCALE is chosen less than or equal to 1 -C to prevent the solution overflowing. -C -C X (output) DOUBLE PRECISION array, dimension (LDX,N2) -C The leading N1-by-N2 part of this array contains the -C solution of the equation. -C Note that X may be identified with B in the calling -C statement. -C -C LDX INTEGER -C The leading dimension of array X. LDX >= MAX(1,N1). -C -C XNORM (output) DOUBLE PRECISION -C The infinity-norm of the solution. -C -C Error Indicator -C -C INFO INTEGER -C = 0: successful exit; -C = 1: if TL and -ISGN*TR have almost reciprocal -C eigenvalues, so TL or TR is perturbed to get a -C nonsingular equation. -C -C NOTE: In the interests of speed, this routine does not -C check the inputs for errors. -C -C METHOD -C -C The equivalent linear algebraic system of equations is formed and -C solved using Gaussian elimination with complete pivoting. -C -C REFERENCES -C -C [1] Anderson, E., Bai, Z., Bischof, C., Demmel, J., Dongarra, J., -C Du Croz, J., Greenbaum, A., Hammarling, S., McKenney, A., -C Ostrouchov, S., and Sorensen, D. -C LAPACK Users' Guide: Second Edition. -C SIAM, Philadelphia, 1995. -C -C NUMERICAL ASPECTS -C -C The algorithm is stable and reliable, since Gaussian elimination -C with complete pivoting is used. -C -C CONTRIBUTOR -C -C V. Sima, Katholieke Univ. Leuven, Belgium, May 2000. -C This is a modification and slightly more efficient version of -C SLICOT Library routine SB03MU. -C -C REVISIONS -C -C - -C -C KEYWORDS -C -C Discrete-time system, Sylvester equation, matrix algebra. -C -C ****************************************************************** -C -C .. Parameters .. - DOUBLE PRECISION ZERO, ONE, TWO, HALF, EIGHT - PARAMETER ( ZERO = 0.0D+0, ONE = 1.0D+0, - $ TWO = 2.0D+0, HALF = 0.5D+0, EIGHT = 8.0D+0 ) -C .. -C .. Scalar Arguments .. - LOGICAL LTRANL, LTRANR - INTEGER INFO, ISGN, LDB, LDTL, LDTR, LDX, N1, N2 - DOUBLE PRECISION SCALE, XNORM -C .. -C .. Array Arguments .. - DOUBLE PRECISION B( LDB, * ), TL( LDTL, * ), TR( LDTR, * ), - $ X( LDX, * ) -C .. -C .. Local Scalars .. - LOGICAL BSWAP, XSWAP - INTEGER I, IP, IPIV, IPSV, J, JP, JPSV, K - DOUBLE PRECISION BET, EPS, GAM, L21, SGN, SMIN, SMLNUM, TAU1, - $ TEMP, U11, U12, U22, XMAX -C .. -C .. Local Arrays .. - LOGICAL BSWPIV( 4 ), XSWPIV( 4 ) - INTEGER JPIV( 4 ), LOCL21( 4 ), LOCU12( 4 ), - $ LOCU22( 4 ) - DOUBLE PRECISION BTMP( 4 ), T16( 4, 4 ), TMP( 4 ), X2( 2 ) -C .. -C .. External Functions .. - INTEGER IDAMAX - DOUBLE PRECISION DLAMCH - EXTERNAL DLAMCH, IDAMAX -C .. -C .. External Subroutines .. - EXTERNAL DSWAP -C .. -C .. Intrinsic Functions .. - INTRINSIC ABS, MAX -C .. -C .. Data statements .. - DATA LOCU12 / 3, 4, 1, 2 / , LOCL21 / 2, 1, 4, 3 / , - $ LOCU22 / 4, 3, 2, 1 / - DATA XSWPIV / .FALSE., .FALSE., .TRUE., .TRUE. / - DATA BSWPIV / .FALSE., .TRUE., .FALSE., .TRUE. / -C .. -C .. Executable Statements .. -C -C Do not check the input parameters for errors. -C - INFO = 0 - SCALE = ONE -C -C Quick return if possible. -C - IF( N1.EQ.0 .OR. N2.EQ.0 ) THEN - XNORM = ZERO - RETURN - END IF -C -C Set constants to control overflow. -C - EPS = DLAMCH( 'P' ) - SMLNUM = DLAMCH( 'S' ) / EPS - SGN = ISGN -C - K = N1 + N1 + N2 - 2 - GO TO ( 10, 20, 30, 50 )K -C -C 1-by-1: TL11*X*TR11 + ISGN*X = B11. -C - 10 CONTINUE - TAU1 = TL( 1, 1 )*TR( 1, 1 ) + SGN - BET = ABS( TAU1 ) - IF( BET.LE.SMLNUM ) THEN - TAU1 = SMLNUM - BET = SMLNUM - INFO = 1 - END IF -C - GAM = ABS( B( 1, 1 ) ) - IF( SMLNUM*GAM.GT.BET ) - $ SCALE = ONE / GAM -C - X( 1, 1 ) = ( B( 1, 1 )*SCALE ) / TAU1 - XNORM = ABS( X( 1, 1 ) ) - RETURN -C -C 1-by-2: -C TL11*[X11 X12]*op[TR11 TR12] + ISGN*[X11 X12] = [B11 B12]. -C [TR21 TR22] -C - 20 CONTINUE -C - SMIN = MAX( MAX( ABS( TR( 1, 1 ) ), ABS( TR( 1, 2 ) ), - $ ABS( TR( 2, 1 ) ), ABS( TR( 2, 2 ) ) ) - $ *ABS( TL( 1, 1 ) )*EPS, - $ SMLNUM ) - TMP( 1 ) = TL( 1, 1 )*TR( 1, 1 ) + SGN - TMP( 4 ) = TL( 1, 1 )*TR( 2, 2 ) + SGN - IF( LTRANR ) THEN - TMP( 2 ) = TL( 1, 1 )*TR( 2, 1 ) - TMP( 3 ) = TL( 1, 1 )*TR( 1, 2 ) - ELSE - TMP( 2 ) = TL( 1, 1 )*TR( 1, 2 ) - TMP( 3 ) = TL( 1, 1 )*TR( 2, 1 ) - END IF - BTMP( 1 ) = B( 1, 1 ) - BTMP( 2 ) = B( 1, 2 ) - GO TO 40 -C -C 2-by-1: -C op[TL11 TL12]*[X11]*TR11 + ISGN*[X11] = [B11]. -C [TL21 TL22] [X21] [X21] [B21] -C - 30 CONTINUE - SMIN = MAX( MAX( ABS( TL( 1, 1 ) ), ABS( TL( 1, 2 ) ), - $ ABS( TL( 2, 1 ) ), ABS( TL( 2, 2 ) ) ) - $ *ABS( TR( 1, 1 ) )*EPS, - $ SMLNUM ) - TMP( 1 ) = TL( 1, 1 )*TR( 1, 1 ) + SGN - TMP( 4 ) = TL( 2, 2 )*TR( 1, 1 ) + SGN - IF( LTRANL ) THEN - TMP( 2 ) = TL( 1, 2 )*TR( 1, 1 ) - TMP( 3 ) = TL( 2, 1 )*TR( 1, 1 ) - ELSE - TMP( 2 ) = TL( 2, 1 )*TR( 1, 1 ) - TMP( 3 ) = TL( 1, 2 )*TR( 1, 1 ) - END IF - BTMP( 1 ) = B( 1, 1 ) - BTMP( 2 ) = B( 2, 1 ) - 40 CONTINUE -C -C Solve 2-by-2 system using complete pivoting. -C Set pivots less than SMIN to SMIN. -C - IPIV = IDAMAX( 4, TMP, 1 ) - U11 = TMP( IPIV ) - IF( ABS( U11 ).LE.SMIN ) THEN - INFO = 1 - U11 = SMIN - END IF - U12 = TMP( LOCU12( IPIV ) ) - L21 = TMP( LOCL21( IPIV ) ) / U11 - U22 = TMP( LOCU22( IPIV ) ) - U12*L21 - XSWAP = XSWPIV( IPIV ) - BSWAP = BSWPIV( IPIV ) - IF( ABS( U22 ).LE.SMIN ) THEN - INFO = 1 - U22 = SMIN - END IF - IF( BSWAP ) THEN - TEMP = BTMP( 2 ) - BTMP( 2 ) = BTMP( 1 ) - L21*TEMP - BTMP( 1 ) = TEMP - ELSE - BTMP( 2 ) = BTMP( 2 ) - L21*BTMP( 1 ) - END IF - IF( ( TWO*SMLNUM )*ABS( BTMP( 2 ) ).GT.ABS( U22 ) .OR. - $ ( TWO*SMLNUM )*ABS( BTMP( 1 ) ).GT.ABS( U11 ) ) THEN - SCALE = HALF / MAX( ABS( BTMP( 1 ) ), ABS( BTMP( 2 ) ) ) - BTMP( 1 ) = BTMP( 1 )*SCALE - BTMP( 2 ) = BTMP( 2 )*SCALE - END IF - X2( 2 ) = BTMP( 2 ) / U22 - X2( 1 ) = BTMP( 1 ) / U11 - ( U12 / U11 )*X2( 2 ) - IF( XSWAP ) THEN - TEMP = X2( 2 ) - X2( 2 ) = X2( 1 ) - X2( 1 ) = TEMP - END IF - X( 1, 1 ) = X2( 1 ) - IF( N1.EQ.1 ) THEN - X( 1, 2 ) = X2( 2 ) - XNORM = ABS( X2( 1 ) ) + ABS( X2( 2 ) ) - ELSE - X( 2, 1 ) = X2( 2 ) - XNORM = MAX( ABS( X2( 1 ) ), ABS( X2( 2 ) ) ) - END IF - RETURN -C -C 2-by-2: -C op[TL11 TL12]*[X11 X12]*op[TR11 TR12] + ISGN*[X11 X12] = [B11 B12] -C [TL21 TL22] [X21 X22] [TR21 TR22] [X21 X22] [B21 B22] -C -C Solve equivalent 4-by-4 system using complete pivoting. -C Set pivots less than SMIN to SMIN. -C - 50 CONTINUE - SMIN = MAX( ABS( TR( 1, 1 ) ), ABS( TR( 1, 2 ) ), - $ ABS( TR( 2, 1 ) ), ABS( TR( 2, 2 ) ) ) - SMIN = MAX( ABS( TL( 1, 1 ) ), ABS( TL( 1, 2 ) ), - $ ABS( TL( 2, 1 ) ), ABS( TL( 2, 2 ) ) )*SMIN - SMIN = MAX( EPS*SMIN, SMLNUM ) - T16( 1, 1 ) = TL( 1, 1 )*TR( 1, 1 ) + SGN - T16( 2, 2 ) = TL( 2, 2 )*TR( 1, 1 ) + SGN - T16( 3, 3 ) = TL( 1, 1 )*TR( 2, 2 ) + SGN - T16( 4, 4 ) = TL( 2, 2 )*TR( 2, 2 ) + SGN - IF( LTRANL ) THEN - T16( 1, 2 ) = TL( 2, 1 )*TR( 1, 1 ) - T16( 2, 1 ) = TL( 1, 2 )*TR( 1, 1 ) - T16( 3, 4 ) = TL( 2, 1 )*TR( 2, 2 ) - T16( 4, 3 ) = TL( 1, 2 )*TR( 2, 2 ) - ELSE - T16( 1, 2 ) = TL( 1, 2 )*TR( 1, 1 ) - T16( 2, 1 ) = TL( 2, 1 )*TR( 1, 1 ) - T16( 3, 4 ) = TL( 1, 2 )*TR( 2, 2 ) - T16( 4, 3 ) = TL( 2, 1 )*TR( 2, 2 ) - END IF - IF( LTRANR ) THEN - T16( 1, 3 ) = TL( 1, 1 )*TR( 1, 2 ) - T16( 2, 4 ) = TL( 2, 2 )*TR( 1, 2 ) - T16( 3, 1 ) = TL( 1, 1 )*TR( 2, 1 ) - T16( 4, 2 ) = TL( 2, 2 )*TR( 2, 1 ) - ELSE - T16( 1, 3 ) = TL( 1, 1 )*TR( 2, 1 ) - T16( 2, 4 ) = TL( 2, 2 )*TR( 2, 1 ) - T16( 3, 1 ) = TL( 1, 1 )*TR( 1, 2 ) - T16( 4, 2 ) = TL( 2, 2 )*TR( 1, 2 ) - END IF - IF( LTRANL .AND. LTRANR ) THEN - T16( 1, 4 ) = TL( 2, 1 )*TR( 1, 2 ) - T16( 2, 3 ) = TL( 1, 2 )*TR( 1, 2 ) - T16( 3, 2 ) = TL( 2, 1 )*TR( 2, 1 ) - T16( 4, 1 ) = TL( 1, 2 )*TR( 2, 1 ) - ELSE IF( LTRANL .AND. .NOT.LTRANR ) THEN - T16( 1, 4 ) = TL( 2, 1 )*TR( 2, 1 ) - T16( 2, 3 ) = TL( 1, 2 )*TR( 2, 1 ) - T16( 3, 2 ) = TL( 2, 1 )*TR( 1, 2 ) - T16( 4, 1 ) = TL( 1, 2 )*TR( 1, 2 ) - ELSE IF( .NOT.LTRANL .AND. LTRANR ) THEN - T16( 1, 4 ) = TL( 1, 2 )*TR( 1, 2 ) - T16( 2, 3 ) = TL( 2, 1 )*TR( 1, 2 ) - T16( 3, 2 ) = TL( 1, 2 )*TR( 2, 1 ) - T16( 4, 1 ) = TL( 2, 1 )*TR( 2, 1 ) - ELSE - T16( 1, 4 ) = TL( 1, 2 )*TR( 2, 1 ) - T16( 2, 3 ) = TL( 2, 1 )*TR( 2, 1 ) - T16( 3, 2 ) = TL( 1, 2 )*TR( 1, 2 ) - T16( 4, 1 ) = TL( 2, 1 )*TR( 1, 2 ) - END IF - BTMP( 1 ) = B( 1, 1 ) - BTMP( 2 ) = B( 2, 1 ) - BTMP( 3 ) = B( 1, 2 ) - BTMP( 4 ) = B( 2, 2 ) -C -C Perform elimination. -C - DO 100 I = 1, 3 - XMAX = ZERO -C - DO 70 IP = I, 4 -C - DO 60 JP = I, 4 - IF( ABS( T16( IP, JP ) ).GE.XMAX ) THEN - XMAX = ABS( T16( IP, JP ) ) - IPSV = IP - JPSV = JP - END IF - 60 CONTINUE -C - 70 CONTINUE -C - IF( IPSV.NE.I ) THEN - CALL DSWAP( 4, T16( IPSV, 1 ), 4, T16( I, 1 ), 4 ) - TEMP = BTMP( I ) - BTMP( I ) = BTMP( IPSV ) - BTMP( IPSV ) = TEMP - END IF - IF( JPSV.NE.I ) - $ CALL DSWAP( 4, T16( 1, JPSV ), 1, T16( 1, I ), 1 ) - JPIV( I ) = JPSV - IF( ABS( T16( I, I ) ).LT.SMIN ) THEN - INFO = 1 - T16( I, I ) = SMIN - END IF -C - DO 90 J = I + 1, 4 - T16( J, I ) = T16( J, I ) / T16( I, I ) - BTMP( J ) = BTMP( J ) - T16( J, I )*BTMP( I ) -C - DO 80 K = I + 1, 4 - T16( J, K ) = T16( J, K ) - T16( J, I )*T16( I, K ) - 80 CONTINUE -C - 90 CONTINUE -C - 100 CONTINUE -C - IF( ABS( T16( 4, 4 ) ).LT.SMIN ) - $ T16( 4, 4 ) = SMIN - IF( ( EIGHT*SMLNUM )*ABS( BTMP( 1 ) ).GT.ABS( T16( 1, 1 ) ) .OR. - $ ( EIGHT*SMLNUM )*ABS( BTMP( 2 ) ).GT.ABS( T16( 2, 2 ) ) .OR. - $ ( EIGHT*SMLNUM )*ABS( BTMP( 3 ) ).GT.ABS( T16( 3, 3 ) ) .OR. - $ ( EIGHT*SMLNUM )*ABS( BTMP( 4 ) ).GT.ABS( T16( 4, 4 ) ) ) THEN - SCALE = ( ONE / EIGHT ) / MAX( ABS( BTMP( 1 ) ), - $ ABS( BTMP( 2 ) ), ABS( BTMP( 3 ) ), - $ ABS( BTMP( 4 ) ) ) - BTMP( 1 ) = BTMP( 1 )*SCALE - BTMP( 2 ) = BTMP( 2 )*SCALE - BTMP( 3 ) = BTMP( 3 )*SCALE - BTMP( 4 ) = BTMP( 4 )*SCALE - END IF -C - DO 120 I = 1, 4 - K = 5 - I - TEMP = ONE / T16( K, K ) - TMP( K ) = BTMP( K )*TEMP -C - DO 110 J = K + 1, 4 - TMP( K ) = TMP( K ) - ( TEMP*T16( K, J ) )*TMP( J ) - 110 CONTINUE -C - 120 CONTINUE -C - DO 130 I = 1, 3 - IF( JPIV( 4-I ).NE.4-I ) THEN - TEMP = TMP( 4-I ) - TMP( 4-I ) = TMP( JPIV( 4-I ) ) - TMP( JPIV( 4-I ) ) = TEMP - END IF - 130 CONTINUE -C - X( 1, 1 ) = TMP( 1 ) - X( 2, 1 ) = TMP( 2 ) - X( 1, 2 ) = TMP( 3 ) - X( 2, 2 ) = TMP( 4 ) - XNORM = MAX( ABS( TMP( 1 ) ) + ABS( TMP( 3 ) ), - $ ABS( TMP( 2 ) ) + ABS( TMP( 4 ) ) ) -C - RETURN -C *** Last line of SB04PX *** - END diff --git a/mex/sources/libslicot/SB04PY.f b/mex/sources/libslicot/SB04PY.f deleted file mode 100644 index 46b81f880..000000000 --- a/mex/sources/libslicot/SB04PY.f +++ /dev/null @@ -1,1111 +0,0 @@ - SUBROUTINE SB04PY( TRANA, TRANB, ISGN, M, N, A, LDA, B, LDB, C, - $ LDC, SCALE, DWORK, INFO ) -C -C SLICOT RELEASE 5.0. -C -C Copyright (c) 2002-2009 NICONET e.V. -C -C This program is free software: you can redistribute it and/or -C modify it under the terms of the GNU General Public License as -C published by the Free Software Foundation, either version 2 of -C the License, or (at your option) any later version. -C -C This program is distributed in the hope that it will be useful, -C but WITHOUT ANY WARRANTY; without even the implied warranty of -C MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the -C GNU General Public License for more details. -C -C You should have received a copy of the GNU General Public License -C along with this program. If not, see -C . -C -C PURPOSE -C -C To solve for X the discrete-time Sylvester equation -C -C op(A)*X*op(B) + ISGN*X = scale*C, -C -C where op(A) = A or A**T, A and B are both upper quasi-triangular, -C and ISGN = 1 or -1. A is M-by-M and B is N-by-N; the right hand -C side C and the solution X are M-by-N; and scale is an output scale -C factor, set less than or equal to 1 to avoid overflow in X. The -C solution matrix X is overwritten onto C. -C -C A and B must be in Schur canonical form (as returned by LAPACK -C Library routine DHSEQR), that is, block upper triangular with -C 1-by-1 and 2-by-2 diagonal blocks; each 2-by-2 diagonal block has -C its diagonal elements equal and its off-diagonal elements of -C opposite sign. -C -C ARGUMENTS -C -C Mode Parameters -C -C TRANA CHARACTER*1 -C Specifies the form of op(A) to be used, as follows: -C = 'N': op(A) = A (No transpose); -C = 'T': op(A) = A**T (Transpose); -C = 'C': op(A) = A**T (Conjugate transpose = Transpose). -C -C TRANB CHARACTER*1 -C Specifies the form of op(B) to be used, as follows: -C = 'N': op(B) = B (No transpose); -C = 'T': op(B) = B**T (Transpose); -C = 'C': op(B) = B**T (Conjugate transpose = Transpose). -C -C ISGN INTEGER -C Specifies the sign of the equation as described before. -C ISGN may only be 1 or -1. -C -C Input/Output Parameters -C -C M (input) INTEGER -C The order of the matrix A, and the number of rows in the -C matrices X and C. M >= 0. -C -C N (input) INTEGER -C The order of the matrix B, and the number of columns in -C the matrices X and C. N >= 0. -C -C A (input) DOUBLE PRECISION array, dimension (LDA,M) -C The leading M-by-M part of this array must contain the -C upper quasi-triangular matrix A, in Schur canonical form. -C The part of A below the first sub-diagonal is not -C referenced. -C -C LDA INTEGER -C The leading dimension of array A. LDA >= MAX(1,M). -C -C B (input) DOUBLE PRECISION array, dimension (LDB,N) -C The leading N-by-N part of this array must contain the -C upper quasi-triangular matrix B, in Schur canonical form. -C The part of B below the first sub-diagonal is not -C referenced. -C -C LDB (input) INTEGER -C The leading dimension of the array B. LDB >= max(1,N). -C -C C (input/output) DOUBLE PRECISION array, dimension (LDC,N) -C On entry, the leading M-by-N part of this array must -C contain the right hand side matrix C. -C On exit, if INFO >= 0, the leading M-by-N part of this -C array contains the solution matrix X. -C -C LDC INTEGER -C The leading dimension of array C. LDC >= MAX(1,M). -C -C SCALE (output) DOUBLE PRECISION -C The scale factor, scale, set less than or equal to 1 to -C prevent the solution overflowing. -C -C Workspace -C -C DWORK DOUBLE PRECISION array, dimension (2*M) -C -C Error Indicator -C -C INFO INTEGER -C = 0: successful exit; -C < 0: if INFO = -i, the i-th argument had an illegal -C value; -C = 1: A and -ISGN*B have almost reciprocal eigenvalues; -C perturbed values were used to solve the equation -C (but the matrices A and B are unchanged). -C -C METHOD -C -C The solution matrix X is computed column-wise via a back -C substitution scheme, an extension and refinement of the algorithm -C in [1], similar to that used in [2] for continuous-time Sylvester -C equations. A set of equivalent linear algebraic systems of -C equations of order at most four are formed and solved using -C Gaussian elimination with complete pivoting. -C -C REFERENCES -C -C [1] Bartels, R.H. and Stewart, G.W. T -C Solution of the matrix equation A X + XB = C. -C Comm. A.C.M., 15, pp. 820-826, 1972. -C -C [2] Anderson, E., Bai, Z., Bischof, C., Demmel, J., Dongarra, J., -C Du Croz, J., Greenbaum, A., Hammarling, S., McKenney, A., -C Ostrouchov, S., and Sorensen, D. -C LAPACK Users' Guide: Second Edition. -C SIAM, Philadelphia, 1995. -C -C NUMERICAL ASPECTS -C -C The algorithm is stable and reliable, since Gaussian elimination -C with complete pivoting is used. -C -C CONTRIBUTORS -C -C A. Varga, German Aerospace Center, Oberpfaffenhofen, March 2000. -C D. Sima, University of Bucharest, April 2000. -C V. Sima, Research Institute for Informatics, Bucharest, Apr. 2000. -C Partly based on the routine SYLSV, A. Varga, 1992. -C -C REVISIONS -C -C - -C -C KEYWORDS -C -C Discrete-time system, matrix algebra, Sylvester equation. -C -C ****************************************************************** -C -C .. Parameters .. - DOUBLE PRECISION ZERO, ONE - PARAMETER ( ZERO = 0.0D+0, ONE = 1.0D+0 ) -C .. -C .. Scalar Arguments .. - CHARACTER TRANA, TRANB - INTEGER INFO, ISGN, LDA, LDB, LDC, M, N - DOUBLE PRECISION SCALE -C .. -C .. Array Arguments .. - DOUBLE PRECISION A( LDA, * ), B( LDB, * ), C( LDC, * ), - $ DWORK( * ) -C .. -C .. Local Scalars .. - LOGICAL NOTRNA, NOTRNB - INTEGER IERR, J, K, K1, K2, KNEXT, L, L1, L2, LNEXT, - $ MNK1, MNK2, MNL1, MNL2 - DOUBLE PRECISION A11, BIGNUM, DA11, DB, EPS, P11, P12, P21, P22, - $ SCALOC, SGN, SMIN, SMLNUM, SUMR, XNORM -C .. -C .. Local Arrays .. - DOUBLE PRECISION DUM( 1 ), VEC( 2, 2 ), X( 2, 2 ) -C .. -C .. External Functions .. - LOGICAL LSAME - DOUBLE PRECISION DDOT, DLAMCH, DLANGE - EXTERNAL DDOT, DLAMCH, DLANGE, LSAME -C .. -C .. External Subroutines .. - EXTERNAL DLABAD, DLALN2, DSCAL, SB04PX, XERBLA -C .. -C .. Intrinsic Functions .. - INTRINSIC ABS, DBLE, MAX, MIN -C .. -C .. Executable Statements .. -C -C Decode and Test input parameters -C - NOTRNA = LSAME( TRANA, 'N' ) - NOTRNB = LSAME( TRANB, 'N' ) -C - INFO = 0 - IF( .NOT.NOTRNA .AND. .NOT.LSAME( TRANA, 'T' ) .AND. - $ .NOT.LSAME( TRANA, 'C' ) ) THEN - INFO = -1 - ELSE IF( .NOT.NOTRNB .AND. .NOT.LSAME( TRANB, 'T' ) .AND. - $ .NOT.LSAME( TRANB, 'C' ) ) THEN - INFO = -2 - ELSE IF( ISGN.NE.1 .AND. ISGN.NE.-1 ) THEN - INFO = -3 - ELSE IF( M.LT.0 ) THEN - INFO = -4 - ELSE IF( N.LT.0 ) THEN - INFO = -5 - ELSE IF( LDA.LT.MAX( 1, M ) ) THEN - INFO = -7 - ELSE IF( LDB.LT.MAX( 1, N ) ) THEN - INFO = -9 - ELSE IF( LDC.LT.MAX( 1, M ) ) THEN - INFO = -11 - END IF - IF( INFO.NE.0 ) THEN - CALL XERBLA( 'SB04PY', -INFO ) - RETURN - END IF -C -C Quick return if possible. -C - SCALE = ONE - IF( M.EQ.0 .OR. N.EQ.0 ) - $ RETURN -C -C Set constants to control overflow. -C - EPS = DLAMCH( 'Precision' ) - SMLNUM = DLAMCH( 'Safe minimum' ) - BIGNUM = ONE / SMLNUM - CALL DLABAD( SMLNUM, BIGNUM ) - SMLNUM = SMLNUM*DBLE( M*N ) / EPS - BIGNUM = ONE / SMLNUM -C - SMIN = MAX( SMLNUM, EPS*DLANGE( 'M', M, M, A, LDA, DUM ), - $ EPS*DLANGE( 'M', N, N, B, LDB, DUM ) ) -C - SGN = ISGN -C - IF( NOTRNA .AND. NOTRNB ) THEN -C -C Solve A*X*B + ISGN*X = scale*C. -C -C The (K,L)th block of X is determined starting from -C bottom-left corner column by column by -C -C A(K,K)*X(K,L)*B(L,L) + ISGN*X(K,L) = C(K,L) - R(K,L) -C -C where -C M -C R(K,L) = { SUM [A(K,J)*X(J,L)] } * B(L,L) + -C J=K+1 -C M L-1 -C SUM { A(K,J) * SUM [X(J,I)*B(I,L)] }. -C J=K I=1 -C -C Start column loop (index = L) -C L1 (L2) : column index of the first (last) row of X(K,L). -C - LNEXT = 1 -C - DO 60 L = 1, N - IF( L.LT.LNEXT ) - $ GO TO 60 - L1 = L - IF( L.EQ.N ) THEN - L2 = L - ELSE - IF( B( L+1, L ).NE.ZERO ) THEN - L2 = L + 1 - ELSE - L2 = L - END IF - LNEXT = L2 + 1 - END IF -C -C Start row loop (index = K) -C K1 (K2): row index of the first (last) row of X(K,L). -C - KNEXT = M -C - DO 50 K = M, 1, -1 - IF( K.GT.KNEXT ) - $ GO TO 50 - K2 = K - IF( K.EQ.1 ) THEN - K1 = K - ELSE - IF( A( K, K-1 ).NE.ZERO ) THEN - K1 = K - 1 - ELSE - K1 = K - END IF - KNEXT = K1 - 1 - END IF -C - MNK1 = MIN( K1+1, M ) - MNK2 = MIN( K2+1, M ) - P11 = DDOT( M-K2, A( K1, MNK2 ), LDA, C( MNK2, L1 ), 1 ) - DWORK( K1 ) = DDOT( L1-1, C( K1, 1 ), LDC, B( 1, L1 ), - $ 1 ) -C - IF( L1.EQ.L2 .AND. K1.EQ.K2 ) THEN -C - SUMR = DDOT( M-K1+1, A( K1, K1 ), LDA, DWORK( K1 ), - $ 1 ) - VEC( 1, 1 ) = C( K1, L1 ) - ( SUMR + P11*B( L1, L1 ) ) - SCALOC = ONE -C - A11 = A( K1, K1 )*B( L1, L1 ) + SGN - DA11 = ABS( A11 ) - IF( DA11.LE.SMIN ) THEN - A11 = SMIN - DA11 = SMIN - INFO = 1 - END IF - DB = ABS( VEC( 1, 1 ) ) - IF( DA11.LT.ONE .AND. DB.GT.ONE ) THEN - IF( DB.GT.BIGNUM*DA11 ) - $ SCALOC = ONE / DB - END IF - X( 1, 1 ) = ( VEC( 1, 1 )*SCALOC ) / A11 -C - IF( SCALOC.NE.ONE ) THEN -C - DO 10 J = 1, N - CALL DSCAL( M, SCALOC, C( 1, J ), 1 ) - 10 CONTINUE -C - CALL DSCAL( M-K1+1, SCALOC, DWORK( K1 ), 1 ) - SCALE = SCALE*SCALOC - END IF - C( K1, L1 ) = X( 1, 1 ) -C - ELSE IF( L1.EQ.L2 .AND. K1.NE.K2 ) THEN -C - P21 = DDOT( M-K2, A( K2, MNK2 ), LDA, C( MNK2, L1 ), - $ 1 ) - DWORK( K2 ) = DDOT( L1-1, C( K2, 1 ), LDC, B( 1, L1 ), - $ 1 ) - SUMR = DDOT( M-K1+1, A( K1, K1 ), LDA, DWORK( K1 ), - $ 1 ) - VEC( 1, 1 ) = C( K1, L1 ) - ( SUMR + P11*B( L1, L1 ) ) -C - SUMR = DDOT( M-K1+1, A( K2, K1 ), LDA, DWORK( K1 ), - $ 1 ) - VEC( 2, 1 ) = C( K2, L1 ) - ( SUMR + P21*B( L1, L1 ) ) -C - CALL DLALN2( .FALSE., 2, 1, SMIN, B( L1, L1 ), - $ A( K1, K1 ), LDA, ONE, ONE, VEC, 2, -SGN, - $ ZERO, X, 2, SCALOC, XNORM, IERR ) - IF( IERR.NE.0 ) - $ INFO = 1 -C - IF( SCALOC.NE.ONE ) THEN -C - DO 20 J = 1, N - CALL DSCAL( M, SCALOC, C( 1, J ), 1 ) - 20 CONTINUE -C - CALL DSCAL( M-K1+1, SCALOC, DWORK( K1 ), 1 ) - SCALE = SCALE*SCALOC - END IF - C( K1, L1 ) = X( 1, 1 ) - C( K2, L1 ) = X( 2, 1 ) -C - ELSE IF( L1.NE.L2 .AND. K1.EQ.K2 ) THEN -C - P12 = DDOT( M-K1, A( K1, MNK1 ), LDA, C( MNK1, L2 ), - $ 1 ) - SUMR = DDOT( M-K1+1, A( K1, K1 ), LDA, DWORK( K1 ), - $ 1 ) - VEC( 1, 1 ) = C( K1, L1 ) - ( SUMR + P11*B( L1, L1 ) + - $ P12*B( L2, L1 ) ) -C - DWORK( K1+M ) = DDOT( L1-1, C( K1, 1 ), LDC, - $ B( 1, L2 ), 1 ) - SUMR = DDOT( M-K1+1, A( K1, K1 ), LDA, DWORK( K1+M ), - $ 1 ) - VEC( 2, 1 ) = C( K1, L2 ) - ( SUMR + P11*B( L1, L2 ) + - $ P12*B( L2, L2 ) ) -C - CALL DLALN2( .TRUE., 2, 1, SMIN, A( K1, K1 ), - $ B( L1, L1 ), LDB, ONE, ONE, VEC, 2, -SGN, - $ ZERO, X, 2, SCALOC, XNORM, IERR ) - IF( IERR.NE.0 ) - $ INFO = 1 -C - IF( SCALOC.NE.ONE ) THEN -C - DO 30 J = 1, N - CALL DSCAL( M, SCALOC, C( 1, J ), 1 ) - 30 CONTINUE -C - CALL DSCAL( M-K1+1, SCALOC, DWORK( K1 ), 1 ) - CALL DSCAL( M-K1+1, SCALOC, DWORK( K1+M ), 1 ) - SCALE = SCALE*SCALOC - END IF - C( K1, L1 ) = X( 1, 1 ) - C( K1, L2 ) = X( 2, 1 ) -C - ELSE IF( L1.NE.L2 .AND. K1.NE.K2 ) THEN -C - P21 = DDOT( M-K2, A( K2, MNK2 ), LDA, C( MNK2, L1 ), - $ 1 ) - P12 = DDOT( M-K2, A( K1, MNK2 ), LDA, C( MNK2, L2 ), - $ 1 ) - P22 = DDOT( M-K2, A( K2, MNK2 ), LDA, C( MNK2, L2 ), - $ 1 ) -C - DWORK( K2 ) = DDOT( L1-1, C( K2, 1 ), LDC, B( 1, L1 ), - $ 1 ) - SUMR = DDOT( M-K1+1, A( K1, K1 ), LDA, DWORK( K1 ), - $ 1 ) - VEC( 1, 1 ) = C( K1, L1 ) - ( SUMR + P11*B( L1, L1 ) + - $ P12*B( L2, L1 ) ) -C - DWORK( K1+M ) = DDOT( L1-1, C( K1, 1 ), LDC, - $ B( 1, L2 ), 1 ) - DWORK( K2+M ) = DDOT( L1-1, C( K2, 1 ), LDC, - $ B( 1, L2 ), 1 ) - SUMR = DDOT( M-K1+1, A( K1, K1 ), LDA, DWORK( K1+M ), - $ 1 ) - VEC( 1, 2 ) = C( K1, L2 ) - ( SUMR + P11*B( L1, L2 ) + - $ P12*B( L2, L2 ) ) -C - SUMR = DDOT( M-K1+1, A( K2, K1 ), LDA, DWORK( K1 ), - $ 1 ) - VEC( 2, 1 ) = C( K2, L1 ) - ( SUMR + P21*B( L1, L1 ) + - $ P22*B( L2, L1 ) ) -C - SUMR = DDOT( M-K1+1, A( K2, K1 ), LDA, DWORK( K1+M ), - $ 1 ) - VEC( 2, 2 ) = C( K2, L2 ) - ( SUMR + P21*B( L1, L2 ) + - $ P22*B( L2, L2 ) ) -C - CALL SB04PX( .FALSE., .FALSE., ISGN, 2, 2, - $ A( K1, K1 ), LDA, B( L1, L1 ), LDB, VEC, - $ 2, SCALOC, X, 2, XNORM, IERR ) - IF( IERR.NE.0 ) - $ INFO = 1 -C - IF( SCALOC.NE.ONE ) THEN -C - DO 40 J = 1, N - CALL DSCAL( M, SCALOC, C( 1, J ), 1 ) - 40 CONTINUE -C - CALL DSCAL( M-K1+1, SCALOC, DWORK( K1 ), 1 ) - CALL DSCAL( M-K1+1, SCALOC, DWORK( K1+M ), 1 ) - SCALE = SCALE*SCALOC - END IF - C( K1, L1 ) = X( 1, 1 ) - C( K1, L2 ) = X( 1, 2 ) - C( K2, L1 ) = X( 2, 1 ) - C( K2, L2 ) = X( 2, 2 ) - END IF -C - 50 CONTINUE -C - 60 CONTINUE -C - ELSE IF( .NOT.NOTRNA .AND. NOTRNB ) THEN -C -C Solve A'*X*B + ISGN*X = scale*C. -C -C The (K,L)th block of X is determined starting from -C upper-left corner column by column by -C -C A(K,K)'*X(K,L)*B(L,L) + ISGN*X(K,L) = C(K,L) - R(K,L) -C -C where -C K-1 -C R(K,L) = { SUM [A(J,K)'*X(J,L)] } * B(L,L) + -C J=1 -C K L-1 -C SUM A(J,K)' * { SUM [X(J,I)*B(I,L)] }. -C J=1 I=1 -C -C Start column loop (index = L) -C L1 (L2): column index of the first (last) row of X(K,L). -C - LNEXT = 1 -C - DO 120 L = 1, N - IF( L.LT.LNEXT ) - $ GO TO 120 - L1 = L - IF( L.EQ.N ) THEN - L2 = L - ELSE - IF( B( L+1, L ).NE.ZERO ) THEN - L2 = L + 1 - ELSE - L2 = L - END IF - LNEXT = L2 + 1 - END IF -C -C Start row loop (index = K) -C K1 (K2): row index of the first (last) row of X(K,L). -C - KNEXT = 1 -C - DO 110 K = 1, M - IF( K.LT.KNEXT ) - $ GO TO 110 - K1 = K - IF( K.EQ.M ) THEN - K2 = K - ELSE - IF( A( K+1, K ).NE.ZERO ) THEN - K2 = K + 1 - ELSE - K2 = K - END IF - KNEXT = K2 + 1 - END IF -C - P11 = DDOT( K1-1, A( 1, K1 ), 1, C( 1, L1 ), 1 ) - DWORK( K1 ) = DDOT( L1-1, C( K1, 1 ), LDC, B( 1, L1), - $ 1 ) -C - IF( L1.EQ.L2 .AND. K1.EQ.K2 ) THEN -C - SUMR = DDOT( K1, A( 1, K1 ), 1, DWORK, 1 ) - VEC( 1, 1 ) = C( K1, L1 ) - ( SUMR + P11*B( L1, L1 ) ) - SCALOC = ONE -C - A11 = A( K1, K1 )*B( L1, L1 ) + SGN - DA11 = ABS( A11 ) - IF( DA11.LE.SMIN ) THEN - A11 = SMIN - DA11 = SMIN - INFO = 1 - END IF - DB = ABS( VEC( 1, 1 ) ) - IF( DA11.LT.ONE .AND. DB.GT.ONE ) THEN - IF( DB.GT.BIGNUM*DA11 ) - $ SCALOC = ONE / DB - END IF - X( 1, 1 ) = ( VEC( 1, 1 )*SCALOC ) / A11 -C - IF( SCALOC.NE.ONE ) THEN -C - DO 70 J = 1, N - CALL DSCAL( M, SCALOC, C( 1, J ), 1 ) - 70 CONTINUE -C - CALL DSCAL( K1, SCALOC, DWORK, 1 ) - SCALE = SCALE*SCALOC - END IF - C( K1, L1 ) = X( 1, 1 ) -C - ELSE IF( L1.EQ.L2 .AND. K1.NE.K2 ) THEN -C - P21 = DDOT( K1-1, A( 1, K2 ), 1, C( 1, L1 ), 1 ) - DWORK( K2 ) = DDOT( L1-1, C( K2, 1 ), LDC, - $ B( 1, L1), 1 ) - SUMR = DDOT( K2, A( 1, K1 ), 1, DWORK, 1 ) - VEC( 1, 1 ) = C( K1, L1 ) - ( SUMR + P11*B( L1, L1 ) ) -C - SUMR = DDOT( K2, A( 1, K2 ), 1, DWORK, 1 ) - VEC( 2, 1 ) = C( K2, L1 ) - ( SUMR + P21*B( L1, L1 ) ) -C - CALL DLALN2( .TRUE., 2, 1, SMIN, B( L1, L1 ), - $ A( K1, K1 ), LDA, ONE, ONE, VEC, 2, -SGN, - $ ZERO, X, 2, SCALOC, XNORM, IERR ) - IF( IERR.NE.0 ) - $ INFO = 1 -C - IF( SCALOC.NE.ONE ) THEN -C - DO 80 J = 1, N - CALL DSCAL( M, SCALOC, C( 1, J ), 1 ) - 80 CONTINUE -C - CALL DSCAL( K2, SCALOC, DWORK, 1 ) - SCALE = SCALE*SCALOC - END IF - C( K1, L1 ) = X( 1, 1 ) - C( K2, L1 ) = X( 2, 1 ) -C - ELSE IF( L1.NE.L2 .AND. K1.EQ.K2 ) THEN -C - P12 = DDOT( K1-1, A( 1, K1 ), 1, C( 1, L2 ), 1 ) - SUMR = DDOT( K1, A( 1, K1 ), 1, DWORK, 1 ) - VEC( 1, 1 ) = C( K1, L1 ) - ( SUMR + P11*B( L1, L1 ) + - $ P12*B( L2, L1 ) ) -C - DWORK( K1+M ) = DDOT( L1-1, C( K1, 1 ), LDC, - $ B( 1, L2 ), 1 ) - SUMR = DDOT( K1, A( 1, K1 ), 1, DWORK( M+1 ), 1 ) - VEC( 2, 1 ) = C( K1, L2 ) - ( SUMR + P11*B( L1, L2 ) + - $ P12*B( L2, L2 ) ) -C - CALL DLALN2( .TRUE., 2, 1, SMIN, A( K1, K1 ), - $ B( L1, L1 ), LDB, ONE, ONE, VEC, 2, -SGN, - $ ZERO, X, 2, SCALOC, XNORM, IERR ) - IF( IERR.NE.0 ) - $ INFO = 1 -C - IF( SCALOC.NE.ONE ) THEN -C - DO 90 J = 1, N - CALL DSCAL( M, SCALOC, C( 1, J ), 1 ) - 90 CONTINUE -C - CALL DSCAL( K1, SCALOC, DWORK, 1 ) - CALL DSCAL( K1, SCALOC, DWORK( M+1 ), 1 ) - SCALE = SCALE*SCALOC - END IF - C( K1, L1 ) = X( 1, 1 ) - C( K1, L2 ) = X( 2, 1 ) -C - ELSE IF( L1.NE.L2 .AND. K1.NE.K2 ) THEN -C - P21 = DDOT( K1-1, A( 1, K2 ), 1, C( 1, L1 ), 1 ) - P12 = DDOT( K1-1, A( 1, K1 ), 1, C( 1, L2 ), 1 ) - P22 = DDOT( K1-1, A( 1, K2 ), 1, C( 1, L2 ), 1 ) -C - DWORK( K2 ) = DDOT( L1-1, C( K2, 1 ), LDC, - $ B( 1, L1), 1 ) - SUMR = DDOT( K2, A( 1, K1 ), 1, DWORK, 1 ) - VEC( 1, 1 ) = C( K1, L1 ) - ( SUMR + P11*B( L1, L1 ) + - $ P12*B( L2, L1 ) ) -C - SUMR = DDOT( K2, A( 1, K2 ), 1, DWORK, 1 ) - VEC( 2, 1 ) = C( K2, L1 ) - ( SUMR + P21*B( L1, L1 ) + - $ P22*B( L2, L1 ) ) -C - DWORK( K1+M ) = DDOT( L1-1, C( K1, 1 ), LDC, - $ B( 1, L2 ), 1 ) - DWORK( K2+M ) = DDOT( L1-1, C( K2, 1 ), LDC, - $ B( 1, L2 ), 1 ) - SUMR = DDOT( K2, A( 1, K1 ), 1, DWORK( M+1 ), 1 ) - VEC( 1, 2 ) = C( K1, L2 ) - ( SUMR + P11*B( L1, L2 ) + - $ P12*B( L2, L2 ) ) -C - SUMR = DDOT( K2, A( 1, K2 ), 1, DWORK( M+1 ), 1 ) - VEC( 2, 2 ) = C( K2, L2 ) - ( SUMR + P21*B( L1, L2 ) + - $ P22*B( L2, L2 ) ) -C - CALL SB04PX( .TRUE., .FALSE., ISGN, 2, 2, A( K1, K1 ), - $ LDA, B( L1, L1 ), LDB, VEC, 2, SCALOC, X, - $ 2, XNORM, IERR ) - IF( IERR.NE.0 ) - $ INFO = 1 -C - IF( SCALOC.NE.ONE ) THEN -C - DO 100 J = 1, N - CALL DSCAL( M, SCALOC, C( 1, J ), 1 ) - 100 CONTINUE -C - CALL DSCAL( K2, SCALOC, DWORK, 1 ) - CALL DSCAL( K2, SCALOC, DWORK( M+1 ), 1 ) - SCALE = SCALE*SCALOC - END IF - C( K1, L1 ) = X( 1, 1 ) - C( K1, L2 ) = X( 1, 2 ) - C( K2, L1 ) = X( 2, 1 ) - C( K2, L2 ) = X( 2, 2 ) - END IF -C - 110 CONTINUE -C - 120 CONTINUE -C - ELSE IF( .NOT.NOTRNA .AND. .NOT.NOTRNB ) THEN -C -C Solve A'*X*B' + ISGN*X = scale*C. -C -C The (K,L)th block of X is determined starting from -C top-right corner column by column by -C -C A(K,K)'*X(K,L)*B(L,L)' + ISGN*X(K,L) = C(K,L) - R(K,L) -C -C where -C K-1 -C R(K,L) = { SUM [A(J,K)'*X(J,L)] } * B(L,L)' + -C J=1 -C K N -C SUM A(J,K)' * { SUM [X(J,I)*B(L,I)'] }. -C J=1 I=L+1 -C -C Start column loop (index = L) -C L1 (L2): column index of the first (last) row of X(K,L). -C - LNEXT = N -C - DO 180 L = N, 1, -1 - IF( L.GT.LNEXT ) - $ GO TO 180 - L2 = L - IF( L.EQ.1 ) THEN - L1 = L - ELSE - IF( B( L, L-1 ).NE.ZERO ) THEN - L1 = L - 1 - ELSE - L1 = L - END IF - LNEXT = L1 - 1 - END IF -C -C Start row loop (index = K) -C K1 (K2): row index of the first (last) row of X(K,L). -C - KNEXT = 1 -C - DO 170 K = 1, M - IF( K.LT.KNEXT ) - $ GO TO 170 - K1 = K - IF( K.EQ.M ) THEN - K2 = K - ELSE - IF( A( K+1, K ).NE.ZERO ) THEN - K2 = K + 1 - ELSE - K2 = K - END IF - KNEXT = K2 + 1 - END IF -C - MNL1 = MIN( L1+1, N ) - MNL2 = MIN( L2+1, N ) - P11 = DDOT( K1-1, A( 1, K1 ), 1, C( 1, L1 ), 1 ) - DWORK( K1 ) = DDOT( N-L2, C( K1, MNL2 ), LDC, - $ B( L1, MNL2 ), LDB ) -C - IF( L1.EQ.L2 .AND. K1.EQ.K2 ) THEN - SUMR = DDOT( K1, A( 1, K1 ), 1, DWORK, 1 ) - VEC( 1, 1 ) = C( K1, L1 ) - ( SUMR + P11*B( L1, L1 ) ) - SCALOC = ONE -C - A11 = A( K1, K1 )*B( L1, L1 ) + SGN - DA11 = ABS( A11 ) - IF( DA11.LE.SMIN ) THEN - A11 = SMIN - DA11 = SMIN - INFO = 1 - END IF - DB = ABS( VEC( 1, 1 ) ) - IF( DA11.LT.ONE .AND. DB.GT.ONE ) THEN - IF( DB.GT.BIGNUM*DA11 ) - $ SCALOC = ONE / DB - END IF - X( 1, 1 ) = ( VEC( 1, 1 )*SCALOC ) / A11 -C - IF( SCALOC.NE.ONE ) THEN -C - DO 130 J = 1, N - CALL DSCAL( M, SCALOC, C( 1, J ), 1 ) - 130 CONTINUE -C - CALL DSCAL( K1, SCALOC, DWORK, 1 ) - SCALE = SCALE*SCALOC - END IF - C( K1, L1 ) = X( 1, 1 ) -C - ELSE IF( L1.EQ.L2 .AND. K1.NE.K2 ) THEN -C - P21 = DDOT( K1-1, A( 1, K2 ), 1, C( 1, L1 ), 1 ) - DWORK( K2 ) = DDOT( N-L1, C( K2, MNL1 ), LDC, - $ B( L1, MNL1 ), LDB ) - SUMR = DDOT( K2, A( 1, K1 ), 1, DWORK, 1 ) - VEC( 1, 1 ) = C( K1, L1 ) - ( SUMR + P11*B( L1, L1 ) ) -C - SUMR = DDOT( K2, A( 1, K2 ), 1, DWORK, 1 ) - VEC( 2, 1 ) = C( K2, L1 ) - ( SUMR + P21*B( L1, L1 ) ) -C - CALL DLALN2( .TRUE., 2, 1, SMIN, B( L1, L1 ), - $ A( K1, K1 ), LDA, ONE, ONE, VEC, 2, -SGN, - $ ZERO, X, 2, SCALOC, XNORM, IERR ) - IF( IERR.NE.0 ) - $ INFO = 1 -C - IF( SCALOC.NE.ONE ) THEN -C - DO 140 J = 1, N - CALL DSCAL( M, SCALOC, C( 1, J ), 1 ) - 140 CONTINUE -C - CALL DSCAL( K2, SCALOC, DWORK, 1 ) - SCALE = SCALE*SCALOC - END IF - C( K1, L1 ) = X( 1, 1 ) - C( K2, L1 ) = X( 2, 1 ) -C - ELSE IF( L1.NE.L2 .AND. K1.EQ.K2 ) THEN -C - P12 = DDOT( K1-1, A( 1, K1 ), 1, C( 1, L2 ), 1 ) - SUMR = DDOT( K1, A( 1, K1 ), 1, DWORK, 1 ) - VEC( 1, 1 ) = C( K1, L1 ) - ( SUMR + P11*B( L1, L1 ) + - $ P12*B( L1, L2 ) ) -C - DWORK( K1+M ) = DDOT( N-L2, C( K1, MNL2 ), LDC, - $ B( L2, MNL2 ), LDB ) - SUMR = DDOT( K1, A( 1, K1 ), 1, DWORK( M+1 ), 1 ) - VEC( 2, 1 ) = C( K1, L2 ) - ( SUMR + P11*B( L2, L1 ) + - $ P12*B( L2, L2 ) ) -C - CALL DLALN2( .FALSE., 2, 1, SMIN, A( K1, K1 ), - $ B( L1, L1 ), LDB, ONE, ONE, VEC, 2, -SGN, - $ ZERO, X, 2, SCALOC, XNORM, IERR ) - IF( IERR.NE.0 ) - $ INFO = 1 -C - IF( SCALOC.NE.ONE ) THEN -C - DO 150 J = 1, N - CALL DSCAL( M, SCALOC, C( 1, J ), 1 ) - 150 CONTINUE -C - CALL DSCAL( K1, SCALOC, DWORK, 1 ) - CALL DSCAL( K1, SCALOC, DWORK(M+1), 1 ) - SCALE = SCALE*SCALOC - END IF - C( K1, L1 ) = X( 1, 1 ) - C( K1, L2 ) = X( 2, 1 ) -C - ELSE IF( L1.NE.L2 .AND. K1.NE.K2 ) THEN -C - P21 = DDOT( K1-1, A( 1, K2 ), 1, C( 1, L1 ), 1 ) - P12 = DDOT( K1-1, A( 1, K1 ), 1, C( 1, L2 ), 1 ) - P22 = DDOT( K1-1, A( 1, K2 ), 1, C( 1, L2 ), 1 ) -C - DWORK( K2 ) = DDOT( N-L2, C( K2, MNL2 ), LDC, - $ B( L1, MNL2 ), LDB ) - SUMR = DDOT( K2, A( 1, K1 ), 1, DWORK, 1 ) - VEC( 1, 1 ) = C( K1, L1 ) - ( SUMR + P11*B( L1, L1 ) + - $ P12*B( L1, L2 ) ) -C - SUMR = DDOT( K2, A( 1, K2 ), 1, DWORK, 1 ) - VEC( 2, 1 ) = C( K2, L1 ) - ( SUMR + P21*B( L1, L1 ) + - $ P22*B( L1, L2 ) ) -C - DWORK( K1+M ) = DDOT( N-L2, C( K1, MNL2 ), LDC, - $ B( L2, MNL2 ), LDB ) - DWORK( K2+M ) = DDOT( N-L2, C( K2, MNL2 ), LDC, - $ B( L2, MNL2 ), LDB ) - SUMR = DDOT( K2, A( 1, K1 ), 1, DWORK( M+1 ), 1 ) - VEC( 1, 2 ) = C( K1, L2 ) - ( SUMR + P11*B( L2, L1 ) + - $ P12*B( L2, L2 ) ) -C - SUMR = DDOT( K2, A( 1, K2 ), 1, DWORK( M+1 ), 1 ) - VEC( 2, 2 ) = C( K2, L2 ) - ( SUMR + P21*B( L2, L1 ) + - $ P22*B( L2, L2 ) ) -C - CALL SB04PX( .TRUE., .TRUE., ISGN, 2, 2, A( K1, K1 ), - $ LDA, B( L1, L1 ), LDB, VEC, 2, SCALOC, X, - $ 2, XNORM, IERR ) - IF( IERR.NE.0 ) - $ INFO = 1 -C - IF( SCALOC.NE.ONE ) THEN -C - DO 160 J = 1, N - CALL DSCAL( M, SCALOC, C( 1, J ), 1 ) - 160 CONTINUE -C - CALL DSCAL( K2, SCALOC, DWORK, 1 ) - CALL DSCAL( K2, SCALOC, DWORK(M+1), 1 ) - SCALE = SCALE*SCALOC - END IF - C( K1, L1 ) = X( 1, 1 ) - C( K1, L2 ) = X( 1, 2 ) - C( K2, L1 ) = X( 2, 1 ) - C( K2, L2 ) = X( 2, 2 ) - END IF -C - 170 CONTINUE -C - 180 CONTINUE -C - ELSE -C -C Solve A*X*B' + ISGN*X = scale*C. -C -C The (K,L)th block of X is determined starting from -C bottom-right corner column by column by -C -C A(K,K)*X(K,L)*B(L,L)' + ISGN*X(K,L) = C(K,L) - R(K,L) -C -C where -C M -C R(K,L) = { SUM [A(K,J)*X(J,L)] } * B(L,L)' + -C J=K+1 -C M N -C SUM { A(K,J) * SUM [X(J,I)*B(L,I)'] }. -C J=K I=L+1 -C -C Start column loop (index = L) -C L1 (L2): column index of the first (last) row of X(K,L). -C - LNEXT = N -C - DO 240 L = N, 1, -1 - IF( L.GT.LNEXT ) - $ GO TO 240 - L2 = L - IF( L.EQ.1 ) THEN - L1 = L - ELSE - IF( B( L, L-1 ).NE.ZERO ) THEN - L1 = L - 1 - ELSE - L1 = L - END IF - LNEXT = L1 - 1 - END IF -C -C Start row loop (index = K) -C K1 (K2): row index of the first (last) row of X(K,L). -C - KNEXT = M -C - DO 230 K = M, 1, -1 - IF( K.GT.KNEXT ) - $ GO TO 230 - K2 = K - IF( K.EQ.1 ) THEN - K1 = K - ELSE - IF( A( K, K-1 ).NE.ZERO ) THEN - K1 = K - 1 - ELSE - K1 = K - END IF - KNEXT = K1 - 1 - END IF -C - MNK1 = MIN( K1+1, M ) - MNK2 = MIN( K2+1, M ) - MNL1 = MIN( L1+1, N ) - MNL2 = MIN( L2+1, N ) - P11 = DDOT( M-K2, A( K1, MNK2 ), LDA, C( MNK2, L1 ), 1 ) - DWORK( K1 ) = DDOT( N-L2, C( K1, MNL2 ), LDC, - $ B( L1, MNL2 ), LDB ) -C - IF( L1.EQ.L2 .AND. K1.EQ.K2 ) THEN -C - SUMR = DDOT( M-K1+1, A( K1, K1 ), LDA, DWORK( K1 ), - $ 1 ) - VEC( 1, 1 ) = C( K1, L1 ) - ( SUMR + P11*B( L1, L1 ) ) - SCALOC = ONE -C - A11 = A( K1, K1 )*B( L1, L1 ) + SGN - DA11 = ABS( A11 ) - IF( DA11.LE.SMIN ) THEN - A11 = SMIN - DA11 = SMIN - INFO = 1 - END IF - DB = ABS( VEC( 1, 1 ) ) - IF( DA11.LT.ONE .AND. DB.GT.ONE ) THEN - IF( DB.GT.BIGNUM*DA11 ) - $ SCALOC = ONE / DB - END IF - X( 1, 1 ) = ( VEC( 1, 1 )*SCALOC ) / A11 -C - IF( SCALOC.NE.ONE ) THEN -C - DO 190 J = 1, N - CALL DSCAL( M, SCALOC, C( 1, J ), 1 ) - 190 CONTINUE -C - CALL DSCAL( M-K1+1, SCALOC, DWORK( K1 ), 1 ) - SCALE = SCALE*SCALOC - END IF - C( K1, L1 ) = X( 1, 1 ) -C - ELSE IF( L1.EQ.L2 .AND. K1.NE.K2 ) THEN -C - P21 = DDOT( M-K2, A( K2, MNK2 ), LDA, C( MNK2, L1 ), - $ 1 ) - DWORK( K2 ) = DDOT( N-L1, C( K2, MNL1 ), LDC, - $ B( L1, MNL1 ), LDB ) - SUMR = DDOT( M-K1+1, A( K1, K1 ), LDA, DWORK( K1 ), - $ 1 ) - VEC( 1, 1 ) = C( K1, L1 ) - ( SUMR + P11*B( L1, L1 ) ) -C - SUMR = DDOT( M-K1+1, A( K2, K1 ), LDA, DWORK( K1 ), - $ 1 ) - VEC( 2, 1 ) = C( K2, L1 ) - ( SUMR + P21*B( L1, L1 ) ) -C - CALL DLALN2( .FALSE., 2, 1, SMIN, B( L1, L1 ), - $ A( K1, K1 ), LDA, ONE, ONE, VEC, 2, -SGN, - $ ZERO, X, 2, SCALOC, XNORM, IERR ) - IF( IERR.NE.0 ) - $ INFO = 1 -C - IF( SCALOC.NE.ONE ) THEN -C - DO 200 J = 1, N - CALL DSCAL( M, SCALOC, C( 1, J ), 1 ) - 200 CONTINUE -C - CALL DSCAL( M-K1+1, SCALOC, DWORK( K1 ), 1 ) - SCALE = SCALE*SCALOC - END IF - C( K1, L1 ) = X( 1, 1 ) - C( K2, L1 ) = X( 2, 1 ) -C - ELSE IF( L1.NE.L2 .AND. K1.EQ.K2 ) THEN -C - P12 = DDOT( M-K1, A( K1, MNK1 ), LDA, C( MNK1, L2 ), - $ 1 ) - SUMR = DDOT( M-K1+1, A( K1, K1 ), LDA, DWORK( K1 ), - $ 1 ) - VEC( 1, 1 ) = C( K1, L1 ) - ( SUMR + P11*B( L1, L1 ) + - $ P12*B( L1, L2 ) ) -C - DWORK( K1+M ) = DDOT( N-L2, C( K1, MNL2 ), LDC, - $ B( L2, MNL2 ), LDB ) - SUMR = DDOT( M-K1+1, A( K1, K1 ), LDA, DWORK( K1+M ), - $ 1 ) - VEC( 2, 1 ) = C( K1, L2 ) - ( SUMR + P11*B( L2, L1 ) + - $ P12*B( L2, L2 ) ) -C - CALL DLALN2( .FALSE., 2, 1, SMIN, A( K1, K1 ), - $ B( L1, L1 ), LDB, ONE, ONE, VEC, 2, -SGN, - $ ZERO, X, 2, SCALOC, XNORM, IERR ) - IF( IERR.NE.0 ) - $ INFO = 1 -C - IF( SCALOC.NE.ONE ) THEN -C - DO 210 J = 1, N - CALL DSCAL( M, SCALOC, C( 1, J ), 1 ) - 210 CONTINUE -C - CALL DSCAL( M-K1+1, SCALOC, DWORK( K1 ), 1 ) - CALL DSCAL( M-K1+1, SCALOC, DWORK( K1+M ), 1 ) - SCALE = SCALE*SCALOC - END IF - C( K1, L1 ) = X( 1, 1 ) - C( K1, L2 ) = X( 2, 1 ) -C - ELSE IF( L1.NE.L2 .AND. K1.NE.K2 ) THEN -C - P21 = DDOT( M-K2, A( K2, MNK2 ), LDA, C( MNK2, L1 ), - $ 1 ) - P12 = DDOT( M-K2, A( K1, MNK2 ), LDA, C( MNK2, L2 ), - $ 1 ) - P22 = DDOT( M-K2, A( K2, MNK2 ), LDA, C( MNK2, L2 ), - $ 1 ) -C - DWORK( K2 ) = DDOT( N-L2, C( K2, MNL2 ), LDC, - $ B( L1, MNL2 ), LDB ) - SUMR = DDOT( M-K1+1, A( K1, K1 ), LDA, DWORK( K1 ), - $ 1 ) - VEC( 1, 1 ) = C( K1, L1 ) - ( SUMR + P11*B( L1, L1 ) + - $ P12*B( L1, L2 ) ) -C - SUMR = DDOT( M-K1+1, A( K2, K1 ), LDA, DWORK( K1 ), - $ 1 ) - VEC( 2, 1 ) = C( K2, L1 ) - ( SUMR + P21*B( L1, L1 ) + - $ P22*B( L1, L2 ) ) -C - DWORK( K1+M ) = DDOT( N-L2, C( K1, MNL2 ), LDC, - $ B( L2, MNL2 ), LDB ) - DWORK( K2+M ) = DDOT( N-L2, C( K2, MNL2 ), LDC, - $ B( L2, MNL2 ), LDB ) - SUMR = DDOT( M-K1+1, A( K1, K1 ), LDA, DWORK( K1+M ), - $ 1 ) - VEC( 1, 2 ) = C( K1, L2 ) - ( SUMR + P11*B( L2, L1 ) + - $ P12*B( L2, L2 ) ) -C - SUMR = DDOT( M-K1+1, A( K2, K1 ), LDA, DWORK( K1+M ), - $ 1 ) - VEC( 2, 2 ) = C( K2, L2 ) - ( SUMR + P21*B( L2, L1 ) + - $ P22*B( L2, L2 ) ) -C - CALL SB04PX( .FALSE., .TRUE., ISGN, 2, 2, A( K1, K1 ), - $ LDA, B( L1, L1 ), LDB, VEC, 2, SCALOC, X, - $ 2, XNORM, IERR ) - IF( IERR.NE.0 ) - $ INFO = 1 -C - IF( SCALOC.NE.ONE ) THEN -C - DO 220 J = 1, N - CALL DSCAL( M, SCALOC, C( 1, J ), 1 ) - 220 CONTINUE -C - CALL DSCAL( M-K1+1, SCALOC, DWORK( K1 ), 1 ) - CALL DSCAL( M-K1+1, SCALOC, DWORK( K1+M ), 1 ) - SCALE = SCALE*SCALOC - END IF - C( K1, L1 ) = X( 1, 1 ) - C( K1, L2 ) = X( 1, 2 ) - C( K2, L1 ) = X( 2, 1 ) - C( K2, L2 ) = X( 2, 2 ) - END IF -C - 230 CONTINUE -C - 240 CONTINUE -C - END IF -C - RETURN -C *** Last line of SB04PY *** - END diff --git a/mex/sources/libslicot/SB04QD.f b/mex/sources/libslicot/SB04QD.f deleted file mode 100644 index 29ceae423..000000000 --- a/mex/sources/libslicot/SB04QD.f +++ /dev/null @@ -1,376 +0,0 @@ - SUBROUTINE SB04QD( N, M, A, LDA, B, LDB, C, LDC, Z, LDZ, IWORK, - $ DWORK, LDWORK, INFO ) -C -C SLICOT RELEASE 5.0. -C -C Copyright (c) 2002-2009 NICONET e.V. -C -C This program is free software: you can redistribute it and/or -C modify it under the terms of the GNU General Public License as -C published by the Free Software Foundation, either version 2 of -C the License, or (at your option) any later version. -C -C This program is distributed in the hope that it will be useful, -C but WITHOUT ANY WARRANTY; without even the implied warranty of -C MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the -C GNU General Public License for more details. -C -C You should have received a copy of the GNU General Public License -C along with this program. If not, see -C . -C -C PURPOSE -C -C To solve for X the discrete-time Sylvester equation -C -C X + AXB = C, -C -C where A, B, C and X are general N-by-N, M-by-M, N-by-M and -C N-by-M matrices respectively. A Hessenberg-Schur method, which -C reduces A to upper Hessenberg form, H = U'AU, and B' to real -C Schur form, S = Z'B'Z (with U, Z orthogonal matrices), is used. -C -C ARGUMENTS -C -C Input/Output Parameters -C -C N (input) INTEGER -C The order of the matrix A. N >= 0. -C -C M (input) INTEGER -C The order of the matrix B. M >= 0. -C -C A (input/output) DOUBLE PRECISION array, dimension (LDA,N) -C On entry, the leading N-by-N part of this array must -C contain the coefficient matrix A of the equation. -C On exit, the leading N-by-N upper Hessenberg part of this -C array contains the matrix H, and the remainder of the -C leading N-by-N part, together with the elements 2,3,...,N -C of array DWORK, contain the orthogonal transformation -C matrix U (stored in factored form). -C -C LDA INTEGER -C The leading dimension of array A. LDA >= MAX(1,N). -C -C B (input/output) DOUBLE PRECISION array, dimension (LDB,M) -C On entry, the leading M-by-M part of this array must -C contain the coefficient matrix B of the equation. -C On exit, the leading M-by-M part of this array contains -C the quasi-triangular Schur factor S of the matrix B'. -C -C LDB INTEGER -C The leading dimension of array B. LDB >= MAX(1,M). -C -C C (input/output) DOUBLE PRECISION array, dimension (LDC,M) -C On entry, the leading N-by-M part of this array must -C contain the coefficient matrix C of the equation. -C On exit, the leading N-by-M part of this array contains -C the solution matrix X of the problem. -C -C LDC INTEGER -C The leading dimension of array C. LDC >= MAX(1,N). -C -C Z (output) DOUBLE PRECISION array, dimension (LDZ,M) -C The leading M-by-M part of this array contains the -C orthogonal matrix Z used to transform B' to real upper -C Schur form. -C -C LDZ INTEGER -C The leading dimension of array Z. LDZ >= MAX(1,M). -C -C Workspace -C -C IWORK INTEGER array, dimension (4*N) -C -C DWORK DOUBLE PRECISION array, dimension (LDWORK) -C On exit, if INFO = 0, DWORK(1) returns the optimal value -C of LDWORK, and DWORK(2), DWORK(3),..., DWORK(N) contain -C the scalar factors of the elementary reflectors used to -C reduce A to upper Hessenberg form, as returned by LAPACK -C Library routine DGEHRD. -C -C LDWORK INTEGER -C The length of the array DWORK. -C LDWORK = MAX(1, 2*N*N + 9*N, 5*M, N + M). -C For optimum performance LDWORK should be larger. -C -C Error Indicator -C -C INFO INTEGER -C = 0: successful exit; -C < 0: if INFO = -i, the i-th argument had an illegal -C value; -C > 0: if INFO = i, 1 <= i <= M, the QR algorithm failed to -C compute all the eigenvalues of B (see LAPACK Library -C routine DGEES); -C > M: if a singular matrix was encountered whilst solving -C for the (INFO-M)-th column of matrix X. -C -C METHOD -C -C The matrix A is transformed to upper Hessenberg form H = U'AU by -C the orthogonal transformation matrix U; matrix B' is transformed -C to real upper Schur form S = Z'B'Z using the orthogonal -C transformation matrix Z. The matrix C is also multiplied by the -C transformations, F = U'CZ, and the solution matrix Y of the -C transformed system -C -C Y + HYS' = F -C -C is computed by back substitution. Finally, the matrix Y is then -C multiplied by the orthogonal transformation matrices, X = UYZ', in -C order to obtain the solution matrix X to the original problem. -C -C REFERENCES -C -C [1] Golub, G.H., Nash, S. and Van Loan, C.F. -C A Hessenberg-Schur method for the problem AX + XB = C. -C IEEE Trans. Auto. Contr., AC-24, pp. 909-913, 1979. -C -C [2] Sima, V. -C Algorithms for Linear-quadratic Optimization. -C Marcel Dekker, Inc., New York, 1996. -C -C NUMERICAL ASPECTS -C 3 3 2 2 -C The algorithm requires about (5/3) N + 10 M + 5 N M + 2.5 M N -C operations and is backward stable. -C -C CONTRIBUTORS -C -C D. Sima, University of Bucharest, May 2000, Aug. 2000. -C -C REVISIONS -C -C V. Sima, Research Institute for Informatics, Bucharest, May 2000. -C -C KEYWORDS -C -C Hessenberg form, orthogonal transformation, real Schur form, -C Sylvester equation. -C -C ****************************************************************** -C -C .. Parameters .. - DOUBLE PRECISION ONE, ZERO - PARAMETER ( ONE = 1.0D0, ZERO = 0.0D0 ) -C .. Scalar Arguments .. - INTEGER INFO, LDA, LDB, LDC, LDWORK, LDZ, M, N -C .. Array Arguments .. - INTEGER IWORK(*) - DOUBLE PRECISION A(LDA,*), B(LDB,*), C(LDC,*), DWORK(*), Z(LDZ,*) -C .. Local Scalars .. - INTEGER BL, CHUNK, I, IEIG, IFAIL, IHI, ILO, IND, ITAU, - $ JWORK, SDIM, WRKOPT -C .. Local Scalars .. - LOGICAL BLAS3, BLOCK -C .. Local Arrays .. - LOGICAL BWORK(1) -C .. External Functions .. - LOGICAL SELECT -C .. External Subroutines .. - EXTERNAL DCOPY, DGEES, DGEHRD, DGEMM, DGEMV, DLACPY, - $ DORMHR, DSWAP, SB04QU, SB04QY, XERBLA -C .. Intrinsic Functions .. - INTRINSIC INT, MAX, MIN -C .. Executable Statements .. -C - INFO = 0 -C -C Test the input scalar arguments. -C - IF( N.LT.0 ) THEN - INFO = -1 - ELSE IF( M.LT.0 ) THEN - INFO = -2 - ELSE IF( LDA.LT.MAX( 1, N ) ) THEN - INFO = -4 - ELSE IF( LDB.LT.MAX( 1, M ) ) THEN - INFO = -6 - ELSE IF( LDC.LT.MAX( 1, N ) ) THEN - INFO = -8 - ELSE IF( LDZ.LT.MAX( 1, M ) ) THEN - INFO = -10 - ELSE IF( LDWORK.LT.MAX( 1, 2*N*N + 9*N, 5*M, N + M ) ) THEN - INFO = -13 - END IF -C - IF ( INFO.NE.0 ) THEN -C -C Error return. -C - CALL XERBLA( 'SB04QD', -INFO ) - RETURN - END IF -C -C Quick return if possible. -C - IF ( N.EQ.0 .OR. M.EQ.0 ) THEN - DWORK(1) = ONE - RETURN - END IF -C - ILO = 1 - IHI = N - WRKOPT = 2*N*N + 9*N -C -C Step 1 : Reduce A to upper Hessenberg and B' to quasi-upper -C triangular. That is, H = U' * A * U (store U in factored -C form) and S = Z' * B' * Z (save Z). -C -C (Note: Comments in the code beginning "Workspace:" describe the -C minimal amount of real workspace needed at that point in the -C code, as well as the preferred amount for good performance. -C NB refers to the optimal block size for the immediately -C following subroutine, as returned by ILAENV.) -C - DO 20 I = 2, M - CALL DSWAP( I-1, B(1,I), 1, B(I,1), LDB ) - 20 CONTINUE -C -C Workspace: need 5*M; -C prefer larger. -C - IEIG = M + 1 - JWORK = IEIG + M - CALL DGEES( 'Vectors', 'Not ordered', SELECT, M, B, LDB, - $ SDIM, DWORK, DWORK(IEIG), Z, LDZ, DWORK(JWORK), - $ LDWORK-JWORK+1, BWORK, INFO ) - IF ( INFO.NE.0 ) - $ RETURN - WRKOPT = MAX( WRKOPT, INT( DWORK(JWORK) )+JWORK-1 ) -C -C Workspace: need 2*N; -C prefer N + N*NB. -C - ITAU = 2 - JWORK = ITAU + N - 1 - CALL DGEHRD( N, ILO, IHI, A, LDA, DWORK(ITAU), DWORK(JWORK), - $ LDWORK-JWORK+1, IFAIL ) - WRKOPT = MAX( WRKOPT, INT( DWORK(JWORK) )+JWORK-1 ) -C -C Step 2 : Form F = ( U' * C ) * Z. Use BLAS 3, if enough space. -C -C Workspace: need N + M; -C prefer N + M*NB. -C - CALL DORMHR( 'Left', 'Transpose', N, M, ILO, IHI, A, LDA, - $ DWORK(ITAU), C, LDC, DWORK(JWORK), LDWORK-JWORK+1, - $ IFAIL ) - WRKOPT = MAX( WRKOPT, MAX( INT( DWORK(JWORK) ), N*M )+JWORK-1 ) -C - CHUNK = ( LDWORK - JWORK + 1 ) / M - BLOCK = MIN( CHUNK, N ).GT.1 - BLAS3 = CHUNK.GE.N .AND. BLOCK -C - IF ( BLAS3 ) THEN - CALL DGEMM( 'No transpose', 'No transpose', N, M, M, ONE, C, - $ LDC, Z, LDZ, ZERO, DWORK(JWORK), N ) - CALL DLACPY( 'Full', N, M, DWORK(JWORK), N, C, LDC ) -C - ELSE IF ( BLOCK ) THEN -C -C Use as many rows of C as possible. -C - DO 40 I = 1, N, CHUNK - BL = MIN( N-I+1, CHUNK ) - CALL DGEMM( 'NoTranspose', 'NoTranspose', BL, M, M, ONE, - $ C(I,1), LDC, Z, LDZ, ZERO, DWORK(JWORK), BL ) - CALL DLACPY( 'Full', BL, M, DWORK(JWORK), BL, C(I,1), LDC ) - 40 CONTINUE -C - ELSE -C - DO 60 I = 1, N - CALL DGEMV( 'Transpose', M, M, ONE, Z, LDZ, C(I,1), LDC, - $ ZERO, DWORK(JWORK), 1 ) - CALL DCOPY( M, DWORK(JWORK), 1, C(I,1), LDC ) - 60 CONTINUE -C - END IF -C -C Step 3 : Solve Y + H * Y * S' = F for Y. -C - IND = M - 80 CONTINUE -C - IF ( IND.GT.1 ) THEN - IF ( B(IND,IND-1).EQ.ZERO ) THEN -C -C Solve a special linear algebraic system of order N. -C Workspace: N*(N+1)/2 + 3*N. -C - CALL SB04QY( M, N, IND, A, LDA, B, LDB, C, LDC, - $ DWORK(JWORK), IWORK, INFO ) -C - IF ( INFO.NE.0 ) THEN - INFO = INFO + M - RETURN - END IF - IND = IND - 1 - ELSE -C -C Solve a special linear algebraic system of order 2*N. -C Workspace: 2*N*N + 9*N; -C - CALL SB04QU( M, N, IND, A, LDA, B, LDB, C, LDC, - $ DWORK(JWORK), IWORK, INFO ) -C - IF ( INFO.NE.0 ) THEN - INFO = INFO + M - RETURN - END IF - IND = IND - 2 - END IF - GO TO 80 - ELSE IF ( IND.EQ.1 ) THEN -C -C Solve a special linear algebraic system of order N. -C Workspace: N*(N+1)/2 + 3*N; -C - CALL SB04QY( M, N, IND, A, LDA, B, LDB, C, LDC, - $ DWORK(JWORK), IWORK, INFO ) - IF ( INFO.NE.0 ) THEN - INFO = INFO + M - RETURN - END IF - END IF -C -C Step 4 : Form C = ( U * Y ) * Z'. Use BLAS 3, if enough space. -C -C Workspace: need N + M; -C prefer N + M*NB. -C - CALL DORMHR( 'Left', 'No transpose', N, M, ILO, IHI, A, LDA, - $ DWORK(ITAU), C, LDC, DWORK(JWORK), LDWORK-JWORK+1, - $ IFAIL ) - WRKOPT = MAX( WRKOPT, INT( DWORK(JWORK) )+JWORK-1 ) -C - IF ( BLAS3 ) THEN - CALL DGEMM( 'No transpose', 'Transpose', N, M, M, ONE, C, LDC, - $ Z, LDZ, ZERO, DWORK(JWORK), N ) - CALL DLACPY( 'Full', N, M, DWORK(JWORK), N, C, LDC ) -C - ELSE IF ( BLOCK ) THEN -C -C Use as many rows of C as possible. -C - DO 100 I = 1, N, CHUNK - BL = MIN( N-I+1, CHUNK ) - CALL DGEMM( 'NoTranspose', 'Transpose', BL, M, M, ONE, - $ C(I,1), LDC, Z, LDZ, ZERO, DWORK(JWORK), BL ) - CALL DLACPY( 'Full', BL, M, DWORK(JWORK), BL, C(I,1), LDC ) - 100 CONTINUE -C - ELSE -C - DO 120 I = 1, N - CALL DGEMV( 'No transpose', M, M, ONE, Z, LDZ, C(I,1), LDC, - $ ZERO, DWORK(JWORK), 1 ) - CALL DCOPY( M, DWORK(JWORK), 1, C(I,1), LDC ) - 120 CONTINUE - END IF -C - RETURN -C *** Last line of SB04QD *** - END diff --git a/mex/sources/libslicot/SB04QR.f b/mex/sources/libslicot/SB04QR.f deleted file mode 100644 index 77231d322..000000000 --- a/mex/sources/libslicot/SB04QR.f +++ /dev/null @@ -1,224 +0,0 @@ - SUBROUTINE SB04QR( M, D, IPR, INFO ) -C -C SLICOT RELEASE 5.0. -C -C Copyright (c) 2002-2009 NICONET e.V. -C -C This program is free software: you can redistribute it and/or -C modify it under the terms of the GNU General Public License as -C published by the Free Software Foundation, either version 2 of -C the License, or (at your option) any later version. -C -C This program is distributed in the hope that it will be useful, -C but WITHOUT ANY WARRANTY; without even the implied warranty of -C MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the -C GNU General Public License for more details. -C -C You should have received a copy of the GNU General Public License -C along with this program. If not, see -C . -C -C PURPOSE -C -C To solve a linear algebraic system of order M whose coefficient -C matrix has zeros below the third subdiagonal and zero elements on -C the third subdiagonal with even column indices. The matrix is -C stored compactly, row-wise. -C -C ARGUMENTS -C -C Input/Output Parameters -C -C M (input) INTEGER -C The order of the system. M >= 0, M even. -C Note that parameter M should have twice the value in the -C original problem (see SLICOT Library routine SB04QU). -C -C D (input/output) DOUBLE PRECISION array, dimension -C (M*M/2+4*M) -C On entry, the first M*M/2 + 3*M elements of this array -C must contain the coefficient matrix, stored compactly, -C row-wise, and the next M elements must contain the right -C hand side of the linear system, as set by SLICOT Library -C routine SB04QU. -C On exit, the content of this array is updated, the last M -C elements containing the solution with components -C interchanged (see IPR). -C -C IPR (output) INTEGER array, dimension (2*M) -C The leading M elements contain information about the -C row interchanges performed for solving the system. -C Specifically, the i-th component of the solution is -C specified by IPR(i). -C -C Error Indicator -C -C INFO INTEGER -C = 0: successful exit; -C = 1: if a singular matrix was encountered. -C -C METHOD -C -C Gaussian elimination with partial pivoting is used. The rows of -C the matrix are not actually permuted, only their indices are -C interchanged in array IPR. -C -C REFERENCES -C -C [1] Golub, G.H., Nash, S. and Van Loan, C.F. -C A Hessenberg-Schur method for the problem AX + XB = C. -C IEEE Trans. Auto. Contr., AC-24, pp. 909-913, 1979. -C -C [2] Sima, V. -C Algorithms for Linear-quadratic Optimization. -C Marcel Dekker, Inc., New York, 1996. -C -C NUMERICAL ASPECTS -C -C None. -C -C CONTRIBUTORS -C -C D. Sima, University of Bucharest, May 2000. -C -C REVISIONS -C -C - -C -C KEYWORDS -C -C Hessenberg form, orthogonal transformation, real Schur form, -C Sylvester equation. -C -C ****************************************************************** -C - DOUBLE PRECISION ZERO - PARAMETER ( ZERO = 0.0D0 ) -C .. Scalar Arguments .. - INTEGER INFO, M -C .. Array Arguments .. - INTEGER IPR(*) - DOUBLE PRECISION D(*) -C .. Local Scalars .. - INTEGER I, I1, I2, IPRM, IPRM1, J, K, L, M1, MPI, MPI1, - $ MPI2 - DOUBLE PRECISION D1, D2, D3, DMAX -C .. External Subroutines .. - EXTERNAL DAXPY -C .. Intrinsic Functions .. - INTRINSIC ABS, MOD -C .. Executable Statements .. -C - INFO = 0 - I2 = M*M/2 + 3*M - MPI = M - IPRM = I2 - M1 = M - I1 = 1 -C - DO 20 I = 1, M - MPI = MPI + 1 - IPRM = IPRM + 1 - IPR(MPI) = I1 - IPR(I) = IPRM - I1 = I1 + M1 - IF ( I.GE.4 .AND. MOD( I, 2 ).EQ.0 ) M1 = M1 - 2 - 20 CONTINUE -C - M1 = M - 1 - MPI1 = M + 1 -C -C Reduce to upper triangular form. -C - DO 80 I = 1, M1 - MPI = MPI1 - MPI1 = MPI1 + 1 - IPRM = IPR(MPI) - D1 = D(IPRM) - I1 = 3 - IF ( MOD( I, 2 ).EQ.0 ) I1 = 2 - IF ( I.EQ.M1 ) I1 = 1 - MPI2 = MPI + I1 - L = 0 - DMAX = ABS( D1 ) -C - DO 40 J = MPI1, MPI2 - D2 = D(IPR(J)) - D3 = ABS( D2 ) - IF ( D3.GT.DMAX ) THEN - DMAX = D3 - D1 = D2 - L = J - MPI - END IF - 40 CONTINUE -C -C Check singularity. -C - IF ( DMAX.EQ.ZERO ) THEN - INFO = 1 - RETURN - END IF -C - IF ( L.GT.0 ) THEN -C -C Permute the row indices. -C - K = IPRM - J = MPI + L - IPRM = IPR(J) - IPR(J) = K - IPR(MPI) = IPRM - K = IPR(I) - I2 = I + L - IPR(I) = IPR(I2) - IPR(I2) = K - END IF - IPRM = IPRM + 1 -C -C Annihilate the subdiagonal elements of the matrix. -C - I2 = I - D3 = D(IPR(I)) -C - DO 60 J = MPI1, MPI2 - I2 = I2 + 1 - IPRM1 = IPR(J) - DMAX = -D(IPRM1)/D1 - D(IPR(I2)) = D(IPR(I2)) + DMAX*D3 - CALL DAXPY( M-I, DMAX, D(IPRM), 1, D(IPRM1+1), 1 ) - IPR(J) = IPR(J) + 1 - 60 CONTINUE -C - 80 CONTINUE -C - MPI = M + M - IPRM = IPR(MPI) -C -C Check singularity. -C - IF ( D(IPRM).EQ.ZERO ) THEN - INFO = 1 - RETURN - END IF -C -C Back substitution. -C - D(IPR(M)) = D(IPR(M))/D(IPRM) -C - DO 120 I = M1, 1, -1 - MPI = MPI - 1 - IPRM = IPR(MPI) - IPRM1 = IPRM - DMAX = ZERO -C - DO 100 K = I+1, M - IPRM1 = IPRM1 + 1 - DMAX = DMAX + D(IPR(K))*D(IPRM1) - 100 CONTINUE -C - D(IPR(I)) = ( D(IPR(I)) - DMAX )/D(IPRM) - 120 CONTINUE -C - RETURN -C *** Last line of SB04QR *** - END diff --git a/mex/sources/libslicot/SB04QU.f b/mex/sources/libslicot/SB04QU.f deleted file mode 100644 index 2a53f1e3b..000000000 --- a/mex/sources/libslicot/SB04QU.f +++ /dev/null @@ -1,218 +0,0 @@ - SUBROUTINE SB04QU( N, M, IND, A, LDA, B, LDB, C, LDC, D, IPR, - $ INFO ) -C -C SLICOT RELEASE 5.0. -C -C Copyright (c) 2002-2009 NICONET e.V. -C -C This program is free software: you can redistribute it and/or -C modify it under the terms of the GNU General Public License as -C published by the Free Software Foundation, either version 2 of -C the License, or (at your option) any later version. -C -C This program is distributed in the hope that it will be useful, -C but WITHOUT ANY WARRANTY; without even the implied warranty of -C MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the -C GNU General Public License for more details. -C -C You should have received a copy of the GNU General Public License -C along with this program. If not, see -C . -C -C PURPOSE -C -C To construct and solve a linear algebraic system of order 2*M -C whose coefficient matrix has zeros below the third subdiagonal, -C and zero elements on the third subdiagonal with even column -C indices. Such systems appear when solving discrete-time Sylvester -C equations using the Hessenberg-Schur method. -C -C ARGUMENTS -C -C Input/Output Parameters -C -C N (input) INTEGER -C The order of the matrix B. N >= 0. -C -C M (input) INTEGER -C The order of the matrix A. M >= 0. -C -C IND (input) INTEGER -C IND and IND - 1 specify the indices of the columns in C -C to be computed. IND > 1. -C -C A (input) DOUBLE PRECISION array, dimension (LDA,M) -C The leading M-by-M part of this array must contain an -C upper Hessenberg matrix. -C -C LDA INTEGER -C The leading dimension of array A. LDA >= MAX(1,M). -C -C B (input) DOUBLE PRECISION array, dimension (LDB,N) -C The leading N-by-N part of this array must contain a -C matrix in real Schur form. -C -C LDB INTEGER -C The leading dimension of array B. LDB >= MAX(1,N). -C -C C (input/output) DOUBLE PRECISION array, dimension (LDC,N) -C On entry, the leading M-by-N part of this array must -C contain the coefficient matrix C of the equation. -C On exit, the leading M-by-N part of this array contains -C the matrix C with columns IND-1 and IND updated. -C -C LDC INTEGER -C The leading dimension of array C. LDC >= MAX(1,M). -C -C Workspace -C -C D DOUBLE PRECISION array, dimension (2*M*M+8*M) -C -C IPR INTEGER array, dimension (4*M) -C -C Error Indicator -C -C INFO INTEGER -C = 0: successful exit; -C > 0: if INFO = IND, a singular matrix was encountered. -C -C METHOD -C -C A special linear algebraic system of order 2*M, whose coefficient -C matrix has zeros below the third subdiagonal and zero elements on -C the third subdiagonal with even column indices, is constructed and -C solved. The coefficient matrix is stored compactly, row-wise. -C -C REFERENCES -C -C [1] Golub, G.H., Nash, S. and Van Loan, C.F. -C A Hessenberg-Schur method for the problem AX + XB = C. -C IEEE Trans. Auto. Contr., AC-24, pp. 909-913, 1979. -C -C [2] Sima, V. -C Algorithms for Linear-quadratic Optimization. -C Marcel Dekker, Inc., New York, 1996. -C -C NUMERICAL ASPECTS -C -C None. -C -C CONTRIBUTORS -C -C D. Sima, University of Bucharest, May 2000. -C -C REVISIONS -C -C - -C -C KEYWORDS -C -C Hessenberg form, orthogonal transformation, real Schur form, -C Sylvester equation. -C -C ****************************************************************** -C - DOUBLE PRECISION ONE, ZERO - PARAMETER ( ONE = 1.0D0, ZERO = 0.0D0 ) -C .. Scalar Arguments .. - INTEGER INFO, IND, LDA, LDB, LDC, M, N -C .. Array Arguments .. - INTEGER IPR(*) - DOUBLE PRECISION A(LDA,*), B(LDB,*), C(LDC,*), D(*) -C .. Local Scalars .. - INTEGER I, I2, IND1, J, K, K1, K2, M2 - DOUBLE PRECISION TEMP -C .. Local Arrays .. - DOUBLE PRECISION DUM(1) -C .. External Subroutines .. - EXTERNAL DAXPY, DCOPY, DTRMV, SB04QR -C .. Intrinsic Functions .. - INTRINSIC MAX -C .. Executable Statements .. -C - IND1 = IND - 1 -C - IF ( IND.LT.N ) THEN - DUM(1) = ZERO - CALL DCOPY ( M, DUM, 0, D, 1 ) - DO 10 I = IND + 1, N - CALL DAXPY ( M, B(IND1,I), C(1,I), 1, D, 1 ) - 10 CONTINUE -C - DO 20 I = 2, M - C(I,IND1) = C(I,IND1) - A(I,I-1)*D(I-1) - 20 CONTINUE - CALL DTRMV ( 'Upper', 'No Transpose', 'Non Unit', M, A, LDA, - $ D, 1 ) - DO 30 I = 1, M - C(I,IND1) = C(I,IND1) - D(I) - 30 CONTINUE -C - CALL DCOPY ( M, DUM, 0, D, 1 ) - DO 40 I = IND + 1, N - CALL DAXPY ( M, B(IND,I), C(1,I), 1, D, 1 ) - 40 CONTINUE -C - DO 50 I = 2, M - C(I,IND) = C(I,IND) - A(I,I-1)*D(I-1) - 50 CONTINUE - CALL DTRMV ( 'Upper', 'No Transpose', 'Non Unit', M, A, LDA, - $ D, 1 ) - DO 60 I = 1, M - C(I,IND) = C(I,IND) - D(I) - 60 CONTINUE - END IF -C -C Construct the linear algebraic system of order 2*M. -C - K1 = -1 - M2 = 2*M - I2 = M2*(M + 3) - K = M2 -C - DO 80 I = 1, M -C - DO 70 J = MAX( 1, I - 1 ), M - K1 = K1 + 2 - K2 = K1 + K - TEMP = A(I,J) - D(K1) = TEMP * B(IND1,IND1) - D(K1+1) = TEMP * B(IND1,IND) - D(K2) = TEMP * B(IND,IND1) - D(K2+1) = TEMP * B(IND,IND) - IF ( I.EQ.J ) THEN - D(K1) = D(K1) + ONE - D(K2+1) = D(K2+1) + ONE - END IF - 70 CONTINUE -C - K1 = K2 - IF ( I.GT.1 ) K = K - 2 -C -C Store the right hand side. -C - I2 = I2 + 2 - D(I2) = C(I,IND) - D(I2-1) = C(I,IND1) - 80 CONTINUE -C -C Solve the linear algebraic system and store the solution in C. -C - CALL SB04QR( M2, D, IPR, INFO ) -C - IF ( INFO.NE.0 ) THEN - INFO = IND - ELSE - I2 = 0 -C - DO 90 I = 1, M - I2 = I2 + 2 - C(I,IND1) = D(IPR(I2-1)) - C(I,IND) = D(IPR(I2)) - 90 CONTINUE -C - END IF -C - RETURN -C *** Last line of SB04QU *** - END diff --git a/mex/sources/libslicot/SB04QY.f b/mex/sources/libslicot/SB04QY.f deleted file mode 100644 index f351a2f4e..000000000 --- a/mex/sources/libslicot/SB04QY.f +++ /dev/null @@ -1,185 +0,0 @@ - SUBROUTINE SB04QY( N, M, IND, A, LDA, B, LDB, C, LDC, D, IPR, - $ INFO ) -C -C SLICOT RELEASE 5.0. -C -C Copyright (c) 2002-2009 NICONET e.V. -C -C This program is free software: you can redistribute it and/or -C modify it under the terms of the GNU General Public License as -C published by the Free Software Foundation, either version 2 of -C the License, or (at your option) any later version. -C -C This program is distributed in the hope that it will be useful, -C but WITHOUT ANY WARRANTY; without even the implied warranty of -C MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the -C GNU General Public License for more details. -C -C You should have received a copy of the GNU General Public License -C along with this program. If not, see -C . -C -C PURPOSE -C -C To construct and solve a linear algebraic system of order M whose -C coefficient matrix is in upper Hessenberg form. Such systems -C appear when solving discrete-time Sylvester equations using the -C Hessenberg-Schur method. -C -C ARGUMENTS -C -C Input/Output Parameters -C -C N (input) INTEGER -C The order of the matrix B. N >= 0. -C -C M (input) INTEGER -C The order of the matrix A. M >= 0. -C -C IND (input) INTEGER -C The index of the column in C to be computed. IND >= 1. -C -C A (input) DOUBLE PRECISION array, dimension (LDA,M) -C The leading M-by-M part of this array must contain an -C upper Hessenberg matrix. -C -C LDA INTEGER -C The leading dimension of array A. LDA >= MAX(1,M). -C -C B (input) DOUBLE PRECISION array, dimension (LDB,N) -C The leading N-by-N part of this array must contain a -C matrix in real Schur form. -C -C LDB INTEGER -C The leading dimension of array B. LDB >= MAX(1,N). -C -C C (input/output) DOUBLE PRECISION array, dimension (LDC,N) -C On entry, the leading M-by-N part of this array must -C contain the coefficient matrix C of the equation. -C On exit, the leading M-by-N part of this array contains -C the matrix C with column IND updated. -C -C LDC INTEGER -C The leading dimension of array C. LDC >= MAX(1,M). -C -C Workspace -C -C D DOUBLE PRECISION array, dimension (M*(M+1)/2+2*M) -C -C IPR INTEGER array, dimension (2*M) -C -C Error Indicator -C -C INFO INTEGER -C = 0: successful exit; -C > 0: if INFO = IND, a singular matrix was encountered. -C -C METHOD -C -C A special linear algebraic system of order M, with coefficient -C matrix in upper Hessenberg form is constructed and solved. The -C coefficient matrix is stored compactly, row-wise. -C -C REFERENCES -C -C [1] Golub, G.H., Nash, S. and Van Loan, C.F. -C A Hessenberg-Schur method for the problem AX + XB = C. -C IEEE Trans. Auto. Contr., AC-24, pp. 909-913, 1979. -C -C [2] Sima, V. -C Algorithms for Linear-quadratic Optimization. -C Marcel Dekker, Inc., New York, 1996. -C -C NUMERICAL ASPECTS -C -C None. -C -C CONTRIBUTORS -C -C D. Sima, University of Bucharest, May 2000. -C -C REVISIONS -C -C - -C -C KEYWORDS -C -C Hessenberg form, orthogonal transformation, real Schur form, -C Sylvester equation. -C -C ****************************************************************** -C -C .. Parameters .. - DOUBLE PRECISION ONE, ZERO - PARAMETER ( ONE = 1.0D0, ZERO = 0.0D0 ) -C .. Scalar Arguments .. - INTEGER INFO, IND, LDA, LDB, LDC, M, N -C .. Array Arguments .. - INTEGER IPR(*) - DOUBLE PRECISION A(LDA,*), B(LDB,*), C(LDC,*), D(*) -C .. Local Scalars .. - INTEGER I, I2, J, K, K1, K2, M1 -C .. Local Arrays .. - DOUBLE PRECISION DUM(1) -C .. External Subroutines .. - EXTERNAL DAXPY, DCOPY, DSCAL, DTRMV, SB04MW -C .. Executable Statements .. -C - IF ( IND.LT.N ) THEN - DUM(1) = ZERO - CALL DCOPY ( M, DUM, 0, D, 1 ) - DO 10 I = IND + 1, N - CALL DAXPY ( M, B(IND,I), C(1,I), 1, D, 1 ) - 10 CONTINUE - DO 20 I = 2, M - C(I,IND) = C(I,IND) - A(I,I-1)*D(I-1) - 20 CONTINUE - CALL DTRMV ( 'Upper', 'No Transpose', 'Non Unit', M, A, LDA, - $ D, 1 ) - DO 30 I = 1, M - C(I,IND) = C(I,IND) - D(I) - 30 CONTINUE - END IF -C - M1 = M + 1 - I2 = ( M*M1 )/2 + M1 - K2 = 1 - K = M -C -C Construct the linear algebraic system of order M. -C - DO 40 I = 1, M - J = M1 - K - CALL DCOPY ( K, A(I,J), LDA, D(K2), 1 ) - CALL DSCAL ( K, B(IND,IND), D(K2), 1 ) - K1 = K2 - K2 = K2 + K - IF ( I.GT.1 ) THEN - K1 = K1 + 1 - K = K - 1 - END IF - D(K1) = D(K1) + ONE -C -C Store the right hand side. -C - D(I2) = C(I,IND) - I2 = I2 + 1 - 40 CONTINUE -C -C Solve the linear algebraic system and store the solution in C. -C - CALL SB04MW( M, D, IPR, INFO ) -C - IF ( INFO.NE.0 ) THEN - INFO = IND - ELSE -C - DO 50 I = 1, M - C(I,IND) = D(IPR(I)) - 50 CONTINUE -C - END IF -C - RETURN -C *** Last line of SB04QY *** - END diff --git a/mex/sources/libslicot/SB04RD.f b/mex/sources/libslicot/SB04RD.f deleted file mode 100644 index 6fd6feaec..000000000 --- a/mex/sources/libslicot/SB04RD.f +++ /dev/null @@ -1,406 +0,0 @@ - SUBROUTINE SB04RD( ABSCHU, ULA, ULB, N, M, A, LDA, B, LDB, C, - $ LDC, TOL, IWORK, DWORK, LDWORK, INFO ) -C -C SLICOT RELEASE 5.0. -C -C Copyright (c) 2002-2009 NICONET e.V. -C -C This program is free software: you can redistribute it and/or -C modify it under the terms of the GNU General Public License as -C published by the Free Software Foundation, either version 2 of -C the License, or (at your option) any later version. -C -C This program is distributed in the hope that it will be useful, -C but WITHOUT ANY WARRANTY; without even the implied warranty of -C MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the -C GNU General Public License for more details. -C -C You should have received a copy of the GNU General Public License -C along with this program. If not, see -C . -C -C PURPOSE -C -C To solve for X the discrete-time Sylvester equation -C -C X + AXB = C, -C -C with at least one of the matrices A or B in Schur form and the -C other in Hessenberg or Schur form (both either upper or lower); -C A, B, C and X are N-by-N, M-by-M, N-by-M, and N-by-M matrices, -C respectively. -C -C ARGUMENTS -C -C Mode Parameters -C -C ABSCHU CHARACTER*1 -C Indicates whether A and/or B is/are in Schur or -C Hessenberg form as follows: -C = 'A': A is in Schur form, B is in Hessenberg form; -C = 'B': B is in Schur form, A is in Hessenberg form; -C = 'S': Both A and B are in Schur form. -C -C ULA CHARACTER*1 -C Indicates whether A is in upper or lower Schur form or -C upper or lower Hessenberg form as follows: -C = 'U': A is in upper Hessenberg form if ABSCHU = 'B' and -C upper Schur form otherwise; -C = 'L': A is in lower Hessenberg form if ABSCHU = 'B' and -C lower Schur form otherwise. -C -C ULB CHARACTER*1 -C Indicates whether B is in upper or lower Schur form or -C upper or lower Hessenberg form as follows: -C = 'U': B is in upper Hessenberg form if ABSCHU = 'A' and -C upper Schur form otherwise; -C = 'L': B is in lower Hessenberg form if ABSCHU = 'A' and -C lower Schur form otherwise. -C -C Input/Output Parameters -C -C N (input) INTEGER -C The order of the matrix A. N >= 0. -C -C M (input) INTEGER -C The order of the matrix B. M >= 0. -C -C A (input) DOUBLE PRECISION array, dimension (LDA,N) -C The leading N-by-N part of this array must contain the -C coefficient matrix A of the equation. -C -C LDA INTEGER -C The leading dimension of array A. LDA >= MAX(1,N). -C -C B (input) DOUBLE PRECISION array, dimension (LDB,M) -C The leading M-by-M part of this array must contain the -C coefficient matrix B of the equation. -C -C LDB INTEGER -C The leading dimension of array B. LDB >= MAX(1,M). -C -C C (input/output) DOUBLE PRECISION array, dimension (LDC,M) -C On entry, the leading N-by-M part of this array must -C contain the coefficient matrix C of the equation. -C On exit, if INFO = 0, the leading N-by-M part of this -C array contains the solution matrix X of the problem. -C -C LDC INTEGER -C The leading dimension of array C. LDC >= MAX(1,N). -C -C Tolerances -C -C TOL DOUBLE PRECISION -C The tolerance to be used to test for near singularity in -C the Sylvester equation. If the user sets TOL > 0, then the -C given value of TOL is used as a lower bound for the -C reciprocal condition number; a matrix whose estimated -C condition number is less than 1/TOL is considered to be -C nonsingular. If the user sets TOL <= 0, then a default -C tolerance, defined by TOLDEF = EPS, is used instead, where -C EPS is the machine precision (see LAPACK Library routine -C DLAMCH). -C This parameter is not referenced if ABSCHU = 'S', -C ULA = 'U', and ULB = 'U'. -C -C Workspace -C -C IWORK INTEGER array, dimension (2*MAX(M,N)) -C This parameter is not referenced if ABSCHU = 'S', -C ULA = 'U', and ULB = 'U'. -C -C DWORK DOUBLE PRECISION array, dimension (LDWORK) -C -C LDWORK INTEGER -C The length of the array DWORK. -C LDWORK = 2*N, if ABSCHU = 'S', ULA = 'U', and ULB = 'U'; -C LDWORK = 2*MAX(M,N)*(4 + 2*MAX(M,N)), otherwise. -C -C Error Indicator -C -C INFO INTEGER -C = 0: successful exit; -C < 0: if INFO = -i, the i-th argument had an illegal -C value; -C = 1: if a (numerically) singular matrix T was encountered -C during the computation of the solution matrix X. -C That is, the estimated reciprocal condition number -C of T is less than or equal to TOL. -C -C METHOD -C -C Matrices A and B are assumed to be in (upper or lower) Hessenberg -C or Schur form (with at least one of them in Schur form). The -C solution matrix X is then computed by rows or columns via the back -C substitution scheme proposed by Golub, Nash and Van Loan (see -C [1]), which involves the solution of triangular systems of -C equations that are constructed recursively and which may be nearly -C singular if A and -B have almost reciprocal eigenvalues. If near -C singularity is detected, then the routine returns with the Error -C Indicator (INFO) set to 1. -C -C REFERENCES -C -C [1] Golub, G.H., Nash, S. and Van Loan, C.F. -C A Hessenberg-Schur method for the problem AX + XB = C. -C IEEE Trans. Auto. Contr., AC-24, pp. 909-913, 1979. -C -C [2] Sima, V. -C Algorithms for Linear-quadratic Optimization. -C Marcel Dekker, Inc., New York, 1996. -C -C NUMERICAL ASPECTS -C 2 2 -C The algorithm requires approximately 5M N + 0.5MN operations in -C 2 2 -C the worst case and 2.5M N + 0.5MN operations in the best case -C (where M is the order of the matrix in Hessenberg form and N is -C the order of the matrix in Schur form) and is mixed stable (see -C [1]). -C -C CONTRIBUTORS -C -C D. Sima, University of Bucharest, May 2000. -C -C REVISIONS -C -C V. Sima, Katholieke Univ. Leuven, Belgium, June 2000. -C -C KEYWORDS -C -C Hessenberg form, orthogonal transformation, real Schur form, -C Sylvester equation. -C -C ****************************************************************** -C -C .. Parameters .. - DOUBLE PRECISION ONE, ZERO - PARAMETER ( ONE = 1.0D0, ZERO = 0.0D0 ) -C .. Scalar Arguments .. - CHARACTER ABSCHU, ULA, ULB - INTEGER INFO, LDA, LDB, LDC, LDWORK, M, N - DOUBLE PRECISION TOL -C .. Array Arguments .. - INTEGER IWORK(*) - DOUBLE PRECISION A(LDA,*), B(LDB,*), C(LDC,*), DWORK(*) -C .. Local Scalars .. - CHARACTER ABSCHR - LOGICAL LABSCB, LABSCS, LULA, LULB - INTEGER FWD, I, IBEG, IEND, INCR, IPINCR, ISTEP, JWORK, - $ LDW, MAXMN - DOUBLE PRECISION SCALE, TOL1 -C .. External Functions .. - LOGICAL LSAME - DOUBLE PRECISION DLAMCH - EXTERNAL DLAMCH, LSAME -C .. External Subroutines .. - EXTERNAL DCOPY, SB04PY, SB04RV, SB04RW, SB04RX, SB04RY, - $ XERBLA -C .. Intrinsic Functions .. - INTRINSIC MAX -C .. Executable Statements .. -C - INFO = 0 - MAXMN = MAX( M, N ) - LABSCB = LSAME( ABSCHU, 'B' ) - LABSCS = LSAME( ABSCHU, 'S' ) - LULA = LSAME( ULA, 'U' ) - LULB = LSAME( ULB, 'U' ) -C -C Test the input scalar arguments. -C - IF( .NOT.LABSCB .AND. .NOT.LABSCS .AND. - $ .NOT.LSAME( ABSCHU, 'A' ) ) THEN - INFO = -1 - ELSE IF( .NOT.LULA .AND. .NOT.LSAME( ULA, 'L' ) ) THEN - INFO = -2 - ELSE IF( .NOT.LULB .AND. .NOT.LSAME( ULB, 'L' ) ) THEN - INFO = -3 - ELSE IF( N.LT.0 ) THEN - INFO = -4 - ELSE IF( M.LT.0 ) THEN - INFO = -5 - ELSE IF( LDA.LT.MAX( 1, N ) ) THEN - INFO = -7 - ELSE IF( LDB.LT.MAX( 1, M ) ) THEN - INFO = -9 - ELSE IF( LDC.LT.MAX( 1, N ) ) THEN - INFO = -11 - ELSE IF( LDWORK.LT.2*N .OR. - $ ( LDWORK.LT.2*MAXMN*( 4 + 2*MAXMN ) .AND. - $ .NOT.( LABSCS .AND. LULA .AND. LULB ) ) ) THEN - INFO = -15 - END IF -C - IF ( INFO.NE.0 ) THEN -C -C Error return. -C - CALL XERBLA( 'SB04RD', -INFO ) - RETURN - END IF -C -C Quick return if possible. -C - IF ( MAXMN.EQ.0 ) - $ RETURN -C - IF ( LABSCS .AND. LULA .AND. LULB ) THEN -C -C If both matrices are in a real Schur form, use SB04PY. -C - CALL SB04PY( 'NoTranspose', 'NoTranspose', 1, N, M, A, LDA, - $ B, LDB, C, LDC, SCALE, DWORK, INFO ) - IF ( SCALE.NE.ONE ) - $ INFO = 1 - RETURN - END IF -C - LDW = 2*MAXMN - JWORK = LDW*LDW + 3*LDW + 1 - TOL1 = TOL - IF ( TOL1.LE.ZERO ) - $ TOL1 = DLAMCH( 'Epsilon' ) -C -C Choose the smallest of both matrices as the one in Hessenberg -C form when possible. -C - ABSCHR = ABSCHU - IF ( LABSCS ) THEN - IF ( N.GT.M ) THEN - ABSCHR = 'A' - ELSE - ABSCHR = 'B' - END IF - END IF - IF ( LSAME( ABSCHR, 'B' ) ) THEN -C -C B is in Schur form: recursion on the columns of B. -C - IF ( LULB ) THEN -C -C B is upper: forward recursion. -C - IBEG = 1 - IEND = M - FWD = 1 - INCR = 0 - ELSE -C -C B is lower: backward recursion. -C - IBEG = M - IEND = 1 - FWD = -1 - INCR = -1 - END IF - I = IBEG -C WHILE ( ( IEND - I ) * FWD .GE. 0 ) DO - 20 IF ( ( IEND - I )*FWD.GE.0 ) THEN -C -C Test for 1-by-1 or 2-by-2 diagonal block in the Schur -C form. -C - IF ( I.EQ.IEND ) THEN - ISTEP = 1 - ELSE - IF ( B(I+FWD,I).EQ.ZERO ) THEN - ISTEP = 1 - ELSE - ISTEP = 2 - END IF - END IF -C - IF ( ISTEP.EQ.1 ) THEN - CALL SB04RW( ABSCHR, ULB, N, M, C, LDC, I, B, LDB, - $ A, LDA, DWORK(JWORK), DWORK ) - CALL SB04RY( 'R', ULA, N, A, LDA, B(I,I), DWORK(JWORK), - $ TOL1, IWORK, DWORK, LDW, INFO ) - IF ( INFO.EQ.1 ) - $ RETURN - CALL DCOPY( N, DWORK(JWORK), 1, C(1,I), 1 ) - ELSE - IPINCR = I + INCR - CALL SB04RV( ABSCHR, ULB, N, M, C, LDC, IPINCR, B, LDB, - $ A, LDA, DWORK(JWORK), DWORK ) - CALL SB04RX( 'R', ULA, N, A, LDA, B(IPINCR,IPINCR), - $ B(IPINCR+1,IPINCR), B(IPINCR,IPINCR+1), - $ B(IPINCR+1,IPINCR+1), DWORK(JWORK), TOL1, - $ IWORK, DWORK, LDW, INFO ) - IF ( INFO.EQ.1 ) - $ RETURN - CALL DCOPY( N, DWORK(JWORK), 2, C(1,IPINCR), 1 ) - CALL DCOPY( N, DWORK(JWORK+1), 2, C(1,IPINCR+1), 1 ) - END IF - I = I + FWD*ISTEP - GO TO 20 - END IF -C END WHILE 20 - ELSE -C -C A is in Schur form: recursion on the rows of A. -C - IF ( LULA ) THEN -C -C A is upper: backward recursion. -C - IBEG = N - IEND = 1 - FWD = -1 - INCR = -1 - ELSE -C -C A is lower: forward recursion. -C - IBEG = 1 - IEND = N - FWD = 1 - INCR = 0 - END IF - I = IBEG -C WHILE ( ( IEND - I ) * FWD .GE. 0 ) DO - 40 IF ( ( IEND - I )*FWD.GE.0 ) THEN -C -C Test for 1-by-1 or 2-by-2 diagonal block in the Schur -C form. -C - IF ( I.EQ.IEND ) THEN - ISTEP = 1 - ELSE - IF ( A(I,I+FWD).EQ.ZERO ) THEN - ISTEP = 1 - ELSE - ISTEP = 2 - END IF - END IF -C - IF ( ISTEP.EQ.1 ) THEN - CALL SB04RW( ABSCHR, ULA, N, M, C, LDC, I, A, LDA, - $ B, LDB, DWORK(JWORK), DWORK ) - CALL SB04RY( 'C', ULB, M, B, LDB, A(I,I), DWORK(JWORK), - $ TOL1, IWORK, DWORK, LDW, INFO ) - IF ( INFO.EQ.1 ) - $ RETURN - CALL DCOPY( M, DWORK(JWORK), 1, C(I,1), LDC ) - ELSE - IPINCR = I + INCR - CALL SB04RV( ABSCHR, ULA, N, M, C, LDC, IPINCR, A, LDA, - $ B, LDB, DWORK(JWORK), DWORK ) - CALL SB04RX( 'C', ULB, M, B, LDB, A(IPINCR,IPINCR), - $ A(IPINCR+1,IPINCR), A(IPINCR,IPINCR+1), - $ A(IPINCR+1,IPINCR+1), DWORK(JWORK), TOL1, - $ IWORK, DWORK, LDW, INFO ) - IF ( INFO.EQ.1 ) - $ RETURN - CALL DCOPY( M, DWORK(JWORK), 2, C(IPINCR,1), LDC ) - CALL DCOPY( M, DWORK(JWORK+1), 2, C(IPINCR+1,1), LDC ) - END IF - I = I + FWD*ISTEP - GO TO 40 - END IF -C END WHILE 40 - END IF -C - RETURN -C *** Last line of SB04RD *** - END diff --git a/mex/sources/libslicot/SB04RV.f b/mex/sources/libslicot/SB04RV.f deleted file mode 100644 index a385fb8ae..000000000 --- a/mex/sources/libslicot/SB04RV.f +++ /dev/null @@ -1,198 +0,0 @@ - SUBROUTINE SB04RV( ABSCHR, UL, N, M, C, LDC, INDX, AB, LDAB, BA, - $ LDBA, D, DWORK ) -C -C SLICOT RELEASE 5.0. -C -C Copyright (c) 2002-2009 NICONET e.V. -C -C This program is free software: you can redistribute it and/or -C modify it under the terms of the GNU General Public License as -C published by the Free Software Foundation, either version 2 of -C the License, or (at your option) any later version. -C -C This program is distributed in the hope that it will be useful, -C but WITHOUT ANY WARRANTY; without even the implied warranty of -C MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the -C GNU General Public License for more details. -C -C You should have received a copy of the GNU General Public License -C along with this program. If not, see -C . -C -C PURPOSE -C -C To construct the right-hand sides D for a system of equations in -C quasi-Hessenberg form solved via SB04RX (case with 2 right-hand -C sides). -C -C ARGUMENTS -C -C Mode Parameters -C -C ABSCHR CHARACTER*1 -C Indicates whether AB contains A or B, as follows: -C = 'A': AB contains A; -C = 'B': AB contains B. -C -C UL CHARACTER*1 -C Indicates whether AB is upper or lower Hessenberg matrix, -C as follows: -C = 'U': AB is upper Hessenberg; -C = 'L': AB is lower Hessenberg. -C -C Input/Output Parameters -C -C N (input) INTEGER -C The order of the matrix A. N >= 0. -C -C M (input) INTEGER -C The order of the matrix B. M >= 0. -C -C C (input) DOUBLE PRECISION array, dimension (LDC,M) -C The leading N-by-M part of this array must contain both -C the not yet modified part of the coefficient matrix C of -C the Sylvester equation X + AXB = C, and both the currently -C computed part of the solution of the Sylvester equation. -C -C LDC INTEGER -C The leading dimension of array C. LDC >= MAX(1,N). -C -C INDX (input) INTEGER -C The position of the first column/row of C to be used in -C the construction of the right-hand side D. -C -C AB (input) DOUBLE PRECISION array, dimension (LDAB,*) -C The leading N-by-N or M-by-M part of this array must -C contain either A or B of the Sylvester equation -C X + AXB = C. -C -C LDAB INTEGER -C The leading dimension of array AB. -C LDAB >= MAX(1,N) or LDAB >= MAX(1,M) (depending on -C ABSCHR = 'A' or ABSCHR = 'B', respectively). -C -C BA (input) DOUBLE PRECISION array, dimension (LDBA,*) -C The leading N-by-N or M-by-M part of this array must -C contain either A or B of the Sylvester equation -C X + AXB = C, the matrix not contained in AB. -C -C LDBA INTEGER -C The leading dimension of array BA. -C LDBA >= MAX(1,N) or LDBA >= MAX(1,M) (depending on -C ABSCHR = 'B' or ABSCHR = 'A', respectively). -C -C D (output) DOUBLE PRECISION array, dimension (*) -C The leading 2*N or 2*M part of this array (depending on -C ABSCHR = 'B' or ABSCHR = 'A', respectively) contains the -C right-hand side stored as a matrix with two rows. -C -C Workspace -C -C DWORK DOUBLE PRECISION array, dimension (LDWORK) -C where LDWORK is equal to 2*N or 2*M (depending on -C ABSCHR = 'B' or ABSCHR = 'A', respectively). -C -C NUMERICAL ASPECTS -C -C None. -C -C CONTRIBUTORS -C -C D. Sima, University of Bucharest, May 2000. -C -C REVISIONS -C -C - -C -C KEYWORDS -C -C Hessenberg form, orthogonal transformation, real Schur form, -C Sylvester equation. -C -C ****************************************************************** -C -C .. Parameters .. - DOUBLE PRECISION ONE, ZERO - PARAMETER ( ONE = 1.0D0, ZERO = 0.0D0 ) -C .. Scalar Arguments .. - CHARACTER ABSCHR, UL - INTEGER INDX, LDAB, LDBA, LDC, M, N -C .. Array Arguments .. - DOUBLE PRECISION AB(LDAB,*), BA(LDBA,*), C(LDC,*), D(*), DWORK(*) -C .. External Functions .. - LOGICAL LSAME - EXTERNAL LSAME -C .. External Subroutines .. - EXTERNAL DCOPY, DGEMV -C .. Executable Statements .. -C -C For speed, no tests on the input scalar arguments are made. -C Quick return if possible. -C - IF ( N.EQ.0 .OR. M.EQ.0 ) - $ RETURN -C - IF ( LSAME( ABSCHR, 'B' ) ) THEN -C -C Construct the 2 columns of the right-hand side. -C - CALL DCOPY( N, C(1,INDX), 1, D(1), 2 ) - CALL DCOPY( N, C(1,INDX+1), 1, D(2), 2 ) - IF ( LSAME( UL, 'U' ) ) THEN - IF ( INDX.GT.1 ) THEN - CALL DGEMV( 'N', N, INDX-1, ONE, C, LDC, AB(1,INDX), 1, - $ ZERO, DWORK, 1 ) - CALL DGEMV( 'N', N, INDX-1, ONE, C, LDC, AB(1,INDX+1), - $ 1, ZERO, DWORK(N+1), 1 ) - CALL DGEMV( 'N', N, N, -ONE, BA, LDBA, DWORK, 1, ONE, - $ D(1), 2 ) - CALL DGEMV( 'N', N, N, -ONE, BA, LDBA, DWORK(N+1), 1, - $ ONE, D(2), 2 ) - END IF - ELSE - IF ( INDX.LT.M-1 ) THEN - CALL DGEMV( 'N', N, M-INDX-1, ONE, C(1,INDX+2), LDC, - $ AB(INDX+2,INDX), 1, ZERO, DWORK, 1 ) - CALL DGEMV( 'N', N, M-INDX-1, ONE, C(1,INDX+2), LDC, - $ AB(INDX+2,INDX+1), 1, ZERO, DWORK(N+1), 1 ) - CALL DGEMV( 'N', N, N, -ONE, BA, LDBA, DWORK, 1, ONE, - $ D(1), 2 ) - CALL DGEMV( 'N', N, N, -ONE, BA, LDBA, DWORK(N+1), 1, - $ ONE, D(2), 2 ) - END IF - END IF - ELSE -C -C Construct the 2 rows of the right-hand side. -C - CALL DCOPY( M, C(INDX,1), LDC, D(1), 2 ) - CALL DCOPY( M, C(INDX+1,1), LDC, D(2), 2 ) - IF ( LSAME( UL, 'U' ) ) THEN - IF ( INDX.LT.N-1 ) THEN - CALL DGEMV( 'T', N-INDX-1, M, ONE, C(INDX+2,1), LDC, - $ AB(INDX,INDX+2), LDAB, ZERO, DWORK, 1 ) - CALL DGEMV( 'T', N-INDX-1, M, ONE, C(INDX+2,1), LDC, - $ AB(INDX+1,INDX+2), LDAB, ZERO, DWORK(M+1), - $ 1 ) - CALL DGEMV( 'T', M, M, -ONE, BA, LDBA, DWORK, 1, ONE, - $ D(1), 2 ) - CALL DGEMV( 'T', M, M, -ONE, BA, LDBA, DWORK(M+1), 1, - $ ONE, D(2), 2 ) - END IF - ELSE - IF ( INDX.GT.1 ) THEN - CALL DGEMV( 'T', INDX-1, M, ONE, C, LDC, AB(INDX,1), - $ LDAB, ZERO, DWORK, 1 ) - CALL DGEMV( 'T', INDX-1, M, ONE, C, LDC, AB(INDX+1,1), - $ LDAB, ZERO, DWORK(M+1), 1 ) - CALL DGEMV( 'T', M, M, -ONE, BA, LDBA, DWORK, 1, ONE, - $ D(1), 2 ) - CALL DGEMV( 'T', M, M, -ONE, BA, LDBA, DWORK(M+1), 1, - $ ONE, D(2), 2 ) - END IF - END IF - END IF -C - RETURN -C *** Last line of SB04RV *** - END diff --git a/mex/sources/libslicot/SB04RW.f b/mex/sources/libslicot/SB04RW.f deleted file mode 100644 index 9dc815c67..000000000 --- a/mex/sources/libslicot/SB04RW.f +++ /dev/null @@ -1,178 +0,0 @@ - SUBROUTINE SB04RW( ABSCHR, UL, N, M, C, LDC, INDX, AB, LDAB, BA, - $ LDBA, D, DWORK ) -C -C SLICOT RELEASE 5.0. -C -C Copyright (c) 2002-2009 NICONET e.V. -C -C This program is free software: you can redistribute it and/or -C modify it under the terms of the GNU General Public License as -C published by the Free Software Foundation, either version 2 of -C the License, or (at your option) any later version. -C -C This program is distributed in the hope that it will be useful, -C but WITHOUT ANY WARRANTY; without even the implied warranty of -C MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the -C GNU General Public License for more details. -C -C You should have received a copy of the GNU General Public License -C along with this program. If not, see -C . -C -C PURPOSE -C -C To construct the right-hand side D for a system of equations in -C Hessenberg form solved via SB04RY (case with 1 right-hand side). -C -C ARGUMENTS -C -C Mode Parameters -C -C ABSCHR CHARACTER*1 -C Indicates whether AB contains A or B, as follows: -C = 'A': AB contains A; -C = 'B': AB contains B. -C -C UL CHARACTER*1 -C Indicates whether AB is upper or lower Hessenberg matrix, -C as follows: -C = 'U': AB is upper Hessenberg; -C = 'L': AB is lower Hessenberg. -C -C Input/Output Parameters -C -C N (input) INTEGER -C The order of the matrix A. N >= 0. -C -C M (input) INTEGER -C The order of the matrix B. M >= 0. -C -C C (input) DOUBLE PRECISION array, dimension (LDC,M) -C The leading N-by-M part of this array must contain both -C the not yet modified part of the coefficient matrix C of -C the Sylvester equation X + AXB = C, and both the currently -C computed part of the solution of the Sylvester equation. -C -C LDC INTEGER -C The leading dimension of array C. LDC >= MAX(1,N). -C -C INDX (input) INTEGER -C The position of the column/row of C to be used in the -C construction of the right-hand side D. -C -C AB (input) DOUBLE PRECISION array, dimension (LDAB,*) -C The leading N-by-N or M-by-M part of this array must -C contain either A or B of the Sylvester equation -C X + AXB = C. -C -C LDAB INTEGER -C The leading dimension of array AB. -C LDAB >= MAX(1,N) or LDAB >= MAX(1,M) (depending on -C ABSCHR = 'A' or ABSCHR = 'B', respectively). -C -C BA (input) DOUBLE PRECISION array, dimension (LDBA,*) -C The leading N-by-N or M-by-M part of this array must -C contain either A or B of the Sylvester equation -C X + AXB = C, the matrix not contained in AB. -C -C LDBA INTEGER -C The leading dimension of array BA. -C LDBA >= MAX(1,N) or LDBA >= MAX(1,M) (depending on -C ABSCHR = 'B' or ABSCHR = 'A', respectively). -C -C D (output) DOUBLE PRECISION array, dimension (*) -C The leading N or M part of this array (depending on -C ABSCHR = 'B' or ABSCHR = 'A', respectively) contains the -C right-hand side. -C -C Workspace -C -C DWORK DOUBLE PRECISION array, dimension (LDWORK) -C where LDWORK is equal to N or M (depending on ABSCHR = 'B' -C or ABSCHR = 'A', respectively). -C -C NUMERICAL ASPECTS -C -C None. -C -C CONTRIBUTORS -C -C D. Sima, University of Bucharest, May 2000. -C -C REVISIONS -C -C - -C -C KEYWORDS -C -C Hessenberg form, orthogonal transformation, real Schur form, -C Sylvester equation. -C -C ****************************************************************** -C -C .. Parameters .. - DOUBLE PRECISION ONE, ZERO - PARAMETER ( ONE = 1.0D0, ZERO = 0.0D0 ) -C .. Scalar Arguments .. - CHARACTER ABSCHR, UL - INTEGER INDX, LDAB, LDBA, LDC, M, N -C .. Array Arguments .. - DOUBLE PRECISION AB(LDAB,*), BA(LDBA,*), C(LDC,*), D(*), DWORK(*) -C .. External Functions .. - LOGICAL LSAME - EXTERNAL LSAME -C .. External Subroutines .. - EXTERNAL DCOPY, DGEMV -C .. Executable Statements .. -C -C For speed, no tests on the input scalar arguments are made. -C Quick return if possible. -C - IF ( N.EQ.0 .OR. M.EQ.0 ) - $ RETURN -C - IF ( LSAME( ABSCHR, 'B' ) ) THEN -C -C Construct the column of the right-hand side. -C - CALL DCOPY( N, C(1,INDX), 1, D, 1 ) - IF ( LSAME( UL, 'U' ) ) THEN - IF ( INDX.GT.1 ) THEN - CALL DGEMV( 'N', N, INDX-1, ONE, C, LDC, AB(1,INDX), 1, - $ ZERO, DWORK, 1 ) - CALL DGEMV( 'N', N, N, -ONE, BA, LDBA, DWORK, 1, - $ ONE, D, 1 ) - END IF - ELSE - IF ( INDX.LT.M ) THEN - CALL DGEMV( 'N', N, M-INDX, ONE, C(1,INDX+1), LDC, - $ AB(INDX+1,INDX), 1, ZERO, DWORK, 1 ) - CALL DGEMV( 'N', N, N, -ONE, BA, LDBA, DWORK, 1, ONE, D, - $ 1 ) - END IF - END IF - ELSE -C -C Construct the row of the right-hand side. -C - CALL DCOPY( M, C(INDX,1), LDC, D, 1 ) - IF ( LSAME( UL, 'U' ) ) THEN - IF ( INDX.LT.N ) THEN - CALL DGEMV( 'T', N-INDX, M, ONE, C(INDX+1,1), LDC, - $ AB(INDX,INDX+1), LDAB, ZERO, DWORK, 1 ) - CALL DGEMV( 'T', M, M, -ONE, BA, LDBA, DWORK, 1, ONE, D, - $ 1 ) - END IF - ELSE - IF ( INDX.GT.1 ) THEN - CALL DGEMV( 'T', INDX-1, M, ONE, C, LDC, AB(INDX,1), - $ LDAB, ZERO, DWORK, 1 ) - CALL DGEMV( 'T', M, M, -ONE, BA, LDBA, DWORK, 1, ONE, D, - $ 1 ) - END IF - END IF - END IF -C - RETURN -C *** Last line of SB04RW *** - END diff --git a/mex/sources/libslicot/SB04RX.f b/mex/sources/libslicot/SB04RX.f deleted file mode 100644 index e84bb188d..000000000 --- a/mex/sources/libslicot/SB04RX.f +++ /dev/null @@ -1,375 +0,0 @@ - SUBROUTINE SB04RX( RC, UL, M, A, LDA, LAMBD1, LAMBD2, LAMBD3, - $ LAMBD4, D, TOL, IWORK, DWORK, LDDWOR, INFO ) -C -C SLICOT RELEASE 5.0. -C -C Copyright (c) 2002-2009 NICONET e.V. -C -C This program is free software: you can redistribute it and/or -C modify it under the terms of the GNU General Public License as -C published by the Free Software Foundation, either version 2 of -C the License, or (at your option) any later version. -C -C This program is distributed in the hope that it will be useful, -C but WITHOUT ANY WARRANTY; without even the implied warranty of -C MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the -C GNU General Public License for more details. -C -C You should have received a copy of the GNU General Public License -C along with this program. If not, see -C . -C -C PURPOSE -C -C To solve a system of equations in quasi-Hessenberg form -C (Hessenberg form plus two consecutive offdiagonals) with two -C right-hand sides. -C -C ARGUMENTS -C -C Mode Parameters -C -C RC CHARACTER*1 -C Indicates processing by columns or rows, as follows: -C = 'R': Row transformations are applied; -C = 'C': Column transformations are applied. -C -C UL CHARACTER*1 -C Indicates whether A is upper or lower Hessenberg matrix, -C as follows: -C = 'U': A is upper Hessenberg; -C = 'L': A is lower Hessenberg. -C -C Input/Output Parameters -C -C M (input) INTEGER -C The order of the matrix A. M >= 0. -C -C A (input) DOUBLE PRECISION array, dimension (LDA,M) -C The leading M-by-M part of this array must contain a -C matrix A in Hessenberg form. -C -C LDA INTEGER -C The leading dimension of array A. LDA >= MAX(1,M). -C -C LAMBD1, (input) DOUBLE PRECISION -C LAMBD2, These variables must contain the 2-by-2 block to be -C LAMBD3, multiplied to the elements of A. -C LAMBD4 -C -C D (input/output) DOUBLE PRECISION array, dimension (2*M) -C On entry, this array must contain the two right-hand -C side vectors of the quasi-Hessenberg system, stored -C row-wise. -C On exit, if INFO = 0, this array contains the two solution -C vectors of the quasi-Hessenberg system, stored row-wise. -C -C Tolerances -C -C TOL DOUBLE PRECISION -C The tolerance to be used to test for near singularity of -C the triangular factor R of the quasi-Hessenberg matrix. -C A matrix whose estimated condition number is less -C than 1/TOL is considered to be nonsingular. -C -C Workspace -C -C IWORK INTEGER array, dimension (2*M) -C -C DWORK DOUBLE PRECISION array, dimension (LDDWOR,2*M+3) -C The leading 2*M-by-2*M part of this array is used for -C computing the triangular factor of the QR decomposition -C of the quasi-Hessenberg matrix. The remaining 6*M elements -C are used as workspace for the computation of the -C reciprocal condition estimate. -C -C LDDWOR INTEGER -C The leading dimension of array DWORK. -C LDDWOR >= MAX(1,2*M). -C -C Error Indicator -C -C INFO INTEGER -C = 0: successful exit; -C = 1: if the quasi-Hessenberg matrix is (numerically) -C singular. That is, its estimated reciprocal -C condition number is less than or equal to TOL. -C -C NUMERICAL ASPECTS -C -C None. -C -C CONTRIBUTORS -C -C D. Sima, University of Bucharest, May 2000. -C -C REVISIONS -C -C - -C -C Note that RC, UL, M, LDA, and LDDWOR must be such that the value -C of the LOGICAL variable OK in the following statement is true. -C -C OK = ( ( UL.EQ.'U' ) .OR. ( UL.EQ.'u' ) .OR. -C ( UL.EQ.'L' ) .OR. ( UL.EQ.'l' ) ) -C .AND. -C ( ( RC.EQ.'R' ) .OR. ( RC.EQ.'r' ) .OR. -C ( RC.EQ.'C' ) .OR. ( RC.EQ.'c' ) ) -C .AND. -C ( M.GE.0 ) -C .AND. -C ( LDA.GE.MAX( 1, M ) ) -C .AND. -C ( LDDWOR.GE.MAX( 1, 2*M ) ) -C -C These conditions are not checked by the routine. -C -C KEYWORDS -C -C Hessenberg form, orthogonal transformation, real Schur form, -C Sylvester equation. -C -C ****************************************************************** -C - DOUBLE PRECISION ONE, ZERO - PARAMETER ( ONE = 1.0D0, ZERO = 0.0D0 ) -C .. Scalar Arguments .. - CHARACTER RC, UL - INTEGER INFO, LDA, LDDWOR, M - DOUBLE PRECISION LAMBD1, LAMBD2, LAMBD3, LAMBD4, TOL -C .. Array Arguments .. - INTEGER IWORK(*) - DOUBLE PRECISION A(LDA,*), D(*), DWORK(LDDWOR,*) -C .. Local Scalars .. - CHARACTER TRANS - INTEGER J, J1, J2, M2, MJ, ML - DOUBLE PRECISION C, R, RCOND, S -C .. External Functions .. - LOGICAL LSAME - EXTERNAL LSAME -C .. External Subroutines .. - EXTERNAL DCOPY, DLARTG, DLASET, DROT, DSCAL, DTRCON, - $ DTRSV -C .. Intrinsic Functions .. - INTRINSIC MAX, MIN, MOD -C .. Executable Statements .. -C - INFO = 0 -C -C For speed, no tests on the input scalar arguments are made. -C Quick return if possible. -C - IF ( M.EQ.0 ) - $ RETURN -C - M2 = M*2 - IF ( LSAME( UL, 'U' ) ) THEN -C - DO 20 J = 1, M - J2 = J*2 - ML = MIN( M, J + 1 ) - CALL DLASET( 'Full', M2, 2, ZERO, ZERO, DWORK(1,J2-1), - $ LDDWOR ) - CALL DCOPY( ML, A(1,J), 1, DWORK(1,J2-1), 2 ) - CALL DSCAL( ML, LAMBD1, DWORK(1,J2-1), 2 ) - CALL DCOPY( ML, A(1,J), 1, DWORK(2,J2-1), 2 ) - CALL DSCAL( ML, LAMBD3, DWORK(2,J2-1), 2 ) - CALL DCOPY( ML, A(1,J), 1, DWORK(1,J2), 2 ) - CALL DSCAL( ML, LAMBD2, DWORK(1,J2), 2 ) - CALL DCOPY( ML, A(1,J), 1, DWORK(2,J2), 2 ) - CALL DSCAL( ML, LAMBD4, DWORK(2,J2), 2 ) -C - DWORK(J2-1,J2-1) = DWORK(J2-1,J2-1) + ONE - DWORK(J2,J2) = DWORK(J2,J2) + ONE - 20 CONTINUE -C - IF ( LSAME( RC, 'R' ) ) THEN - TRANS = 'N' -C -C A is an upper Hessenberg matrix, row transformations. -C - DO 40 J = 1, M2 - 1 - MJ = M2 - J - IF ( MOD(J,2).EQ.1 .AND. J.LT.M2-2 ) THEN - IF ( DWORK(J+3,J).NE.ZERO ) THEN - CALL DLARTG( DWORK(J+2,J), DWORK(J+3,J), C, S, R ) - DWORK(J+2,J) = R - DWORK(J+3,J) = ZERO - CALL DROT( MJ, DWORK(J+2,J+1), LDDWOR, - $ DWORK(J+3,J+1), LDDWOR, C, S ) - CALL DROT( 1, D(J+2), 1, D(J+3), 1, C, S ) - END IF - END IF - IF ( J.LT.M2-1 ) THEN - IF ( DWORK(J+2,J).NE.ZERO ) THEN - CALL DLARTG( DWORK(J+1,J), DWORK(J+2,J), C, S, R ) - DWORK(J+1,J) = R - DWORK(J+2,J) = ZERO - CALL DROT( MJ, DWORK(J+1,J+1), LDDWOR, - $ DWORK(J+2,J+1), LDDWOR, C, S ) - CALL DROT( 1, D(J+1), 1, D(J+2), 1, C, S ) - END IF - END IF - IF ( DWORK(J+1,J).NE.ZERO ) THEN - CALL DLARTG( DWORK(J,J), DWORK(J+1,J), C, S, R ) - DWORK(J,J) = R - DWORK(J+1,J) = ZERO - CALL DROT( MJ, DWORK(J,J+1), LDDWOR, DWORK(J+1,J+1), - $ LDDWOR, C, S ) - CALL DROT( 1, D(J), 1, D(J+1), 1, C, S ) - END IF - 40 CONTINUE -C - ELSE - TRANS = 'T' -C -C A is an upper Hessenberg matrix, column transformations. -C - DO 60 J = 1, M2 - 1 - MJ = M2 - J - IF ( MOD(J,2).EQ.1 .AND. J.LT.M2-2 ) THEN - IF ( DWORK(MJ+1,MJ-2).NE.ZERO ) THEN - CALL DLARTG( DWORK(MJ+1,MJ-1), DWORK(MJ+1,MJ-2), C, - $ S, R ) - DWORK(MJ+1,MJ-1) = R - DWORK(MJ+1,MJ-2) = ZERO - CALL DROT( MJ, DWORK(1,MJ-1), 1, DWORK(1,MJ-2), 1, - $ C, S ) - CALL DROT( 1, D(MJ-1), 1, D(MJ-2), 1, C, S ) - END IF - END IF - IF ( J.LT.M2-1 ) THEN - IF ( DWORK(MJ+1,MJ-1).NE.ZERO ) THEN - CALL DLARTG( DWORK(MJ+1,MJ), DWORK(MJ+1,MJ-1), C, - $ S, R ) - DWORK(MJ+1,MJ) = R - DWORK(MJ+1,MJ-1) = ZERO - CALL DROT( MJ, DWORK(1,MJ), 1, DWORK(1,MJ-1), 1, C, - $ S ) - CALL DROT( 1, D(MJ), 1, D(MJ-1), 1, C, S ) - END IF - END IF - IF ( DWORK(MJ+1,MJ).NE.ZERO ) THEN - CALL DLARTG( DWORK(MJ+1,MJ+1), DWORK(MJ+1,MJ), C, S, - $ R ) - DWORK(MJ+1,MJ+1) = R - DWORK(MJ+1,MJ) = ZERO - CALL DROT( MJ, DWORK(1,MJ+1), 1, DWORK(1,MJ), 1, C, - $ S ) - CALL DROT( 1, D(MJ+1), 1, D(MJ), 1, C, S ) - END IF - 60 CONTINUE -C - END IF - ELSE -C - DO 80 J = 1, M - J2 = J*2 - J1 = MAX( J - 1, 1 ) - ML = MIN( M - J + 2, M ) - CALL DLASET( 'Full', M2, 2, ZERO, ZERO, DWORK(1,J2-1), - $ LDDWOR ) - CALL DCOPY( ML, A(J1,J), 1, DWORK(J1*2-1,J2-1), 2 ) - CALL DSCAL( ML, LAMBD1, DWORK(J1*2-1,J2-1), 2 ) - CALL DCOPY( ML, A(J1,J), 1, DWORK(J1*2,J2-1), 2 ) - CALL DSCAL( ML, LAMBD3, DWORK(J1*2,J2-1), 2 ) - CALL DCOPY( ML, A(J1,J), 1, DWORK(J1*2-1,J2), 2 ) - CALL DSCAL( ML, LAMBD2, DWORK(J1*2-1,J2), 2 ) - CALL DCOPY( ML, A(J1,J), 1, DWORK(J1*2,J2), 2 ) - CALL DSCAL( ML, LAMBD4, DWORK(J1*2,J2), 2 ) -C - DWORK(J2-1,J2-1) = DWORK(J2-1,J2-1) + ONE - DWORK(J2,J2) = DWORK(J2,J2) + ONE - 80 CONTINUE -C - IF ( LSAME( RC, 'R' ) ) THEN - TRANS = 'N' -C -C A is a lower Hessenberg matrix, row transformations. -C - DO 100 J = 1, M2 - 1 - MJ = M2 - J - IF ( MOD(J,2).EQ.1 .AND. J.LT.M2-2 ) THEN - IF ( DWORK(MJ-2,MJ+1).NE.ZERO ) THEN - CALL DLARTG( DWORK(MJ-1,MJ+1), DWORK(MJ-2,MJ+1), C, - $ S, R ) - DWORK(MJ-1,MJ+1) = R - DWORK(MJ-2,MJ+1) = ZERO - CALL DROT( MJ, DWORK(MJ-1,1), LDDWOR, - $ DWORK(MJ-2,1), LDDWOR, C, S ) - CALL DROT( 1, D(MJ-1), 1, D(MJ-2), 1, C, S ) - END IF - END IF - IF ( J.LT.M2-1 ) THEN - IF ( DWORK(MJ-1,MJ+1).NE.ZERO ) THEN - CALL DLARTG( DWORK(MJ,MJ+1), DWORK(MJ-1,MJ+1), C, - $ S, R ) - DWORK(MJ,MJ+1) = R - DWORK(MJ-1,MJ+1) = ZERO - CALL DROT( MJ, DWORK(MJ,1), LDDWOR, DWORK(MJ-1,1), - $ LDDWOR, C, S ) - CALL DROT( 1, D(MJ), 1, D(MJ-1), 1, C, S ) - END IF - END IF - IF ( DWORK(MJ,MJ+1).NE.ZERO ) THEN - CALL DLARTG( DWORK(MJ+1,MJ+1), DWORK(MJ,MJ+1), C, S, - $ R ) - DWORK(MJ+1,MJ+1) = R - DWORK(MJ,MJ+1) = ZERO - CALL DROT( MJ, DWORK(MJ+1,1), LDDWOR, DWORK(MJ,1), - $ LDDWOR, C, S) - CALL DROT( 1, D(MJ+1), 1, D(MJ), 1, C, S ) - END IF - 100 CONTINUE -C - ELSE - TRANS = 'T' -C -C A is a lower Hessenberg matrix, column transformations. -C - DO 120 J = 1, M2 - 1 - MJ = M2 - J - IF ( MOD(J,2).EQ.1 .AND. J.LT.M2-2 ) THEN - IF ( DWORK(J,J+3).NE.ZERO ) THEN - CALL DLARTG( DWORK(J,J+2), DWORK(J,J+3), C, S, R ) - DWORK(J,J+2) = R - DWORK(J,J+3) = ZERO - CALL DROT( MJ, DWORK(J+1,J+2), 1, DWORK(J+1,J+3), - $ 1, C, S ) - CALL DROT( 1, D(J+2), 1, D(J+3), 1, C, S ) - END IF - END IF - IF ( J.LT.M2-1 ) THEN - IF ( DWORK(J,J+2).NE.ZERO ) THEN - CALL DLARTG( DWORK(J,J+1), DWORK(J,J+2), C, S, R ) - DWORK(J,J+1) = R - DWORK(J,J+2) = ZERO - CALL DROT( MJ, DWORK(J+1,J+1), 1, DWORK(J+1,J+2), - $ 1, C, S ) - CALL DROT( 1, D(J+1), 1, D(J+2), 1, C, S ) - END IF - END IF - IF ( DWORK(J,J+1).NE.ZERO ) THEN - CALL DLARTG( DWORK(J,J), DWORK(J,J+1), C, S, R ) - DWORK(J,J) = R - DWORK(J,J+1) = ZERO - CALL DROT( MJ, DWORK(J+1,J), 1, DWORK(J+1,J+1), 1, C, - $ S ) - CALL DROT( 1, D(J), 1, D(J+1), 1, C, S ) - END IF - 120 CONTINUE -C - END IF - END IF -C - CALL DTRCON( '1-norm', UL, 'Non-unit', M2, DWORK, LDDWOR, RCOND, - $ DWORK(1,M2+1), IWORK, INFO ) - IF ( RCOND.LE.TOL ) THEN - INFO = 1 - ELSE - CALL DTRSV( UL, TRANS, 'Non-unit', M2, DWORK, LDDWOR, D, 1 ) - END IF -C - RETURN -C *** Last line of SB04RX *** - END diff --git a/mex/sources/libslicot/SB04RY.f b/mex/sources/libslicot/SB04RY.f deleted file mode 100644 index 2ea8fd91e..000000000 --- a/mex/sources/libslicot/SB04RY.f +++ /dev/null @@ -1,261 +0,0 @@ - SUBROUTINE SB04RY( RC, UL, M, A, LDA, LAMBDA, D, TOL, IWORK, - $ DWORK, LDDWOR, INFO ) -C -C SLICOT RELEASE 5.0. -C -C Copyright (c) 2002-2009 NICONET e.V. -C -C This program is free software: you can redistribute it and/or -C modify it under the terms of the GNU General Public License as -C published by the Free Software Foundation, either version 2 of -C the License, or (at your option) any later version. -C -C This program is distributed in the hope that it will be useful, -C but WITHOUT ANY WARRANTY; without even the implied warranty of -C MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the -C GNU General Public License for more details. -C -C You should have received a copy of the GNU General Public License -C along with this program. If not, see -C . -C -C PURPOSE -C -C To solve a system of equations in Hessenberg form with one -C right-hand side. -C -C ARGUMENTS -C -C Mode Parameters -C -C RC CHARACTER*1 -C Indicates processing by columns or rows, as follows: -C = 'R': Row transformations are applied; -C = 'C': Column transformations are applied. -C -C UL CHARACTER*1 -C Indicates whether A is upper or lower Hessenberg matrix, -C as follows: -C = 'U': A is upper Hessenberg; -C = 'L': A is lower Hessenberg. -C -C Input/Output Parameters -C -C M (input) INTEGER -C The order of the matrix A. M >= 0. -C -C A (input) DOUBLE PRECISION array, dimension (LDA,M) -C The leading M-by-M part of this array must contain a -C matrix A in Hessenberg form. -C -C LDA INTEGER -C The leading dimension of array A. LDA >= MAX(1,M). -C -C LAMBDA (input) DOUBLE PRECISION -C This variable must contain the value to be multiplied with -C the elements of A. -C -C D (input/output) DOUBLE PRECISION array, dimension (M) -C On entry, this array must contain the right-hand side -C vector of the Hessenberg system. -C On exit, if INFO = 0, this array contains the solution -C vector of the Hessenberg system. -C -C Tolerances -C -C TOL DOUBLE PRECISION -C The tolerance to be used to test for near singularity of -C the triangular factor R of the Hessenberg matrix. A matrix -C whose estimated condition number is less than 1/TOL is -C considered to be nonsingular. -C -C Workspace -C -C IWORK INTEGER array, dimension (M) -C -C DWORK DOUBLE PRECISION array, dimension (LDDWOR,M+3) -C The leading M-by-M part of this array is used for -C computing the triangular factor of the QR decomposition -C of the Hessenberg matrix. The remaining 3*M elements are -C used as workspace for the computation of the reciprocal -C condition estimate. -C -C LDDWOR INTEGER -C The leading dimension of array DWORK. LDDWOR >= MAX(1,M). -C -C Error Indicator -C -C INFO INTEGER -C = 0: successful exit; -C = 1: if the Hessenberg matrix is (numerically) singular. -C That is, its estimated reciprocal condition number -C is less than or equal to TOL. -C -C NUMERICAL ASPECTS -C -C None. -C -C CONTRIBUTORS -C -C D. Sima, University of Bucharest, May 2000. -C -C REVISIONS -C -C - -C -C Note that RC, UL, M, LDA, and LDDWOR must be such that the value -C of the LOGICAL variable OK in the following statement is true. -C -C OK = ( ( UL.EQ.'U' ) .OR. ( UL.EQ.'u' ) .OR. -C ( UL.EQ.'L' ) .OR. ( UL.EQ.'l' ) ) -C .AND. -C ( ( RC.EQ.'R' ) .OR. ( RC.EQ.'r' ) .OR. -C ( RC.EQ.'C' ) .OR. ( RC.EQ.'c' ) ) -C .AND. -C ( M.GE.0 ) -C .AND. -C ( LDA.GE.MAX( 1, M ) ) -C .AND. -C ( LDDWOR.GE.MAX( 1, M ) ) -C -C These conditions are not checked by the routine. -C -C KEYWORDS -C -C Hessenberg form, orthogonal transformation, real Schur form, -C Sylvester equation. -C -C ****************************************************************** -C - DOUBLE PRECISION ONE, ZERO - PARAMETER ( ONE = 1.0D0, ZERO = 0.0D0 ) -C .. Scalar Arguments .. - CHARACTER RC, UL - INTEGER INFO, LDA, LDDWOR, M - DOUBLE PRECISION LAMBDA, TOL -C .. Array Arguments .. - INTEGER IWORK(*) - DOUBLE PRECISION A(LDA,*), D(*), DWORK(LDDWOR,*) -C .. Local Scalars .. - CHARACTER TRANS - INTEGER J, J1, MJ - DOUBLE PRECISION C, R, RCOND, S -C .. External Functions .. - LOGICAL LSAME - EXTERNAL LSAME -C .. External Subroutines .. - EXTERNAL DCOPY, DLARTG, DROT, DSCAL, DTRCON, DTRSV -C .. Intrinsic Functions .. - INTRINSIC MAX, MIN -C .. Executable Statements .. -C - INFO = 0 -C -C For speed, no tests on the input scalar arguments are made. -C Quick return if possible. -C - IF ( M.EQ.0 ) - $ RETURN -C - IF ( LSAME( UL, 'U' ) ) THEN -C - DO 20 J = 1, M - CALL DCOPY( MIN( J+1, M ), A(1,J), 1, DWORK(1,J), 1 ) - CALL DSCAL( MIN( J+1, M ), LAMBDA, DWORK(1,J), 1 ) - DWORK(J,J) = DWORK(J,J) + ONE - 20 CONTINUE -C - IF ( LSAME( RC, 'R' ) ) THEN - TRANS = 'N' -C -C A is an upper Hessenberg matrix, row transformations. -C - DO 40 J = 1, M - 1 - MJ = M - J - IF ( DWORK(J+1,J).NE.ZERO ) THEN - CALL DLARTG( DWORK(J,J), DWORK(J+1,J), C, S, R ) - DWORK(J,J) = R - DWORK(J+1,J) = ZERO - CALL DROT( MJ, DWORK(J,J+1), LDDWOR, DWORK(J+1,J+1), - $ LDDWOR, C, S ) - CALL DROT( 1, D(J), 1, D(J+1), 1, C, S ) - END IF - 40 CONTINUE -C - ELSE - TRANS = 'T' -C -C A is an upper Hessenberg matrix, column transformations. -C - DO 60 J = 1, M - 1 - MJ = M - J - IF ( DWORK(MJ+1,MJ).NE.ZERO ) THEN - CALL DLARTG( DWORK(MJ+1,MJ+1), DWORK(MJ+1,MJ), C, S, - $ R ) - DWORK(MJ+1,MJ+1) = R - DWORK(MJ+1,MJ) = ZERO - CALL DROT( MJ, DWORK(1,MJ+1), 1, DWORK(1,MJ), 1, C, - $ S ) - CALL DROT( 1, D(MJ+1), 1, D(MJ), 1, C, S ) - END IF - 60 CONTINUE -C - END IF - ELSE -C - DO 80 J = 1, M - J1 = MAX( J - 1, 1 ) - CALL DCOPY( M-J1+1, A(J1,J), 1, DWORK(J1,J), 1 ) - CALL DSCAL( M-J1+1, LAMBDA, DWORK(J1,J), 1 ) - DWORK(J,J) = DWORK(J,J) + ONE - 80 CONTINUE -C - IF ( LSAME( RC, 'R' ) ) THEN - TRANS = 'N' -C -C A is a lower Hessenberg matrix, row transformations. -C - DO 100 J = 1, M - 1 - MJ = M - J - IF ( DWORK(MJ,MJ+1).NE.ZERO ) THEN - CALL DLARTG( DWORK(MJ+1,MJ+1), DWORK(MJ,MJ+1), C, S, - $ R ) - DWORK(MJ+1,MJ+1) = R - DWORK(MJ,MJ+1) = ZERO - CALL DROT( MJ, DWORK(MJ+1,1), LDDWOR, DWORK(MJ,1), - $ LDDWOR, C, S ) - CALL DROT( 1, D(MJ+1), 1, D(MJ), 1, C, S ) - END IF - 100 CONTINUE -C - ELSE - TRANS = 'T' -C -C A is a lower Hessenberg matrix, column transformations. -C - DO 120 J = 1, M - 1 - MJ = M - J - IF ( DWORK(J,J+1).NE.ZERO ) THEN - CALL DLARTG( DWORK(J,J), DWORK(J,J+1), C, S, R ) - DWORK(J,J) = R - DWORK(J,J+1) = ZERO - CALL DROT( MJ, DWORK(J+1,J), 1, DWORK(J+1,J+1), 1, C, - $ S ) - CALL DROT( 1, D(J), 1, D(J+1), 1, C, S ) - END IF - 120 CONTINUE -C - END IF - END IF -C - CALL DTRCON( '1-norm', UL, 'Non-unit', M, DWORK, LDDWOR, RCOND, - $ DWORK(1,M+1), IWORK, INFO ) - IF ( RCOND.LE.TOL ) THEN - INFO = 1 - ELSE - CALL DTRSV( UL, TRANS, 'Non-unit', M, DWORK, LDDWOR, D, 1 ) - END IF -C - RETURN -C *** Last line of SB04RY *** - END diff --git a/mex/sources/libslicot/SB06ND.f b/mex/sources/libslicot/SB06ND.f deleted file mode 100644 index 3ea986376..000000000 --- a/mex/sources/libslicot/SB06ND.f +++ /dev/null @@ -1,325 +0,0 @@ - SUBROUTINE SB06ND( N, M, KMAX, A, LDA, B, LDB, KSTAIR, U, LDU, F, - $ LDF, DWORK, INFO ) -C -C SLICOT RELEASE 5.0. -C -C Copyright (c) 2002-2009 NICONET e.V. -C -C This program is free software: you can redistribute it and/or -C modify it under the terms of the GNU General Public License as -C published by the Free Software Foundation, either version 2 of -C the License, or (at your option) any later version. -C -C This program is distributed in the hope that it will be useful, -C but WITHOUT ANY WARRANTY; without even the implied warranty of -C MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the -C GNU General Public License for more details. -C -C You should have received a copy of the GNU General Public License -C along with this program. If not, see -C . -C -C PURPOSE -C -C To construct the minimum norm feedback matrix F to perform -C "deadbeat control" on a (A,B)-pair of a state-space model (which -C must be preliminarily reduced to upper "staircase" form using -C SLICOT Library routine AB01OD) such that the matrix R = A + BFU' -C is nilpotent. -C (The transformation matrix U reduces R to upper Schur form with -C zero blocks on its diagonal (of dimension KSTAIR(i)) and -C therefore contains bases for the i-th controllable subspaces, -C where i = 1,...,KMAX). -C -C ARGUMENTS -C -C Input/Output Parameters -C -C N (input) INTEGER -C The actual state dimension, i.e. the order of the -C matrix A. N >= 0. -C -C M (input) INTEGER -C The actual input dimension. M >= 0. -C -C KMAX (input) INTEGER -C The number of "stairs" in the staircase form as produced -C by SLICOT Library routine AB01OD. 0 <= KMAX <= N. -C -C A (input/output) DOUBLE PRECISION array, dimension (LDA,N) -C On entry, the leading N-by-N part of this array must -C contain the transformed state-space matrix of the -C (A,B)-pair with triangular stairs, as produced by SLICOT -C Library routine AB01OD (with option STAGES = 'A'). -C On exit, the leading N-by-N part of this array contains -C the matrix U'AU + U'BF. -C -C LDA INTEGER -C The leading dimension of array A. LDA >= MAX(1,N). -C -C B (input/output) DOUBLE PRECISION array, dimension (LDB,M) -C On entry, the leading N-by-M part of this array must -C contain the transformed triangular input matrix of the -C (A,B)-pair as produced by SLICOT Library routine AB01OD -C (with option STAGES = 'A'). -C On exit, the leading N-by-M part of this array contains -C the matrix U'B. -C -C LDB INTEGER -C The leading dimension of array B. LDB >= MAX(1,N). -C -C KSTAIR (input) INTEGER array, dimension (KMAX) -C The leading KMAX elements of this array must contain the -C dimensions of each "stair" as produced by SLICOT Library -C routine AB01OD. -C -C U (input/output) DOUBLE PRECISION array, dimension (LDU,N) -C On entry, the leading N-by-N part of this array must -C contain either a transformation matrix (e.g. from a -C previous call to other SLICOT routine) or be initialised -C as the identity matrix. -C On exit, the leading N-by-N part of this array contains -C the product of the input matrix U and the state-space -C transformation matrix which reduces A + BFU' to real -C Schur form. -C -C LDU INTEGER -C The leading dimension of array U. LDU >= MAX(1,N). -C -C F (output) DOUBLE PRECISION array, dimension (LDF,N) -C The leading M-by-N part of this array contains the -C deadbeat feedback matrix F. -C -C LDF INTEGER -C The leading dimension of array F. LDF >= MAX(1,M). -C -C Workspace -C -C DWORK DOUBLE PRECISION array, dimension (2*N) -C -C Error Indicator -C -C INFO INTEGER -C = 0: successful exit; -C < 0: if INFO = -i, the i-th argument had an illegal -C value. -C -C METHOD -C -C Starting from the (A,B)-pair in "staircase form" with "triangular" -C stairs, dimensions KSTAIR(i+1) x KSTAIR(i), (described by the -C vector KSTAIR): -C -C | B | A * . . . * | -C | 1| 11 . . | -C | | A A . . | -C | | 21 22 . . | -C | | . . . | -C [ B | A ] = | | . . * | -C | | . . | -C | 0 | 0 | -C | | A A | -C | | r,r-1 rr | -C -C where the i-th diagonal block of A has dimension KSTAIR(i), for -C i = 1,2,...,r, the feedback matrix F is constructed recursively in -C r steps (where the number of "stairs" r is given by KMAX). In each -C step a unitary state-space transformation U and a part of F are -C updated in order to achieve the final form: -C -C | 0 A * . . . * | -C | 12 . . | -C | . . | -C | 0 A . . | -C | 23 . . | -C | . . | -C [ U'AU + U'BF ] = | . . * | . -C | . . | -C | | -C | A | -C | r-1,r| -C | | -C | 0 | -C -C -C REFERENCES -C -C [1] Van Dooren, P. -C Deadbeat control: a special inverse eigenvalue problem. -C BIT, 24, pp. 681-699, 1984. -C -C NUMERICAL ASPECTS -C -C The algorithm requires O((N + M) * N**2) operations and is mixed -C numerical stable (see [1]). -C -C CONTRIBUTORS -C -C Release 3.0: V. Sima, Katholieke Univ. Leuven, Belgium, Sep. 1997. -C Supersedes Release 2.0 routine SB06BD by M. Vanbegin, and -C P. Van Dooren, Philips Research Laboratory, Brussels, Belgium. -C -C REVISIONS -C -C 1997, December 10; 2003, September 27. -C -C KEYWORDS -C -C Canonical form, deadbeat control, eigenvalue assignment, feedback -C control, orthogonal transformation, real Schur form, staircase -C form. -C -C ****************************************************************** -C -C .. Parameters .. - DOUBLE PRECISION ZERO, ONE - PARAMETER ( ZERO = 0.0D0, ONE = 1.0D0 ) -C .. Scalar Arguments .. - INTEGER INFO, KMAX, LDA, LDB, LDF, LDU, M, N -C .. Array Arguments .. - INTEGER KSTAIR(*) - DOUBLE PRECISION A(LDA,*), B(LDB,*), DWORK(*), F(LDF,*), U(LDU,*) -C .. Local Scalars .. - INTEGER J, J0, JCUR, JKCUR, JMKCUR, KCUR, KK, KMIN, - $ KSTEP, MKCUR, NCONT -C .. External Subroutines .. - EXTERNAL DCOPY, DGEMM, DLACPY, DLARFG, DLASET, DLATZM, - $ DTRSM, XERBLA -C .. Executable Statements .. -C - INFO = 0 -C -C Test the input scalar arguments. -C - IF( N.LT.0 ) THEN - INFO = -1 - ELSE IF( M.LT.0 ) THEN - INFO = -2 - ELSE IF( KMAX.LT.0 .OR. KMAX.GT.N ) THEN - INFO = -3 - ELSE IF( LDA.LT.MAX( 1, N ) ) THEN - INFO = -5 - ELSE IF( LDB.LT.MAX( 1, N ) ) THEN - INFO = -7 - ELSE IF( LDU.LT.MAX( 1, N ) ) THEN - INFO = -10 - ELSE IF( LDF.LT.MAX( 1, M ) ) THEN - INFO = -12 - ELSE - NCONT = 0 -C - DO 10 KK = 1, KMAX - NCONT = NCONT + KSTAIR(KK) - 10 CONTINUE -C - IF( NCONT.GT.N ) - $ INFO = -8 - END IF -C - IF ( INFO.NE.0 ) THEN -C -C Error return. -C - CALL XERBLA( 'SB06ND', -INFO ) - RETURN - END IF -C -C Quick return if possible. -C - IF ( N.EQ.0 .OR. M.EQ.0 ) - $ RETURN -C - DO 120 KMIN = 1, KMAX - JCUR = NCONT - KSTEP = KMAX - KMIN -C -C Triangularize bottom part of A (if KSTEP > 0). -C - DO 40 KK = KMAX, KMAX - KSTEP + 1, -1 - KCUR = KSTAIR(KK) -C -C Construct Ukk and store in Fkk. -C - DO 20 J = 1, KCUR - JMKCUR = JCUR - KCUR - CALL DCOPY( KCUR, A(JCUR,JMKCUR), LDA, F(1,JCUR), 1 ) - CALL DLARFG( KCUR+1, A(JCUR,JCUR), F(1,JCUR), 1, - $ DWORK(JCUR) ) - CALL DLASET( 'Full', 1, KCUR, ZERO, ZERO, A(JCUR,JMKCUR), - $ LDA ) -C -C Backmultiply A and U with Ukk. -C - CALL DLATZM( 'Right', JCUR-1, KCUR+1, F(1,JCUR), 1, - $ DWORK(JCUR), A(1,JCUR), A(1,JMKCUR), LDA, - $ DWORK ) -C - CALL DLATZM( 'Right', N, KCUR+1, F(1,JCUR), 1, - $ DWORK(JCUR), U(1,JCUR), U(1,JMKCUR), LDU, - $ DWORK(N+1) ) - JCUR = JCUR - 1 - 20 CONTINUE -C - 40 CONTINUE -C -C Eliminate diagonal block Aii by feedback Fi. -C - KCUR = KSTAIR(KMIN) - J0 = JCUR - KCUR + 1 - MKCUR = M - KCUR + 1 -C -C Solve for Fi and add B x Fi to A. -C - CALL DLACPY( 'Full', KCUR, KCUR, A(J0,J0), LDA, F(MKCUR,J0), - $ LDF ) - CALL DTRSM( 'Left', 'Upper', 'No transpose', 'Non-unit', KCUR, - $ KCUR, -ONE, B(J0,MKCUR), LDB, F(MKCUR,J0), LDF ) - IF ( J0.GT.1 ) - $ CALL DGEMM( 'No transpose', 'No transpose', J0-1, KCUR, - $ KCUR, ONE, B(1,MKCUR), LDB, F(MKCUR,J0), LDF, - $ ONE, A(1,J0), LDA ) - CALL DLASET( 'Full', KCUR, KCUR, ZERO, ZERO, A(J0,J0), LDA ) - CALL DLASET( 'Full', M-KCUR, KCUR, ZERO, ZERO, F(1,J0), LDF ) -C - IF ( KSTEP.NE.0 ) THEN - JKCUR = NCONT -C -C Premultiply A with Ukk. -C - DO 80 KK = KMAX, KMAX - KSTEP + 1, -1 - KCUR = KSTAIR(KK) - JCUR = JKCUR - KCUR -C - DO 60 J = 1, KCUR - CALL DLATZM( 'Left', KCUR+1, N-JCUR+1, F(1,JKCUR), 1, - $ DWORK(JKCUR), A(JKCUR,JCUR), - $ A(JCUR,JCUR), LDA, DWORK(N+1) ) - JCUR = JCUR - 1 - JKCUR = JKCUR - 1 - 60 CONTINUE -C - 80 CONTINUE -C -C Premultiply B with Ukk. -C - JCUR = JCUR + KCUR - JKCUR = JCUR + KCUR -C - DO 100 J = M, M - KCUR + 1, -1 - CALL DLATZM( 'Left', KCUR+1, M-J+1, F(1,JKCUR), 1, - $ DWORK(JKCUR), B(JKCUR,J), B(JCUR,J), LDB, - $ DWORK(N+1) ) - JCUR = JCUR - 1 - JKCUR = JKCUR - 1 - 100 CONTINUE -C - END IF - 120 CONTINUE -C - IF ( NCONT.NE.N ) - $ CALL DLASET( 'Full', M, N-NCONT, ZERO, ZERO, F(1,NCONT+1), - $ LDF ) -C - RETURN -C *** Last line of SB06ND *** - END diff --git a/mex/sources/libslicot/SB08CD.f b/mex/sources/libslicot/SB08CD.f deleted file mode 100644 index ed703beb5..000000000 --- a/mex/sources/libslicot/SB08CD.f +++ /dev/null @@ -1,355 +0,0 @@ - SUBROUTINE SB08CD( DICO, N, M, P, A, LDA, B, LDB, C, LDC, D, LDD, - $ NQ, NR, BR, LDBR, DR, LDDR, TOL, DWORK, LDWORK, - $ IWARN, INFO ) -C -C SLICOT RELEASE 5.0. -C -C Copyright (c) 2002-2009 NICONET e.V. -C -C This program is free software: you can redistribute it and/or -C modify it under the terms of the GNU General Public License as -C published by the Free Software Foundation, either version 2 of -C the License, or (at your option) any later version. -C -C This program is distributed in the hope that it will be useful, -C but WITHOUT ANY WARRANTY; without even the implied warranty of -C MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the -C GNU General Public License for more details. -C -C You should have received a copy of the GNU General Public License -C along with this program. If not, see -C . -C -C PURPOSE -C -C To construct, for a given system G = (A,B,C,D), an output -C injection matrix H, an orthogonal transformation matrix Z, and a -C gain matrix V, such that the systems -C -C Q = (Z'*(A+H*C)*Z, Z'*(B+H*D), V*C*Z, V*D) -C and -C R = (Z'*(A+H*C)*Z, Z'*H, V*C*Z, V) -C -C provide a stable left coprime factorization of G in the form -C -1 -C G = R * Q, -C -C where G, Q and R are the corresponding transfer-function matrices -C and the denominator R is co-inner, that is, R(s)*R'(-s) = I in -C the continuous-time case, or R(z)*R'(1/z) = I in the discrete-time -C case. The Z matrix is not explicitly computed. -C -C Note: G must have no observable poles on the imaginary axis -C for a continuous-time system, or on the unit circle for a -C discrete-time system. If the given state-space representation -C is not detectable, the undetectable part of the original -C system is automatically deflated and the order of the systems -C Q and R is accordingly reduced. -C -C ARGUMENTS -C -C Mode Parameters -C -C DICO CHARACTER*1 -C Specifies the type of the original system as follows: -C = 'C': continuous-time system; -C = 'D': discrete-time system. -C -C Input/Output Parameters -C -C N (input) INTEGER -C The dimension of the state vector, i.e. the order of the -C matrix A, and also the number of rows of the matrices B -C and BR, and the number of columns of the matrix C. -C N >= 0. -C -C M (input) INTEGER -C The dimension of input vector, i.e. the number of columns -C of the matrices B and D. M >= 0. -C -C P (input) INTEGER -C The dimension of output vector, i.e. the number of rows -C of the matrices C, D and DR, and the number of columns -C of the matrices BR and DR. P >= 0. -C -C A (input/output) DOUBLE PRECISION array, dimension (LDA,N) -C On entry, the leading N-by-N part of this array must -C contain the state dynamics matrix A. The matrix A must not -C have observable eigenvalues on the imaginary axis, if -C DICO = 'C', or on the unit circle, if DICO = 'D'. -C On exit, the leading NQ-by-NQ part of this array contains -C the leading NQ-by-NQ part of the matrix Z'*(A+H*C)*Z, the -C state dynamics matrix of the numerator factor Q, in a -C real Schur form. The leading NR-by-NR part of this matrix -C represents the state dynamics matrix of a minimal -C realization of the denominator factor R. -C -C LDA INTEGER -C The leading dimension of array A. LDA >= MAX(1,N). -C -C B (input/output) DOUBLE PRECISION array, dimension -C (LDB,MAX(M,P)) -C On entry, the leading N-by-M part of this array must -C contain the input/state matrix. -C On exit, the leading NQ-by-M part of this array contains -C the leading NQ-by-M part of the matrix Z'*(B+H*D), the -C input/state matrix of the numerator factor Q. -C The remaining part of this array is needed as workspace. -C -C LDB INTEGER -C The leading dimension of array B. LDB >= MAX(1,N). -C -C C (input/output) DOUBLE PRECISION array, dimension (LDC,N) -C On entry, the leading P-by-N part of this array must -C contain the state/output matrix C. -C On exit, the leading P-by-NQ part of this array contains -C the leading P-by-NQ part of the matrix V*C*Z, the -C state/output matrix of the numerator factor Q. -C The first NR columns of this array represent the -C state/output matrix of a minimal realization of the -C denominator factor R. -C The remaining part of this array is needed as workspace. -C -C LDC INTEGER -C The leading dimension of array C. -C LDC >= MAX(1,M,P), if N > 0. -C LDC >= 1, if N = 0. -C -C D (input/output) DOUBLE PRECISION array, dimension -C (LDD,MAX(M,P)) -C On entry, the leading P-by-M part of this array must -C contain the input/output matrix. -C On exit, the leading P-by-M part of this array contains -C the matrix V*D representing the input/output matrix -C of the numerator factor Q. -C The remaining part of this array is needed as workspace. -C -C LDD INTEGER -C The leading dimension of array D. LDD >= MAX(1,M,P). -C -C NQ (output) INTEGER -C The order of the resulting factors Q and R. -C Generally, NQ = N - NS, where NS is the number of -C unobservable eigenvalues outside the stability region. -C -C NR (output) INTEGER -C The order of the minimal realization of the factor R. -C Generally, NR is the number of observable eigenvalues -C of A outside the stability region (the number of modified -C eigenvalues). -C -C BR (output) DOUBLE PRECISION array, dimension (LDBR,P) -C The leading NQ-by-P part of this array contains the -C leading NQ-by-P part of the output injection matrix -C Z'*H, which reflects the eigenvalues of A lying outside -C the stable region to values which are symmetric with -C respect to the imaginary axis (if DICO = 'C') or the unit -C circle (if DICO = 'D'). The first NR rows of this matrix -C form the input/state matrix of a minimal realization of -C the denominator factor R. -C -C LDBR INTEGER -C The leading dimension of array BR. LDBR >= MAX(1,N). -C -C DR (output) DOUBLE PRECISION array, dimension (LDDR,P) -C The leading P-by-P part of this array contains the lower -C triangular matrix V representing the input/output matrix -C of the denominator factor R. -C -C LDDR INTEGER -C The leading dimension of array DR. LDDR >= MAX(1,P). -C -C Tolerances -C -C TOL DOUBLE PRECISION -C The absolute tolerance level below which the elements of -C C are considered zero (used for observability tests). -C If the user sets TOL <= 0, then an implicitly computed, -C default tolerance, defined by TOLDEF = N*EPS*NORM(C), -C is used instead, where EPS is the machine precision -C (see LAPACK Library routine DLAMCH) and NORM(C) denotes -C the infinity-norm of C. -C -C Workspace -C -C DWORK DOUBLE PRECISION array, dimension (LDWORK) -C On exit, if INFO = 0, DWORK(1) returns the optimal value -C of LDWORK. -C -C LDWORK INTEGER -C The dimension of working array DWORK. -C LDWORK >= MAX( 1, P*N + MAX( N*(N+5),P*(P+2),4*P,4*M ) ). -C For optimum performance LDWORK should be larger. -C -C Warning Indicator -C -C IWARN INTEGER -C = 0: no warning; -C = K: K violations of the numerical stability condition -C NORM(H) <= 10*NORM(A)/NORM(C) occured during the -C assignment of eigenvalues. -C -C Error Indicator -C -C INFO INTEGER -C = 0: successful exit; -C < 0: if INFO = -i, the i-th argument had an illegal -C value; -C = 1: the reduction of A to a real Schur form failed; -C = 2: a failure was detected during the ordering of the -C real Schur form of A, or in the iterative process -C for reordering the eigenvalues of Z'*(A + H*C)*Z -C along the diagonal; -C = 3: if DICO = 'C' and the matrix A has an observable -C eigenvalue on the imaginary axis, or DICO = 'D' and -C A has an observable eigenvalue on the unit circle. -C -C METHOD -C -C The subroutine uses the right coprime factorization algorithm with -C inner denominator of [1] applied to G'. -C -C REFERENCES -C -C [1] Varga A. -C A Schur method for computing coprime factorizations with -C inner denominators and applications in model reduction. -C Proc. ACC'93, San Francisco, CA, pp. 2130-2131, 1993. -C -C NUMERICAL ASPECTS -C 3 -C The algorithm requires no more than 14N floating point -C operations. -C -C CONTRIBUTOR -C -C A. Varga, German Aerospace Center, -C DLR Oberpfaffenhofen, July 1998. -C Based on the RASP routine LCFID. -C -C REVISIONS -C -C Nov. 1998, V. Sima, Research Institute for Informatics, Bucharest. -C Dec. 1998, V. Sima, Katholieke Univ. Leuven, Leuven. -C May 2003, A. Varga, DLR Oberpfaffenhofen. -C Nov 2003, A. Varga, DLR Oberpfaffenhofen. -C -C KEYWORDS -C -C Coprime factorization, eigenvalue, eigenvalue assignment, -C feedback control, pole placement, state-space model. -C -C ****************************************************************** -C -C .. Parameters .. - DOUBLE PRECISION ONE, ZERO - PARAMETER ( ONE = 1.0D0, ZERO = 0.0D0 ) -C .. Scalar Arguments .. - CHARACTER DICO - INTEGER INFO, IWARN, LDA, LDB, LDBR, LDC, LDD, LDDR, - $ LDWORK, M, N, NQ, NR, P - DOUBLE PRECISION TOL -C .. Array Arguments .. - DOUBLE PRECISION A(LDA,*), B(LDB,*), BR(LDBR,*), C(LDC,*), - $ D(LDD,*), DR(LDDR,*), DWORK(*) -C .. Local Scalars .. - INTEGER I, KBR, KW -C .. External Functions .. - LOGICAL LSAME - EXTERNAL LSAME -C .. External subroutines .. - EXTERNAL AB07MD, DLASET, DSWAP, MA02AD, MA02BD, SB08DD, - $ TB01XD, XERBLA -C .. Intrinsic Functions .. - INTRINSIC DBLE, MAX, MIN -C .. Executable Statements .. -C - IWARN = 0 - INFO = 0 -C -C Check the scalar input parameters. -C - IF( .NOT.LSAME( DICO, 'C' ) .AND. - $ .NOT.LSAME( DICO, 'D' ) ) THEN - INFO = -1 - ELSE IF( N.LT.0 ) THEN - INFO = -2 - ELSE IF( M.LT.0 ) THEN - INFO = -3 - ELSE IF( P.LT.0 ) THEN - INFO = -4 - ELSE IF( LDA.LT.MAX( 1, N ) ) THEN - INFO = -6 - ELSE IF( LDB.LT.MAX( 1, N ) ) THEN - INFO = -8 - ELSE IF( LDC.LT.1 .OR. ( N.GT.0 .AND. LDC.LT.MAX( M, P ) ) ) - $ THEN - INFO = -10 - ELSE IF( LDD.LT.MAX( 1, M, P ) ) THEN - INFO = -12 - ELSE IF( LDBR.LT.MAX( 1, N ) ) THEN - INFO = -16 - ELSE IF( LDDR.LT.MAX( 1, P ) ) THEN - INFO = -18 - ELSE IF( LDWORK.LT.MAX( 1, P*N + MAX( N*(N+5), P*(P+2), 4*P, - $ 4*M ) ) ) THEN - INFO = -21 - END IF - IF( INFO.NE.0 )THEN -C -C Error return. -C - CALL XERBLA( 'SB08CD', -INFO ) - RETURN - END IF -C -C Quick return if possible. -C - IF( MIN( N, P ).EQ.0 ) THEN - NQ = 0 - NR = 0 - DWORK(1) = ONE - CALL DLASET( 'Full', P, P, ZERO, ONE, DR, LDDR ) - RETURN - END IF -C -C Compute the dual system G' = (A',C',B',D'). -C - CALL AB07MD( 'D', N, M, P, A, LDA, B, LDB, C, LDC, D, LDD, - $ INFO ) -C -C Compute the right coprime factorization with inner -C denominator of G'. -C -C Workspace needed: P*N; -C Additional workspace: need MAX( N*(N+5), P*(P+2), 4*P, 4*M ); -C prefer larger. -C - KBR = 1 - KW = KBR + P*N - CALL SB08DD( DICO, N, P, M, A, LDA, B, LDB, C, LDC, D, LDD, - $ NQ, NR, DWORK(KBR), P, DR, LDDR, TOL, DWORK(KW), - $ LDWORK-KW+1, IWARN, INFO ) - IF( INFO.EQ.0 ) THEN -C -C Determine the elements of the left coprime factorization from -C those of the computed right coprime factorization and make the -C state-matrix upper real Schur. -C - CALL TB01XD( 'D', NQ, P, M, MAX( 0, NQ-1 ), MAX( 0, NQ-1 ), - $ A, LDA, B, LDB, C, LDC, D, LDD, INFO ) -C - CALL MA02AD( 'Full', P, NQ, DWORK(KBR), P, BR, LDBR ) - CALL MA02BD( 'Left', NQ, P, BR, LDBR ) -C - DO 10 I = 2, P - CALL DSWAP( I-1, DR(I,1), LDDR, DR(1,I), 1 ) - 10 CONTINUE -C - END IF -C - DWORK(1) = DWORK(KW) + DBLE( KW-1 ) -C - RETURN -C *** Last line of SB08CD *** - END diff --git a/mex/sources/libslicot/SB08DD.f b/mex/sources/libslicot/SB08DD.f deleted file mode 100644 index e88c9028d..000000000 --- a/mex/sources/libslicot/SB08DD.f +++ /dev/null @@ -1,583 +0,0 @@ - SUBROUTINE SB08DD( DICO, N, M, P, A, LDA, B, LDB, C, LDC, D, LDD, - $ NQ, NR, CR, LDCR, DR, LDDR, TOL, DWORK, LDWORK, - $ IWARN, INFO ) -C -C SLICOT RELEASE 5.0. -C -C Copyright (c) 2002-2009 NICONET e.V. -C -C This program is free software: you can redistribute it and/or -C modify it under the terms of the GNU General Public License as -C published by the Free Software Foundation, either version 2 of -C the License, or (at your option) any later version. -C -C This program is distributed in the hope that it will be useful, -C but WITHOUT ANY WARRANTY; without even the implied warranty of -C MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the -C GNU General Public License for more details. -C -C You should have received a copy of the GNU General Public License -C along with this program. If not, see -C . -C -C PURPOSE -C -C To construct, for a given system G = (A,B,C,D), a feedback matrix -C F, an orthogonal transformation matrix Z, and a gain matrix V, -C such that the systems -C -C Q = (Z'*(A+B*F)*Z, Z'*B*V, (C+D*F)*Z, D*V) -C and -C R = (Z'*(A+B*F)*Z, Z'*B*V, F*Z, V) -C -C provide a stable right coprime factorization of G in the form -C -1 -C G = Q * R , -C -C where G, Q and R are the corresponding transfer-function matrices -C and the denominator R is inner, that is, R'(-s)*R(s) = I in the -C continuous-time case, or R'(1/z)*R(z) = I in the discrete-time -C case. The Z matrix is not explicitly computed. -C -C Note: G must have no controllable poles on the imaginary axis -C for a continuous-time system, or on the unit circle for a -C discrete-time system. If the given state-space representation -C is not stabilizable, the unstabilizable part of the original -C system is automatically deflated and the order of the systems -C Q and R is accordingly reduced. -C -C ARGUMENTS -C -C Mode Parameters -C -C DICO CHARACTER*1 -C Specifies the type of the original system as follows: -C = 'C': continuous-time system; -C = 'D': discrete-time system. -C -C Input/Output Parameters -C -C N (input) INTEGER -C The dimension of the state vector, i.e. the order of the -C matrix A, and also the number of rows of the matrix B and -C the number of columns of the matrices C and CR. N >= 0. -C -C M (input) INTEGER -C The dimension of input vector, i.e. the number of columns -C of the matrices B, D and DR and the number of rows of the -C matrices CR and DR. M >= 0. -C -C P (input) INTEGER -C The dimension of output vector, i.e. the number of rows -C of the matrices C and D. P >= 0. -C -C A (input/output) DOUBLE PRECISION array, dimension (LDA,N) -C On entry, the leading N-by-N part of this array must -C contain the state dynamics matrix A. The matrix A must not -C have controllable eigenvalues on the imaginary axis, if -C DICO = 'C', or on the unit circle, if DICO = 'D'. -C On exit, the leading NQ-by-NQ part of this array contains -C the leading NQ-by-NQ part of the matrix Z'*(A+B*F)*Z, the -C state dynamics matrix of the numerator factor Q, in a -C real Schur form. The trailing NR-by-NR part of this matrix -C represents the state dynamics matrix of a minimal -C realization of the denominator factor R. -C -C LDA INTEGER -C The leading dimension of array A. LDA >= MAX(1,N). -C -C B (input/output) DOUBLE PRECISION array, dimension (LDB,M) -C On entry, the leading N-by-M part of this array must -C contain the input/state matrix. -C On exit, the leading NQ-by-M part of this array contains -C the leading NQ-by-M part of the matrix Z'*B*V, the -C input/state matrix of the numerator factor Q. The last -C NR rows of this matrix form the input/state matrix of -C a minimal realization of the denominator factor R. -C -C LDB INTEGER -C The leading dimension of array B. LDB >= MAX(1,N). -C -C C (input/output) DOUBLE PRECISION array, dimension (LDC,N) -C On entry, the leading P-by-N part of this array must -C contain the state/output matrix C. -C On exit, the leading P-by-NQ part of this array contains -C the leading P-by-NQ part of the matrix (C+D*F)*Z, -C the state/output matrix of the numerator factor Q. -C -C LDC INTEGER -C The leading dimension of array C. LDC >= MAX(1,P). -C -C D (input/output) DOUBLE PRECISION array, dimension (LDD,M) -C On entry, the leading P-by-M part of this array must -C contain the input/output matrix. -C On exit, the leading P-by-M part of this array contains -C the matrix D*V representing the input/output matrix -C of the numerator factor Q. -C -C LDD INTEGER -C The leading dimension of array D. LDD >= MAX(1,P). -C -C NQ (output) INTEGER -C The order of the resulting factors Q and R. -C Generally, NQ = N - NS, where NS is the number of -C uncontrollable eigenvalues outside the stability region. -C -C NR (output) INTEGER -C The order of the minimal realization of the factor R. -C Generally, NR is the number of controllable eigenvalues -C of A outside the stability region (the number of modified -C eigenvalues). -C -C CR (output) DOUBLE PRECISION array, dimension (LDCR,N) -C The leading M-by-NQ part of this array contains the -C leading M-by-NQ part of the feedback matrix F*Z, which -C reflects the eigenvalues of A lying outside the stable -C region to values which are symmetric with respect to the -C imaginary axis (if DICO = 'C') or the unit circle (if -C DICO = 'D'). The last NR columns of this matrix form the -C state/output matrix of a minimal realization of the -C denominator factor R. -C -C LDCR INTEGER -C The leading dimension of array CR. LDCR >= MAX(1,M). -C -C DR (output) DOUBLE PRECISION array, dimension (LDDR,M) -C The leading M-by-M part of this array contains the upper -C triangular matrix V of order M representing the -C input/output matrix of the denominator factor R. -C -C LDDR INTEGER -C The leading dimension of array DR. LDDR >= MAX(1,M). -C -C Tolerances -C -C TOL DOUBLE PRECISION -C The absolute tolerance level below which the elements of -C B are considered zero (used for controllability tests). -C If the user sets TOL <= 0, then an implicitly computed, -C default tolerance, defined by TOLDEF = N*EPS*NORM(B), -C is used instead, where EPS is the machine precision -C (see LAPACK Library routine DLAMCH) and NORM(B) denotes -C the 1-norm of B. -C -C Workspace -C -C DWORK DOUBLE PRECISION array, dimension (LDWORK) -C On exit, if INFO = 0, DWORK(1) returns the optimal value -C of LDWORK. -C -C LDWORK INTEGER -C The dimension of working array DWORK. -C LDWORK >= MAX( 1, N*(N+5), M*(M+2), 4*M, 4*P ). -C For optimum performance LDWORK should be larger. -C -C Warning Indicator -C -C IWARN INTEGER -C = 0: no warning; -C = K: K violations of the numerical stability condition -C NORM(F) <= 10*NORM(A)/NORM(B) occured during the -C assignment of eigenvalues. -C -C Error Indicator -C -C INFO INTEGER -C = 0: successful exit; -C < 0: if INFO = -i, the i-th argument had an illegal -C value; -C = 1: the reduction of A to a real Schur form failed; -C = 2: a failure was detected during the ordering of the -C real Schur form of A, or in the iterative process -C for reordering the eigenvalues of Z'*(A + B*F)*Z -C along the diagonal; -C = 3: if DICO = 'C' and the matrix A has a controllable -C eigenvalue on the imaginary axis, or DICO = 'D' -C and A has a controllable eigenvalue on the unit -C circle. -C -C METHOD -C -C The subroutine is based on the factorization algorithm of [1]. -C -C REFERENCES -C -C [1] Varga A. -C A Schur method for computing coprime factorizations with inner -C denominators and applications in model reduction. -C Proc. ACC'93, San Francisco, CA, pp. 2130-2131, 1993. -C -C NUMERICAL ASPECTS -C 3 -C The algorithm requires no more than 14N floating point -C operations. -C -C CONTRIBUTOR -C -C A. Varga, German Aerospace Center, -C DLR Oberpfaffenhofen, July 1998. -C Based on the RASP routine RCFID. -C -C REVISIONS -C -C Nov. 1998, V. Sima, Research Institute for Informatics, Bucharest. -C Dec. 1998, V. Sima, Katholieke Univ. Leuven, Leuven. -C Feb. 1999, May 2003, A. Varga, DLR Oberpfaffenhofen. -C -C KEYWORDS -C -C Coprime factorization, eigenvalue, eigenvalue assignment, -C feedback control, pole placement, state-space model. -C -C ****************************************************************** -C -C .. Parameters .. - DOUBLE PRECISION ONE, TEN, ZERO - PARAMETER ( ONE = 1.0D0, TEN = 1.0D1, ZERO = 0.0D0 ) -C .. Scalar Arguments .. - CHARACTER DICO - INTEGER INFO, IWARN, LDA, LDB, LDC, LDCR, LDD, LDDR, - $ LDWORK, M, N, NQ, NR, P - DOUBLE PRECISION TOL -C .. Array Arguments .. - DOUBLE PRECISION A(LDA,*), B(LDB,*), C(LDC,*), CR(LDCR,*), - $ D(LDD,*), DR(LDDR,*), DWORK(*) -C .. Local Scalars .. - LOGICAL DISCR - INTEGER I, IB, IB1, J, K, KFI, KV, KW, KWI, KWR, KZ, L, - $ L1, NB, NCUR, NFP, NLOW, NSUP - DOUBLE PRECISION ALPHA, BNORM, CS, PR, RMAX, SM, SN, TOLER, - $ WRKOPT, X, Y -C .. Local Arrays .. - DOUBLE PRECISION Z(4,4) -C .. External Functions .. - DOUBLE PRECISION DLAMCH, DLANGE - LOGICAL LSAME - EXTERNAL DLAMCH, DLANGE, LSAME -C .. External Subroutines .. - EXTERNAL DGEMM, DLACPY, DLAEXC, DLANV2, DLASET, DROT, - $ DTRMM, DTRMV, SB01FY, TB01LD, XERBLA -C .. Intrinsic Functions .. - INTRINSIC DBLE, MAX, MIN -C .. Executable Statements .. -C - DISCR = LSAME( DICO, 'D' ) - IWARN = 0 - INFO = 0 -C -C Check the scalar input parameters. -C - IF( .NOT. ( LSAME( DICO, 'C' ) .OR. DISCR ) ) THEN - INFO = -1 - ELSE IF( N.LT.0 ) THEN - INFO = -2 - ELSE IF( M.LT.0 ) THEN - INFO = -3 - ELSE IF( P.LT.0 ) THEN - INFO = -4 - ELSE IF( LDA.LT.MAX( 1, N ) ) THEN - INFO = -6 - ELSE IF( LDB.LT.MAX( 1, N ) ) THEN - INFO = -8 - ELSE IF( LDC.LT.MAX( 1, P ) ) THEN - INFO = -10 - ELSE IF( LDD.LT.MAX( 1, P ) ) THEN - INFO = -12 - ELSE IF( LDCR.LT.MAX( 1, M ) ) THEN - INFO = -16 - ELSE IF( LDDR.LT.MAX( 1, M ) ) THEN - INFO = -18 - ELSE IF( LDWORK.LT.MAX( 1, N*(N+5), M*(M+2), 4*M, 4*P ) ) THEN - INFO = -21 - END IF - IF( INFO.NE.0 )THEN -C -C Error return. -C - CALL XERBLA( 'SB08DD', -INFO ) - RETURN - END IF -C -C Set DR = I and quick return if possible. -C - NR = 0 - IF( MIN( M, P ).GT.0 ) - $ CALL DLASET( 'Full', M, M, ZERO, ONE, DR, LDDR ) - IF( MIN( N, M ).EQ.0 ) THEN - NQ = 0 - DWORK(1) = ONE - RETURN - END IF -C -C Set F = 0 in the array CR. -C - CALL DLASET( 'Full', M, N, ZERO, ZERO, CR, LDCR ) -C -C Compute the norm of B and set the default tolerance if necessary. -C - BNORM = DLANGE( '1-norm', N, M, B, LDB, DWORK ) - TOLER = TOL - IF( TOLER.LE.ZERO ) - $ TOLER = DBLE( N ) * BNORM * DLAMCH( 'Epsilon' ) - IF( BNORM.LE.TOLER ) THEN - NQ = 0 - DWORK(1) = ONE - RETURN - END IF -C -C Compute the bound for the numerical stability condition. -C - RMAX = TEN * DLANGE( '1-norm', N, N, A, LDA, DWORK ) / BNORM -C -C Allocate working storage. -C - KZ = 1 - KWR = KZ + N*N - KWI = KWR + N - KW = KWI + N -C -C Reduce A to an ordered real Schur form using an orthogonal -C similarity transformation A <- Z'*A*Z and accumulate the -C transformations in Z. The separation of spectrum of A is -C performed such that the leading NFP-by-NFP submatrix of A -C corresponds to the "stable" eigenvalues which will be not -C modified. The bottom (N-NFP)-by-(N-NFP) diagonal block of A -C corresponds to the "unstable" eigenvalues to be modified. -C Apply the transformation to B and C: B <- Z'*B and C <- C*Z. -C -C Workspace needed: N*(N+2); -C Additional workspace: need 3*N; -C prefer larger. -C - IF( DISCR ) THEN - ALPHA = ONE - ELSE - ALPHA = ZERO - END IF - CALL TB01LD( DICO, 'Stable', 'General', N, M, P, ALPHA, A, LDA, - $ B, LDB, C, LDC, NFP, DWORK(KZ), N, DWORK(KWR), - $ DWORK(KWI), DWORK(KW), LDWORK-KW+1, INFO ) - IF( INFO.NE.0 ) - $ RETURN -C - WRKOPT = DWORK(KW) + DBLE( KW-1 ) -C -C Perform the pole assignment if there exist "unstable" eigenvalues. -C - NQ = N - IF( NFP.LT.N ) THEN - KV = 1 - KFI = KV + M*M - KW = KFI + 2*M -C -C Set the limits for the bottom diagonal block. -C - NLOW = NFP + 1 - NSUP = N -C -C WHILE (NLOW <= NSUP) DO - 10 IF( NLOW.LE.NSUP ) THEN -C -C Main loop for assigning one or two poles. -C -C Determine the dimension of the last block. -C - IB = 1 - IF( NLOW.LT.NSUP ) THEN - IF( A(NSUP,NSUP-1).NE.ZERO ) IB = 2 - END IF - L = NSUP - IB + 1 -C -C Check the controllability of the last block. -C - IF( DLANGE( '1-norm', IB, M, B(L,1), LDB, DWORK(KW) ) - $ .LE.TOLER ) THEN -C -C Deflate the uncontrollable block and resume the main -C loop. -C - NSUP = NSUP - IB - ELSE -C -C Determine the M-by-IB feedback matrix FI which assigns -C the selected IB poles for the pair -C ( A(L:L+IB-1,L:L+IB-1), B(L:L+IB-1,1:M) ). -C -C Workspace needed: M*(M+2). -C - CALL SB01FY( DISCR, IB, M, A(L,L), LDA, B(L,1), LDB, - $ DWORK(KFI), M, DWORK(KV), M, INFO ) - IF( INFO.EQ.2 ) THEN - INFO = 3 - RETURN - END IF -C -C Check for possible numerical instability. -C - IF( DLANGE( '1-norm', M, IB, DWORK(KFI), M, DWORK(KW) ) - $ .GT.RMAX ) IWARN = IWARN + 1 -C -C Update the state matrix A <-- A + B*[0 FI]. -C - CALL DGEMM( 'NoTranspose', 'NoTranspose', NSUP, IB, M, - $ ONE, B, LDB, DWORK(KFI), M, ONE, A(1,L), - $ LDA ) -C -C Update the feedback matrix F <-- F + V*[0 FI] in CR. -C - IF( DISCR ) - $ CALL DTRMM( 'Left', 'Upper', 'NoTranspose', 'NonUnit', - $ M, IB, ONE, DR, LDDR, DWORK(KFI), M ) - K = KFI - DO 30 J = L, L + IB - 1 - DO 20 I = 1, M - CR(I,J) = CR(I,J) + DWORK(K) - K = K + 1 - 20 CONTINUE - 30 CONTINUE -C - IF( DISCR ) THEN -C -C Update the input matrix B <-- B*V. -C - CALL DTRMM( 'Right', 'Upper', 'NoTranspose', - $ 'NonUnit', N, M, ONE, DWORK(KV), M, B, - $ LDB ) -C -C Update the feedthrough matrix DR <-- DR*V. -C - K = KV - DO 40 I = 1, M - CALL DTRMV( 'Upper', 'Transpose', 'NonUnit', - $ M-I+1, DWORK(K), M, DR(I,I), LDDR ) - K = K + M + 1 - 40 CONTINUE - END IF -C - IF( IB.EQ.2 ) THEN -C -C Put the 2x2 block in a standard form. -C - L1 = L + 1 - CALL DLANV2( A(L,L), A(L,L1), A(L1,L), A(L1,L1), - $ X, Y, PR, SM, CS, SN ) -C -C Apply the transformation to A, B, C and F. -C - IF( L1.LT.NSUP ) - $ CALL DROT( NSUP-L1, A(L,L1+1), LDA, A(L1,L1+1), - $ LDA, CS, SN ) - CALL DROT( L-1, A(1,L), 1, A(1,L1), 1, CS, SN ) - CALL DROT( M, B(L,1), LDB, B(L1,1), LDB, CS, SN ) - IF( P.GT.0 ) - $ CALL DROT( P, C(1,L), 1, C(1,L1), 1, CS, SN ) - CALL DROT( M, CR(1,L), 1, CR(1,L1), 1, CS, SN ) - END IF - IF( NLOW+IB.LE.NSUP ) THEN -C -C Move the last block(s) to the leading position(s) of -C the bottom block. -C -C Workspace: need MAX(4*N, 4*M, 4*P). -C - NCUR = NSUP - IB -C WHILE (NCUR >= NLOW) DO - 50 IF( NCUR.GE.NLOW ) THEN -C -C Loop for positioning of the last block. -C -C Determine the dimension of the current block. -C - IB1 = 1 - IF( NCUR.GT.NLOW ) THEN - IF( A(NCUR,NCUR-1).NE.ZERO ) IB1 = 2 - END IF - NB = IB1 + IB -C -C Initialize the local transformation matrix Z. -C - CALL DLASET( 'Full', NB, NB, ZERO, ONE, Z, 4 ) - L = NCUR - IB1 + 1 -C -C Exchange two adjacent blocks and accumulate the -C transformations in Z. -C - CALL DLAEXC( .TRUE., NB, A(L,L), LDA, Z, 4, 1, IB1, - $ IB, DWORK, INFO ) - IF( INFO.NE.0 ) THEN - INFO = 2 - RETURN - END IF -C -C Apply the transformation to the rest of A. -C - L1 = L + NB - IF( L1.LE.NSUP ) THEN - CALL DGEMM( 'Transpose', 'NoTranspose', NB, - $ NSUP-L1+1, NB, ONE, Z, 4, A(L,L1), - $ LDA, ZERO, DWORK, NB ) - CALL DLACPY( 'Full', NB, NSUP-L1+1, DWORK, NB, - $ A(L,L1), LDA ) - END IF - CALL DGEMM( 'NoTranspose', 'NoTranspose', L-1, NB, - $ NB, ONE, A(1,L), LDA, Z, 4, ZERO, - $ DWORK, N ) - CALL DLACPY( 'Full', L-1, NB, DWORK, N, A(1,L), - $ LDA ) -C -C Apply the transformation to B, C and F. -C - CALL DGEMM( 'Transpose', 'NoTranspose', NB, M, NB, - $ ONE, Z, 4, B(L,1), LDB, ZERO, DWORK, - $ NB ) - CALL DLACPY( 'Full', NB, M, DWORK, NB, B(L,1), - $ LDB ) -C - IF( P.GT.0 ) THEN - CALL DGEMM( 'NoTranspose', 'NoTranspose', P, NB, - $ NB, ONE, C(1,L), LDC, Z, 4, ZERO, - $ DWORK, P ) - CALL DLACPY( 'Full', P, NB, DWORK, P, - $ C(1,L), LDC ) - END IF -C - CALL DGEMM( 'NoTranspose', 'NoTranspose', M, NB, - $ NB, ONE, CR(1,L), LDCR, Z, 4, ZERO, - $ DWORK, M ) - CALL DLACPY( 'Full', M, NB, DWORK, M, CR(1,L), - $ LDCR ) -C - NCUR = NCUR - IB1 - GO TO 50 - END IF -C END WHILE 50 -C - END IF - NLOW = NLOW + IB - END IF - GO TO 10 - END IF -C END WHILE 10 -C - NQ = NSUP - NR = NSUP - NFP -C -C Annihilate the elements below the first subdiagonal of A. -C - IF( NQ.GT.2 ) - $ CALL DLASET( 'Lower', NQ-2, NQ-2, ZERO, ZERO, A(3,1), LDA ) - END IF -C -C Compute C <-- CQ = C + D*F and D <-- DQ = D*DR. -C - CALL DGEMM( 'NoTranspose', 'NoTranspose', P, NQ, M, ONE, D, LDD, - $ CR, LDCR, ONE, C, LDC ) - IF( DISCR ) - $ CALL DTRMM( 'Right', 'Upper', 'NoTranspose', 'NonUnit', P, M, - $ ONE, DR, LDDR, D, LDD ) -C - DWORK(1) = MAX( WRKOPT, DBLE( MAX( M*(M+2), 4*M, 4*P ) ) ) -C - RETURN -C *** Last line of SB08DD *** - END diff --git a/mex/sources/libslicot/SB08ED.f b/mex/sources/libslicot/SB08ED.f deleted file mode 100644 index b171c4a16..000000000 --- a/mex/sources/libslicot/SB08ED.f +++ /dev/null @@ -1,359 +0,0 @@ - SUBROUTINE SB08ED( DICO, N, M, P, ALPHA, A, LDA, B, LDB, C, LDC, - $ D, LDD, NQ, NR, BR, LDBR, DR, LDDR, TOL, DWORK, - $ LDWORK, IWARN, INFO ) -C -C SLICOT RELEASE 5.0. -C -C Copyright (c) 2002-2009 NICONET e.V. -C -C This program is free software: you can redistribute it and/or -C modify it under the terms of the GNU General Public License as -C published by the Free Software Foundation, either version 2 of -C the License, or (at your option) any later version. -C -C This program is distributed in the hope that it will be useful, -C but WITHOUT ANY WARRANTY; without even the implied warranty of -C MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the -C GNU General Public License for more details. -C -C You should have received a copy of the GNU General Public License -C along with this program. If not, see -C . -C -C PURPOSE -C -C To construct, for a given system G = (A,B,C,D), an output -C injection matrix H and an orthogonal transformation matrix Z, such -C that the systems -C -C Q = (Z'*(A+H*C)*Z, Z'*(B+H*D), C*Z, D) -C and -C R = (Z'*(A+H*C)*Z, Z'*H, C*Z, I) -C -C provide a stable left coprime factorization of G in the form -C -1 -C G = R * Q, -C -C where G, Q and R are the corresponding transfer-function matrices. -C The resulting state dynamics matrix of the systems Q and R has -C eigenvalues lying inside a given stability domain. -C The Z matrix is not explicitly computed. -C -C Note: If the given state-space representation is not detectable, -C the undetectable part of the original system is automatically -C deflated and the order of the systems Q and R is accordingly -C reduced. -C -C ARGUMENTS -C -C Mode Parameters -C -C DICO CHARACTER*1 -C Specifies the type of the original system as follows: -C = 'C': continuous-time system; -C = 'D': discrete-time system. -C -C Input/Output Parameters -C -C N (input) INTEGER -C The dimension of the state vector, i.e. the order of the -C matrix A, and also the number of rows of the matrices B -C and BR, and the number of columns of the matrix C. -C N >= 0. -C -C M (input) INTEGER -C The dimension of input vector, i.e. the number of columns -C of the matrices B and D. M >= 0. -C -C P (input) INTEGER -C The dimension of output vector, i.e. the number of rows -C of the matrices C, D and DR, and the number of columns of -C the matrices BR and DR. P >= 0. -C -C ALPHA (input) DOUBLE PRECISION array, dimension (2) -C ALPHA(1) contains the desired stability degree to be -C assigned for the eigenvalues of A+H*C, and ALPHA(2) -C the stability margin. The eigenvalues outside the -C ALPHA(2)-stability region will be assigned to have the -C real parts equal to ALPHA(1) < 0 and unmodified -C imaginary parts for a continuous-time system -C (DICO = 'C'), or moduli equal to 0 <= ALPHA(2) < 1 -C for a discrete-time system (DICO = 'D'). -C -C A (input/output) DOUBLE PRECISION array, dimension (LDA,N) -C On entry, the leading N-by-N part of this array must -C contain the state dynamics matrix A. -C On exit, the leading NQ-by-NQ part of this array contains -C the leading NQ-by-NQ part of the matrix Z'*(A+H*C)*Z, the -C state dynamics matrix of the numerator factor Q, in a -C real Schur form. The leading NR-by-NR part of this matrix -C represents the state dynamics matrix of a minimal -C realization of the denominator factor R. -C -C LDA INTEGER -C The leading dimension of array A. LDA >= MAX(1,N). -C -C B (input/output) DOUBLE PRECISION array, dimension -C (LDB,MAX(M,P)) -C On entry, the leading N-by-M part of this array must -C contain the input/state matrix of the system. -C On exit, the leading NQ-by-M part of this array contains -C the leading NQ-by-M part of the matrix Z'*(B+H*D), the -C input/state matrix of the numerator factor Q. -C The remaining part of this array is needed as workspace. -C -C LDB INTEGER -C The leading dimension of array B. LDB >= MAX(1,N). -C -C C (input/output) DOUBLE PRECISION array, dimension (LDC,N) -C On entry, the leading P-by-N part of this array must -C contain the state/output matrix of the system. -C On exit, the leading P-by-NQ part of this array contains -C the leading P-by-NQ part of the matrix C*Z, the -C state/output matrix of the numerator factor Q. -C The first NR columns of this array represent the -C state/output matrix of a minimal realization of the -C denominator factor R. -C The remaining part of this array is needed as workspace. -C -C LDC INTEGER -C The leading dimension of array C. -C LDC >= MAX(1,M,P), if N > 0. -C LDC >= 1, if N = 0. -C -C D (input) DOUBLE PRECISION array, dimension (LDD,MAX(M,P)) -C The leading P-by-M part of this array must contain the -C input/output matrix. D represents also the input/output -C matrix of the numerator factor Q. -C This array is modified internally, but restored on exit. -C The remaining part of this array is needed as workspace. -C -C LDD INTEGER -C The leading dimension of array D. LDD >= MAX(1,M,P). -C -C NQ (output) INTEGER -C The order of the resulting factors Q and R. -C Generally, NQ = N - NS, where NS is the number of -C unobservable eigenvalues outside the stability region. -C -C NR (output) INTEGER -C The order of the minimal realization of the factor R. -C Generally, NR is the number of observable eigenvalues -C of A outside the stability region (the number of modified -C eigenvalues). -C -C BR (output) DOUBLE PRECISION array, dimension (LDBR,P) -C The leading NQ-by-P part of this array contains the -C leading NQ-by-P part of the output injection matrix -C Z'*H, which moves the eigenvalues of A lying outside -C the ALPHA-stable region to values on the ALPHA-stability -C boundary. The first NR rows of this matrix form the -C input/state matrix of a minimal realization of the -C denominator factor R. -C -C LDBR INTEGER -C The leading dimension of array BR. LDBR >= MAX(1,N). -C -C DR (output) DOUBLE PRECISION array, dimension (LDDR,P) -C The leading P-by-P part of this array contains an -C identity matrix representing the input/output matrix -C of the denominator factor R. -C -C LDDR INTEGER -C The leading dimension of array DR. LDDR >= MAX(1,P). -C -C Tolerances -C -C TOL DOUBLE PRECISION -C The absolute tolerance level below which the elements of -C C are considered zero (used for observability tests). -C If the user sets TOL <= 0, then an implicitly computed, -C default tolerance, defined by TOLDEF = N*EPS*NORM(C), -C is used instead, where EPS is the machine precision -C (see LAPACK Library routine DLAMCH) and NORM(C) denotes -C the infinity-norm of C. -C -C Workspace -C -C DWORK DOUBLE PRECISION array, dimension (LDWORK) -C On exit, if INFO = 0, DWORK(1) returns the optimal value -C of LDWORK. -C -C LDWORK INTEGER -C The dimension of working array DWORK. -C LDWORK >= MAX( 1, N*P + MAX( N*(N+5), 5*P, 4*M ) ). -C For optimum performance LDWORK should be larger. -C -C Warning Indicator -C -C IWARN INTEGER -C = 0: no warning; -C = K: K violations of the numerical stability condition -C NORM(H) <= 10*NORM(A)/NORM(C) occured during the -C assignment of eigenvalues. -C -C Error Indicator -C -C INFO INTEGER -C = 0: successful exit; -C < 0: if INFO = -i, the i-th argument had an illegal -C value; -C = 1: the reduction of A to a real Schur form failed; -C = 2: a failure was detected during the ordering of the -C real Schur form of A, or in the iterative process -C for reordering the eigenvalues of Z'*(A + H*C)*Z -C along the diagonal. -C -C METHOD -C -C The subroutine uses the right coprime factorization algorithm -C of [1] applied to G'. -C -C REFERENCES -C -C [1] Varga A. -C Coprime factors model reduction method based on -C square-root balancing-free techniques. -C System Analysis, Modelling and Simulation, -C vol. 11, pp. 303-311, 1993. -C -C NUMERICAL ASPECTS -C 3 -C The algorithm requires no more than 14N floating point -C operations. -C -C CONTRIBUTOR -C -C A. Varga, German Aerospace Center, -C DLR Oberpfaffenhofen, July 1998. -C Based on the RASP routine LCFS. -C -C REVISIONS -C -C Nov. 1998, V. Sima, Research Institute for Informatics, Bucharest. -C Dec. 1998, V. Sima, Katholieke Univ. Leuven, Leuven. -C May 2003, A. Varga, DLR Oberpfaffenhofen. -C Nov 2003, A. Varga, DLR Oberpfaffenhofen. -C Sep. 2005, A. Varga, German Aerospace Center. -C -C KEYWORDS -C -C Coprime factorization, eigenvalue, eigenvalue assignment, -C feedback control, pole placement, state-space model. -C -C ****************************************************************** -C -C .. Parameters .. - DOUBLE PRECISION ONE, ZERO - PARAMETER ( ONE = 1.0D0, ZERO = 0.0D0 ) -C .. Scalar Arguments .. - CHARACTER DICO - INTEGER INFO, IWARN, LDA, LDB, LDBR, LDC, LDD, LDDR, - $ LDWORK, M, N, NQ, NR, P - DOUBLE PRECISION TOL -C .. Array Arguments .. - DOUBLE PRECISION A(LDA,*), ALPHA(*), B(LDB,*), BR(LDBR,*), - $ C(LDC,*), D(LDD,*), DR(LDDR,*), DWORK(*) -C .. Local Scalars .. - LOGICAL DISCR - INTEGER KBR, KW -C .. External Functions .. - LOGICAL LSAME - EXTERNAL LSAME -C .. External subroutines .. - EXTERNAL AB07MD, DLASET, MA02AD, MA02BD, SB08FD, TB01XD, - $ XERBLA -C .. Intrinsic Functions .. - INTRINSIC DBLE, MAX, MIN -C .. Executable Statements .. -C - DISCR = LSAME( DICO, 'D' ) - IWARN = 0 - INFO = 0 -C -C Check the scalar input parameters. -C - IF( .NOT.( LSAME( DICO, 'C' ) .OR. DISCR ) ) THEN - INFO = -1 - ELSE IF( N.LT.0 ) THEN - INFO = -2 - ELSE IF( M.LT.0 ) THEN - INFO = -3 - ELSE IF( P.LT.0 ) THEN - INFO = -4 - ELSE IF( ( DISCR .AND. ( ALPHA(1).LT.ZERO .OR. ALPHA(1).GE.ONE - $ .OR. ALPHA(2).LT.ZERO .OR. ALPHA(2).GE.ONE ) ) - $ .OR. - $ ( .NOT.DISCR .AND. ( ALPHA(1).GE.ZERO .OR. ALPHA(2).GE.ZERO ) - $ ) ) THEN - INFO = -5 - ELSE IF( LDA.LT.MAX( 1, N ) ) THEN - INFO = -7 - ELSE IF( LDB.LT.MAX( 1, N ) ) THEN - INFO = -9 - ELSE IF( LDC.LT.1 .OR. ( N.GT.0 .AND. LDC.LT.MAX( M, P ) ) ) - $ THEN - INFO = -11 - ELSE IF( LDD.LT.MAX( 1, M, P ) ) THEN - INFO = -13 - ELSE IF( LDBR.LT.MAX( 1, N ) ) THEN - INFO = -17 - ELSE IF( LDDR.LT.MAX( 1, P ) ) THEN - INFO = -19 - ELSE IF( LDWORK.LT.MAX( 1, N*P + MAX( N*(N+5), 5*P, 4*M ) ) ) THEN - INFO = -22 - END IF - IF( INFO.NE.0 )THEN -C -C Error return. -C - CALL XERBLA( 'SB08ED', -INFO ) - RETURN - END IF -C -C Quick return if possible. -C - IF( MIN( N, P ).EQ.0 ) THEN - NQ = 0 - NR = 0 - DWORK(1) = ONE - CALL DLASET( 'Full', P, P, ZERO, ONE, DR, LDDR ) - RETURN - END IF -C -C Compute the dual system G' = (A',C',B',D'). -C - CALL AB07MD( 'D', N, M, P, A, LDA, B, LDB, C, LDC, D, LDD, - $ INFO ) -C -C Compute the right coprime factorization of G' with -C prescribed stability degree. -C -C Workspace needed: P*N; -C Additional workspace: need MAX( N*(N+5), 5*P, 4*M ); -C prefer larger. -C - KBR = 1 - KW = KBR + P*N - CALL SB08FD( DICO, N, P, M, ALPHA, A, LDA, B, LDB, C, LDC, D, LDD, - $ NQ, NR, DWORK(KBR), P, DR, LDDR, TOL, DWORK(KW), - $ LDWORK-KW+1, IWARN, INFO ) - IF( INFO.EQ.0 ) THEN -C -C Determine the elements of the left coprime factorization from -C those of the computed right coprime factorization and make the -C state-matrix upper real Schur. -C - CALL TB01XD( 'D', NQ, P, M, MAX( 0, NQ-1 ), MAX( 0, NQ-1 ), - $ A, LDA, B, LDB, C, LDC, D, LDD, INFO ) -C - CALL MA02AD( 'Full', P, NQ, DWORK(KBR), P, BR, LDBR ) - CALL MA02BD( 'Left', NQ, P, BR, LDBR ) -C - END IF -C - DWORK(1) = DWORK(KW) + DBLE( KW-1 ) -C - RETURN -C *** Last line of SB08ED *** - END diff --git a/mex/sources/libslicot/SB08FD.f b/mex/sources/libslicot/SB08FD.f deleted file mode 100644 index 54a21b1d9..000000000 --- a/mex/sources/libslicot/SB08FD.f +++ /dev/null @@ -1,630 +0,0 @@ - SUBROUTINE SB08FD( DICO, N, M, P, ALPHA, A, LDA, B, LDB, C, LDC, - $ D, LDD, NQ, NR, CR, LDCR, DR, LDDR, TOL, DWORK, - $ LDWORK, IWARN, INFO ) -C -C SLICOT RELEASE 5.0. -C -C Copyright (c) 2002-2009 NICONET e.V. -C -C This program is free software: you can redistribute it and/or -C modify it under the terms of the GNU General Public License as -C published by the Free Software Foundation, either version 2 of -C the License, or (at your option) any later version. -C -C This program is distributed in the hope that it will be useful, -C but WITHOUT ANY WARRANTY; without even the implied warranty of -C MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the -C GNU General Public License for more details. -C -C You should have received a copy of the GNU General Public License -C along with this program. If not, see -C . -C -C PURPOSE -C -C To construct, for a given system G = (A,B,C,D), a feedback -C matrix F and an orthogonal transformation matrix Z, such that -C the systems -C -C Q = (Z'*(A+B*F)*Z, Z'*B, (C+D*F)*Z, D) -C and -C R = (Z'*(A+B*F)*Z, Z'*B, F*Z, I) -C -C provide a stable right coprime factorization of G in the form -C -1 -C G = Q * R , -C -C where G, Q and R are the corresponding transfer-function matrices. -C The resulting state dynamics matrix of the systems Q and R has -C eigenvalues lying inside a given stability domain. -C The Z matrix is not explicitly computed. -C -C Note: If the given state-space representation is not stabilizable, -C the unstabilizable part of the original system is automatically -C deflated and the order of the systems Q and R is accordingly -C reduced. -C -C ARGUMENTS -C -C Mode Parameters -C -C DICO CHARACTER*1 -C Specifies the type of the original system as follows: -C = 'C': continuous-time system; -C = 'D': discrete-time system. -C -C Input/Output Parameters -C -C N (input) INTEGER -C The dimension of the state vector, i.e. the order of the -C matrix A, and also the number of rows of the matrix B and -C the number of columns of the matrices C and CR. N >= 0. -C -C M (input) INTEGER -C The dimension of input vector, i.e. the number of columns -C of the matrices B, D and DR and the number of rows of the -C matrices CR and DR. M >= 0. -C -C P (input) INTEGER -C The dimension of output vector, i.e. the number of rows -C of the matrices C and D. P >= 0. -C -C ALPHA (input) DOUBLE PRECISION array, dimension (2) -C ALPHA(1) contains the desired stability degree to be -C assigned for the eigenvalues of A+B*F, and ALPHA(2) -C the stability margin. The eigenvalues outside the -C ALPHA(2)-stability region will be assigned to have the -C real parts equal to ALPHA(1) < 0 and unmodified -C imaginary parts for a continuous-time system -C (DICO = 'C'), or moduli equal to 0 <= ALPHA(2) < 1 -C for a discrete-time system (DICO = 'D'). -C -C A (input/output) DOUBLE PRECISION array, dimension (LDA,N) -C On entry, the leading N-by-N part of this array must -C contain the state dynamics matrix A. -C On exit, the leading NQ-by-NQ part of this array contains -C the leading NQ-by-NQ part of the matrix Z'*(A+B*F)*Z, the -C state dynamics matrix of the numerator factor Q, in a -C real Schur form. The trailing NR-by-NR part of this matrix -C represents the state dynamics matrix of a minimal -C realization of the denominator factor R. -C -C LDA INTEGER -C The leading dimension of array A. LDA >= MAX(1,N). -C -C B (input/output) DOUBLE PRECISION array, dimension (LDB,M) -C On entry, the leading N-by-M part of this array must -C contain the input/state matrix. -C On exit, the leading NQ-by-M part of this array contains -C the leading NQ-by-M part of the matrix Z'*B, the -C input/state matrix of the numerator factor Q. The last -C NR rows of this matrix form the input/state matrix of -C a minimal realization of the denominator factor R. -C -C LDB INTEGER -C The leading dimension of array B. LDB >= MAX(1,N). -C -C C (input/output) DOUBLE PRECISION array, dimension (LDC,N) -C On entry, the leading P-by-N part of this array must -C contain the state/output matrix C. -C On exit, the leading P-by-NQ part of this array contains -C the leading P-by-NQ part of the matrix (C+D*F)*Z, -C the state/output matrix of the numerator factor Q. -C -C LDC INTEGER -C The leading dimension of array C. LDC >= MAX(1,P). -C -C D (input) DOUBLE PRECISION array, dimension (LDD,M) -C The leading P-by-M part of this array must contain the -C input/output matrix. D represents also the input/output -C matrix of the numerator factor Q. -C -C LDD INTEGER -C The leading dimension of array D. LDD >= MAX(1,P). -C -C NQ (output) INTEGER -C The order of the resulting factors Q and R. -C Generally, NQ = N - NS, where NS is the number of -C uncontrollable eigenvalues outside the stability region. -C -C NR (output) INTEGER -C The order of the minimal realization of the factor R. -C Generally, NR is the number of controllable eigenvalues -C of A outside the stability region (the number of modified -C eigenvalues). -C -C CR (output) DOUBLE PRECISION array, dimension (LDCR,N) -C The leading M-by-NQ part of this array contains the -C leading M-by-NQ part of the feedback matrix F*Z, which -C moves the eigenvalues of A lying outside the ALPHA-stable -C region to values which are on the ALPHA-stability -C boundary. The last NR columns of this matrix form the -C state/output matrix of a minimal realization of the -C denominator factor R. -C -C LDCR INTEGER -C The leading dimension of array CR. LDCR >= MAX(1,M). -C -C DR (output) DOUBLE PRECISION array, dimension (LDDR,M) -C The leading M-by-M part of this array contains an -C identity matrix representing the input/output matrix -C of the denominator factor R. -C -C LDDR INTEGER -C The leading dimension of array DR. LDDR >= MAX(1,M). -C -C Tolerances -C -C TOL DOUBLE PRECISION -C The absolute tolerance level below which the elements of -C B are considered zero (used for controllability tests). -C If the user sets TOL <= 0, then an implicitly computed, -C default tolerance, defined by TOLDEF = N*EPS*NORM(B), -C is used instead, where EPS is the machine precision -C (see LAPACK Library routine DLAMCH) and NORM(B) denotes -C the 1-norm of B. -C -C Workspace -C -C DWORK DOUBLE PRECISION array, dimension (LDWORK) -C On exit, if INFO = 0, DWORK(1) returns the optimal value -C of LDWORK. -C -C LDWORK INTEGER -C The dimension of working array DWORK. -C LWORK >= MAX( 1, N*(N+5), 5*M, 4*P ). -C For optimum performance LDWORK should be larger. -C -C Warning Indicator -C -C IWARN INTEGER -C = 0: no warning; -C = K: K violations of the numerical stability condition -C NORM(F) <= 10*NORM(A)/NORM(B) occured during the -C assignment of eigenvalues. -C -C Error Indicator -C -C INFO INTEGER -C = 0: successful exit; -C < 0: if INFO = -i, the i-th argument had an illegal -C value; -C = 1: the reduction of A to a real Schur form failed; -C = 2: a failure was detected during the ordering of the -C real Schur form of A, or in the iterative process -C for reordering the eigenvalues of Z'*(A + B*F)*Z -C along the diagonal. -C -C METHOD -C -C The subroutine is based on the factorization algorithm of [1]. -C -C REFERENCES -C -C [1] Varga A. -C Coprime factors model reduction method based on -C square-root balancing-free techniques. -C System Analysis, Modelling and Simulation, -C vol. 11, pp. 303-311, 1993. -C -C NUMERICAL ASPECTS -C 3 -C The algorithm requires no more than 14N floating point -C operations. -C -C CONTRIBUTOR -C -C A. Varga, German Aerospace Center, -C DLR Oberpfaffenhofen, July 1998. -C Based on the RASP routine RCFS. -C -C REVISIONS -C -C Nov. 1998, V. Sima, Research Institute for Informatics, Bucharest. -C Dec. 1998, V. Sima, Katholieke Univ. Leuven, Leuven. -C Mar. 2003, May 2003, A. Varga, German Aerospace Center. -C May 2003, V. Sima, Research Institute for Informatics, Bucharest. -C Sep. 2005, A. Varga, German Aerospace Center. -C -C KEYWORDS -C -C Coprime factorization, eigenvalue, eigenvalue assignment, -C feedback control, pole placement, state-space model. -C -C ****************************************************************** -C -C .. Parameters .. - DOUBLE PRECISION ONE, TEN, ZERO - PARAMETER ( ONE = 1.0D0, TEN = 1.0D1, ZERO = 0.0D0 ) -C .. Scalar Arguments .. - CHARACTER DICO - INTEGER INFO, IWARN, LDA, LDB, LDC, LDCR, LDD, LDDR, - $ LDWORK, M, N, NQ, NR, P - DOUBLE PRECISION TOL -C .. Array Arguments .. - DOUBLE PRECISION A(LDA,*), ALPHA(*), B(LDB,*), C(LDC,*), - $ CR(LDCR,*), D(LDD,*), DR(LDDR,*), DWORK(*) -C .. Local Scalars .. - LOGICAL DISCR - INTEGER I, IB, IB1, J, K, KFI, KG, KW, KWI, KWR, KZ, L, - $ L1, NB, NCUR, NCUR1, NFP, NLOW, NMOVES, NSUP - DOUBLE PRECISION BNORM, CS, PR, RMAX, SM, SN, TOLER, WRKOPT, X, Y -C .. Local Arrays .. - DOUBLE PRECISION A2(2,2), Z(4,4) -C .. External Functions .. - DOUBLE PRECISION DLAMCH, DLANGE, DLAPY2 - LOGICAL LSAME - EXTERNAL DLAMCH, DLANGE, DLAPY2, LSAME -C .. External Subroutines .. - EXTERNAL DGEMM, DLACPY, DLAEXC, DLANV2, DLASET, DROT, - $ SB01BY, TB01LD, XERBLA -C .. Intrinsic Functions .. - INTRINSIC ABS, DBLE, MAX, MIN, SIGN, SQRT -C -C .. Executable Statements .. -C - DISCR = LSAME( DICO, 'D' ) - IWARN = 0 - INFO = 0 -C -C Check the scalar input parameters. -C - IF( .NOT. ( LSAME( DICO, 'C' ) .OR. DISCR ) ) THEN - INFO = -1 - ELSE IF( N.LT.0 ) THEN - INFO = -2 - ELSE IF( M.LT.0 ) THEN - INFO = -3 - ELSE IF( P.LT.0 ) THEN - INFO = -4 - ELSE IF( ( DISCR .AND. ( ALPHA(1).LT.ZERO .OR. ALPHA(1).GE.ONE - $ .OR. ALPHA(2).LT.ZERO .OR. ALPHA(2).GE.ONE ) ) - $ .OR. - $ ( .NOT.DISCR .AND. ( ALPHA(1).GE.ZERO .OR. ALPHA(2).GE.ZERO ) - $ ) ) THEN - INFO = -5 - ELSE IF( LDA.LT.MAX( 1, N ) ) THEN - INFO = -7 - ELSE IF( LDB.LT.MAX( 1, N ) ) THEN - INFO = -9 - ELSE IF( LDC.LT.MAX( 1, P ) ) THEN - INFO = -11 - ELSE IF( LDD.LT.MAX( 1, P ) ) THEN - INFO = -13 - ELSE IF( LDCR.LT.MAX( 1, M ) ) THEN - INFO = -17 - ELSE IF( LDDR.LT.MAX( 1, M ) ) THEN - INFO = -19 - ELSE IF( LDWORK.LT.MAX( 1, N*(N+5), 5*M, 4*P ) ) THEN - INFO = -22 - END IF - IF( INFO.NE.0 )THEN -C -C Error return. -C - CALL XERBLA( 'SB08FD', -INFO ) - RETURN - END IF -C -C Set DR = I and quick return if possible. -C - NR = 0 - CALL DLASET( 'Full', M, M, ZERO, ONE, DR, LDDR ) - IF( MIN( N, M ).EQ.0 ) THEN - NQ = 0 - DWORK(1) = ONE - RETURN - END IF -C -C Set F = 0 in the array CR. -C - CALL DLASET( 'Full', M, N, ZERO, ZERO, CR, LDCR ) -C -C Compute the norm of B and set the default tolerance if necessary. -C - BNORM = DLANGE( '1-norm', N, M, B, LDB, DWORK ) - TOLER = TOL - IF( TOLER.LE.ZERO ) - $ TOLER = DBLE( N ) * BNORM * DLAMCH( 'Epsilon' ) - IF( BNORM.LE.TOLER ) THEN - NQ = 0 - DWORK(1) = ONE - RETURN - END IF -C -C Compute the bound for the numerical stability condition. -C - RMAX = TEN * DLANGE( '1-norm', N, N, A, LDA, DWORK ) / BNORM -C -C Allocate working storage. -C - KZ = 1 - KWR = KZ + N*N - KWI = KWR + N - KW = KWI + N -C -C Reduce A to an ordered real Schur form using an orthogonal -C similarity transformation A <- Z'*A*Z and accumulate the -C transformations in Z. The separation of spectrum of A is -C performed such that the leading NFP-by-NFP submatrix of A -C corresponds to the "stable" eigenvalues which will be not -C modified. The bottom (N-NFP)-by-(N-NFP) diagonal block of A -C corresponds to the "unstable" eigenvalues to be modified. -C Apply the transformation to B and C: B <- Z'*B and C <- C*Z. -C -C Workspace needed: N*(N+2); -C Additional workspace: need 3*N; -C prefer larger. -C - CALL TB01LD( DICO, 'Stable', 'General', N, M, P, ALPHA(2), A, LDA, - $ B, LDB, C, LDC, NFP, DWORK(KZ), N, DWORK(KWR), - $ DWORK(KWI), DWORK(KW), LDWORK-KW+1, INFO ) - IF( INFO.NE.0 ) - $ RETURN -C - WRKOPT = DWORK(KW) + DBLE( KW-1 ) -C -C Perform the pole assignment if there exist "unstable" eigenvalues. -C - NQ = N - IF( NFP.LT.N ) THEN - KG = 1 - KFI = KG + 2*M - KW = KFI + 2*M -C -C Set the limits for the bottom diagonal block. -C - NLOW = NFP + 1 - NSUP = N -C -C WHILE (NLOW <= NSUP) DO - 10 IF( NLOW.LE.NSUP ) THEN -C -C Main loop for assigning one or two poles. -C -C Determine the dimension of the last block. -C - IB = 1 - IF( NLOW.LT.NSUP ) THEN - IF( A(NSUP,NSUP-1).NE.ZERO ) IB = 2 - END IF - L = NSUP - IB + 1 -C -C Save the last IB rows of B in G. -C - CALL DLACPY( 'Full', IB, M, B(L,1), LDB, DWORK(KG), IB ) -C -C Check the controllability of the last block. -C - IF( DLANGE( '1-norm', IB, M, DWORK(KG), IB, DWORK(KW) ) - $ .LE.TOLER )THEN -C -C Deflate the uncontrollable block and resume the -C main loop. -C - NSUP = NSUP - IB - ELSE -C -C Form the IBxIB matrix A2 from the last diagonal block and -C set the pole(s) to be assigned. -C - A2(1,1) = A(L,L) - IF( IB.EQ.1 ) THEN - SM = ALPHA(1) - IF( DISCR ) SM = SIGN( ALPHA(1), A2(1,1) ) - PR = ALPHA(1) - ELSE - A2(1,2) = A(L,NSUP) - A2(2,1) = A(NSUP,L) - A2(2,2) = A(NSUP,NSUP) - SM = ALPHA(1) + ALPHA(1) - PR = ALPHA(1)*ALPHA(1) - IF( DISCR ) THEN - X = A2(1,1) - Y = SQRT( ABS( A2(1,2)*A2(2,1) ) ) - SM = SM * X / DLAPY2( X, Y ) - ELSE - PR = PR - A2(1,2)*A2(2,1) - END IF - END IF -C -C Determine the M-by-IB feedback matrix FI which assigns -C the selected IB poles for the pair (A2,G). -C -C Workspace needed: 5*M. -C - CALL SB01BY( IB, M, SM, PR, A2, DWORK(KG), DWORK(KFI), - $ TOLER, DWORK(KW), INFO ) - IF( INFO.NE.0 ) THEN -C -C Uncontrollable 2x2 block with double real eigenvalues -C which due to roundoff appear as a pair of complex -C conjugated eigenvalues. -C One of them can be elliminated using the information -C in DWORK(KFI) and DWORK(KFI+M). -C - CS = DWORK(KFI) - SN = -DWORK(KFI+M) -C -C Apply the Givens transformation to A, B, C and F. -C - L1 = L + 1 - CALL DROT( NSUP-L+1, A(L1,L), LDA, A(L,L), - $ LDA, CS, SN ) - CALL DROT( L1, A(1,L1), 1, A(1,L), 1, CS, SN ) - CALL DROT( M, B(L1,1), LDB, B(L,1), LDB, CS, SN ) - IF( P.GT.0 ) - $ CALL DROT( P, C(1,L1), 1, C(1,L), 1, CS, SN ) - CALL DROT( M, CR(1,L1), 1, CR(1,L), 1, CS, SN ) -C -C Deflate the uncontrollable block and resume the -C main loop. -C - A(L1,L) = ZERO - NSUP = NSUP - 1 - INFO = 0 - GO TO 10 - END IF -C -C Check for possible numerical instability. -C - IF( DLANGE( '1-norm', M, IB, DWORK(KFI), M, DWORK(KW) ) - $ .GT.RMAX ) IWARN = IWARN + 1 -C -C Update the feedback matrix F <-- F + [0 FI] in CR. -C - K = KFI - DO 30 J = L, L + IB - 1 - DO 20 I = 1, M - CR(I,J) = CR(I,J) + DWORK(K) - K = K + 1 - 20 CONTINUE - 30 CONTINUE -C -C Update the state matrix A <-- A + B*[0 FI]. -C - CALL DGEMM( 'NoTranspose', 'NoTranspose', NSUP, IB, M, - $ ONE, B, LDB, DWORK(KFI), M, ONE, A(1,L), - $ LDA ) - IF( IB.EQ.2 ) THEN -C -C Try to split the 2x2 block and standardize it. -C - L1 = L + 1 - CALL DLANV2( A(L,L), A(L,L1), A(L1,L), A(L1,L1), - $ X, Y, PR, SM, CS, SN ) -C -C Apply the transformation to A, B, C and F. -C - IF( L1.LT.NSUP ) - $ CALL DROT( NSUP-L1, A(L,L1+1), LDA, A(L1,L1+1), - $ LDA, CS, SN ) - CALL DROT( L-1, A(1,L), 1, A(1,L1), 1, CS, SN ) - CALL DROT( M, B(L,1), LDB, B(L1,1), LDB, CS, SN ) - IF( P.GT.0 ) - $ CALL DROT( P, C(1,L), 1, C(1,L1), 1, CS, SN ) - CALL DROT( M, CR(1,L), 1, CR(1,L1), 1, CS, SN ) - END IF - IF( NLOW+IB.LE.NSUP ) THEN -C -C Move the last block(s) to the leading position(s) of -C the bottom block. -C -C Workspace: need MAX(4*N, 4*M, 4*P). -C - NCUR1 = NSUP - IB - NMOVES = 1 - IF( IB.EQ.2 .AND. A(NSUP,NSUP-1).EQ.ZERO ) THEN - IB = 1 - NMOVES = 2 - END IF -C -C WHILE (NMOVES > 0) DO - 40 IF( NMOVES.GT.0 ) THEN - NCUR = NCUR1 -C -C WHILE (NCUR >= NLOW) DO - 50 IF( NCUR.GE.NLOW ) THEN -C -C Loop for positioning of the last block. -C -C Determine the dimension of the current block. -C - IB1 = 1 - IF( NCUR.GT.NLOW ) THEN - IF( A(NCUR,NCUR-1).NE.ZERO ) IB1 = 2 - END IF - NB = IB1 + IB -C -C Initialize the local transformation matrix Z. -C - CALL DLASET( 'Full', NB, NB, ZERO, ONE, Z, 4 ) - L = NCUR - IB1 + 1 -C -C Exchange two adjacent blocks and accumulate the -C transformations in Z. -C - CALL DLAEXC( .TRUE., NB, A(L,L), LDA, Z, 4, 1, - $ IB1, IB, DWORK, INFO ) - IF( INFO.NE.0 ) THEN - INFO = 2 - RETURN - END IF -C -C Apply the transformation to the rest of A. -C - L1 = L + NB - IF( L1.LE.NSUP ) THEN - CALL DGEMM( 'Transpose', 'NoTranspose', NB, - $ NSUP-L1+1, NB, ONE, Z, 4, - $ A(L,L1), LDA, ZERO, DWORK, NB ) - CALL DLACPY( 'Full', NB, NSUP-L1+1, DWORK, - $ NB, A(L,L1), LDA ) - END IF - CALL DGEMM( 'NoTranspose', 'NoTranspose', L-1, - $ NB, NB, ONE, A(1,L), LDA, Z, 4, - $ ZERO, DWORK, N ) - CALL DLACPY( 'Full', L-1, NB, DWORK, N, A(1,L), - $ LDA ) -C -C Apply the transformation to B, C and F. -C - CALL DGEMM( 'Transpose', 'NoTranspose', NB, M, - $ NB, ONE, Z, 4, B(L,1), LDB, ZERO, - $ DWORK, NB ) - CALL DLACPY( 'Full', NB, M, DWORK, NB, B(L,1), - $ LDB ) -C - IF( P.GT.0 ) THEN - CALL DGEMM( 'NoTranspose', 'NoTranspose', P, - $ NB, NB, ONE, C(1,L), LDC, Z, 4, - $ ZERO, DWORK, P ) - CALL DLACPY( 'Full', P, NB, DWORK, P, - $ C(1,L), LDC ) - END IF -C - CALL DGEMM( 'NoTranspose', 'NoTranspose', M, NB, - $ NB, ONE, CR(1,L), LDCR, Z, 4, ZERO, - $ DWORK, M ) - CALL DLACPY( 'Full', M, NB, DWORK, M, CR(1,L), - $ LDCR ) -C - NCUR = NCUR - IB1 - GO TO 50 - END IF -C END WHILE 50 -C - NMOVES = NMOVES - 1 - NCUR1 = NCUR1 + 1 - NLOW = NLOW + IB - GO TO 40 - END IF -C END WHILE 40 -C - ELSE - NLOW = NLOW + IB - END IF - END IF - GO TO 10 - END IF -C END WHILE 10 -C - NQ = NSUP - NR = NSUP - NFP -C -C Annihilate the elements below the first subdiagonal of A. -C - IF( NQ.GT.2 ) - $ CALL DLASET( 'Lower', NQ-2, NQ-2, ZERO, ZERO, A(3,1), LDA ) - END IF -C -C Compute C <-- CQ = C + D*F. -C - CALL DGEMM( 'NoTranspose', 'NoTranspose', P, NQ, M, ONE, D, LDD, - $ CR, LDCR, ONE, C, LDC ) -C - DWORK(1) = MAX( WRKOPT, DBLE( MAX( 5*M, 4*P ) ) ) -C - RETURN -C *** Last line of SB08FD *** - END diff --git a/mex/sources/libslicot/SB08GD.f b/mex/sources/libslicot/SB08GD.f deleted file mode 100644 index 0368fdf78..000000000 --- a/mex/sources/libslicot/SB08GD.f +++ /dev/null @@ -1,256 +0,0 @@ - SUBROUTINE SB08GD( N, M, P, A, LDA, B, LDB, C, LDC, D, LDD, BR, - $ LDBR, DR, LDDR, IWORK, DWORK, INFO ) -C -C SLICOT RELEASE 5.0. -C -C Copyright (c) 2002-2009 NICONET e.V. -C -C This program is free software: you can redistribute it and/or -C modify it under the terms of the GNU General Public License as -C published by the Free Software Foundation, either version 2 of -C the License, or (at your option) any later version. -C -C This program is distributed in the hope that it will be useful, -C but WITHOUT ANY WARRANTY; without even the implied warranty of -C MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the -C GNU General Public License for more details. -C -C You should have received a copy of the GNU General Public License -C along with this program. If not, see -C . -C -C PURPOSE -C -C To construct the state-space representation for the system -C G = (A,B,C,D) from the factors Q = (AQR,BQ,CQR,DQ) and -C R = (AQR,BR,CQR,DR) of its left coprime factorization -C -1 -C G = R * Q, -C -C where G, Q and R are the corresponding transfer-function matrices. -C -C ARGUMENTS -C -C Input/Output Parameters -C -C N (input) INTEGER -C The order of the matrix A. Also the number of rows of the -C matrices B and BR and the number of columns of the matrix -C C. N represents the order of the systems Q and R. N >= 0. -C -C M (input) INTEGER -C The dimension of input vector, i.e. the number of columns -C of the matrices B and D. M >= 0. -C -C P (input) INTEGER -C The dimension of output vector, i.e. the number of rows of -C the matrices C, D and DR and the number of columns of the -C matrices BR and DR. P >= 0. -C -C A (input/output) DOUBLE PRECISION array, dimension (LDA,N) -C On entry, the leading N-by-N part of this array must -C contain the state dynamics matrix AQR of the systems -C Q and R. -C On exit, the leading N-by-N part of this array contains -C the state dynamics matrix of the system G. -C -C LDA INTEGER -C The leading dimension of array A. LDA >= MAX(1,N). -C -C B (input/output) DOUBLE PRECISION array, dimension (LDB,M) -C On entry, the leading N-by-M part of this array must -C contain the input/state matrix BQ of the system Q. -C On exit, the leading N-by-M part of this array contains -C the input/state matrix of the system G. -C -C LDB INTEGER -C The leading dimension of array B. LDB >= MAX(1,N). -C -C C (input/output) DOUBLE PRECISION array, dimension (LDC,N) -C On entry, the leading P-by-N part of this array must -C contain the state/output matrix CQR of the systems -C Q and R. -C On exit, the leading P-by-N part of this array contains -C the state/output matrix of the system G. -C -C LDC INTEGER -C The leading dimension of array C. LDC >= MAX(1,P). -C -C D (input/output) DOUBLE PRECISION array, dimension (LDD,M) -C On entry, the leading P-by-M part of this array must -C contain the input/output matrix DQ of the system Q. -C On exit, the leading P-by-M part of this array contains -C the input/output matrix of the system G. -C -C LDD INTEGER -C The leading dimension of array D. LDD >= MAX(1,P). -C -C BR (input) DOUBLE PRECISION array, dimension (LDBR,P) -C The leading N-by-P part of this array must contain the -C input/state matrix BR of the system R. -C -C LDBR INTEGER -C The leading dimension of array BR. LDBR >= MAX(1,N). -C -C DR (input/output) DOUBLE PRECISION array, dimension (LDDR,P) -C On entry, the leading P-by-P part of this array must -C contain the input/output matrix DR of the system R. -C On exit, the leading P-by-P part of this array contains -C the LU factorization of the matrix DR, as computed by -C LAPACK Library routine DGETRF. -C -C LDDR INTEGER -C The leading dimension of array DR. LDDR >= MAX(1,P). -C -C Workspace -C -C IWORK INTEGER array, dimension (P) -C -C DWORK DOUBLE PRECISION array, dimension (MAX(1,4*P)) -C On exit, DWORK(1) contains an estimate of the reciprocal -C condition number of the matrix DR. -C -C Error Indicator -C -C INFO INTEGER -C = 0: successful exit; -C < 0: if INFO = -i, the i-th argument had an illegal -C value; -C = 1: the matrix DR is singular; -C = 2: the matrix DR is numerically singular (warning); -C the calculations continued. -C -C METHOD -C -C The subroutine computes the matrices of the state-space -C representation G = (A,B,C,D) by using the formulas: -C -C -1 -1 -C A = AQR - BR * DR * CQR, C = DR * CQR, -C -1 -1 -C B = BQ - BR * DR * DQ, D = DR * DQ. -C -C REFERENCES -C -C [1] Varga A. -C Coprime factors model reduction method based on -C square-root balancing-free techniques. -C System Analysis, Modelling and Simulation, -C vol. 11, pp. 303-311, 1993. -C -C CONTRIBUTOR -C -C C. Oara and A. Varga, German Aerospace Center, -C DLR Oberpfaffenhofen, July 1998. -C Based on the RASP routine LCFI. -C -C REVISIONS -C -C Nov. 1998, V. Sima, Research Institute for Informatics, Bucharest. -C Dec. 1998, V. Sima, Katholieke Univ. Leuven, Leuven. -C -C KEYWORDS -C -C Coprime factorization, state-space model. -C -C ****************************************************************** -C -C .. Parameters .. - DOUBLE PRECISION ONE, ZERO - PARAMETER ( ONE = 1.0D0, ZERO = 0.0D0 ) -C .. Scalar Arguments .. - INTEGER INFO, LDA, LDB, LDBR, LDC, LDD, LDDR, M, N, P -C .. Array Arguments .. - DOUBLE PRECISION A(LDA,*), B(LDB,*), BR(LDBR,*), C(LDC,*), - $ D(LDD,*), DR(LDDR,*), DWORK(*) - INTEGER IWORK(*) -C .. Local Scalars - DOUBLE PRECISION DRNORM, RCOND -C .. External Functions .. - DOUBLE PRECISION DLAMCH, DLANGE - EXTERNAL DLAMCH, DLANGE -C .. External Subroutines .. - EXTERNAL DGECON, DGEMM, DGETRF, DGETRS, XERBLA -C .. Intrinsic Functions .. - INTRINSIC MAX -C .. Executable Statements .. -C - INFO = 0 -C -C Check the scalar input parameters. -C - IF( N.LT.0 ) THEN - INFO = -1 - ELSE IF( M.LT.0 ) THEN - INFO = -2 - ELSE IF( P.LT.0 ) THEN - INFO = -3 - ELSE IF( LDA.LT.MAX( 1, N ) ) THEN - INFO = -5 - ELSE IF( LDB.LT.MAX( 1, N ) ) THEN - INFO = -7 - ELSE IF( LDC.LT.MAX( 1, P ) ) THEN - INFO = -9 - ELSE IF( LDD.LT.MAX( 1, P ) ) THEN - INFO = -11 - ELSE IF( LDBR.LT.MAX( 1, N ) ) THEN - INFO = -13 - ELSE IF( LDDR.LT.MAX( 1, P ) ) THEN - INFO = -15 - END IF - IF( INFO.NE.0 )THEN -C -C Error return. -C - CALL XERBLA( 'SB08GD', -INFO ) - RETURN - END IF -C -C Quick return if possible. -C - IF( P.EQ.0 )THEN - DWORK(1) = ONE - RETURN - END IF -C -C Factor the matrix DR. First, compute the 1-norm. -C - DRNORM = DLANGE( '1-norm', P, P, DR, LDDR, DWORK ) - CALL DGETRF( P, P, DR, LDDR, IWORK, INFO ) - IF( INFO.NE.0 ) THEN - INFO = 1 - DWORK(1) = ZERO - RETURN - END IF -C -1 -C Compute C = DR * CQR. -C - CALL DGETRS( 'NoTranspose', P, N, DR, LDDR, IWORK, C, LDC, INFO ) -C -1 -C Compute A = AQR - BR * DR * CQR. -C - CALL DGEMM( 'NoTranspose', 'NoTranspose', N, N, P, -ONE, BR, LDBR, - $ C, LDC, ONE, A, LDA ) -C -1 -C Compute D = DR * DQ. -C - CALL DGETRS( 'NoTranspose', P, M, DR, LDDR, IWORK, D, LDD, INFO ) -C -1 -C Compute B = BQ - BR * DR * DQ. -C - CALL DGEMM( 'NoTranspose', 'NoTranspose', N, M, P, -ONE, BR, LDBR, - $ D, LDD, ONE, B, LDB ) -C -C Estimate the reciprocal condition number of DR. -C Workspace 4*P. -C - CALL DGECON( '1-norm', P, DR, LDDR, DRNORM, RCOND, DWORK, IWORK, - $ INFO ) - IF( RCOND.LE.DLAMCH( 'Epsilon' ) ) - $ INFO = 2 -C - DWORK(1) = RCOND -C - RETURN -C *** Last line of SB08GD *** - END diff --git a/mex/sources/libslicot/SB08HD.f b/mex/sources/libslicot/SB08HD.f deleted file mode 100644 index b1a2227d9..000000000 --- a/mex/sources/libslicot/SB08HD.f +++ /dev/null @@ -1,267 +0,0 @@ - SUBROUTINE SB08HD( N, M, P, A, LDA, B, LDB, C, LDC, D, LDD, CR, - $ LDCR, DR, LDDR, IWORK, DWORK, INFO ) -C -C SLICOT RELEASE 5.0. -C -C Copyright (c) 2002-2009 NICONET e.V. -C -C This program is free software: you can redistribute it and/or -C modify it under the terms of the GNU General Public License as -C published by the Free Software Foundation, either version 2 of -C the License, or (at your option) any later version. -C -C This program is distributed in the hope that it will be useful, -C but WITHOUT ANY WARRANTY; without even the implied warranty of -C MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the -C GNU General Public License for more details. -C -C You should have received a copy of the GNU General Public License -C along with this program. If not, see -C . -C -C PURPOSE -C -C To construct the state-space representation for the system -C G = (A,B,C,D) from the factors Q = (AQR,BQR,CQ,DQ) and -C R = (AQR,BQR,CR,DR) of its right coprime factorization -C -1 -C G = Q * R , -C -C where G, Q and R are the corresponding transfer-function matrices. -C -C ARGUMENTS -C -C Input/Output Parameters -C -C N (input) INTEGER -C The order of the matrix A. Also the number of rows of the -C matrix B and the number of columns of the matrices C and -C CR. N represents the order of the systems Q and R. -C N >= 0. -C -C M (input) INTEGER -C The dimension of input vector. Also the number of columns -C of the matrices B, D and DR and the number of rows of the -C matrices CR and DR. M >= 0. -C -C P (input) INTEGER -C The dimension of output vector. Also the number of rows -C of the matrices C and D. P >= 0. -C -C A (input/output) DOUBLE PRECISION array, dimension (LDA,N) -C On entry, the leading N-by-N part of this array must -C contain the state dynamics matrix AQR of the systems -C Q and R. -C On exit, the leading N-by-N part of this array contains -C the state dynamics matrix of the system G. -C -C LDA INTEGER -C The leading dimension of array A. LDA >= MAX(1,N). -C -C B (input/output) DOUBLE PRECISION array, dimension (LDB,M) -C On entry, the leading N-by-M part of this array must -C contain the input/state matrix BQR of the systems Q and R. -C On exit, the leading N-by-M part of this array contains -C the input/state matrix of the system G. -C -C LDB INTEGER -C The leading dimension of array B. LDB >= MAX(1,N). -C -C C (input/output) DOUBLE PRECISION array, dimension (LDC,N) -C On entry, the leading P-by-N part of this array must -C contain the state/output matrix CQ of the system Q. -C On exit, the leading P-by-N part of this array contains -C the state/output matrix of the system G. -C -C LDC INTEGER -C The leading dimension of array C. LDC >= MAX(1,P). -C -C -C D (input/output) DOUBLE PRECISION array, dimension (LDD,M) -C On entry, the leading P-by-M part of this array must -C contain the input/output matrix DQ of the system Q. -C On exit, the leading P-by-M part of this array contains -C the input/output matrix of the system G. -C -C LDD INTEGER -C The leading dimension of array D. LDD >= MAX(1,P). -C -C CR (input) DOUBLE PRECISION array, dimension (LDCR,N) -C The leading M-by-N part of this array must contain the -C state/output matrix CR of the system R. -C -C LDCR INTEGER -C The leading dimension of array CR. LDCR >= MAX(1,M). -C -C DR (input/output) DOUBLE PRECISION array, dimension (LDDR,M) -C On entry, the leading M-by-M part of this array must -C contain the input/output matrix DR of the system R. -C On exit, the leading M-by-M part of this array contains -C the LU factorization of the matrix DR, as computed by -C LAPACK Library routine DGETRF. -C -C LDDR INTEGER -C The leading dimension of array DR. LDDR >= MAX(1,M). -C -C Workspace -C -C IWORK INTEGER array, dimension (M) -C -C DWORK DOUBLE PRECISION array, dimension (MAX(1,4*M)) -C On exit, DWORK(1) contains an estimate of the reciprocal -C condition number of the matrix DR. -C -C Error Indicator -C -C INFO INTEGER -C = 0: successful exit; -C < 0: if INFO = -i, the i-th argument had an illegal -C value; -C = 1: the matrix DR is singular; -C = 2: the matrix DR is numerically singular (warning); -C the calculations continued. -C -C METHOD -C -C The subroutine computes the matrices of the state-space -C representation G = (A,B,C,D) by using the formulas: -C -C -1 -1 -C A = AQR - BQR * DR * CR, B = BQR * DR , -C -1 -1 -C C = CQ - DQ * DR * CR, D = DQ * DR . -C -C REFERENCES -C -C [1] Varga A. -C Coprime factors model reduction method based on -C square-root balancing-free techniques. -C System Analysis, Modelling and Simulation, -C vol. 11, pp. 303-311, 1993. -C -C CONTRIBUTOR -C -C C. Oara and A. Varga, German Aerospace Center, -C DLR Oberpfaffenhofen, July 1998. -C Based on the RASP routine RCFI. -C V. Sima, Research Institute for Informatics, Bucharest, Nov. 1998, -C full BLAS 3 version. -C -C REVISIONS -C -C Dec. 1998, V. Sima, Katholieke Univ. Leuven, Leuven. -C Mar. 2000, V. Sima, Research Institute for Informatics, Bucharest. -C -C KEYWORDS -C -C Coprime factorization, state-space model. -C -C ****************************************************************** -C -C .. Parameters .. - DOUBLE PRECISION ONE, ZERO - PARAMETER ( ONE = 1.0D0, ZERO = 0.0D0 ) -C .. Scalar Arguments .. - INTEGER INFO, LDA, LDB, LDC, LDCR, LDD, LDDR, M, N, P -C .. Array Arguments .. - DOUBLE PRECISION A(LDA,*), B(LDB,*), C(LDC,*), CR(LDCR,*), - $ D(LDD,*), DR(LDDR,*), DWORK(*) - INTEGER IWORK(*) -C .. Local Scalars - DOUBLE PRECISION DRNORM, RCOND -C .. External Functions .. - DOUBLE PRECISION DLAMCH, DLANGE - EXTERNAL DLAMCH, DLANGE -C .. External Subroutines .. - EXTERNAL DGECON, DGEMM, DGETRF, DTRSM, MA02GD, XERBLA -C .. Intrinsic Functions .. - INTRINSIC MAX -C .. Executable Statements .. -C - INFO = 0 -C -C Check the scalar input parameters. -C - IF( N.LT.0 ) THEN - INFO = -1 - ELSE IF( M.LT.0 ) THEN - INFO = -2 - ELSE IF( P.LT.0 ) THEN - INFO = -3 - ELSE IF( LDA.LT.MAX( 1, N ) ) THEN - INFO = -5 - ELSE IF( LDB.LT.MAX( 1, N ) ) THEN - INFO = -7 - ELSE IF( LDC.LT.MAX( 1, P ) ) THEN - INFO = -9 - ELSE IF( LDD.LT.MAX( 1, P ) ) THEN - INFO = -11 - ELSE IF( LDCR.LT.MAX( 1, M ) ) THEN - INFO = -13 - ELSE IF( LDDR.LT.MAX( 1, M ) ) THEN - INFO = -15 - END IF - IF( INFO.NE.0 )THEN -C -C Error return. -C - CALL XERBLA( 'SB08HD', -INFO ) - RETURN - END IF -C -C Quick return if possible. -C - IF( M.EQ.0 )THEN - DWORK(1) = ONE - RETURN - END IF -C -C Factor the matrix DR. First, compute the 1-norm. -C - DRNORM = DLANGE( '1-norm', M, M, DR, LDDR, DWORK ) - CALL DGETRF( M, M, DR, LDDR, IWORK, INFO ) - IF( INFO.NE.0 ) THEN - INFO = 1 - DWORK(1) = ZERO - RETURN - END IF -C -1 -C Compute B = BQR * DR , using the factorization P*DR = L*U. -C - CALL DTRSM( 'Right', 'Upper', 'NoTranspose', 'NonUnit', N, M, ONE, - $ DR, LDDR, B, LDB ) - CALL DTRSM( 'Right', 'Lower', 'NoTranspose', 'Unit', N, M, ONE, - $ DR, LDDR, B, LDB ) - CALL MA02GD( N, B, LDB, 1, M, IWORK, -1 ) -C -1 -C Compute A = AQR - BQR * DR * CR. -C - CALL DGEMM( 'NoTranspose', 'NoTranspose', N, N, M, -ONE, B, LDB, - $ CR, LDCR, ONE, A, LDA ) -C -1 -C Compute D = DQ * DR . -C - CALL DTRSM( 'Right', 'Upper', 'NoTranspose', 'NonUnit', P, M, ONE, - $ DR, LDDR, D, LDD ) - CALL DTRSM( 'Right', 'Lower', 'NoTranspose', 'Unit', P, M, ONE, - $ DR, LDDR, D, LDD ) - CALL MA02GD( P, D, LDD, 1, M, IWORK, -1 ) -C -1 -C Compute C = CQ - DQ * DR * CR. -C - CALL DGEMM( 'NoTranspose', 'NoTranspose', P, N, M, -ONE, D, LDD, - $ CR, LDCR, ONE, C, LDC ) -C -C Estimate the reciprocal condition number of DR. -C Workspace 4*M. -C - CALL DGECON( '1-norm', M, DR, LDDR, DRNORM, RCOND, DWORK, IWORK, - $ INFO ) - IF( RCOND.LE.DLAMCH( 'Epsilon' ) ) - $ INFO = 2 -C - DWORK(1) = RCOND -C - RETURN -C *** Last line of SB08HD *** - END diff --git a/mex/sources/libslicot/SB08MD.f b/mex/sources/libslicot/SB08MD.f deleted file mode 100644 index 78f6d46c2..000000000 --- a/mex/sources/libslicot/SB08MD.f +++ /dev/null @@ -1,471 +0,0 @@ - SUBROUTINE SB08MD( ACONA, DA, A, RES, E, DWORK, LDWORK, INFO ) -C -C SLICOT RELEASE 5.0. -C -C Copyright (c) 2002-2009 NICONET e.V. -C -C This program is free software: you can redistribute it and/or -C modify it under the terms of the GNU General Public License as -C published by the Free Software Foundation, either version 2 of -C the License, or (at your option) any later version. -C -C This program is distributed in the hope that it will be useful, -C but WITHOUT ANY WARRANTY; without even the implied warranty of -C MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the -C GNU General Public License for more details. -C -C You should have received a copy of the GNU General Public License -C along with this program. If not, see -C . -C -C PURPOSE -C -C To compute a real polynomial E(s) such that -C -C (a) E(-s) * E(s) = A(-s) * A(s) and -C (b) E(s) is stable - that is, all the zeros of E(s) have -C non-positive real parts, -C -C which corresponds to computing the spectral factorization of the -C real polynomial A(s) arising from continuous optimality problems. -C -C The input polynomial may be supplied either in the form -C -C A(s) = a(0) + a(1) * s + ... + a(DA) * s**DA -C -C or as -C -C B(s) = A(-s) * A(s) -C = b(0) + b(1) * s**2 + ... + b(DA) * s**(2*DA) (1) -C -C ARGUMENTS -C -C Mode Parameters -C -C ACONA CHARACTER*1 -C Indicates whether the coefficients of A(s) or B(s) = -C A(-s) * A(s) are to be supplied as follows: -C = 'A': The coefficients of A(s) are to be supplied; -C = 'B': The coefficients of B(s) are to be supplied. -C -C Input/Output Parameters -C -C DA (input) INTEGER -C The degree of the polynomials A(s) and E(s). DA >= 0. -C -C A (input/output) DOUBLE PRECISION array, dimension (DA+1) -C On entry, this array must contain either the coefficients -C of the polynomial A(s) in increasing powers of s if -C ACONA = 'A', or the coefficients of the polynomial B(s) in -C increasing powers of s**2 (see equation (1)) if ACONA = -C 'B'. -C On exit, this array contains the coefficients of the -C polynomial B(s) in increasing powers of s**2. -C -C RES (output) DOUBLE PRECISION -C An estimate of the accuracy with which the coefficients of -C the polynomial E(s) have been computed (see also METHOD -C and NUMERICAL ASPECTS). -C -C E (output) DOUBLE PRECISION array, dimension (DA+1) -C The coefficients of the spectral factor E(s) in increasing -C powers of s. -C -C Workspace -C -C DWORK DOUBLE PRECISION array, dimension (LDWORK) -C -C LDWORK INTEGER -C The length of the array DWORK. LDWORK >= 5*DA+5. -C -C Error Indicator -C -C INFO INTEGER -C = 0: successful exit; -C < 0: if INFO = -i, the i-th argument had an illegal -C value; -C = 1: if on entry, A(I) = 0.0, for I = 1,2,...,DA+1. -C = 2: if on entry, ACONA = 'B' but the supplied -C coefficients of the polynomial B(s) are not the -C coefficients of A(-s) * A(s) for some real A(s); -C in this case, RES and E are unassigned; -C = 3: if the iterative process (see METHOD) has failed to -C converge in 30 iterations; -C = 4: if the last computed iterate (see METHOD) is -C unstable. If ACONA = 'B', then the supplied -C coefficients of the polynomial B(s) may not be the -C coefficients of A(-s) * A(s) for some real A(s). -C -C METHOD -C _ _ -C Let A(s) be the conjugate polynomial of A(s), i.e., A(s) = A(-s). -C -C The method used by the routine is based on applying the -C Newton-Raphson iteration to the function -C _ _ -C F(e) = A * A - e * e, -C -C which leads to the iteration formulae (see [1]): -C -C _(i) (i) _(i) (i) _ ) -C q * x + x * q = 2 A * A ) -C ) for i = 0, 1, 2,... -C (i+1) (i) (i) ) -C q = (q + x )/2 ) -C -C (0) DA -C Starting from q = (1 + s) (which has no zeros in the closed -C (1) (2) (3) -C right half-plane), the sequence of iterates q , q , q ,... -C converges to a solution of F(e) = 0 which has no zeros in the -C open right half-plane. -C -C The iterates satisfy the following conditions: -C -C (i) -C (a) q is a stable polynomial (no zeros in the closed right -C half-plane) and -C -C (i) (i-1) -C (b) q (1) <= q (1). -C -C (i-1) (i) -C The iterative process stops with q , (where i <= 30) if q -C violates either (a) or (b), or if the condition -C _(i) (i) _ -C (c) RES = ||(q q - A A)|| < tol, -C -C is satisfied, where || . || denotes the largest coefficient of -C _(i) (i) _ -C the polynomial (q q - A A) and tol is an estimate of the -C _(i) (i) -C rounding error in the computed coefficients of q q . If there -C is no convergence after 30 iterations then the routine returns -C with the Error Indicator (INFO) set to 3, and the value of RES may -C indicate whether or not the last computed iterate is close to the -C solution. -C -C If ACONA = 'B', then it is possible that the equation e(-s) * -C e(s) = B(s) has no real solution, which will be the case if A(1) -C < 0 or if ( -1)**DA * A(DA+1) < 0. -C -C REFERENCES -C -C [1] Vostry, Z. -C New Algorithm for Polynomial Spectral Factorization with -C Quadratic Convergence II. -C Kybernetika, 12, pp. 248-259, 1976. -C -C NUMERICAL ASPECTS -C -C The conditioning of the problem depends upon the distance of the -C zeros of A(s) from the imaginary axis and on their multiplicity. -C For a well-conditioned problem the accuracy of the computed -C coefficients of E(s) is of the order of RES. However, for problems -C with zeros near the imaginary axis or with multiple zeros, the -C value of RES may be an overestimate of the true accuracy. -C -C FURTHER COMMENTS -C -C In order for the problem e(-s) * e(s) = B(s) to have a real -C solution e(s), it is necessary and sufficient that B(j*omega) -C >= 0 for any purely imaginary argument j*omega (see [1]). -C -C CONTRIBUTOR -C -C Release 3.0: V. Sima, Katholieke Univ. Leuven, Belgium, Aug. 1997. -C Supersedes Release 2.0 routine SB08AD by A.J. Geurts. -C -C REVISIONS -C -C - -C -C KEYWORDS -C -C Factorization, Laplace transform, optimal control, optimal -C filtering, polynomial operations, spectral factorization, zeros. -C -C ****************************************************************** -C -C .. Parameters .. - DOUBLE PRECISION ZERO, HALF, ONE - PARAMETER ( ZERO = 0.0D0, HALF = 0.5D0, ONE = 1.0D0 ) -C .. Scalar Arguments .. - CHARACTER ACONA - INTEGER DA, INFO, LDWORK - DOUBLE PRECISION RES -C .. Array Arguments .. - DOUBLE PRECISION A(*), DWORK(*), E(*) -C .. Local Scalars .. - LOGICAL CONV, LACONA, STABLE - INTEGER BINC, DA1, I, I0, J, K, LAMBDA, LAY, LAYEND, - $ LDIF, LPHEND, LPHI, LQ, M, NC - DOUBLE PRECISION A0, EPS, MU, MUJ, SI, SIGNI, SIGNI0, SIGNJ, - $ SIMIN1, SQRTA0, SQRTMJ, SQRTMU, TOLPHI, W, XDA -C .. External Functions .. - LOGICAL LSAME - INTEGER IDAMAX - DOUBLE PRECISION DLAMCH - EXTERNAL DLAMCH, IDAMAX, LSAME -C .. External Subroutines .. - EXTERNAL DAXPY, DCOPY, SB08MY, XERBLA -C .. Intrinsic Functions .. - INTRINSIC ABS, DBLE, MOD, SQRT -C .. Executable Statements .. -C - INFO = 0 - LACONA = LSAME( ACONA, 'A' ) -C -C Test the input scalar arguments. -C - IF( .NOT.LACONA .AND. .NOT.LSAME( ACONA, 'B' ) ) THEN - INFO = -1 - ELSE IF( DA.LT.0 ) THEN - INFO = -2 - ELSE IF( LDWORK.LT.5*DA + 5 ) THEN - INFO = -7 - END IF -C - IF ( INFO.NE.0 ) THEN -C -C Error return. -C - CALL XERBLA( 'SB08MD', -INFO ) - RETURN - END IF -C - IF ( .NOT.LACONA ) THEN - CALL DCOPY( DA+1, A, 1, E, 1 ) - ELSE - W = ZERO - CALL SB08MY( DA, A, E, W ) - END IF -C -C Reduce E such that the first and the last element are non-zero. -C - DA1 = DA + 1 -C -C WHILE ( DA1 >= 1 and E(DA1) = 0 ) DO - 20 IF ( DA1.GE.1 ) THEN - IF ( E(DA1).EQ.ZERO ) THEN - DA1 = DA1 - 1 - GO TO 20 - END IF - END IF -C END WHILE 20 -C - DA1 = DA1 - 1 - IF ( DA1.LT.0 ) THEN - INFO = 1 - RETURN - END IF -C - I0 = 1 -C -C WHILE ( E(I0) = 0 ) DO - 40 IF ( E(I0).EQ.ZERO ) THEN - I0 = I0 + 1 - GO TO 40 - END IF -C END WHILE 40 -C - I0 = I0 - 1 - IF ( I0.NE.0 ) THEN - IF ( MOD( I0, 2 ).EQ.0 ) THEN - SIGNI0 = ONE - ELSE - SIGNI0 = -ONE - END IF -C - DO 60 I = 1, DA1 - I0 + 1 - E(I) = SIGNI0*E(I+I0) - 60 CONTINUE -C - DA1 = DA1 - I0 - END IF - IF ( MOD( DA1, 2 ).EQ.0 ) THEN - SIGNI = ONE - ELSE - SIGNI = -ONE - END IF - NC = DA1 + 1 - IF ( ( E(1).LT.ZERO ) .OR. ( ( E(NC)*SIGNI ).LT.ZERO ) ) THEN - INFO = 2 - RETURN - END IF -C -C Initialization. -C - EPS = DLAMCH( 'Epsilon' ) - SI = ONE/DLAMCH( 'Safe minimum' ) - LQ = 1 - LAY = LQ + NC - LAMBDA = LAY + NC - LPHI = LAMBDA + NC - LDIF = LPHI + NC -C - A0 = E(1) - BINC = 1 -C -C Computation of the starting polynomial and scaling of the input -C polynomial. -C - MU = ( A0/ABS( E(NC) ) )**( ONE/DBLE( DA1 ) ) - MUJ = ONE -C - DO 80 J = 1, NC - W = E(J)*MUJ/A0 - A(J) = W - E(J) = BINC - DWORK(LQ+J-1) = BINC - MUJ = MUJ*MU - BINC = BINC*( NC - J )/J - 80 CONTINUE -C - CONV = .FALSE. - STABLE = .TRUE. -C -C The contents of the arrays is, cf [1], -C -C E : the last computed stable polynomial q ; -C i-1 -C DWORK(LAY+1,...,LAY+DA1-1) : a'(1), ..., a'(DA1-1), these values -C are changed during the computation -C into y; -C (LAMBDA+1,...,LAMBDA+DA1-2) : lambda(1), ..., lambda(DA1-2), -C the factors of the Routh -C stability test, (lambda(i) is -C P(i) in [1]); -C (LPHI+1,...,LPHI+DA1-1) : phi(1), ..., phi(DA1-1), the values -C phi(i,j), see [1], scheme (11); -C (LDIF,...,LDIF+DA1) : the coeffs of q (-s) * q (s) - b(s). -C i i -C DWORK(LQ,...,LQ+DA1) : the last computed polynomial q . -C i - I = 0 -C -C WHILE ( I < 30 and CONV = FALSE and STABLE = TRUE ) DO - 100 IF ( I.LT.30 .AND. .NOT.CONV .AND. STABLE ) THEN - I = I + 1 - CALL DCOPY( NC, A, 1, DWORK(LAY), 1 ) - CALL DCOPY( NC, DWORK(LQ), 1, DWORK(LPHI), 1 ) - M = DA1/2 - LAYEND = LAY + DA1 - LPHEND = LPHI + DA1 - XDA = A(NC)/DWORK(LQ+DA1) -C - DO 120 K = 1, M - DWORK(LAY+K) = DWORK(LAY+K) - DWORK(LPHI+2*K) - DWORK(LAYEND-K) = DWORK(LAYEND-K) - DWORK(LPHEND-2*K)*XDA - 120 CONTINUE -C -C Computation of lambda(k) and y(k). -C - K = 1 -C -C WHILE ( K <= DA1 - 2 and STABLE = TRUE ) DO - 140 IF ( ( K.LE.( DA1 - 2 ) ) .AND. STABLE ) THEN - IF ( DWORK(LPHI+K).LE.ZERO ) STABLE = .FALSE. - IF ( STABLE ) THEN - W = DWORK(LPHI+K-1)/DWORK(LPHI+K) - DWORK(LAMBDA+K) = W - CALL DAXPY( ( DA1 - K )/2, -W, DWORK(LPHI+K+2), 2, - $ DWORK(LPHI+K+1), 2 ) - W = DWORK(LAY+K)/DWORK(LPHI+K) - DWORK(LAY+K) = W - CALL DAXPY( ( DA1 - K )/2, -W, DWORK(LPHI+K+2), 2, - $ DWORK(LAY+K+1), 1 ) - K = K + 1 - END IF - GO TO 140 - END IF -C END WHILE 140 -C - IF ( DWORK(LPHI+DA1-1).LE.ZERO ) THEN - STABLE = .FALSE. - ELSE - DWORK(LAY+DA1-1) = DWORK(LAY+DA1-1)/DWORK(LPHI+DA1-1) - END IF -C -C STABLE = The polynomial q is stable. -C i-1 - IF ( STABLE ) THEN -C -C Computation of x and q . -C i i -C - DO 160 K = DA1 - 2, 1, -1 - W = DWORK(LAMBDA+K) - CALL DAXPY( ( DA1 - K )/2, -W, DWORK(LAY+K+1), 2, - $ DWORK(LAY+K), 2 ) - 160 CONTINUE -C - DWORK(LAY+DA1) = XDA -C - CALL DCOPY( NC, DWORK(LQ), 1, E, 1 ) - SIMIN1 = SI - SI = DWORK(LQ) - SIGNJ = -ONE -C - DO 180 J = 1, DA1 - W = HALF*( DWORK(LQ+J) + SIGNJ*DWORK(LAY+J) ) - DWORK(LQ+J) = W - SI = SI + W - SIGNJ = -SIGNJ - 180 CONTINUE -C - TOLPHI = EPS - CALL SB08MY( DA1, E, DWORK(LDIF), TOLPHI ) - CALL DAXPY( NC, -ONE, A, 1, DWORK(LDIF), 1 ) - RES = ABS( DWORK( IDAMAX( NC, DWORK(LDIF), 1 ) + LDIF-1 ) ) -C -C Convergency test. -C - IF ( ( SI.GT.SIMIN1 ) .OR. ( RES.LT.TOLPHI ) ) THEN - CONV = .TRUE. - END IF - GO TO 100 - END IF - END IF -C END WHILE 100 -C -C Backscaling. -C - MU = ONE/MU - SQRTA0 = SQRT( A0 ) - SQRTMU = SQRT( MU ) - MUJ = ONE - SQRTMJ = ONE -C - DO 200 J = 1, NC - E(J) = E(J)*SQRTA0*SQRTMJ - A(J) = A(J)*A0*MUJ - MUJ = MUJ*MU - SQRTMJ = SQRTMJ*SQRTMU - 200 CONTINUE -C - IF ( I0.NE.0 ) THEN -C - DO 220 J = NC, 1, -1 - E(I0+J) = E(J) - A(I0+J) = SIGNI0*A(J) - 220 CONTINUE -C - DO 240 J = 1, I0 - E(J) = ZERO - A(J) = ZERO - 240 CONTINUE -C - END IF -C - IF ( .NOT.CONV ) THEN - IF ( STABLE ) THEN - INFO = 3 - ELSE - INFO = 4 - END IF - END IF -C - RETURN -C *** Last line of SB08MD *** - END diff --git a/mex/sources/libslicot/SB08MY.f b/mex/sources/libslicot/SB08MY.f deleted file mode 100644 index 085be630a..000000000 --- a/mex/sources/libslicot/SB08MY.f +++ /dev/null @@ -1,102 +0,0 @@ - SUBROUTINE SB08MY( DA, A, B, EPSB ) -C -C SLICOT RELEASE 5.0. -C -C Copyright (c) 2002-2009 NICONET e.V. -C -C This program is free software: you can redistribute it and/or -C modify it under the terms of the GNU General Public License as -C published by the Free Software Foundation, either version 2 of -C the License, or (at your option) any later version. -C -C This program is distributed in the hope that it will be useful, -C but WITHOUT ANY WARRANTY; without even the implied warranty of -C MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the -C GNU General Public License for more details. -C -C You should have received a copy of the GNU General Public License -C along with this program. If not, see -C . -C -C PURPOSE -C -C To compute the coefficients of B(s) = A(s) * A(-s) and a norm -C for the accuracy of the computed coefficients. -C -C ARGUMENTS -C -C Input/Output Parameters -C -C DA (input) INTEGER -C The degree of the polynomials A(s) and B(s). DA >= 0. -C -C A (input) DOUBLE PRECISION array, dimension (DA+1) -C This array must contain the coefficients of the polynomial -C A(s) in increasing powers of s. -C -C B (output) DOUBLE PRECISION array, dimension (DA+1) -C This array contains the coefficients of the polynomial -C B(s) in increasing powers of s**2. -C -C EPSB (input/output) DOUBLE PRECISION -C On entry, EPSB must contain the machine precision (see -C LAPACK Library routine DLAMCH). -C On exit, EPSB contains an updated value, using a norm -C for the accuracy of the computed coefficients. -C -C CONTRIBUTOR -C -C Release 3.0: V. Sima, Katholieke Univ. Leuven, Belgium, Aug. 1997. -C Supersedes Release 2.0 routine SB08AZ by A.J. Geurts. -C -C REVISIONS -C -C - -C -C KEYWORDS -C -C Laplace transform, polynomial operations, spectral factorization. -C -C ****************************************************************** -C -C .. Parameters .. - DOUBLE PRECISION ZERO, ONE, TWO, THREE - PARAMETER ( ZERO = 0.0D0, ONE = 1.0D0, TWO=2.0D0, - $ THREE = 3.0D0 ) -C .. Scalar Arguments .. - INTEGER DA - DOUBLE PRECISION EPSB -C .. Array Arguments .. - DOUBLE PRECISION A(*), B(*) -C .. Local Scalars .. - INTEGER I, K - DOUBLE PRECISION MAXSA, SA, SABS, SIGNI, SIGNK, TERM -C .. Intrinsic Functions .. - INTRINSIC ABS, MAX, MIN -C .. Executable Statements .. -C - SIGNI = ONE - MAXSA = ZERO -C - DO 40 I = 0, DA - SABS = A(I+1)**2 - SA = SIGNI*SABS - SIGNK = -TWO*SIGNI -C - DO 20 K = 1, MIN( I, DA - I ) - TERM = SIGNK*A(I-K+1)*A(I+K+1) - SA = SA + TERM - SABS = SABS + ABS( TERM ) - SIGNK = -SIGNK - 20 CONTINUE -C - B(I+1) = SA - MAXSA = MAX( MAXSA, SABS ) - SIGNI = -SIGNI - 40 CONTINUE -C - EPSB = THREE*MAXSA*EPSB -C - RETURN -C *** Last line of SB08MY *** - END diff --git a/mex/sources/libslicot/SB08ND.f b/mex/sources/libslicot/SB08ND.f deleted file mode 100644 index ced79b329..000000000 --- a/mex/sources/libslicot/SB08ND.f +++ /dev/null @@ -1,382 +0,0 @@ - SUBROUTINE SB08ND( ACONA, DA, A, RES, E, DWORK, LDWORK, INFO ) -C -C SLICOT RELEASE 5.0. -C -C Copyright (c) 2002-2009 NICONET e.V. -C -C This program is free software: you can redistribute it and/or -C modify it under the terms of the GNU General Public License as -C published by the Free Software Foundation, either version 2 of -C the License, or (at your option) any later version. -C -C This program is distributed in the hope that it will be useful, -C but WITHOUT ANY WARRANTY; without even the implied warranty of -C MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the -C GNU General Public License for more details. -C -C You should have received a copy of the GNU General Public License -C along with this program. If not, see -C . -C -C PURPOSE -C -C To compute a real polynomial E(z) such that -C -C (a) E(1/z) * E(z) = A(1/z) * A(z) and -C (b) E(z) is stable - that is, E(z) has no zeros with modulus -C greater than 1, -C -C which corresponds to computing the spectral factorization of the -C real polynomial A(z) arising from discrete optimality problems. -C -C The input polynomial may be supplied either in the form -C -C A(z) = a(0) + a(1) * z + ... + a(DA) * z**DA -C -C or as -C -C B(z) = A(1/z) * A(z) -C = b(0) + b(1) * (z + 1/z) + ... + b(DA) * (z**DA + 1/z**DA) -C (1) -C -C ARGUMENTS -C -C Mode Parameters -C -C ACONA CHARACTER*1 -C Indicates whether the coefficients of A(z) or B(z) = -C A(1/z) * A(z) are to be supplied as follows: -C = 'A': The coefficients of A(z) are to be supplied; -C = 'B': The coefficients of B(z) are to be supplied. -C -C Input/Output Parameters -C -C DA (input) INTEGER -C The degree of the polynomials A(z) and E(z). DA >= 0. -C -C A (input/output) DOUBLE PRECISION array, dimension (DA+1) -C On entry, if ACONA = 'A', this array must contain the -C coefficients of the polynomial A(z) in increasing powers -C of z, and if ACONA = 'B', this array must contain the -C coefficients b ,b ,...,b of the polynomial B(z) in -C 0 1 DA -C equation (1). That is, A(i) = b for i = 1,2,...,DA+1. -C i-1 -C On exit, this array contains the coefficients of the -C polynomial B(z) in eqation (1). Specifically, A(i) -C contains b , for i = 1,2,...DA+1. -C i-1 -C -C RES (output) DOUBLE PRECISION -C An estimate of the accuracy with which the coefficients of -C the polynomial E(z) have been computed (see also METHOD -C and NUMERICAL ASPECTS). -C -C E (output) DOUBLE PRECISION array, dimension (DA+1) -C The coefficients of the spectral factor E(z) in increasing -C powers of z. -C -C Workspace -C -C DWORK DOUBLE PRECISION array, dimension (LDWORK) -C -C LDWORK INTEGER -C The length of the array DWORK. LDWORK >= 5*DA+5. -C -C Error Indicator -C -C INFO INTEGER -C = 0: successful exit; -C < 0: if INFO = -i, the i-th argument had an illegal -C value; -C = 2: if on entry, ACONA = 'B' but the supplied -C coefficients of the polynomial B(z) are not the -C coefficients of A(1/z) * A(z) for some real A(z); -C in this case, RES and E are unassigned; -C = 3: if the iterative process (see METHOD) has failed to -C converge in 30 iterations; -C = 4: if the last computed iterate (see METHOD) is -C unstable. If ACONA = 'B', then the supplied -C coefficients of the polynomial B(z) may not be the -C coefficients of A(1/z) * A(z) for some real A(z). -C -C METHOD -C _ _ -C Let A(z) be the conjugate polynomial of A(z), i.e., A(z) = A(1/z). -C -C The method used by the routine is based on applying the -C Newton-Raphson iteration to the function -C _ _ -C F(e) = A * A - e * e, -C -C which leads to the iteration formulae (see [1] and [2]) -C -C _(i) (i) _(i) (i) _ ) -C q * x + x * q = 2 A * A ) -C ) for i = 0, 1, 2,... -C (i+1) (i) (i) ) -C q = (q + x )/2 ) -C -C The iteration starts from -C -C (0) DA -C q (z) = (b(0) + b(1) * z + ... + b(DA) * z ) / SQRT( b(0)) -C -C which is a Hurwitz polynomial that has no zeros in the closed unit -C (i) -C circle (see [2], Theorem 3). Then lim q = e, the convergence is -C uniform and e is a Hurwitz polynomial. -C -C The iterates satisfy the following conditions: -C (i) -C (a) q has no zeros in the closed unit circle, -C (i) (i-1) -C (b) q <= q and -C 0 0 -C DA (i) 2 DA 2 -C (c) SUM (q ) - SUM (A ) >= 0. -C k=0 k k=0 k -C (i) -C The iterative process stops if q violates (a), (b) or (c), -C or if the condition -C _(i) (i) _ -C (d) RES = ||(q q - A A)|| < tol, -C -C is satisfied, where || . || denotes the largest coefficient of -C _(i) (i) _ -C the polynomial (q q - A A) and tol is an estimate of the -C _(i) (i) -C rounding error in the computed coefficients of q q . If -C (i-1) -C condition (a) or (b) is violated then q is taken otherwise -C (i) -C q is used. Thus the computed reciprocal polynomial E(z) = z**DA -C * q(1/z) is stable. If there is no convergence after 30 iterations -C then the routine returns with the Error Indicator (INFO) set to 3, -C and the value of RES may indicate whether or not the last computed -C iterate is close to the solution. -C (0) -C If ACONA = 'B', then it is possible that q is not a Hurwitz -C polynomial, in which case the equation e(1/z) * e(z) = B(z) has no -C real solution (see [2], Theorem 3). -C -C REFERENCES -C -C [1] Kucera, V. -C Discrete Linear Control, The polynomial Approach. -C John Wiley & Sons, Chichester, 1979. -C -C [2] Vostry, Z. -C New Algorithm for Polynomial Spectral Factorization with -C Quadratic Convergence I. -C Kybernetika, 11, pp. 415-422, 1975. -C -C NUMERICAL ASPECTS -C -C None. -C -C CONTRIBUTORS -C -C Release 3.0: V. Sima, Katholieke Univ. Leuven, Belgium, Aug. 1997. -C Supersedes Release 2.0 routine SB08BD by F. Delebecque and -C A.J. Geurts. -C -C REVISIONS -C -C - -C -C KEYWORDS -C -C Factorization, Laplace transform, optimal control, optimal -C filtering, polynomial operations, spectral factorization, zeros. -C -C ****************************************************************** -C -C .. Parameters .. - DOUBLE PRECISION ZERO, HALF, ONE, TWO - PARAMETER ( ZERO = 0.0D0, HALF = 0.5D0, ONE = 1.0D0, - $ TWO = 2.0D0 ) -C .. Scalar Arguments .. - CHARACTER ACONA - INTEGER DA, INFO, LDWORK - DOUBLE PRECISION RES -C .. Array Arguments .. - DOUBLE PRECISION A(*), DWORK(*), E(*) -C .. Local Scalars .. - LOGICAL CONV, HURWTZ, LACONA - INTEGER I, J, K, LALPHA, LAMBDA, LETA, LQ, LRO, NC, NCK - DOUBLE PRECISION A0, RES0, S, SA0, TOLQ, W -C .. External Functions .. - LOGICAL LSAME - INTEGER IDAMAX - EXTERNAL IDAMAX, LSAME -C .. External Subroutines .. - EXTERNAL DAXPY, DCOPY, DSCAL, DSWAP, SB08NY, XERBLA -C .. Intrinsic Functions .. - INTRINSIC ABS, SQRT -C .. Executable Statements .. -C - INFO = 0 - LACONA = LSAME( ACONA, 'A' ) -C -C Test the input scalar arguments. -C - IF( .NOT.LACONA .AND. .NOT.LSAME( ACONA, 'B' ) ) THEN - INFO = -1 - ELSE IF( DA.LT.0 ) THEN - INFO = -2 - ELSE IF( LDWORK.LT.5*DA + 5 ) THEN - INFO = -7 - END IF -C - IF ( INFO.NE.0 ) THEN -C -C Error return. -C - CALL XERBLA( 'SB08ND', -INFO ) - RETURN - END IF -C - NC = DA + 1 - IF ( .NOT.LACONA ) THEN - IF ( A(1).LE.ZERO ) THEN - INFO = 2 - RETURN - END IF - CALL DCOPY( NC, A, 1, E, 1 ) - ELSE - CALL SB08NY( DA, A, E, W ) - END IF -C -C Initialization. -C - LALPHA = 1 - LRO = LALPHA + NC - LETA = LRO + NC - LAMBDA = LETA + NC - LQ = LAMBDA + NC -C - A0 = E(1) - SA0 = SQRT( A0 ) - S = ZERO -C - DO 20 J = 1, NC - W = E(J) - A(J) = W - W = W/SA0 - E(J) = W - DWORK(LQ-1+J) = W - S = S + W**2 - 20 CONTINUE -C - RES0 = S - A0 -C -C The contents of the arrays is, cf [1], Section 7.6, -C -C E : the last computed Hurwitz polynomial q ; -C i-1 -C DWORK(LALPHA,..,LALPHA+DA-K) : alpha(k,0),...alpha(k,n-k); -C (LRO,...,LRO+DA-K) : alpha(k,n-k),...,alpha(k); -C (LETA,...,LETA+DA) : eta(0),...,eta(n); -C (LAMBDA,...,LAMBDA+DA-1) : lambda(0),...,lambda(n-1) -C -C DWORK(LQ,...,LQ+DA) : the last computed polynomial q . -C i - I = 0 - CONV = .FALSE. - HURWTZ = .TRUE. -C -C WHILE ( I < 30 and CONV = FALSE and HURWTZ = TRUE ) DO - 40 IF ( I.LT.30 .AND. .NOT.CONV .AND. HURWTZ ) THEN - I = I + 1 - CALL DCOPY( NC, A, 1, DWORK(LETA), 1 ) - CALL DSCAL( NC, TWO, DWORK(LETA), 1 ) - CALL DCOPY( NC, DWORK(LQ), 1, DWORK(LALPHA), 1 ) -C -C Computation of lambda(k) and eta(k). -C - K = 1 -C -C WHILE ( K <= DA and HURWTZ = TRUE ) DO - 60 IF ( ( K.LE.DA ) .AND. HURWTZ ) THEN - NCK = NC - K - CALL DCOPY( NCK+1, DWORK(LALPHA), -1, DWORK(LRO), 1 ) - W = DWORK(LALPHA+NCK)/DWORK(LRO+NCK) - IF ( ABS( W ).GE.ONE ) HURWTZ = .FALSE. - IF ( HURWTZ ) THEN - DWORK(LAMBDA+K-1) = W - CALL DAXPY( NCK, -W, DWORK(LRO), 1, DWORK(LALPHA), 1 ) - W = DWORK(LETA+NCK)/DWORK(LALPHA) - DWORK(LETA+NCK) = W - CALL DAXPY( NCK-1, -W, DWORK(LALPHA+1), -1, - $ DWORK(LETA+1), 1 ) - K = K + 1 - END IF - GO TO 60 - END IF -C END WHILE 60 -C -C HURWTZ = The polynomial q is a Hurwitz polynomial. -C i-1 - IF ( HURWTZ ) THEN - CALL DCOPY( NC, DWORK(LQ), 1, E, 1 ) -C -C Accuracy test. -C - CALL SB08NY( DA, E, DWORK(LQ), TOLQ ) - CALL DAXPY( NC, -ONE, A, 1, DWORK(LQ), 1 ) - RES = ABS( DWORK( IDAMAX( NC, DWORK(LQ), 1 ) + LQ - 1 ) ) - CONV = ( RES.LT.TOLQ ) .OR. ( RES0.LT.ZERO ) -C - IF ( .NOT.CONV ) THEN - DWORK(LETA) = HALF*DWORK(LETA)/DWORK(LALPHA) -C -C Computation of x and q . -C i i -C DWORK(LETA,...,LETA+DA) : eta(k,0),...,eta(k,n) -C (LRO,...,LRO+DA-K+1) : eta(k,n-k+1),...,eta(k,0) -C - DO 80 K = DA, 1, -1 - NCK = NC - K + 1 - CALL DCOPY( NCK, DWORK(LETA), -1, DWORK(LRO), 1 ) - W = DWORK(LAMBDA+K-1) - CALL DAXPY( NCK, -W, DWORK(LRO), 1, DWORK(LETA), 1 ) - 80 CONTINUE -C - S = ZERO -C - DO 100 J = 0, DA - W = HALF*( DWORK(LETA+J) + E(J+1) ) - DWORK(LQ+J) = W - S = S + W**2 - 100 CONTINUE -C - RES0 = S - A0 -C -C Test on the monotonicity of q . -C 0 - CONV = DWORK(LQ).GT.E(1) - GO TO 40 - END IF - END IF - END IF -C END WHILE 40 -C -C Reverse the order of the coefficients in the array E. -C - CALL DSWAP( NC, E, 1, DWORK, -1 ) - CALL DSWAP( NC, DWORK, 1, E, 1 ) -C - IF ( .NOT.CONV ) THEN - IF ( HURWTZ ) THEN - INFO = 3 - ELSE IF ( I.EQ.1 ) THEN - INFO = 2 - ELSE - INFO = 4 - END IF - END IF -C - RETURN -C *** Last line of SB08ND *** - END diff --git a/mex/sources/libslicot/SB08NY.f b/mex/sources/libslicot/SB08NY.f deleted file mode 100644 index f6c0cb668..000000000 --- a/mex/sources/libslicot/SB08NY.f +++ /dev/null @@ -1,83 +0,0 @@ - SUBROUTINE SB08NY( DA, A, B, EPSB ) -C -C SLICOT RELEASE 5.0. -C -C Copyright (c) 2002-2009 NICONET e.V. -C -C This program is free software: you can redistribute it and/or -C modify it under the terms of the GNU General Public License as -C published by the Free Software Foundation, either version 2 of -C the License, or (at your option) any later version. -C -C This program is distributed in the hope that it will be useful, -C but WITHOUT ANY WARRANTY; without even the implied warranty of -C MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the -C GNU General Public License for more details. -C -C You should have received a copy of the GNU General Public License -C along with this program. If not, see -C . -C -C PURPOSE -C -C To compute the coefficients of B(z) = A(1/z) * A(z) and a norm for -C the accuracy of the computed coefficients. -C -C ARGUMENTS -C -C Input/Output Parameters -C -C DA (input) INTEGER -C The degree of the polynomials A(z) and B(z). DA >= 0. -C -C A (input) DOUBLE PRECISION array, dimension (DA+1) -C This array must contain the coefficients of the polynomial -C A(z) in increasing powers of z. -C -C B (output) DOUBLE PRECISION array, dimension (DA+1) -C This array contains the coefficients of the polynomial -C B(z). -C -C EPSB (output) DOUBLE PRECISION -C A value used for checking the accuracy of the computed -C coefficients. -C -C CONTRIBUTOR -C -C Release 3.0: V. Sima, Katholieke Univ. Leuven, Belgium, Aug. 1997. -C Supersedes Release 2.0 routine SB08BZ by A.J. Geurts. -C -C REVISIONS -C -C - -C -C KEYWORDS -C -C Laplace transform, polynomial operations, spectral factorization. -C -C ****************************************************************** -C -C .. Parameters .. - DOUBLE PRECISION THREE - PARAMETER ( THREE = 3.0D0 ) -C .. Scalar Arguments .. - INTEGER DA - DOUBLE PRECISION EPSB -C .. Array Arguments .. - DOUBLE PRECISION A(*), B(*) -C .. Local Scalars .. - INTEGER I -C .. External Functions .. - DOUBLE PRECISION DDOT, DLAMCH - EXTERNAL DDOT, DLAMCH -C .. Executable Statements .. -C - DO 20 I = 1, DA + 1 - B(I) = DDOT( DA-I+2, A(1), 1, A(I), 1 ) - 20 CONTINUE -C - EPSB = THREE*DLAMCH( 'Epsilon' )*B(1) -C - RETURN -C *** Last line of SB08NY *** - END diff --git a/mex/sources/libslicot/SB09MD.f b/mex/sources/libslicot/SB09MD.f deleted file mode 100644 index edb0e2d1a..000000000 --- a/mex/sources/libslicot/SB09MD.f +++ /dev/null @@ -1,251 +0,0 @@ - SUBROUTINE SB09MD( N, NC, NB, H1, LDH1, H2, LDH2, SS, LDSS, SE, - $ LDSE, PRE, LDPRE, TOL, INFO ) -C -C SLICOT RELEASE 5.0. -C -C Copyright (c) 2002-2009 NICONET e.V. -C -C This program is free software: you can redistribute it and/or -C modify it under the terms of the GNU General Public License as -C published by the Free Software Foundation, either version 2 of -C the License, or (at your option) any later version. -C -C This program is distributed in the hope that it will be useful, -C but WITHOUT ANY WARRANTY; without even the implied warranty of -C MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the -C GNU General Public License for more details. -C -C You should have received a copy of the GNU General Public License -C along with this program. If not, see -C . -C -C PURPOSE -C -C To compare two multivariable sequences M1(k) and M2(k) for -C k = 1,2,...,N, and evaluate their closeness. Each of the -C parameters M1(k) and M2(k) is an NC by NB matrix. -C -C ARGUMENTS -C -C Input/Output Parameters -C -C N (input) INTEGER -C The number of parameters. N >= 0. -C -C NC (input) INTEGER -C The number of rows in M1(k) and M2(k). NC >= 0. -C -C NB (input) INTEGER -C The number of columns in M1(k) and M2(k). NB >= 0. -C -C H1 (input) DOUBLE PRECISION array, dimension (LDH1,N*NB) -C The leading NC-by-N*NB part of this array must contain -C the multivariable sequence M1(k), where k = 1,2,...,N. -C Each parameter M1(k) is an NC-by-NB matrix, whose -C (i,j)-th element must be stored in H1(i,(k-1)*NB+j) for -C i = 1,2,...,NC and j = 1,2,...,NB. -C -C LDH1 INTEGER -C The leading dimension of array H1. LDH1 >= MAX(1,NC). -C -C H2 (input) DOUBLE PRECISION array, dimension (LDH2,N*NB) -C The leading NC-by-N*NB part of this array must contain -C the multivariable sequence M2(k), where k = 1,2,...,N. -C Each parameter M2(k) is an NC-by-NB matrix, whose -C (i,j)-th element must be stored in H2(i,(k-1)*NB+j) for -C i = 1,2,...,NC and j = 1,2,...,NB. -C -C LDH2 INTEGER -C The leading dimension of array H2. LDH2 >= MAX(1,NC). -C -C SS (output) DOUBLE PRECISION array, dimension (LDSS,NB) -C The leading NC-by-NB part of this array contains the -C matrix SS. -C -C LDSS INTEGER -C The leading dimension of array SS. LDSS >= MAX(1,NC). -C -C SE (output) DOUBLE PRECISION array, dimension (LDSE,NB) -C The leading NC-by-NB part of this array contains the -C quadratic error matrix SE. -C -C LDSE INTEGER -C The leading dimension of array SE. LDSE >= MAX(1,NC). -C -C PRE (output) DOUBLE PRECISION array, dimension (LDPRE,NB) -C The leading NC-by-NB part of this array contains the -C percentage relative error matrix PRE. -C -C LDPRE INTEGER -C The leading dimension of array PRE. LDPRE >= MAX(1,NC). -C -C Tolerances -C -C TOL DOUBLE PRECISION -C The tolerance to be used in the computation of the error -C matrices SE and PRE. If the user sets TOL to be less than -C EPS then the tolerance is taken as EPS, where EPS is the -C machine precision (see LAPACK Library routine DLAMCH). -C -C Error Indicator -C -C INFO INTEGER -C = 0: successful exit; -C < 0: if INFO = -i, the i-th argument had an illegal -C value. -C -C METHOD -C -C The (i,j)-th element of the matrix SS is defined by: -C N 2 -C SS = SUM M1 (k) . (1) -C ij k=1 ij -C -C The (i,j)-th element of the quadratic error matrix SE is defined -C by: -C N 2 -C SE = SUM (M1 (k) - M2 (k)) . (2) -C ij k=1 ij ij -C -C The (i,j)-th element of the percentage relative error matrix PRE -C is defined by: -C -C PRE = 100 x SQRT( SE / SS ). (3) -C ij ij ij -C -C The following precautions are taken by the routine to guard -C against underflow and overflow: -C -C (i) if ABS( M1 (k) ) > 1/TOL or ABS( M1 (k) - M2 (k) ) > 1/TOL, -C ij ij ij -C -C then SE and SS are set to 1/TOL and PRE is set to 1; and -C ij ij ij -C -C (ii) if ABS( SS ) <= TOL, then PRE is set to 100. -C ij ij -C -C NUMERICAL ASPECTS -C -C The algorithm requires approximately -C 2xNBxNCx(N+1) multiplications/divisions, -C 4xNBxNCxN additions/subtractions and -C NBxNC square roots. -C -C CONTRIBUTOR -C -C Release 3.0: V. Sima, Katholieke Univ. Leuven, Belgium, Aug. 1997. -C Supersedes Release 2.0 routine SB09AD by S. Van Huffel, Katholieke -C University Leuven, Belgium. -C -C REVISIONS -C -C - -C -C KEYWORDS -C -C Closeness multivariable sequences, elementary matrix operations, -C real signals, system response. -C -C ****************************************************************** -C -C .. Parameters .. - DOUBLE PRECISION ZERO, ONE, HUNDRD - PARAMETER ( ZERO = 0.0D0, ONE = 1.0D0, HUNDRD = 100.0D0 ) -C .. Scalar Arguments .. - INTEGER INFO, LDH1, LDH2, LDPRE, LDSE, LDSS, N, NB, NC - DOUBLE PRECISION TOL -C .. Array Arguments .. - DOUBLE PRECISION H1(LDH1,*), H2(LDH2,*), PRE(LDPRE,*), - $ SE(LDSE,*), SS(LDSS,*) -C .. Local Scalars .. - LOGICAL NOFLOW - INTEGER I, J, K - DOUBLE PRECISION EPSO, SSE, SSS, TOLER, VAR, VARE -C .. External Functions .. - DOUBLE PRECISION DLAMCH - EXTERNAL DLAMCH -C .. External Subroutines .. - EXTERNAL XERBLA -C .. Intrinsic Functions .. - INTRINSIC ABS, MAX, SQRT -C .. Executable Statements .. -C - INFO = 0 -C -C Test the input scalar arguments. -C - IF( N.LT.0 ) THEN - INFO = -1 - ELSE IF( NC.LT.0 ) THEN - INFO = -2 - ELSE IF( NB.LT.0 ) THEN - INFO = -3 - ELSE IF( LDH1.LT.MAX( 1, NC ) ) THEN - INFO = -5 - ELSE IF( LDH2.LT.MAX( 1, NC ) ) THEN - INFO = -7 - ELSE IF( LDSS.LT.MAX( 1, NC ) ) THEN - INFO = -9 - ELSE IF( LDSE.LT.MAX( 1, NC ) ) THEN - INFO = -11 - ELSE IF( LDPRE.LT.MAX( 1, NC ) ) THEN - INFO = -13 - END IF -C - IF ( INFO.NE.0 ) THEN -C -C Error return. -C - CALL XERBLA( 'SB09MD', -INFO ) - RETURN - END IF -C -C Quick return if possible. -C - IF ( N.EQ.0 .OR. NC.EQ.0 .OR. NB.EQ.0 ) - $ RETURN -C - TOLER = MAX( TOL, DLAMCH( 'Epsilon' ) ) - EPSO = ONE/TOLER -C - DO 60 J = 1, NB -C - DO 40 I = 1, NC - SSE = ZERO - SSS = ZERO - NOFLOW = .TRUE. - K = 0 -C -C WHILE ( ( NOFLOW .AND. ( K .LT. N*NB ) ) DO - 20 IF ( ( NOFLOW ) .AND. ( K.LT.N*NB ) ) THEN - VAR = H1(I,K+J) - VARE = H2(I,K+J) - VAR - IF ( ABS( VAR ).GT.EPSO .OR. ABS( VARE ).GT.EPSO ) - $ THEN - SE(I,J) = EPSO - SS(I,J) = EPSO - PRE(I,J) = ONE - NOFLOW = .FALSE. - ELSE - IF ( ABS( VARE ).GT.TOLER ) SSE = SSE + VARE*VARE - IF ( ABS( VAR ).GT.TOLER ) SSS = SSS + VAR*VAR - K = K + NB - END IF - GO TO 20 - END IF -C END WHILE 20 -C - IF ( NOFLOW ) THEN - SE(I,J) = SSE - SS(I,J) = SSS - PRE(I,J) = HUNDRD - IF ( SSS.GT.TOLER ) PRE(I,J) = SQRT( SSE/SSS )*HUNDRD - END IF - 40 CONTINUE -C - 60 CONTINUE -C - RETURN -C *** Last line of SB09MD *** - END diff --git a/mex/sources/libslicot/SB10AD.f b/mex/sources/libslicot/SB10AD.f deleted file mode 100644 index a74b3a8ee..000000000 --- a/mex/sources/libslicot/SB10AD.f +++ /dev/null @@ -1,827 +0,0 @@ - SUBROUTINE SB10AD( JOB, N, M, NP, NCON, NMEAS, GAMMA, A, LDA, - $ B, LDB, C, LDC, D, LDD, AK, LDAK, BK, LDBK, CK, - $ LDCK, DK, LDDK, AC, LDAC, BC, LDBC, CC, LDCC, - $ DC, LDDC, RCOND, GTOL, ACTOL, IWORK, LIWORK, - $ DWORK, LDWORK, BWORK, LBWORK, INFO ) -C -C SLICOT RELEASE 5.0. -C -C Copyright (c) 2002-2009 NICONET e.V. -C -C This program is free software: you can redistribute it and/or -C modify it under the terms of the GNU General Public License as -C published by the Free Software Foundation, either version 2 of -C the License, or (at your option) any later version. -C -C This program is distributed in the hope that it will be useful, -C but WITHOUT ANY WARRANTY; without even the implied warranty of -C MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the -C GNU General Public License for more details. -C -C You should have received a copy of the GNU General Public License -C along with this program. If not, see -C . -C -C PURPOSE -C -C To compute the matrices of an H-infinity optimal n-state -C controller -C -C | AK | BK | -C K = |----|----|, -C | CK | DK | -C -C using modified Glover's and Doyle's 1988 formulas, for the system -C -C | A | B1 B2 | | A | B | -C P = |----|---------| = |---|---| -C | C1 | D11 D12 | | C | D | -C | C2 | D21 D22 | -C -C and for the estimated minimal possible value of gamma with respect -C to GTOL, where B2 has as column size the number of control inputs -C (NCON) and C2 has as row size the number of measurements (NMEAS) -C being provided to the controller, and then to compute the matrices -C of the closed-loop system -C -C | AC | BC | -C G = |----|----|, -C | CC | DC | -C -C if the stabilizing controller exists. -C -C It is assumed that -C -C (A1) (A,B2) is stabilizable and (C2,A) is detectable, -C -C (A2) D12 is full column rank and D21 is full row rank, -C -C (A3) | A-j*omega*I B2 | has full column rank for all omega, -C | C1 D12 | -C -C (A4) | A-j*omega*I B1 | has full row rank for all omega. -C | C2 D21 | -C -C ARGUMENTS -C -C Input/Output Parameters -C -C JOB (input) INTEGER -C Indicates the strategy for reducing the GAMMA value, as -C follows: -C = 1: Use bisection method for decreasing GAMMA from GAMMA -C to GAMMAMIN until the closed-loop system leaves -C stability. -C = 2: Scan from GAMMA to 0 trying to find the minimal GAMMA -C for which the closed-loop system retains stability. -C = 3: First bisection, then scanning. -C = 4: Find suboptimal controller only. -C -C N (input) INTEGER -C The order of the system. N >= 0. -C -C M (input) INTEGER -C The column size of the matrix B. M >= 0. -C -C NP (input) INTEGER -C The row size of the matrix C. NP >= 0. -C -C NCON (input) INTEGER -C The number of control inputs (M2). M >= NCON >= 0, -C NP-NMEAS >= NCON. -C -C NMEAS (input) INTEGER -C The number of measurements (NP2). NP >= NMEAS >= 0, -C M-NCON >= NMEAS. -C -C GAMMA (input/output) DOUBLE PRECISION -C The initial value of gamma on input. It is assumed that -C gamma is sufficiently large so that the controller is -C admissible. GAMMA >= 0. -C On output it contains the minimal estimated gamma. -C -C A (input) DOUBLE PRECISION array, dimension (LDA,N) -C The leading N-by-N part of this array must contain the -C system state matrix A. -C -C LDA INTEGER -C The leading dimension of the array A. LDA >= max(1,N). -C -C B (input) DOUBLE PRECISION array, dimension (LDB,M) -C The leading N-by-M part of this array must contain the -C system input matrix B. -C -C LDB INTEGER -C The leading dimension of the array B. LDB >= max(1,N). -C -C C (input) DOUBLE PRECISION array, dimension (LDC,N) -C The leading NP-by-N part of this array must contain the -C system output matrix C. -C -C LDC INTEGER -C The leading dimension of the array C. LDC >= max(1,NP). -C -C D (input) DOUBLE PRECISION array, dimension (LDD,M) -C The leading NP-by-M part of this array must contain the -C system input/output matrix D. -C -C LDD INTEGER -C The leading dimension of the array D. LDD >= max(1,NP). -C -C AK (output) DOUBLE PRECISION array, dimension (LDAK,N) -C The leading N-by-N part of this array contains the -C controller state matrix AK. -C -C LDAK INTEGER -C The leading dimension of the array AK. LDAK >= max(1,N). -C -C BK (output) DOUBLE PRECISION array, dimension (LDBK,NMEAS) -C The leading N-by-NMEAS part of this array contains the -C controller input matrix BK. -C -C LDBK INTEGER -C The leading dimension of the array BK. LDBK >= max(1,N). -C -C CK (output) DOUBLE PRECISION array, dimension (LDCK,N) -C The leading NCON-by-N part of this array contains the -C controller output matrix CK. -C -C LDCK INTEGER -C The leading dimension of the array CK. -C LDCK >= max(1,NCON). -C -C DK (output) DOUBLE PRECISION array, dimension (LDDK,NMEAS) -C The leading NCON-by-NMEAS part of this array contains the -C controller input/output matrix DK. -C -C LDDK INTEGER -C The leading dimension of the array DK. -C LDDK >= max(1,NCON). -C -C AC (output) DOUBLE PRECISION array, dimension (LDAC,2*N) -C The leading 2*N-by-2*N part of this array contains the -C closed-loop system state matrix AC. -C -C LDAC INTEGER -C The leading dimension of the array AC. -C LDAC >= max(1,2*N). -C -C BC (output) DOUBLE PRECISION array, dimension (LDBC,M-NCON) -C The leading 2*N-by-(M-NCON) part of this array contains -C the closed-loop system input matrix BC. -C -C LDBC INTEGER -C The leading dimension of the array BC. -C LDBC >= max(1,2*N). -C -C CC (output) DOUBLE PRECISION array, dimension (LDCC,2*N) -C The leading (NP-NMEAS)-by-2*N part of this array contains -C the closed-loop system output matrix CC. -C -C LDCC INTEGER -C The leading dimension of the array CC. -C LDCC >= max(1,NP-NMEAS). -C -C DC (output) DOUBLE PRECISION array, dimension (LDDC,M-NCON) -C The leading (NP-NMEAS)-by-(M-NCON) part of this array -C contains the closed-loop system input/output matrix DC. -C -C LDDC INTEGER -C The leading dimension of the array DC. -C LDDC >= max(1,NP-NMEAS). -C -C RCOND (output) DOUBLE PRECISION array, dimension (4) -C For the last successful step: -C RCOND(1) contains the reciprocal condition number of the -C control transformation matrix; -C RCOND(2) contains the reciprocal condition number of the -C measurement transformation matrix; -C RCOND(3) contains an estimate of the reciprocal condition -C number of the X-Riccati equation; -C RCOND(4) contains an estimate of the reciprocal condition -C number of the Y-Riccati equation. -C -C Tolerances -C -C GTOL DOUBLE PRECISION -C Tolerance used for controlling the accuracy of GAMMA -C and its distance to the estimated minimal possible -C value of GAMMA. -C If GTOL <= 0, then a default value equal to sqrt(EPS) -C is used, where EPS is the relative machine precision. -C -C ACTOL DOUBLE PRECISION -C Upper bound for the poles of the closed-loop system -C used for determining if it is stable. -C ACTOL <= 0 for stable systems. -C -C Workspace -C -C IWORK INTEGER array, dimension (LIWORK) -C -C LIWORK INTEGER -C The dimension of the array IWORK. -C LIWORK >= max(2*max(N,M-NCON,NP-NMEAS,NCON,NMEAS),N*N) -C -C DWORK DOUBLE PRECISION array, dimension (LDWORK) -C On exit, if INFO = 0, DWORK(1) contains the optimal -C value of LDWORK. -C -C LDWORK INTEGER -C The dimension of the array DWORK. -C LDWORK >= LW1 + max(1,LW2,LW3,LW4,LW5 + MAX(LW6,LW7)), -C where -C LW1 = N*M + NP*N + NP*M + M2*M2 + NP2*NP2; -C LW2 = max( ( N + NP1 + 1 )*( N + M2 ) + -C max( 3*( N + M2 ) + N + NP1, 5*( N + M2 ) ), -C ( N + NP2 )*( N + M1 + 1 ) + -C max( 3*( N + NP2 ) + N + M1, 5*( N + NP2 ) ), -C M2 + NP1*NP1 + max( NP1*max( N, M1 ), -C 3*M2 + NP1, 5*M2 ), -C NP2 + M1*M1 + max( max( N, NP1 )*M1, -C 3*NP2 + M1, 5*NP2 ) ); -C LW3 = max( ND1*M1 + max( 4*min( ND1, M1 ) + max( ND1,M1 ), -C 6*min( ND1, M1 ) ), -C NP1*ND2 + max( 4*min( NP1, ND2 ) + -C max( NP1,ND2 ), -C 6*min( NP1, ND2 ) ) ); -C LW4 = 2*M*M + NP*NP + 2*M*N + M*NP + 2*N*NP; -C LW5 = 2*N*N + M*N + N*NP; -C LW6 = max( M*M + max( 2*M1, 3*N*N + -C max( N*M, 10*N*N + 12*N + 5 ) ), -C NP*NP + max( 2*NP1, 3*N*N + -C max( N*NP, 10*N*N + 12*N + 5 ) )); -C LW7 = M2*NP2 + NP2*NP2 + M2*M2 + -C max( ND1*ND1 + max( 2*ND1, ( ND1 + ND2 )*NP2 ), -C ND2*ND2 + max( 2*ND2, ND2*M2 ), 3*N, -C N*( 2*NP2 + M2 ) + -C max( 2*N*M2, M2*NP2 + -C max( M2*M2 + 3*M2, NP2*( 2*NP2 + -C M2 + max( NP2, N ) ) ) ) ); -C M1 = M - M2, NP1 = NP - NP2, -C ND1 = NP1 - M2, ND2 = M1 - NP2. -C For good performance, LDWORK must generally be larger. -C -C BWORK LOGICAL array, dimension (LBWORK) -C -C LBWORK INTEGER -C The dimension of the array BWORK. LBWORK >= 2*N. -C -C Error Indicator -C -C INFO INTEGER -C = 0: successful exit; -C < 0: if INFO = -i, the i-th argument had an illegal -C value; -C = 1: if the matrix | A-j*omega*I B2 | had not full -C | C1 D12 | -C column rank in respect to the tolerance EPS; -C = 2: if the matrix | A-j*omega*I B1 | had not full row -C | C2 D21 | -C rank in respect to the tolerance EPS; -C = 3: if the matrix D12 had not full column rank in -C respect to the tolerance SQRT(EPS); -C = 4: if the matrix D21 had not full row rank in respect -C to the tolerance SQRT(EPS); -C = 5: if the singular value decomposition (SVD) algorithm -C did not converge (when computing the SVD of one of -C the matrices |A B2 |, |A B1 |, D12 or D21); -C |C1 D12| |C2 D21| -C = 6: if the controller is not admissible (too small value -C of gamma); -C = 7: if the X-Riccati equation was not solved -C successfully (the controller is not admissible or -C there are numerical difficulties); -C = 8: if the Y-Riccati equation was not solved -C successfully (the controller is not admissible or -C there are numerical difficulties); -C = 9: if the determinant of Im2 + Tu*D11HAT*Ty*D22 is -C zero [3]; -C = 10: if there are numerical problems when estimating -C singular values of D1111, D1112, D1111', D1121'; -C = 11: if the matrices Inp2 - D22*DK or Im2 - DK*D22 -C are singular to working precision; -C = 12: if a stabilizing controller cannot be found. -C -C METHOD -C -C The routine implements the Glover's and Doyle's 1988 formulas [1], -C [2], modified to improve the efficiency as described in [3]. -C -C JOB = 1: It tries with a decreasing value of GAMMA, starting with -C the given, and with the newly obtained controller estimates of the -C closed-loop system. If it is stable, (i.e., max(eig(AC)) < ACTOL) -C the iterations can be continued until the given tolerance between -C GAMMA and the estimated GAMMAMIN is reached. Otherwise, in the -C next step GAMMA is increased. The step in the all next iterations -C is step = step/2. The closed-loop system is obtained by the -C formulas given in [2]. -C -C JOB = 2: The same as for JOB = 1, but with non-varying step till -C GAMMA = 0, step = max(0.1, GTOL). -C -C JOB = 3: Combines the JOB = 1 and JOB = 2 cases for a quicker -C procedure. -C -C JOB = 4: Suboptimal controller for current GAMMA only. -C -C REFERENCES -C -C [1] Glover, K. and Doyle, J.C. -C State-space formulae for all stabilizing controllers that -C satisfy an Hinf norm bound and relations to risk sensitivity. -C Systems and Control Letters, vol. 11, pp. 167-172, 1988. -C -C [2] Balas, G.J., Doyle, J.C., Glover, K., Packard, A., and -C Smith, R. -C mu-Analysis and Synthesis Toolbox. -C The MathWorks Inc., Natick, MA, 1995. -C -C [3] Petkov, P.Hr., Gu, D.W., and Konstantinov, M.M. -C Fortran 77 routines for Hinf and H2 design of continuous-time -C linear control systems. -C Rep. 98-14, Department of Engineering, Leicester University, -C Leicester, U.K., 1998. -C -C NUMERICAL ASPECTS -C -C The accuracy of the result depends on the condition numbers of the -C input and output transformations and on the condition numbers of -C the two Riccati equations, as given by the values of RCOND(1), -C RCOND(2), RCOND(3) and RCOND(4), respectively. -C This approach by estimating the closed-loop system and checking -C its poles seems to be reliable. -C -C CONTRIBUTORS -C -C A. Markovski, P.Hr. Petkov, D.W. Gu and M.M. Konstantinov, -C July 2003. -C -C REVISIONS -C -C V. Sima, Research Institute for Informatics, Bucharest, Aug. 2003. -C -C KEYWORDS -C -C Algebraic Riccati equation, H-infinity optimal control, robust -C control. -C -C ****************************************************************** -C -C .. Parameters .. - DOUBLE PRECISION ZERO, ONE, TWO, P1, THOUS - PARAMETER ( ZERO = 0.0D+0, ONE = 1.0D+0, TWO = 2.0D+0, - $ P1 = 0.1D+0, THOUS = 1.0D+3 ) -C .. -C .. Scalar Arguments .. - INTEGER INFO, JOB, LBWORK, LDA, LDAC, LDAK, LDB, LDBC, - $ LDBK, LDC, LDCC, LDCK, LDD, LDDC, LDDK, LDWORK, - $ LIWORK, M, N, NCON, NMEAS, NP - DOUBLE PRECISION ACTOL, GAMMA, GTOL -C .. -C .. Array Arguments .. - LOGICAL BWORK( * ) - INTEGER IWORK( * ) - DOUBLE PRECISION A( LDA, * ), AC( LDAC, * ), AK( LDAK, * ), - $ B( LDB, * ), BC( LDBC, * ), BK( LDBK, * ), - $ C( LDC, * ), CC( LDCC, * ), CK( LDCK, * ), - $ D( LDD, * ), DC( LDDC, * ), DK( LDDK, * ), - $ DWORK( * ), RCOND( 4 ) -C .. -C .. Local Scalars .. - INTEGER I, INF, INFO2, INFO3, IWAC, IWC, IWD, IWD1, - $ IWF, IWH, IWRE, IWRK, IWS1, IWS2, IWTU, IWTY, - $ IWWI, IWWR, IWX, IWY, LW1, LW2, LW3, LW4, LW5, - $ LW6, LW7, LWAMAX, M1, M11, M2, MINWRK, MODE, - $ NP1, NP11, NP2 - DOUBLE PRECISION GAMABS, GAMAMN, GAMAMX, GTOLL, MINEAC, STEPG, - $ TOL2 -C .. -C .. External Functions .. - LOGICAL SELECT - DOUBLE PRECISION DLAMCH - EXTERNAL DLAMCH, SELECT -C .. -C .. External Subroutines .. - EXTERNAL DGEES, DGESVD, DLACPY, SB10LD, SB10PD, SB10QD, - $ SB10RD, XERBLA -C .. -C .. Intrinsic Functions .. - INTRINSIC DBLE, INT, MAX, MIN, SQRT -C .. -C .. Executable Statements .. -C -C Decode and test input parameters. -C - M1 = M - NCON - M2 = NCON - NP1 = NP - NMEAS - NP2 = NMEAS - NP11 = NP1 - M2 - M11 = M1 - NP2 -C - INFO = 0 - IF ( JOB.LT.1 .OR. JOB.GT.4 ) THEN - INFO = -1 - ELSE IF( N.LT.0 ) THEN - INFO = -2 - ELSE IF( M.LT.0 ) THEN - INFO = -3 - ELSE IF( NP.LT.0 ) THEN - INFO = -4 - ELSE IF( NCON.LT.0 .OR. M1.LT.0 .OR. M2.GT.NP1 ) THEN - INFO = -5 - ELSE IF( NMEAS.LT.0 .OR. NP1.LT.0 .OR. NP2.GT.M1 ) THEN - INFO = -6 - ELSE IF( GAMMA.LT.ZERO ) THEN - INFO = -7 - ELSE IF( LDA.LT.MAX( 1, N ) ) THEN - INFO = -9 - ELSE IF( LDB.LT.MAX( 1, N ) ) THEN - INFO = -11 - ELSE IF( LDC.LT.MAX( 1, NP ) ) THEN - INFO = -13 - ELSE IF( LDD.LT.MAX( 1, NP ) ) THEN - INFO = -15 - ELSE IF( LDAK.LT.MAX( 1, N ) ) THEN - INFO = -17 - ELSE IF( LDBK.LT.MAX( 1, N ) ) THEN - INFO = -19 - ELSE IF( LDCK.LT.MAX( 1, M2 ) ) THEN - INFO = -21 - ELSE IF( LDDK.LT.MAX( 1, M2 ) ) THEN - INFO = -23 - ELSE IF( LDAC.LT.MAX( 1, 2*N ) ) THEN - INFO = -25 - ELSE IF( LDBC.LT.MAX( 1, 2*N ) ) THEN - INFO = -27 - ELSE IF( LDCC.LT.MAX( 1, NP1 ) ) THEN - INFO = -29 - ELSE IF( LDDC.LT.MAX( 1, NP1 ) ) THEN - INFO = -31 - ELSE -C -C Compute workspace. -C - LW1 = N*M + NP*N + NP*M + M2*M2 + NP2*NP2 - LW2 = MAX( ( N + NP1 + 1 )*( N + M2 ) + - $ MAX( 3*( N + M2 ) + N + NP1, 5*( N + M2 ) ), - $ ( N + NP2 )*( N + M1 + 1 ) + - $ MAX( 3*( N + NP2 ) + N + M1, 5*( N + NP2 ) ), - $ M2 + NP1*NP1 + MAX( NP1*MAX( N, M1 ), 3*M2 + NP1, - $ 5*M2 ), - $ NP2 + M1*M1 + MAX( MAX( N, NP1 )*M1, 3*NP2 + M1, - $ 5*NP2 ) ) - LW3 = MAX( NP11*M1 + MAX( 4*MIN( NP11, M1 ) + MAX( NP11, M1 ), - $ 6*MIN( NP11, M1 ) ), - $ NP1*M11 + MAX( 4*MIN( NP1, M11 ) + MAX( NP1, M11 ), - $ 6*MIN( NP1, M11 ) ) ) - LW4 = 2*M*M + NP*NP + 2*M*N + M*NP + 2*N*NP - LW5 = 2*N*N + M*N + N*NP - LW6 = MAX( M*M + MAX( 2*M1, 3*N*N + - $ MAX( N*M, 10*N*N + 12*N + 5 ) ), - $ NP*NP + MAX( 2*NP1, 3*N*N + - $ MAX( N*NP, 10*N*N + 12*N + 5 ) ) ) - LW7 = M2*NP2 + NP2*NP2 + M2*M2 + - $ MAX( NP11*NP11 + MAX( 2*NP11, ( NP11 + M11 )*NP2 ), - $ M11*M11 + MAX( 2*M11, M11*M2 ), 3*N, - $ N*( 2*NP2 + M2 ) + - $ MAX( 2*N*M2, M2*NP2 + - $ MAX( M2*M2 + 3*M2, NP2*( 2*NP2 + - $ M2 + MAX( NP2, N ) ) ) ) ) - MINWRK = LW1 + MAX( 1, LW2, LW3, LW4, LW5 + MAX( LW6, LW7 ) ) - IF( LDWORK.LT.MINWRK ) THEN - INFO = -38 - ELSE IF( LIWORK.LT.MAX( 2*MAX( N, M1, NP1, M2, NP2 ), - $ N*N ) ) THEN - INFO = -36 - ELSE IF( LBWORK.LT.2*N ) THEN - INFO = -40 - END IF - END IF -C - IF ( INFO.NE.0 ) THEN -C -C Error return. -C - CALL XERBLA( 'SB10AD', -INFO ) - RETURN - END IF -C -C Quick return if possible. -C - IF( N.EQ.0 .OR. M.EQ.0 .OR. NP.EQ.0 .OR. M1.EQ.0 .OR. M2.EQ.0 - $ .OR. NP1.EQ.0 .OR. NP2.EQ.0 ) THEN - RCOND( 1 ) = ONE - RCOND( 2 ) = ONE - RCOND( 3 ) = ONE - RCOND( 4 ) = ONE - DWORK( 1 ) = ONE - RETURN - END IF -C - MODE = JOB - IF ( MODE.GT.2 ) - $ MODE = 1 - GTOLL = GTOL - IF( GTOLL.LE.ZERO ) THEN -C -C Set the default value of the tolerance for GAMMA. -C - GTOLL = SQRT( DLAMCH( 'Epsilon' ) ) - END IF -C -C Workspace usage 1. -C - IWC = 1 + N*M - IWD = IWC + NP*N - IWTU = IWD + NP*M - IWTY = IWTU + M2*M2 - IWRK = IWTY + NP2*NP2 -C - CALL DLACPY( 'Full', N, M, B, LDB, DWORK, N ) -C - CALL DLACPY( 'Full', NP, N, C, LDC, DWORK( IWC ), NP ) -C - CALL DLACPY( 'Full', NP, M, D, LDD, DWORK( IWD ), NP ) -C -C Transform the system so that D12 and D21 satisfy the formulas -C in the computation of the Hinf optimal controller. -C Workspace: need LW1 + MAX(1,LWP1,LWP2,LWP3,LWP4), -C prefer larger, -C where -C LW1 = N*M + NP*N + NP*M + M2*M2 + NP2*NP2 -C LWP1 = (N+NP1+1)*(N+M2) + MAX(3*(N+M2)+N+NP1,5*(N+M2)), -C LWP2 = (N+NP2)*(N+M1+1) + MAX(3*(N+NP2)+N+M1,5*(N+NP2)), -C LWP3 = M2 + NP1*NP1 + MAX(NP1*MAX(N,M1),3*M2+NP1,5*M2), -C LWP4 = NP2 + M1*M1 + MAX(MAX(N,NP1)*M1,3*NP2+M1,5*NP2), -C with M1 = M - M2 and NP1 = NP - NP2. -C Denoting Q = MAX(M1,M2,NP1,NP2), an upper bound is -C LW1 + MAX(1,(N+Q)*(N+Q+6),Q*(Q+MAX(N,Q,5)+1). -C - TOL2 = -ONE -C - CALL SB10PD( N, M, NP, NCON, NMEAS, A, LDA, DWORK, N, - $ DWORK( IWC ), NP, DWORK( IWD ), NP, DWORK( IWTU ), - $ M2, DWORK( IWTY ), NP2, RCOND, TOL2, DWORK( IWRK ), - $ LDWORK-IWRK+1, INFO2 ) -C - LWAMAX = INT( DWORK( IWRK ) ) + IWRK - 1 -C - IF ( INFO2.NE.0 ) THEN - INFO = INFO2 - RETURN - END IF -C -C Workspace usage 2. -C - IWD1 = IWRK - IWS1 = IWD1 + NP11*M1 -C -C Check if GAMMA < max(sigma[D1111,D1112],sigma[D1111',D1121']). -C Workspace: need LW1 + MAX(1, LWS1, LWS2), -C prefer larger, -C where -C LWS1 = NP11*M1 + MAX(4*MIN(NP11,M1)+MAX(NP11,M1),6*MIN(NP11,M1)) -C LWS2 = NP1*M11 + MAX(4*MIN(NP1,M11)+MAX(NP1,M11),6*MIN(NP1,M11)) -C - INFO2 = 0 - INFO3 = 0 -C - IF ( NP11.NE.0 .AND. M1.NE.0 ) THEN - IWRK = IWS1 + MIN( NP11, M1 ) - CALL DLACPY( 'Full', NP11, M1, DWORK(IWD), LDD, DWORK(IWD1), - $ NP11 ) - CALL DGESVD( 'N', 'N', NP11, M1, DWORK(IWD1), NP11, - $ DWORK(IWS1), DWORK(IWS1), 1, DWORK(IWS1), 1, - $ DWORK( IWRK ), LDWORK-IWRK+1, INFO2 ) - LWAMAX = MAX( LWAMAX, INT( DWORK( IWRK ) ) + IWRK - 1 ) - ELSE - DWORK(IWS1) = ZERO - END IF -C - IWS2 = IWD1 + NP1*M11 - IF ( NP1.NE.0 .AND. M11.NE.0 ) THEN - IWRK = IWS2 + MIN( NP1, M11 ) - CALL DLACPY( 'Full', NP1, M11, DWORK(IWD), LDD, DWORK(IWD1), - $ NP1 ) - CALL DGESVD( 'N', 'N', NP1, M11, DWORK(IWD1), NP1, DWORK(IWS2), - $ DWORK(IWS2), 1, DWORK(IWS2), 1, DWORK( IWRK ), - $ LDWORK-IWRK+1, INFO3 ) - LWAMAX = MAX( LWAMAX, INT( DWORK( IWRK ) ) + IWRK - 1 ) - ELSE - DWORK(IWS2) = ZERO - END IF -C - GAMAMN = MAX( DWORK(IWS1), DWORK(IWS2) ) -C - IF ( INFO2.GT.0 .OR. INFO3.GT.0 ) THEN - INFO = 10 - RETURN - ELSE IF ( GAMMA.LE.GAMAMN ) THEN - INFO = 6 - RETURN - END IF -C -C Workspace usage 3. -C - IWX = IWD1 - IWY = IWX + N*N - IWF = IWY + N*N - IWH = IWF + M*N - IWRK = IWH + N*NP - IWAC = IWD1 - IWWR = IWAC + 4*N*N - IWWI = IWWR + 2*N - IWRE = IWWI + 2*N -C -C Prepare some auxiliary variables for the gamma iteration. -C - STEPG = GAMMA - GAMAMN - GAMABS = GAMMA - GAMAMX = GAMMA - INF = 0 -C -C ############################################################### -C -C Begin the gamma iteration. -C - 10 CONTINUE - STEPG = STEPG/TWO -C -C Try to compute the state feedback and output injection -C matrices for the current GAMMA. -C - CALL SB10QD( N, M, NP, NCON, NMEAS, GAMMA, A, LDA, DWORK, N, - $ DWORK( IWC ), NP, DWORK( IWD ), NP, DWORK( IWF ), - $ M, DWORK( IWH ), N, DWORK( IWX ), N, DWORK( IWY ), - $ N, RCOND(3), IWORK, DWORK( IWRK ), LDWORK-IWRK+1, - $ BWORK, INFO2 ) -C - IF ( INFO2.NE.0 ) GOTO 30 -C -C Try to compute the Hinf suboptimal (yet) controller. -C - CALL SB10RD( N, M, NP, NCON, NMEAS, GAMMA, A, LDA, DWORK, N, - $ DWORK( IWC ), NP, DWORK( IWD ), NP, DWORK( IWF ), - $ M, DWORK( IWH ), N, DWORK( IWTU ), M2, - $ DWORK( IWTY ), NP2, DWORK( IWX ), N, DWORK( IWY ), - $ N, AK, LDAK, BK, LDBK, CK, LDCK, DK, LDDK, IWORK, - $ DWORK( IWRK ), LDWORK-IWRK+1, INFO2 ) -C - IF ( INFO2.NE.0 ) GOTO 30 -C -C Compute the closed-loop system. -C Workspace: need LW1 + 2*M*M + NP*NP + 2*M*N + M*NP + 2*N*NP; -C prefer larger. -C - CALL SB10LD( N, M, NP, NCON, NMEAS, A, LDA, B, LDB, C, LDC, D, - $ LDD, AK, LDAK, BK, LDBK, CK, LDCK, DK, LDDK, AC, - $ LDAC, BC, LDBC, CC, LDCC, DC, LDDC, IWORK, - $ DWORK( IWD1 ), LDWORK-IWD1+1, INFO2 ) -C - IF ( INFO2.NE.0 ) GOTO 30 -C - LWAMAX = MAX( LWAMAX, INT( DWORK( IWD1 ) ) + IWD1 - 1 ) -C -C Compute the poles of the closed-loop system. -C Workspace: need LW1 + 4*N*N + 4*N + max(1,6*N); -C prefer larger. -C - CALL DLACPY( 'Full', 2*N, 2*N, AC, LDAC, DWORK(IWAC), 2*N ) -C - CALL DGEES( 'N', 'N', SELECT, 2*N, DWORK(IWAC), 2*N, IWORK, - $ DWORK(IWWR), DWORK(IWWI), DWORK(IWRE), 1, - $ DWORK(IWRE), LDWORK-IWRE+1, BWORK, INFO2 ) -C - LWAMAX = MAX( LWAMAX, INT( DWORK( IWRE ) ) + IWRE - 1 ) -C -C Now DWORK(IWWR+I)=Re(Lambda), DWORK(IWWI+I)=Im(Lambda), -C for I=0,2*N-1. -C - MINEAC = -THOUS -C - DO 20 I = 0, 2*N - 1 - MINEAC = MAX( MINEAC, DWORK(IWWR+I) ) - 20 CONTINUE -C -C Check if the closed-loop system is stable. -C - 30 IF ( MODE.EQ.1 ) THEN - IF ( INFO2.EQ.0 .AND. MINEAC.LT.ACTOL ) THEN - GAMABS = GAMMA - GAMMA = GAMMA - STEPG - INF = 1 - ELSE - GAMMA = MIN( GAMMA + STEPG, GAMAMX ) - END IF - ELSE IF ( MODE.EQ.2 ) THEN - IF ( INFO2.EQ.0 .AND. MINEAC.LT.ACTOL ) THEN - GAMABS = GAMMA - INF = 1 - END IF - GAMMA = GAMMA - MAX( P1, GTOLL ) - END IF -C -C More iterations? -C - IF ( MODE.EQ.1 .AND. JOB.EQ.3 .AND. TWO*STEPG.LT.GTOLL ) THEN - MODE = 2 - GAMMA = GAMABS - END IF -C - IF ( JOB.NE.4 .AND. - $ ( MODE.EQ.1 .AND. TWO*STEPG.GE.GTOLL .OR. - $ MODE.EQ.2 .AND. GAMMA.GT.ZERO ) ) THEN - GOTO 10 - END IF -C -C ############################################################### -C -C End of the gamma iteration - Return if no stabilizing controller -C was found. -C - IF ( INF.EQ.0 ) THEN - INFO = 12 - RETURN - END IF -C -C Now compute the state feedback and output injection matrices -C using GAMABS. -C - GAMMA = GAMABS -C -C Integer workspace: need max(2*max(N,M-NCON,NP-NMEAS),N*N). -C Workspace: need LW1P + -C max(1,M*M + max(2*M1,3*N*N + -C max(N*M,10*N*N+12*N+5)), -C NP*NP + max(2*NP1,3*N*N + -C max(N*NP,10*N*N+12*N+5))); -C prefer larger, -C where LW1P = LW1 + 2*N*N + M*N + N*NP. -C An upper bound of the second term after LW1P is -C max(1,4*Q*Q+max(2*Q,3*N*N + max(2*N*Q,10*N*N+12*N+5))). -C - CALL SB10QD( N, M, NP, NCON, NMEAS, GAMMA, A, LDA, DWORK, N, - $ DWORK( IWC ), NP, DWORK( IWD ), NP, DWORK( IWF ), - $ M, DWORK( IWH ), N, DWORK( IWX ), N, DWORK( IWY ), - $ N, RCOND(3), IWORK, DWORK( IWRK ), LDWORK-IWRK+1, - $ BWORK, INFO2 ) -C - LWAMAX = MAX( LWAMAX, INT( DWORK( IWRK ) ) + IWRK - 1 ) -C - IF ( INFO2.GT.0 ) THEN - INFO = INFO2 + 5 - RETURN - END IF -C -C Compute the Hinf optimal controller. -C Integer workspace: need max(2*(max(NP,M)-M2-NP2,M2,N),NP2). -C Workspace: need LW1P + -C max(1, M2*NP2 + NP2*NP2 + M2*M2 + -C max(D1*D1 + max(2*D1, (D1+D2)*NP2), -C D2*D2 + max(2*D2, D2*M2), 3*N, -C N*(2*NP2 + M2) + -C max(2*N*M2, M2*NP2 + -C max(M2*M2+3*M2, NP2*(2*NP2+ -C M2+max(NP2,N)))))) -C where D1 = NP1 - M2 = NP11, D2 = M1 - NP2 = M11; -C prefer larger. -C An upper bound of the second term after LW1P is -C max( 1, Q*(3*Q + 3*N + max(2*N, 4*Q + max(Q, N)))). -C - CALL SB10RD( N, M, NP, NCON, NMEAS, GAMMA, A, LDA, DWORK, N, - $ DWORK( IWC ), NP, DWORK( IWD ), NP, DWORK( IWF ), - $ M, DWORK( IWH ), N, DWORK( IWTU ), M2, DWORK( IWTY ), - $ NP2, DWORK( IWX ), N, DWORK( IWY ), N, AK, LDAK, BK, - $ LDBK, CK, LDCK, DK, LDDK, IWORK, DWORK( IWRK ), - $ LDWORK-IWRK+1, INFO2 ) -C - LWAMAX = MAX( LWAMAX, INT( DWORK( IWRK ) ) + IWRK - 1 ) -C - IF( INFO2.EQ.1 ) THEN - INFO = 6 - RETURN - ELSE IF( INFO2.EQ.2 ) THEN - INFO = 9 - RETURN - END IF -C -C Integer workspace: need 2*max(NCON,NMEAS). -C Workspace: need 2*M*M + NP*NP + 2*M*N + M*NP + 2*N*NP; -C prefer larger. -C - CALL SB10LD( N, M, NP, NCON, NMEAS, A, LDA, B, LDB, C, LDC, D, - $ LDD, AK, LDAK, BK, LDBK, CK, LDCK, DK, LDDK, AC, - $ LDAC, BC, LDBC, CC, LDCC, DC, LDDC, IWORK, DWORK, - $ LDWORK, INFO2 ) -C - IF( INFO2.GT.0 ) THEN - INFO = 11 - RETURN - END IF -C - DWORK( 1 ) = DBLE( LWAMAX ) - RETURN -C *** Last line of SB10AD *** - END diff --git a/mex/sources/libslicot/SB10DD.f b/mex/sources/libslicot/SB10DD.f deleted file mode 100644 index b6a99f7b9..000000000 --- a/mex/sources/libslicot/SB10DD.f +++ /dev/null @@ -1,1007 +0,0 @@ - SUBROUTINE SB10DD( N, M, NP, NCON, NMEAS, GAMMA, A, LDA, B, LDB, - $ C, LDC, D, LDD, AK, LDAK, BK, LDBK, CK, LDCK, - $ DK, LDDK, X, LDX, Z, LDZ, RCOND, TOL, IWORK, - $ DWORK, LDWORK, BWORK, INFO ) -C -C SLICOT RELEASE 5.0. -C -C Copyright (c) 2002-2009 NICONET e.V. -C -C This program is free software: you can redistribute it and/or -C modify it under the terms of the GNU General Public License as -C published by the Free Software Foundation, either version 2 of -C the License, or (at your option) any later version. -C -C This program is distributed in the hope that it will be useful, -C but WITHOUT ANY WARRANTY; without even the implied warranty of -C MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the -C GNU General Public License for more details. -C -C You should have received a copy of the GNU General Public License -C along with this program. If not, see -C . -C -C PURPOSE -C -C To compute the matrices of an H-infinity (sub)optimal n-state -C controller -C -C | AK | BK | -C K = |----|----|, -C | CK | DK | -C -C for the discrete-time system -C -C | A | B1 B2 | | A | B | -C P = |----|---------| = |---|---| -C | C1 | D11 D12 | | C | D | -C | C2 | D21 D22 | -C -C and for a given value of gamma, where B2 has as column size the -C number of control inputs (NCON) and C2 has as row size the number -C of measurements (NMEAS) being provided to the controller. -C -C It is assumed that -C -C (A1) (A,B2) is stabilizable and (C2,A) is detectable, -C -C (A2) D12 is full column rank and D21 is full row rank, -C -C j*Theta -C (A3) | A-e *I B2 | has full column rank for all -C | C1 D12 | -C -C 0 <= Theta < 2*Pi , -C -C j*Theta -C (A4) | A-e *I B1 | has full row rank for all -C | C2 D21 | -C -C 0 <= Theta < 2*Pi . -C -C ARGUMENTS -C -C Input/Output Parameters -C -C N (input) INTEGER -C The order of the system. N >= 0. -C -C M (input) INTEGER -C The column size of the matrix B. M >= 0. -C -C NP (input) INTEGER -C The row size of the matrix C. NP >= 0. -C -C NCON (input) INTEGER -C The number of control inputs (M2). M >= NCON >= 0, -C NP-NMEAS >= NCON. -C -C NMEAS (input) INTEGER -C The number of measurements (NP2). NP >= NMEAS >= 0, -C M-NCON >= NMEAS. -C -C GAMMA (input) DOUBLE PRECISION -C The value of gamma. It is assumed that gamma is -C sufficiently large so that the controller is admissible. -C GAMMA > 0. -C -C A (input) DOUBLE PRECISION array, dimension (LDA,N) -C The leading N-by-N part of this array must contain the -C system state matrix A. -C -C LDA INTEGER -C The leading dimension of the array A. LDA >= max(1,N). -C -C B (input) DOUBLE PRECISION array, dimension (LDB,M) -C The leading N-by-M part of this array must contain the -C system input matrix B. -C -C LDB INTEGER -C The leading dimension of the array B. LDB >= max(1,N). -C -C C (input) DOUBLE PRECISION array, dimension (LDC,N) -C The leading NP-by-N part of this array must contain the -C system output matrix C. -C -C LDC INTEGER -C The leading dimension of the array C. LDC >= max(1,NP). -C -C D (input) DOUBLE PRECISION array, dimension (LDD,M) -C The leading NP-by-M part of this array must contain the -C system input/output matrix D. -C -C LDD INTEGER -C The leading dimension of the array D. LDD >= max(1,NP). -C -C AK (output) DOUBLE PRECISION array, dimension (LDAK,N) -C The leading N-by-N part of this array contains the -C controller state matrix AK. -C -C LDAK INTEGER -C The leading dimension of the array AK. LDAK >= max(1,N). -C -C BK (output) DOUBLE PRECISION array, dimension (LDBK,NMEAS) -C The leading N-by-NMEAS part of this array contains the -C controller input matrix BK. -C -C LDBK INTEGER -C The leading dimension of the array BK. LDBK >= max(1,N). -C -C CK (output) DOUBLE PRECISION array, dimension (LDCK,N) -C The leading NCON-by-N part of this array contains the -C controller output matrix CK. -C -C LDCK INTEGER -C The leading dimension of the array CK. -C LDCK >= max(1,NCON). -C -C DK (output) DOUBLE PRECISION array, dimension (LDDK,NMEAS) -C The leading NCON-by-NMEAS part of this array contains the -C controller input/output matrix DK. -C -C LDDK INTEGER -C The leading dimension of the array DK. -C LDDK >= max(1,NCON). -C -C X (output) DOUBLE PRECISION array, dimension (LDX,N) -C The leading N-by-N part of this array contains the matrix -C X, solution of the X-Riccati equation. -C -C LDX INTEGER -C The leading dimension of the array X. LDX >= max(1,N). -C -C Z (output) DOUBLE PRECISION array, dimension (LDZ,N) -C The leading N-by-N part of this array contains the matrix -C Z, solution of the Z-Riccati equation. -C -C LDZ INTEGER -C The leading dimension of the array Z. LDZ >= max(1,N). -C -C RCOND (output) DOUBLE PRECISION array, dimension (8) -C RCOND contains estimates of the reciprocal condition -C numbers of the matrices which are to be inverted and -C estimates of the reciprocal condition numbers of the -C Riccati equations which have to be solved during the -C computation of the controller. (See the description of -C the algorithm in [2].) -C RCOND(1) contains the reciprocal condition number of the -C matrix R3; -C RCOND(2) contains the reciprocal condition number of the -C matrix R1 - R2'*inv(R3)*R2; -C RCOND(3) contains the reciprocal condition number of the -C matrix V21; -C RCOND(4) contains the reciprocal condition number of the -C matrix St3; -C RCOND(5) contains the reciprocal condition number of the -C matrix V12; -C RCOND(6) contains the reciprocal condition number of the -C matrix Im2 + DKHAT*D22 -C RCOND(7) contains the reciprocal condition number of the -C X-Riccati equation; -C RCOND(8) contains the reciprocal condition number of the -C Z-Riccati equation. -C -C Tolerances -C -C TOL DOUBLE PRECISION -C Tolerance used in neglecting the small singular values -C in rank determination. If TOL <= 0, then a default value -C equal to 1000*EPS is used, where EPS is the relative -C machine precision. -C -C Workspace -C -C IWORK INTEGER array, dimension max(2*max(M2,N),M,M2+NP2,N*N) -C -C DWORK DOUBLE PRECISION array, dimension (LDWORK) -C On exit, if INFO = 0, DWORK(1) contains the optimal -C LDWORK. -C -C LDWORK INTEGER -C The dimension of the array DWORK. -C LDWORK >= max(LW1,LW2,LW3,LW4), where -C LW1 = (N+NP1+1)*(N+M2) + max(3*(N+M2)+N+NP1,5*(N+M2)); -C LW2 = (N+NP2)*(N+M1+1) + max(3*(N+NP2)+N+M1,5*(N+NP2)); -C LW3 = 13*N*N + 2*M*M + N*(8*M+NP2) + M1*(M2+NP2) + 6*N + -C max(14*N+23,16*N,2*N+M,3*M); -C LW4 = 13*N*N + M*M + (8*N+M+M2+2*NP2)*(M2+NP2) + 6*N + -C N*(M+NP2) + max(14*N+23,16*N,2*N+M2+NP2,3*(M2+NP2)); -C For good performance, LDWORK must generally be larger. -C Denoting Q = max(M1,M2,NP1,NP2), an upper bound is -C max((N+Q)*(N+Q+6),13*N*N + M*M + 2*Q*Q + N*(M+Q) + -C max(M*(M+7*N),2*Q*(8*N+M+2*Q)) + 6*N + -C max(14*N+23,16*N,2*N+max(M,2*Q),3*max(M,2*Q)). -C -C BWORK LOGICAL array, dimension (2*N) -C -C Error Indicator -C -C INFO INTEGER -C = 0: successful exit; -C < 0: if INFO = -i, the i-th argument had an illegal -C value; -C j*Theta -C = 1: if the matrix | A-e *I B2 | had not full -C | C1 D12 | -C column rank; -C j*Theta -C = 2: if the matrix | A-e *I B1 | had not full -C | C2 D21 | -C row rank; -C = 3: if the matrix D12 had not full column rank; -C = 4: if the matrix D21 had not full row rank; -C = 5: if the controller is not admissible (too small value -C of gamma); -C = 6: if the X-Riccati equation was not solved -C successfully (the controller is not admissible or -C there are numerical difficulties); -C = 7: if the Z-Riccati equation was not solved -C successfully (the controller is not admissible or -C there are numerical difficulties); -C = 8: if the matrix Im2 + DKHAT*D22 is singular. -C = 9: if the singular value decomposition (SVD) algorithm -C did not converge (when computing the SVD of one of -C the matrices |A B2 |, |A B1 |, D12 or D21). -C |C1 D12| |C2 D21| -C -C METHOD -C -C The routine implements the method presented in [1]. -C -C REFERENCES -C -C [1] Green, M. and Limebeer, D.J.N. -C Linear Robust Control. -C Prentice-Hall, Englewood Cliffs, NJ, 1995. -C -C [2] Petkov, P.Hr., Gu, D.W., and Konstantinov, M.M. -C Fortran 77 routines for Hinf and H2 design of linear -C discrete-time control systems. -C Report 99-8, Department of Engineering, Leicester University, -C April 1999. -C -C NUMERICAL ASPECTS -C -C With approaching the minimum value of gamma some of the matrices -C which are to be inverted tend to become ill-conditioned and -C the X- or Z-Riccati equation may also become ill-conditioned -C which may deteriorate the accuracy of the result. (The -C corresponding reciprocal condition numbers are given in -C the output array RCOND.) -C -C CONTRIBUTORS -C -C P.Hr. Petkov, D.W. Gu and M.M. Konstantinov, April 1999. -C -C REVISIONS -C -C V. Sima, Research Institute for Informatics, Bucharest, Sep. 1999. -C V. Sima, Research Institute for Informatics, Bucharest, Feb. 2000. -C -C KEYWORDS -C -C Algebraic Riccati equation, discrete-time H-infinity optimal -C control, robust control. -C -C ****************************************************************** -C -C .. Parameters .. - DOUBLE PRECISION ZERO, ONE, THOUSN - PARAMETER ( ZERO = 0.0D+0, ONE = 1.0D+0, - $ THOUSN = 1.0D+3 ) -C .. -C .. Scalar Arguments .. - INTEGER INFO, LDA, LDAK, LDB, LDBK, LDC, LDCK, LDD, - $ LDDK, LDWORK, LDX, LDZ, M, N, NCON, NMEAS, NP - DOUBLE PRECISION GAMMA, TOL -C .. -C .. Array Arguments .. - INTEGER IWORK( * ) - DOUBLE PRECISION A( LDA, * ), AK( LDAK, * ), B( LDB, * ), - $ BK( LDBK, * ), C( LDC, * ), CK( LDCK, * ), - $ D( LDD, * ), DK( LDDK, * ), DWORK( * ), - $ RCOND( * ), X( LDX, * ), Z( LDZ, * ) - LOGICAL BWORK( * ) -C .. -C .. Local Scalars .. - INTEGER INFO2, IR2, IR3, IS2, IS3, IWB, IWC, IWD, IWG, - $ IWH, IWI, IWL, IWQ, IWR, IWRK, IWS, IWT, IWU, - $ IWV, IWW, J, LWAMAX, M1, M2, MINWRK, NP1, NP2 - DOUBLE PRECISION ANORM, FERR, RCOND2, SEPD, TOLL -C -C .. External Functions - DOUBLE PRECISION DLAMCH, DLANGE, DLANSY - EXTERNAL DLAMCH, DLANGE, DLANSY -C .. -C .. External Subroutines .. - EXTERNAL DGECON, DGEMM, DGESVD, DGETRF, DGETRS, DLACPY, - $ DLASET, DPOCON, DPOTRF, DSCAL, DSWAP, DSYRK, - $ DSYTRF, DSYTRS, DTRCON, DTRSM, MA02AD, MB01RU, - $ MB01RX, SB02OD, SB02SD, XERBLA -C .. -C .. Intrinsic Functions .. - INTRINSIC DBLE, INT, MAX -C .. -C .. Executable Statements .. -C -C Decode and Test input parameters. -C - M1 = M - NCON - M2 = NCON - NP1 = NP - NMEAS - NP2 = NMEAS -C - INFO = 0 - IF( N.LT.0 ) THEN - INFO = -1 - ELSE IF( M.LT.0 ) THEN - INFO = -2 - ELSE IF( NP.LT.0 ) THEN - INFO = -3 - ELSE IF( NCON.LT.0 .OR. M1.LT.0 .OR. M2.GT.NP1 ) THEN - INFO = -4 - ELSE IF( NMEAS.LT.0 .OR. NP1.LT.0 .OR. NP2.GT.M1 ) THEN - INFO = -5 - ELSE IF( GAMMA.LE.ZERO ) THEN - INFO = -6 - ELSE IF( LDA.LT.MAX( 1, N ) ) THEN - INFO = -8 - ELSE IF( LDB.LT.MAX( 1, N ) ) THEN - INFO = -10 - ELSE IF( LDC.LT.MAX( 1, NP ) ) THEN - INFO = -12 - ELSE IF( LDD.LT.MAX( 1, NP ) ) THEN - INFO = -14 - ELSE IF( LDAK.LT.MAX( 1, N ) ) THEN - INFO = -16 - ELSE IF( LDBK.LT.MAX( 1, N ) ) THEN - INFO = -18 - ELSE IF( LDCK.LT.MAX( 1, M2 ) ) THEN - INFO = -20 - ELSE IF( LDDK.LT.MAX( 1, M2 ) ) THEN - INFO = -22 - ELSE IF( LDX.LT.MAX( 1, N ) ) THEN - INFO = -24 - ELSE IF( LDZ.LT.MAX( 1, N ) ) THEN - INFO = -26 - ELSE -C -C Compute workspace. -C - IWB = ( N + NP1 + 1 )*( N + M2 ) + - $ MAX( 3*( N + M2 ) + N + NP1, 5*( N + M2 ) ) - IWC = ( N + NP2 )*( N + M1 + 1 ) + - $ MAX( 3*( N + NP2 ) + N + M1, 5*( N + NP2 ) ) - IWD = 13*N*N + 2*M*M + N*( 8*M + NP2 ) + M1*( M2 + NP2 ) + - $ 6*N + MAX( 14*N + 23, 16*N, 2*N + M, 3*M ) - IWG = 13*N*N + M*M + ( 8*N + M + M2 + 2*NP2 )*( M2 + NP2 ) + - $ 6*N + N*( M + NP2 ) + - $ MAX( 14*N + 23, 16*N, 2*N + M2 + NP2, 3*( M2 + NP2 ) ) - MINWRK = MAX( IWB, IWC, IWD, IWG ) - IF( LDWORK.LT.MINWRK ) - $ INFO = -31 - END IF - IF( INFO.NE.0 ) THEN - CALL XERBLA( 'SB10DD', -INFO ) - RETURN - END IF -C -C Quick return if possible. -C - IF( N.EQ.0 .OR. M.EQ.0 .OR. NP.EQ.0 .OR. M1.EQ.0 .OR. M2.EQ.0 - $ .OR. NP1.EQ.0 .OR. NP2.EQ.0 ) THEN - RCOND( 1 ) = ONE - RCOND( 2 ) = ONE - RCOND( 3 ) = ONE - RCOND( 4 ) = ONE - RCOND( 5 ) = ONE - RCOND( 6 ) = ONE - RCOND( 7 ) = ONE - RCOND( 8 ) = ONE - DWORK( 1 ) = ONE - RETURN - END IF -C - TOLL = TOL - IF( TOLL.LE.ZERO ) THEN -C -C Set the default value of the tolerance in rank determination. -C - TOLL = THOUSN*DLAMCH( 'Epsilon' ) - END IF -C -C Workspace usage. -C - IWS = (N+NP1)*(N+M2) + 1 - IWRK = IWS + (N+M2) -C -C jTheta -C Determine if |A-e I B2 | has full column rank at -C | C1 D12| -C Theta = Pi/2 . -C Workspace: need (N+NP1+1)*(N+M2) + MAX(3*(N+M2)+N+NP1,5*(N+M2)); -C prefer larger. -C - CALL DLACPY( 'Full', N, N, A, LDA, DWORK, N+NP1 ) - CALL DLACPY( 'Full', NP1, N, C, LDC, DWORK( N+1 ), N+NP1 ) - CALL DLACPY( 'Full', N, M2, B( 1, M1+1 ), LDB, - $ DWORK( (N+NP1)*N+1 ), N+NP1 ) - CALL DLACPY( 'Full', NP1, M2, D( 1, M1+1 ), LDD, - $ DWORK( (N+NP1)*N+N+1 ), N+NP1 ) - CALL DGESVD( 'N', 'N', N+NP1, N+M2, DWORK, N+NP1, DWORK( IWS ), - $ DWORK, N+NP1, DWORK, N+M2, DWORK( IWRK ), - $ LDWORK-IWRK+1, INFO2 ) - IF( INFO2.GT.0 ) THEN - INFO = 9 - RETURN - END IF - IF( DWORK( IWS+N+M2 ) / DWORK( IWS ).LE.TOLL ) THEN - INFO = 1 - RETURN - END IF - LWAMAX = INT( DWORK( IWRK ) ) + IWRK - 1 -C -C Workspace usage. -C - IWS = (N+NP2)*(N+M1) + 1 - IWRK = IWS + (N+NP2) -C -C jTheta -C Determine if |A-e I B1 | has full row rank at -C | C2 D21| -C Theta = Pi/2 . -C Workspace: need (N+NP2)*(N+M1+1) + -C MAX(3*(N+NP2)+N+M1,5*(N+NP2)); -C prefer larger. -C - CALL DLACPY( 'Full', N, N, A, LDA, DWORK, N+NP2 ) - CALL DLACPY( 'Full', NP2, N, C( NP1+1, 1), LDC, DWORK( N+1 ), - $ N+NP2 ) - CALL DLACPY( 'Full', N, M1, B, LDB, DWORK( (N+NP2)*N+1 ), - $ N+NP2 ) - CALL DLACPY( 'Full', NP2, M1, D( NP1+1, 1 ), LDD, - $ DWORK( (N+NP2)*N+N+1 ), N+NP2 ) - CALL DGESVD( 'N', 'N', N+NP2, N+M1, DWORK, N+NP2, DWORK( IWS ), - $ DWORK, N+NP2, DWORK, N+M1, DWORK( IWRK ), - $ LDWORK-IWRK+1, INFO2 ) - IF( INFO2.GT.0 ) THEN - INFO = 9 - RETURN - END IF - IF( DWORK( IWS+N+NP2 ) / DWORK( IWS ).LE.TOLL ) THEN - INFO = 2 - RETURN - END IF - LWAMAX = MAX( INT( DWORK( IWRK ) ) + IWRK - 1, LWAMAX ) -C -C Workspace usage. -C - IWS = NP1*M2 + 1 - IWRK = IWS + M2 -C -C Determine if D12 has full column rank. -C Workspace: need (NP1+1)*M2 + MAX(3*M2+NP1,5*M2); -C prefer larger. -C - CALL DLACPY( 'Full', NP1, M2, D( 1, M1+1 ), LDD, DWORK, NP1 ) - CALL DGESVD( 'N', 'N', NP1, M2, DWORK, NP1, DWORK( IWS ), DWORK, - $ NP1, DWORK, M2, DWORK( IWRK ), LDWORK-IWRK+1, INFO2 ) - IF( INFO2.GT.0 ) THEN - INFO = 9 - RETURN - END IF - IF( DWORK( IWS+M2 ) / DWORK( IWS ).LE.TOLL ) THEN - INFO = 3 - RETURN - END IF - LWAMAX = MAX( INT( DWORK( IWRK ) ) + IWRK - 1, LWAMAX ) -C -C Workspace usage. -C - IWS = NP2*M1 + 1 - IWRK = IWS + NP2 -C -C Determine if D21 has full row rank. -C Workspace: need NP2*(M1+1) + MAX(3*NP2+M1,5*NP2); -C prefer larger. -C - CALL DLACPY( 'Full', NP2, M1, D( NP1+1, 1 ), LDD, DWORK, NP2 ) - CALL DGESVD( 'N', 'N', NP2, M1, DWORK, NP2, DWORK( IWS ), DWORK, - $ NP2, DWORK, M1, DWORK( IWRK ), LDWORK-IWRK+1, INFO2 ) - IF( INFO2.GT.0 ) THEN - INFO = 9 - RETURN - END IF - IF( DWORK( IWS+NP2 ) / DWORK( IWS ).LE.TOLL ) THEN - INFO = 4 - RETURN - END IF - LWAMAX = MAX( INT( DWORK( IWRK ) ) + IWRK - 1, LWAMAX ) -C -C Workspace usage. -C - IWV = 1 - IWB = IWV + M*M - IWC = IWB + N*M1 - IWD = IWC + ( M2 + NP2 )*N - IWQ = IWD + ( M2 + NP2 )*M1 - IWL = IWQ + N*N - IWR = IWL + N*M - IWI = IWR + 2*N - IWH = IWI + 2*N - IWS = IWH + 2*N - IWT = IWS + ( 2*N + M )*( 2*N + M ) - IWU = IWT + ( 2*N + M )*2*N - IWRK = IWU + 4*N*N - IR2 = IWV + M1 - IR3 = IR2 + M*M1 -C -C Compute R0 = |D11'||D11 D12| -|gamma^2*Im1 0| . -C |D12'| | 0 0| -C - CALL DSYRK( 'Lower', 'Transpose', M, NP1, ONE, D, LDD, ZERO, - $ DWORK, M ) - DO 10 J = 1, M*M1, M + 1 - DWORK( J ) = DWORK( J ) - GAMMA*GAMMA - 10 CONTINUE -C -C Compute C1'*C1 . -C - CALL DSYRK( 'Lower', 'Transpose', N, NP1, ONE, C, LDC, ZERO, - $ DWORK( IWQ ), N ) -C -C Compute C1'*|D11 D12| . -C - CALL DGEMM( 'Transpose', 'NoTranspose', N, M, NP1, ONE, C, LDC, - $ D, LDD, ZERO, DWORK( IWL ), N ) -C -C Solution of the X-Riccati equation. -C Workspace: need 13*N*N + 2*M*M + N*(8*M+NP2) + M1*(M2+NP2) + -C 6*N + max(14*N+23,16*N,2*N+M,3*M); -C prefer larger. -C - CALL SB02OD( 'D', 'B', 'N', 'L', 'N', 'S', N, M, NP, A, LDA, B, - $ LDB, DWORK( IWQ ), N, DWORK, M, DWORK( IWL ), N, - $ RCOND2, X, LDX, DWORK( IWR ), DWORK( IWI ), - $ DWORK( IWH ), DWORK( IWS ), 2*N+M, DWORK( IWT ), - $ 2*N+M, DWORK( IWU ), 2*N, TOLL, IWORK, - $ DWORK( IWRK ), LDWORK-IWRK+1, BWORK, INFO2 ) - IF( INFO2.GT.0 ) THEN - INFO = 6 - RETURN - END IF - LWAMAX = MAX( INT( DWORK( IWRK ) ) + IWRK - 1, LWAMAX ) -C -C Condition estimation. -C Workspace: need 4*N*N + 2*M*M + N*(3*M+NP2) + M1*(M2+NP2) + -C max(5*N,max(3,2*N*N)+N*N); -C prefer larger. -C - IWS = IWR - IWH = IWS + M*M - IWT = IWH + N*M - IWU = IWT + N*N - IWG = IWU + N*N - IWRK = IWG + N*N - CALL DLACPY( 'Lower', M, M, DWORK, M, DWORK( IWS ), M ) - CALL DSYTRF( 'Lower', M, DWORK( IWS ), M, IWORK, DWORK( IWRK ), - $ LDWORK-IWRK+1, INFO2 ) - IF( INFO2.GT.0 ) THEN - INFO = 5 - RETURN - END IF - LWAMAX = MAX( INT( DWORK( IWRK ) ) + IWRK - 1, LWAMAX ) -C - CALL MA02AD( 'Full', N, M, B, LDB, DWORK( IWH ), M ) - CALL DSYTRS( 'Lower', M, N, DWORK( IWS ), M, IWORK, DWORK( IWH ), - $ M, INFO2 ) - CALL MB01RX( 'Left', 'Lower', 'NoTranspose', N, M, ZERO, ONE, - $ DWORK( IWG ), N, B, LDB, DWORK( IWH ), M, INFO2 ) - CALL SB02SD( 'C', 'N', 'N', 'L', 'O', N, A, LDA, DWORK( IWT ), N, - $ DWORK( IWU ), N, DWORK( IWG ), N, DWORK( IWQ ), N, X, - $ LDX, SEPD, RCOND( 7 ), FERR, IWORK, DWORK( IWRK ), - $ LDWORK-IWRK+1, INFO2 ) - IF( INFO2.GT.0 ) RCOND( 7 ) = ZERO - LWAMAX = MAX( INT( DWORK( IWRK ) ) + IWRK - 1, LWAMAX ) -C -C Workspace usage. -C - IWRK = IWR -C -C Compute the lower triangle of |R1 R2'| = R0 + B'*X*B . -C |R2 R3 | -C - CALL MB01RU( 'Lower', 'Transpose', M, N, ONE, ONE, DWORK, M, - $ B, LDB, X, LDX, DWORK( IWRK ), M*N, INFO2 ) -C -C Compute the Cholesky factorization of R3, R3 = V12'*V12 . -C Note that V12' is stored. -C - ANORM = DLANSY( '1', 'Lower', M2, DWORK( IR3 ), M, DWORK( IWRK ) ) - CALL DPOTRF( 'Lower', M2, DWORK( IR3 ), M, INFO2 ) - IF( INFO2.GT.0 ) THEN - INFO = 5 - RETURN - END IF - CALL DPOCON( 'Lower', M2, DWORK( IR3 ), M, ANORM, RCOND( 1 ), - $ DWORK( IWRK ), IWORK, INFO2 ) -C -C Return if the matrix is singular to working precision. -C - IF( RCOND( 1 ).LT.TOLL ) THEN - INFO = 5 - RETURN - END IF -C - CALL DTRCON( '1', 'Lower', 'NonUnit', M2, DWORK( IR3 ), M, - $ RCOND( 5 ), DWORK( IWRK ), IWORK, INFO2 ) -C -C Return if the matrix is singular to working precision. -C - IF( RCOND( 5 ).LT.TOLL ) THEN - INFO = 5 - RETURN - END IF -C -C Compute R2 <- inv(V12')*R2 . -C - CALL DTRSM( 'Left', 'Lower', 'NoTranspose', 'NonUnit', M2, M1, - $ ONE, DWORK( IR3 ), M, DWORK( IR2 ), M ) -C -C Compute -Nabla = R2'*inv(R3)*R2 - R1 . -C - CALL DSYRK( 'Lower', 'Transpose', M1, M2, ONE, DWORK( IR2 ), M, - $ -ONE, DWORK, M ) -C -C Compute the Cholesky factorization of -Nabla, -Nabla = V21t'*V21t. -C Note that V21t' is stored. -C - ANORM = DLANSY( '1', 'Lower', M1, DWORK, M, DWORK( IWRK ) ) - CALL DPOTRF( 'Lower', M1, DWORK, M, INFO2 ) - IF( INFO2.GT.0 ) THEN - INFO = 5 - RETURN - END IF - CALL DPOCON( 'Lower', M1, DWORK, M, ANORM, RCOND( 2 ), - $ DWORK( IWRK ), IWORK, INFO2 ) -C -C Return if the matrix is singular to working precision. -C - IF( RCOND( 2 ).LT.TOLL ) THEN - INFO = 5 - RETURN - END IF -C - CALL DTRCON( '1', 'Lower', 'NonUnit', M1, DWORK, M, RCOND( 3 ), - $ DWORK( IWRK ), IWORK, INFO2 ) -C -C Return if the matrix is singular to working precision. -C - IF( RCOND( 3 ).LT.TOLL ) THEN - INFO = 5 - RETURN - END IF -C -C Compute X*A . -C - CALL DGEMM( 'NoTranspose', 'NoTranspose', N, N, N, ONE, X, LDX, - $ A, LDA, ZERO, DWORK( IWQ ), N ) -C -C Compute |L1| = |D11'|*C1 + B'*X*A . -C |L2| = |D12'| -C - CALL MA02AD( 'Full', N, M, DWORK( IWL ), N, DWORK( IWRK ), M ) - CALL DLACPY( 'Full', M, N, DWORK( IWRK ), M, DWORK( IWL ), M ) - CALL DGEMM( 'Transpose', 'NoTranspose', M, N, N, ONE, B, LDB, - $ DWORK( IWQ ), N, ONE, DWORK( IWL ), M ) -C -C Compute L2 <- inv(V12')*L2 . -C - CALL DTRSM( 'Left', 'Lower', 'NoTranspose', 'NonUnit', M2, N, ONE, - $ DWORK( IR3 ), M, DWORK( IWL+M1 ), M ) -C -C Compute L_Nabla = L1 - R2'*inv(R3)*L2 . -C - CALL DGEMM( 'Transpose', 'NoTranspose', M1, N, M2, -ONE, - $ DWORK( IR2 ), M, DWORK( IWL+M1 ), M, ONE, - $ DWORK( IWL ), M ) -C -C Compute L_Nabla <- inv(V21t')*L_Nabla . -C - CALL DTRSM( 'Left', 'Lower', 'NoTranspose', 'NonUnit', M1, N, ONE, - $ DWORK, M, DWORK( IWL ), M ) -C -C Compute Bt1 = B1*inv(V21t) . -C - CALL DLACPY( 'Full', N, M1, B, LDB, DWORK( IWB ), N ) - CALL DTRSM( 'Right', 'Lower', 'Transpose', 'NonUnit', N, M1, ONE, - $ DWORK, M, DWORK( IWB ), N ) -C -C Compute At . -C - CALL DLACPY( 'Full', N, N, A, LDA, AK, LDAK ) - CALL DGEMM( 'NoTranspose', 'NoTranspose', N, N, M1, ONE, - $ DWORK( IWB ), N, DWORK( IWL ), M, ONE, AK, LDAK ) -C -C Scale Bt1 . -C - CALL DSCAL( N*M1, GAMMA, DWORK( IWB ), 1 ) -C -C Compute |Dt11| = |R2 |*inv(V21t) . -C |Dt21| |D21| -C - CALL DLACPY( 'Full', M2, M1, DWORK( IR2 ), M, DWORK( IWD ), - $ M2+NP2 ) - CALL DLACPY( 'Full', NP2, M1, D( NP1+1, 1 ), LDD, DWORK( IWD+M2 ), - $ M2+NP2 ) - CALL DTRSM( 'Right', 'Lower', 'Transpose', 'NonUnit', M2+NP2, - $ M1, ONE, DWORK, M, DWORK( IWD ), M2+NP2 ) -C -C Compute Ct = |Ct1| = |L2| + |Dt11|*inv(V21t')*L_Nabla . -C |Ct2| = |C2| + |Dt21| -C - CALL DLACPY( 'Full', M2, N, DWORK( IWL+M1 ), M, DWORK( IWC ), - $ M2+NP2 ) - CALL DLACPY( 'Full', NP2, N, C( NP1+1, 1 ), LDC, DWORK( IWC+M2 ), - $ M2+NP2 ) - CALL DGEMM( 'NoTranspose', 'NoTranspose', M2+NP2, N, M1, ONE, - $ DWORK( IWD ), M2+NP2, DWORK( IWL ), M, ONE, - $ DWORK( IWC ), M2+NP2 ) -C -C Scale |Dt11| . -C |Dt21| -C - CALL DSCAL( ( M2+NP2 )*M1, GAMMA, DWORK( IWD ), 1 ) -C -C Workspace usage. -C - IWW = IWD + ( M2 + NP2 )*M1 - IWQ = IWW + ( M2 + NP2 )*( M2 + NP2 ) - IWL = IWQ + N*N - IWR = IWL + N*( M2 + NP2 ) - IWI = IWR + 2*N - IWH = IWI + 2*N - IWS = IWH + 2*N - IWT = IWS + ( 2*N + M2 + NP2 )*( 2*N + M2 + NP2 ) - IWU = IWT + ( 2*N + M2 + NP2 )*2*N - IWG = IWU + 4*N*N - IWRK = IWG + ( M2 + NP2 )*N - IS2 = IWW + ( M2 + NP2 )*M2 - IS3 = IS2 + M2 -C -C Compute S0 = |Dt11||Dt11' Dt21'| -|gamma^2*Im2 0| . -C |Dt21| | 0 0| -C - CALL DSYRK( 'Upper', 'NoTranspose', M2+NP2, M1, ONE, DWORK( IWD ), - $ M2+NP2, ZERO, DWORK( IWW ), M2+NP2 ) - DO 20 J = IWW, IWW - 1 + ( M2 + NP2 )*M2, M2 + NP2 + 1 - DWORK( J ) = DWORK( J ) - GAMMA*GAMMA - 20 CONTINUE -C -C Compute Bt1*Bt1' . -C - CALL DSYRK( 'Upper', 'NoTranspose', N, M1, ONE, DWORK( IWB ), N, - $ ZERO, DWORK( IWQ ), N ) -C -C Compute Bt1*|Dt11' Dt21'| . -C - CALL DGEMM( 'NoTranspose', 'Transpose', N, M2+NP2, M1, ONE, - $ DWORK( IWB ), N, DWORK( IWD ), M2+NP2, ZERO, - $ DWORK( IWL ), N ) -C -C Transpose At in situ (in AK) . -C - DO 30 J = 2, N - CALL DSWAP( J-1, AK( J, 1 ), LDAK, AK( 1, J ), 1 ) - 30 CONTINUE -C -C Transpose Ct . -C - CALL MA02AD( 'Full', M2+NP2, N, DWORK( IWC ), M2+NP2, - $ DWORK( IWG ), N ) -C -C Solution of the Z-Riccati equation. -C Workspace: need 13*N*N + M*M + (8*N+M+M2+2*NP2)*(M2+NP2) + -C N*(M+NP2) + 6*N + -C max(14*N+23,16*N,2*N+M2+NP2,3*(M2+NP2)); -C prefer larger. -C - CALL SB02OD( 'D', 'B', 'N', 'U', 'N', 'S', N, M2+NP2, NP, AK, - $ LDAK, DWORK( IWG ), N, DWORK( IWQ ), N, DWORK( IWW ), - $ M2+NP2, DWORK( IWL ), N, RCOND2, Z, LDZ, DWORK( IWR), - $ DWORK( IWI ), DWORK( IWH ), DWORK( IWS ), 2*N+M2+NP2, - $ DWORK( IWT ), 2*N+M2+NP2, DWORK( IWU ), 2*N, TOLL, - $ IWORK, DWORK( IWRK ), LDWORK-IWRK+1, BWORK, INFO2 ) - IF( INFO2.GT.0 ) THEN - INFO = 7 - RETURN - END IF - LWAMAX = MAX( INT( DWORK( IWRK ) ) + IWRK - 1, LWAMAX ) -C -C Condition estimation. -C Workspace: need 4*N*N + M*M + 2*(M2+NP2)*(M2+NP2)+ -C N*(M+2*M2+3*NP2) + (M2+NP2)*M1 + -C max(5*N,max(3,2*N*N)+N*N); -C prefer larger. -C - IWS = IWR - IWH = IWS + ( M2 + NP2 )*( M2 + NP2 ) - IWT = IWH + N*( M2 + NP2 ) - IWU = IWT + N*N - IWG = IWU + N*N - IWRK = IWG + N*N - CALL DLACPY( 'Upper', M2+NP2, M2+NP2, DWORK( IWW ), M2+NP2, - $ DWORK( IWS ), M2+NP2 ) - CALL DSYTRF( 'Upper', M2+NP2, DWORK( IWS ), M2+NP2, IWORK, - $ DWORK( IWRK ), LDWORK-IWRK+1, INFO2 ) - IF( INFO2.GT.0 ) THEN - INFO = 5 - RETURN - END IF - LWAMAX = MAX( INT( DWORK( IWRK ) ) + IWRK - 1, LWAMAX ) -C - CALL DLACPY( 'Full', M2+NP2, N, DWORK( IWC ), M2+NP2, - $ DWORK( IWH ), M2+NP2 ) - CALL DSYTRS( 'Upper', M2+NP2, N, DWORK( IWS ), M2+NP2, IWORK, - $ DWORK( IWH ), M2+NP2, INFO2 ) - CALL MB01RX( 'Left', 'Upper', 'Transpose', N, M2+NP2, ZERO, ONE, - $ DWORK( IWG ), N, DWORK( IWC ), M2+NP2, DWORK( IWH ), - $ M2+NP2, INFO2 ) - CALL SB02SD( 'C', 'N', 'N', 'U', 'O', N, AK, LDAK, DWORK( IWT ), - $ N, DWORK( IWU ), N, DWORK( IWG ), N, DWORK( IWQ ), N, - $ Z, LDZ, SEPD, RCOND( 8 ), FERR, IWORK, DWORK( IWRK ), - $ LDWORK-IWRK+1, INFO2 ) - IF( INFO2.GT.0 ) RCOND( 8 ) = ZERO - LWAMAX = MAX( INT( DWORK( IWRK ) ) + IWRK - 1, LWAMAX ) -C -C Workspace usage. -C - IWRK = IWR -C -C Compute the upper triangle of -C |St1 St2| = S0 + |Ct1|*Z*|Ct1' Ct2'| . -C |St2' St3| |Ct2| -C - CALL MB01RU( 'Upper', 'NoTranspose', M2+NP2, N, ONE, ONE, - $ DWORK( IWW ), M2+NP2, DWORK( IWC ), M2+NP2, Z, LDZ, - $ DWORK( IWRK ), (M2+NP2)*N, INFO2 ) -C -C Compute the Cholesky factorization of St3, St3 = U12'*U12 . -C - ANORM = DLANSY( '1', 'Upper', NP2, DWORK( IS3 ), M2+NP2, - $ DWORK( IWRK ) ) - CALL DPOTRF( 'Upper', NP2, DWORK( IS3 ), M2+NP2, INFO2 ) - IF( INFO2.GT.0 ) THEN - INFO = 5 - RETURN - END IF - CALL DPOCON( 'Upper', NP2, DWORK( IS3 ), M2+NP2, ANORM, - $ RCOND( 4 ), DWORK( IWRK ), IWORK, INFO2 ) -C -C Return if the matrix is singular to working precision. -C - IF( RCOND( 4 ).LT.TOLL ) THEN - INFO = 5 - RETURN - END IF -C -C Compute St2 <- St2*inv(U12) . -C - CALL DTRSM( 'Right', 'Upper', 'NoTranspose', 'NonUnit', M2, NP2, - $ ONE, DWORK( IS3 ), M2+NP2, DWORK( IS2 ), M2+NP2 ) -C -C Check the negative definiteness of St1 - St2*inv(St3)*St2' . -C - CALL DSYRK( 'Upper', 'NoTranspose', M2, NP2, ONE, DWORK( IS2 ), - $ M2+NP2, -ONE, DWORK( IWW ), M2+NP2 ) - CALL DPOTRF( 'Upper', M2, DWORK( IWW ), M2+NP2, INFO2 ) - IF( INFO2.GT.0 ) THEN - INFO = 5 - RETURN - END IF -C -C Restore At in situ . -C - DO 40 J = 2, N - CALL DSWAP( J-1, AK( J, 1 ), LDAK, AK( 1, J ), 1 ) - 40 CONTINUE -C -C Compute At*Z . -C - CALL DGEMM( 'NoTranspose', 'NoTranspose', N, N, N, ONE, AK, LDAK, - $ Z, LDZ, ZERO, DWORK( IWRK ), N ) -C -C Compute Mt2 = Bt1*Dt21' + At*Z*Ct2' in BK . -C - CALL DLACPY( 'Full', N, NP2, DWORK( IWL+N*M2 ), N, BK, LDBK ) - CALL DGEMM( 'NoTranspose', 'Transpose', N, NP2, N, ONE, - $ DWORK( IWRK ), N, DWORK( IWC+M2 ), M2+NP2, ONE, - $ BK, LDBK ) -C -C Compute St2 <- St2*inv(U12') . -C - CALL DTRSM( 'Right', 'Upper', 'Transpose', 'NonUnit', M2, NP2, - $ ONE, DWORK( IS3 ), M2+NP2, DWORK( IS2 ), M2+NP2 ) -C -C Compute DKHAT = -inv(V12)*St2 in DK . -C - CALL DLACPY( 'Full', M2, NP2, DWORK( IS2 ), M2+NP2, DK, LDDK ) - CALL DTRSM( 'Left', 'Lower', 'Transpose', 'NonUnit', M2, NP2, - $ -ONE, DWORK( IR3 ), M, DK, LDDK ) -C -C Compute CKHAT = -inv(V12)*(Ct1 - St2*inv(St3)*Ct2) in CK . -C - CALL DLACPY( 'Full', M2, N, DWORK( IWC ), M2+NP2, CK, LDCK ) - CALL DGEMM( 'NoTranspose', 'NoTranspose', M2, N, NP2, -ONE, - $ DWORK( IS2 ), M2+NP2, DWORK( IWC+M2 ), M2+NP2, ONE, - $ CK, LDCK ) - CALL DTRSM( 'Left', 'Lower', 'Transpose', 'NonUnit', M2, N, -ONE, - $ DWORK( IR3 ), M, CK, LDCK ) -C -C Compute Mt2*inv(St3) in BK . -C - CALL DTRSM( 'Right', 'Upper', 'NoTranspose', 'NonUnit', N, NP2, - $ ONE, DWORK( IS3 ), M2+NP2, BK, LDBK ) - CALL DTRSM( 'Right', 'Upper', 'Transpose', 'NonUnit', N, NP2, - $ ONE, DWORK( IS3 ), M2+NP2, BK, LDBK ) -C -C Compute AKHAT in AK . -C - CALL DGEMM( 'NoTranspose', 'NoTranspose', N, N, M2, ONE, - $ B( 1, M1+1 ), LDB, CK, LDCK, ONE, AK, LDAK ) - CALL DGEMM( 'NoTranspose', 'NoTranspose', N, N, NP2, -ONE, BK, - $ LDBK, DWORK( IWC+M2 ), M2+NP2, ONE, AK, LDAK ) -C -C Compute BKHAT in BK . -C - CALL DGEMM( 'NoTranspose', 'NoTranspose', N, NP2, M2, ONE, - $ B( 1, M1+1 ), LDB, DK, LDDK, ONE, BK, LDBK ) -C -C Compute Im2 + DKHAT*D22 . -C - IWRK = M2*M2 + 1 - CALL DLASET( 'Full', M2, M2, ZERO, ONE, DWORK, M2 ) - CALL DGEMM( 'NoTranspose', 'NoTranspose', M2, M2, NP2, ONE, DK, - $ LDDK, D( NP1+1, M1+1 ), LDD, ONE, DWORK, M2 ) - ANORM = DLANGE( '1', M2, M2, DWORK, M2, DWORK( IWRK ) ) - CALL DGETRF( M2, M2, DWORK, M2, IWORK, INFO2 ) - IF( INFO2.GT.0 ) THEN - INFO = 8 - RETURN - END IF - CALL DGECON( '1', M2, DWORK, M2, ANORM, RCOND( 6 ), DWORK( IWRK ), - $ IWORK( M2+1 ), INFO2 ) -C -C Return if the matrix is singular to working precision. -C - IF( RCOND( 6 ).LT.TOLL ) THEN - INFO = 8 - RETURN - END IF -C -C Compute CK . -C - CALL DGETRS( 'NoTranspose', M2, N, DWORK, M2, IWORK, CK, LDCK, - $ INFO2 ) -C -C Compute DK . -C - CALL DGETRS( 'NoTranspose', M2, NP2, DWORK, M2, IWORK, DK, LDDK, - $ INFO2 ) -C -C Compute AK . -C - CALL DGEMM( 'NoTranspose', 'NoTranspose', N, M2, NP2, ONE, BK, - $ LDBK, D( NP1+1, M1+1 ), LDD, ZERO, DWORK, N ) - CALL DGEMM( 'NoTranspose', 'NoTranspose', N, N, M2, -ONE, DWORK, - $ N, CK, LDCK, ONE, AK, LDAK ) -C -C Compute BK . -C - CALL DGEMM( 'NoTranspose', 'NoTranspose', N, NP2, M2, -ONE, DWORK, - $ N, DK, LDDK, ONE, BK, LDBK ) -C - DWORK( 1 ) = DBLE( LWAMAX ) - RETURN -C *** Last line of SB10DD *** - END diff --git a/mex/sources/libslicot/SB10ED.f b/mex/sources/libslicot/SB10ED.f deleted file mode 100644 index 51f7f048f..000000000 --- a/mex/sources/libslicot/SB10ED.f +++ /dev/null @@ -1,468 +0,0 @@ - SUBROUTINE SB10ED( N, M, NP, NCON, NMEAS, A, LDA, B, LDB, C, LDC, - $ D, LDD, AK, LDAK, BK, LDBK, CK, LDCK, DK, LDDK, - $ RCOND, TOL, IWORK, DWORK, LDWORK, BWORK, INFO ) -C -C SLICOT RELEASE 5.0. -C -C Copyright (c) 2002-2009 NICONET e.V. -C -C This program is free software: you can redistribute it and/or -C modify it under the terms of the GNU General Public License as -C published by the Free Software Foundation, either version 2 of -C the License, or (at your option) any later version. -C -C This program is distributed in the hope that it will be useful, -C but WITHOUT ANY WARRANTY; without even the implied warranty of -C MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the -C GNU General Public License for more details. -C -C You should have received a copy of the GNU General Public License -C along with this program. If not, see -C . -C -C PURPOSE -C -C To compute the matrices of the H2 optimal n-state controller -C -C | AK | BK | -C K = |----|----| -C | CK | DK | -C -C for the discrete-time system -C -C | A | B1 B2 | | A | B | -C P = |----|---------| = |---|---| , -C | C1 | 0 D12 | | C | D | -C | C2 | D21 D22 | -C -C where B2 has as column size the number of control inputs (NCON) -C and C2 has as row size the number of measurements (NMEAS) being -C provided to the controller. -C -C It is assumed that -C -C (A1) (A,B2) is stabilizable and (C2,A) is detectable, -C -C (A2) D12 is full column rank and D21 is full row rank, -C -C j*Theta -C (A3) | A-e *I B2 | has full column rank for all -C | C1 D12 | -C -C 0 <= Theta < 2*Pi , -C -C -C j*Theta -C (A4) | A-e *I B1 | has full row rank for all -C | C2 D21 | -C -C 0 <= Theta < 2*Pi . -C -C ARGUMENTS -C -C Input/Output Parameters -C -C N (input) INTEGER -C The order of the system. N >= 0. -C -C M (input) INTEGER -C The column size of the matrix B. M >= 0. -C -C NP (input) INTEGER -C The row size of the matrix C. NP >= 0. -C -C NCON (input) INTEGER -C The number of control inputs (M2). M >= NCON >= 0, -C NP-NMEAS >= NCON. -C -C NMEAS (input) INTEGER -C The number of measurements (NP2). NP >= NMEAS >= 0, -C M-NCON >= NMEAS. -C -C A (input/worksp.) DOUBLE PRECISION array, dimension (LDA,N) -C The leading N-by-N part of this array must contain the -C system state matrix A. -C This array is modified internally, but it is restored on -C exit. -C -C LDA INTEGER -C The leading dimension of the array A. LDA >= max(1,N). -C -C B (input) DOUBLE PRECISION array, dimension (LDB,M) -C The leading N-by-M part of this array must contain the -C system input matrix B. -C -C LDB INTEGER -C The leading dimension of the array B. LDB >= max(1,N). -C -C C (input) DOUBLE PRECISION array, dimension (LDC,N) -C The leading NP-by-N part of this array must contain the -C system output matrix C. -C -C LDC INTEGER -C The leading dimension of the array C. LDC >= max(1,NP). -C -C D (input) DOUBLE PRECISION array, dimension (LDD,M) -C The leading NP-by-M part of this array must contain the -C system input/output matrix D. -C -C LDD INTEGER -C The leading dimension of the array D. LDD >= max(1,NP). -C -C AK (output) DOUBLE PRECISION array, dimension (LDAK,N) -C The leading N-by-N part of this array contains the -C controller state matrix AK. -C -C LDAK INTEGER -C The leading dimension of the array AK. LDAK >= max(1,N). -C -C BK (output) DOUBLE PRECISION array, dimension (LDBK,NMEAS) -C The leading N-by-NMEAS part of this array contains the -C controller input matrix BK. -C -C LDBK INTEGER -C The leading dimension of the array BK. LDBK >= max(1,N). -C -C CK (output) DOUBLE PRECISION array, dimension (LDCK,N) -C The leading NCON-by-N part of this array contains the -C controller output matrix CK. -C -C LDCK INTEGER -C The leading dimension of the array CK. -C LDCK >= max(1,NCON). -C -C DK (output) DOUBLE PRECISION array, dimension (LDDK,NMEAS) -C The leading NCON-by-NMEAS part of this array contains the -C controller input/output matrix DK. -C -C LDDK INTEGER -C The leading dimension of the array DK. -C LDDK >= max(1,NCON). -C -C RCOND (output) DOUBLE PRECISION array, dimension (7) -C RCOND contains estimates the reciprocal condition -C numbers of the matrices which are to be inverted and the -C reciprocal condition numbers of the Riccati equations -C which have to be solved during the computation of the -C controller. (See the description of the algorithm in [2].) -C RCOND(1) contains the reciprocal condition number of the -C control transformation matrix TU; -C RCOND(2) contains the reciprocal condition number of the -C measurement transformation matrix TY; -C RCOND(3) contains the reciprocal condition number of the -C matrix Im2 + B2'*X2*B2; -C RCOND(4) contains the reciprocal condition number of the -C matrix Ip2 + C2*Y2*C2'; -C RCOND(5) contains the reciprocal condition number of the -C X-Riccati equation; -C RCOND(6) contains the reciprocal condition number of the -C Y-Riccati equation; -C RCOND(7) contains the reciprocal condition number of the -C matrix Im2 + DKHAT*D22 . -C -C Tolerances -C -C TOL DOUBLE PRECISION -C Tolerance used for controlling the accuracy of the -C transformations applied for diagonalizing D12 and D21, -C and for checking the nonsingularity of the matrices to be -C inverted. If TOL <= 0, then a default value equal to -C sqrt(EPS) is used, where EPS is the relative machine -C precision. -C -C Workspace -C -C IWORK INTEGER array, dimension max(2*M2,2*N,N*N,NP2) -C -C DWORK DOUBLE PRECISION array, dimension (LDWORK) -C On exit, if INFO = 0, DWORK(1) contains the optimal -C LDWORK. -C -C LDWORK INTEGER -C The dimension of the array DWORK. -C LDWORK >= N*M + NP*(N+M) + M2*M2 + NP2*NP2 + -C max(1,LW1,LW2,LW3,LW4,LW5,LW6), where -C LW1 = (N+NP1+1)*(N+M2) + max(3*(N+M2)+N+NP1,5*(N+M2)), -C LW2 = (N+NP2)*(N+M1+1) + max(3*(N+NP2)+N+M1,5*(N+NP2)), -C LW3 = M2 + NP1*NP1 + max(NP1*max(N,M1),3*M2+NP1,5*M2), -C LW4 = NP2 + M1*M1 + max(max(N,NP1)*M1,3*NP2+M1,5*NP2), -C LW5 = 2*N*N+max(1,14*N*N+6*N+max(14*N+23,16*N),M2*(N+M2+ -C max(3,M1)),NP2*(N+NP2+3)), -C LW6 = max(N*M2,N*NP2,M2*NP2,M2*M2+4*M2), -C with M1 = M - M2 and NP1 = NP - NP2. -C For good performance, LDWORK must generally be larger. -C Denoting Q = max(M1,M2,NP1,NP2), an upper bound is -C 2*Q*(3*Q+2*N)+max(1,(N+Q)*(N+Q+6),Q*(Q+max(N,Q,5)+1), -C 2*N*N+max(1,14*N*N+6*N+max(14*N+23,16*N), -C Q*(N+Q+max(Q,3)))). -C -C BWORK LOGICAL array, dimension (2*N) -C -C Error Indicator -C -C INFO INTEGER -C = 0: successful exit; -C < 0: if INFO = -i, the i-th argument had an illegal -C value; -C j*Theta -C = 1: if the matrix | A-e *I B2 | had not full -C | C1 D12 | -C column rank in respect to the tolerance EPS; -C j*Theta -C = 2: if the matrix | A-e *I B1 | had not full -C | C2 D21 | -C row rank in respect to the tolerance EPS; -C = 3: if the matrix D12 had not full column rank in -C respect to the tolerance TOL; -C = 4: if the matrix D21 had not full row rank in respect -C to the tolerance TOL; -C = 5: if the singular value decomposition (SVD) algorithm -C did not converge (when computing the SVD of one of -C the matrices |A-I B2 |, |A-I B1 |, D12 or D21). -C |C1 D12| |C2 D21| -C = 6: if the X-Riccati equation was not solved -C successfully; -C = 7: if the matrix Im2 + B2'*X2*B2 is not positive -C definite, or it is numerically singular (with -C respect to the tolerance TOL); -C = 8: if the Y-Riccati equation was not solved -C successfully; -C = 9: if the matrix Ip2 + C2*Y2*C2' is not positive -C definite, or it is numerically singular (with -C respect to the tolerance TOL); -C =10: if the matrix Im2 + DKHAT*D22 is singular, or its -C estimated condition number is larger than or equal -C to 1/TOL. -C -C METHOD -C -C The routine implements the formulas given in [1]. -C -C REFERENCES -C -C [1] Zhou, K., Doyle, J.C., and Glover, K. -C Robust and Optimal Control. -C Prentice-Hall, Upper Saddle River, NJ, 1996. -C -C [2] Petkov, P.Hr., Gu, D.W., and Konstantinov, M.M. -C Fortran 77 routines for Hinf and H2 design of linear -C discrete-time control systems. -C Report 99-8, Department of Engineering, Leicester University, -C April 1999. -C -C NUMERICAL ASPECTS -C -C The accuracy of the result depends on the condition numbers of the -C matrices which are to be inverted and on the condition numbers of -C the matrix Riccati equations which are to be solved in the -C computation of the controller. (The corresponding reciprocal -C condition numbers are given in the output array RCOND.) -C -C CONTRIBUTORS -C -C P.Hr. Petkov, D.W. Gu and M.M. Konstantinov, May 1999. -C -C REVISIONS -C -C V. Sima, Research Institute for Informatics, Bucharest, May 1999, -C Sept. 1999, Feb. 2000, Nov. 2005. -C -C KEYWORDS -C -C Algebraic Riccati equation, H2 optimal control, optimal regulator, -C robust control. -C -C ****************************************************************** -C -C .. Parameters .. - DOUBLE PRECISION ZERO, ONE - PARAMETER ( ZERO = 0.0D+0, ONE = 1.0D+0 ) -C .. -C .. Scalar Arguments .. - INTEGER INFO, LDA, LDAK, LDB, LDBK, LDC, LDCK, LDD, - $ LDDK, LDWORK, M, N, NCON, NMEAS, NP - DOUBLE PRECISION TOL -C .. -C .. Array Arguments .. - INTEGER IWORK( * ) - DOUBLE PRECISION A( LDA, * ), AK( LDAK, * ), B( LDB, * ), - $ BK( LDBK, * ), C( LDC, * ), CK( LDCK, * ), - $ D( LDD, * ), DK( LDDK, * ), DWORK( * ), - $ RCOND( * ) - LOGICAL BWORK( * ) -C .. -C .. Local Scalars .. - INTEGER I, INFO2, IWC, IWD, IWRK, IWTU, IWTY, IWX, IWY, - $ LW1, LW2, LW3, LW4, LW5, LW6, LWAMAX, M1, M2, - $ M2L, MINWRK, NL, NLP, NP1, NP2, NPL - DOUBLE PRECISION TOLL -C .. -C .. External Functions .. - DOUBLE PRECISION DLAMCH - EXTERNAL DLAMCH -C .. -C .. External Subroutines .. - EXTERNAL DLACPY, SB10PD, SB10SD, SB10TD, XERBLA -C .. -C .. Intrinsic Functions .. - INTRINSIC DBLE, INT, MAX, SQRT -C .. -C .. Executable Statements .. -C -C Decode and Test input parameters. -C - M1 = M - NCON - M2 = NCON - NP1 = NP - NMEAS - NP2 = NMEAS - NL = MAX( 1, N ) - NPL = MAX( 1, NP ) - M2L = MAX( 1, M2 ) - NLP = MAX( 1, NP2 ) -C - INFO = 0 - IF( N.LT.0 ) THEN - INFO = -1 - ELSE IF( M.LT.0 ) THEN - INFO = -2 - ELSE IF( NP.LT.0 ) THEN - INFO = -3 - ELSE IF( NCON.LT.0 .OR. M1.LT.0 .OR. M2.GT.NP1 ) THEN - INFO = -4 - ELSE IF( NMEAS.LT.0 .OR. NP1.LT.0 .OR. NP2.GT.M1 ) THEN - INFO = -5 - ELSE IF( LDA.LT.NL ) THEN - INFO = -7 - ELSE IF( LDB.LT.NL ) THEN - INFO = -9 - ELSE IF( LDC.LT.NPL ) THEN - INFO = -11 - ELSE IF( LDD.LT.NPL ) THEN - INFO = -13 - ELSE IF( LDAK.LT.NL ) THEN - INFO = -15 - ELSE IF( LDBK.LT.NL ) THEN - INFO = -17 - ELSE IF( LDCK.LT.M2L ) THEN - INFO = -19 - ELSE IF( LDDK.LT.M2L ) THEN - INFO = -21 - ELSE -C -C Compute workspace. -C - LW1 = ( N + NP1 + 1 )*( N + M2 ) + MAX( 3*( N + M2 ) + N + NP1, - $ 5*( N + M2 ) ) - LW2 = ( N + NP2 )*( N + M1 + 1 ) + MAX( 3*( N + NP2 ) + N + - $ M1, 5*( N + NP2 ) ) - LW3 = M2 + NP1*NP1 + MAX( NP1*MAX( N, M1 ), 3*M2 + NP1, 5*M2 ) - LW4 = NP2 + M1*M1 + MAX( MAX( N, NP1 )*M1, 3*NP2 + M1, 5*NP2 ) - LW5 = 2*N*N + MAX( 1, 14*N*N + - $ 6*N + MAX( 14*N + 23, 16*N ), - $ M2*( N + M2 + MAX( 3, M1 ) ), - $ NP2*( N + NP2 + 3 ) ) - LW6 = MAX( N*M2, N*NP2, M2*NP2, M2*M2 + 4*M2 ) - MINWRK = N*M + NP*( N + M ) + M2*M2 + NP2*NP2 + - $ MAX( 1, LW1, LW2, LW3, LW4, LW5, LW6 ) - IF( LDWORK.LT.MINWRK ) - $ INFO = -26 - END IF - IF( INFO.NE.0 ) THEN - CALL XERBLA( 'SB10ED', -INFO ) - RETURN - END IF -C -C Quick return if possible. -C - IF( N.EQ.0 .AND. MAX( M2, NP2 ).EQ.0 ) THEN - RCOND( 1 ) = ONE - RCOND( 2 ) = ONE - RCOND( 3 ) = ONE - RCOND( 4 ) = ONE - RCOND( 5 ) = ONE - RCOND( 6 ) = ONE - RCOND( 7 ) = ONE - DWORK( 1 ) = ONE - RETURN - END IF -C - TOLL = TOL - IF( TOLL.LE.ZERO ) THEN -C -C Set the default value of the tolerance for rank tests. -C - TOLL = SQRT( DLAMCH( 'Epsilon' ) ) - END IF -C -C Workspace usage. -C - IWC = N*M + 1 - IWD = IWC + NP*N - IWTU = IWD + NP*M - IWTY = IWTU + M2*M2 - IWRK = IWTY + NP2*NP2 -C - CALL DLACPY( 'Full', N, M, B, LDB, DWORK, NL ) - CALL DLACPY( 'Full', NP, N, C, LDC, DWORK( IWC ), NPL ) - CALL DLACPY( 'Full', NP, M, D, LDD, DWORK( IWD ), NPL ) -C -C Transform the system so that D12 and D21 satisfy the formulas -C in the computation of the H2 optimal controller. -C Since SLICOT Library routine SB10PD performs the tests -C corresponding to the continuous-time counterparts of the -C assumptions (A3) and (A4), for the frequency w = 0, the -C next SB10PD routine call uses A - I. -C - DO 10 I = 1, N - A(I,I) = A(I,I) - ONE - 10 CONTINUE -C - CALL SB10PD( N, M, NP, NCON, NMEAS, A, LDA, DWORK, NL, - $ DWORK( IWC ), NPL, DWORK( IWD ), NPL, DWORK( IWTU ), - $ M2L, DWORK( IWTY ), NLP, RCOND, TOLL, DWORK( IWRK ), - $ LDWORK-IWRK+1, INFO2 ) -C - DO 20 I = 1, N - A(I,I) = A(I,I) + ONE - 20 CONTINUE -C - IF( INFO2.GT.0 ) THEN - INFO = INFO2 - RETURN - END IF - LWAMAX = INT( DWORK( IWRK ) ) + IWRK - 1 -C - IWX = IWRK - IWY = IWX + N*N - IWRK = IWY + N*N -C -C Compute the optimal H2 controller for the normalized system. -C - CALL SB10SD( N, M, NP, NCON, NMEAS, A, LDA, DWORK, NL, - $ DWORK( IWC ), NPL, DWORK( IWD ), NPL, AK, LDAK, BK, - $ LDBK, CK, LDCK, DK, LDDK, DWORK( IWX ), NL, - $ DWORK( IWY ), NL, RCOND( 3 ), TOLL, IWORK, - $ DWORK( IWRK ), LDWORK-IWRK+1, BWORK, INFO2 ) - IF( INFO2.GT.0 ) THEN - INFO = INFO2 + 5 - RETURN - END IF - LWAMAX = MAX( INT( DWORK( IWRK ) ) + IWRK - 1, LWAMAX ) -C - IWRK = IWX -C -C Compute the H2 optimal controller for the original system. -C - CALL SB10TD( N, M, NP, NCON, NMEAS, DWORK( IWD ), NPL, - $ DWORK( IWTU ), M2L, DWORK( IWTY ), NLP, AK, LDAK, BK, - $ LDBK, CK, LDCK, DK, LDDK, RCOND( 7 ), TOLL, IWORK, - $ DWORK( IWRK ), LDWORK-IWRK+1, INFO2 ) - IF( INFO2.GT.0 ) THEN - INFO = 10 - RETURN - END IF -C - DWORK( 1 ) = DBLE( LWAMAX ) - RETURN -C *** Last line of SB10ED *** - END diff --git a/mex/sources/libslicot/SB10FD.f b/mex/sources/libslicot/SB10FD.f deleted file mode 100644 index 61fcdd4f3..000000000 --- a/mex/sources/libslicot/SB10FD.f +++ /dev/null @@ -1,469 +0,0 @@ - SUBROUTINE SB10FD( N, M, NP, NCON, NMEAS, GAMMA, A, LDA, B, LDB, - $ C, LDC, D, LDD, AK, LDAK, BK, LDBK, CK, LDCK, - $ DK, LDDK, RCOND, TOL, IWORK, DWORK, LDWORK, - $ BWORK, INFO ) -C -C SLICOT RELEASE 5.0. -C -C Copyright (c) 2002-2009 NICONET e.V. -C -C This program is free software: you can redistribute it and/or -C modify it under the terms of the GNU General Public License as -C published by the Free Software Foundation, either version 2 of -C the License, or (at your option) any later version. -C -C This program is distributed in the hope that it will be useful, -C but WITHOUT ANY WARRANTY; without even the implied warranty of -C MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the -C GNU General Public License for more details. -C -C You should have received a copy of the GNU General Public License -C along with this program. If not, see -C . -C -C PURPOSE -C -C To compute the matrices of an H-infinity (sub)optimal n-state -C controller -C -C | AK | BK | -C K = |----|----|, -C | CK | DK | -C -C using modified Glover's and Doyle's 1988 formulas, for the system -C -C | A | B1 B2 | | A | B | -C P = |----|---------| = |---|---| -C | C1 | D11 D12 | | C | D | -C | C2 | D21 D22 | -C -C and for a given value of gamma, where B2 has as column size the -C number of control inputs (NCON) and C2 has as row size the number -C of measurements (NMEAS) being provided to the controller. -C -C It is assumed that -C -C (A1) (A,B2) is stabilizable and (C2,A) is detectable, -C -C (A2) D12 is full column rank and D21 is full row rank, -C -C (A3) | A-j*omega*I B2 | has full column rank for all omega, -C | C1 D12 | -C -C (A4) | A-j*omega*I B1 | has full row rank for all omega. -C | C2 D21 | -C -C ARGUMENTS -C -C Input/Output Parameters -C -C N (input) INTEGER -C The order of the system. N >= 0. -C -C M (input) INTEGER -C The column size of the matrix B. M >= 0. -C -C NP (input) INTEGER -C The row size of the matrix C. NP >= 0. -C -C NCON (input) INTEGER -C The number of control inputs (M2). M >= NCON >= 0, -C NP-NMEAS >= NCON. -C -C NMEAS (input) INTEGER -C The number of measurements (NP2). NP >= NMEAS >= 0, -C M-NCON >= NMEAS. -C -C GAMMA (input) DOUBLE PRECISION -C The value of gamma. It is assumed that gamma is -C sufficiently large so that the controller is admissible. -C GAMMA >= 0. -C -C A (input) DOUBLE PRECISION array, dimension (LDA,N) -C The leading N-by-N part of this array must contain the -C system state matrix A. -C -C LDA INTEGER -C The leading dimension of the array A. LDA >= max(1,N). -C -C B (input) DOUBLE PRECISION array, dimension (LDB,M) -C The leading N-by-M part of this array must contain the -C system input matrix B. -C -C LDB INTEGER -C The leading dimension of the array B. LDB >= max(1,N). -C -C C (input) DOUBLE PRECISION array, dimension (LDC,N) -C The leading NP-by-N part of this array must contain the -C system output matrix C. -C -C LDC INTEGER -C The leading dimension of the array C. LDC >= max(1,NP). -C -C D (input) DOUBLE PRECISION array, dimension (LDD,M) -C The leading NP-by-M part of this array must contain the -C system input/output matrix D. -C -C LDD INTEGER -C The leading dimension of the array D. LDD >= max(1,NP). -C -C AK (output) DOUBLE PRECISION array, dimension (LDAK,N) -C The leading N-by-N part of this array contains the -C controller state matrix AK. -C -C LDAK INTEGER -C The leading dimension of the array AK. LDAK >= max(1,N). -C -C BK (output) DOUBLE PRECISION array, dimension (LDBK,NMEAS) -C The leading N-by-NMEAS part of this array contains the -C controller input matrix BK. -C -C LDBK INTEGER -C The leading dimension of the array BK. LDBK >= max(1,N). -C -C CK (output) DOUBLE PRECISION array, dimension (LDCK,N) -C The leading NCON-by-N part of this array contains the -C controller output matrix CK. -C -C LDCK INTEGER -C The leading dimension of the array CK. -C LDCK >= max(1,NCON). -C -C DK (output) DOUBLE PRECISION array, dimension (LDDK,NMEAS) -C The leading NCON-by-NMEAS part of this array contains the -C controller input/output matrix DK. -C -C LDDK INTEGER -C The leading dimension of the array DK. -C LDDK >= max(1,NCON). -C -C RCOND (output) DOUBLE PRECISION array, dimension (4) -C RCOND(1) contains the reciprocal condition number of the -C control transformation matrix; -C RCOND(2) contains the reciprocal condition number of the -C measurement transformation matrix; -C RCOND(3) contains an estimate of the reciprocal condition -C number of the X-Riccati equation; -C RCOND(4) contains an estimate of the reciprocal condition -C number of the Y-Riccati equation. -C -C Tolerances -C -C TOL DOUBLE PRECISION -C Tolerance used for controlling the accuracy of the applied -C transformations for computing the normalized form in -C SLICOT Library routine SB10PD. Transformation matrices -C whose reciprocal condition numbers are less than TOL are -C not allowed. If TOL <= 0, then a default value equal to -C sqrt(EPS) is used, where EPS is the relative machine -C precision. -C -C Workspace -C -C IWORK INTEGER array, dimension (LIWORK), where -C LIWORK = max(2*max(N,M-NCON,NP-NMEAS,NCON),N*N) -C -C DWORK DOUBLE PRECISION array, dimension (LDWORK) -C On exit, if INFO = 0, DWORK(1) contains the optimal -C LDWORK. -C -C LDWORK INTEGER -C The dimension of the array DWORK. -C LDWORK >= N*M + NP*(N+M) + M2*M2 + NP2*NP2 + -C max(1,LW1,LW2,LW3,LW4,LW5,LW6), where -C LW1 = (N+NP1+1)*(N+M2) + max(3*(N+M2)+N+NP1,5*(N+M2)), -C LW2 = (N+NP2)*(N+M1+1) + max(3*(N+NP2)+N+M1,5*(N+NP2)), -C LW3 = M2 + NP1*NP1 + max(NP1*max(N,M1),3*M2+NP1,5*M2), -C LW4 = NP2 + M1*M1 + max(max(N,NP1)*M1,3*NP2+M1,5*NP2), -C LW5 = 2*N*N + N*(M+NP) + -C max(1,M*M + max(2*M1,3*N*N+max(N*M,10*N*N+12*N+5)), -C NP*NP + max(2*NP1,3*N*N + -C max(N*NP,10*N*N+12*N+5))), -C LW6 = 2*N*N + N*(M+NP) + -C max(1, M2*NP2 + NP2*NP2 + M2*M2 + -C max(D1*D1 + max(2*D1, (D1+D2)*NP2), -C D2*D2 + max(2*D2, D2*M2), 3*N, -C N*(2*NP2 + M2) + -C max(2*N*M2, M2*NP2 + -C max(M2*M2+3*M2, NP2*(2*NP2+ -C M2+max(NP2,N)))))), -C with D1 = NP1 - M2, D2 = M1 - NP2, -C NP1 = NP - NP2, M1 = M - M2. -C For good performance, LDWORK must generally be larger. -C Denoting Q = max(M1,M2,NP1,NP2), an upper bound is -C 2*Q*(3*Q+2*N)+max(1,(N+Q)*(N+Q+6),Q*(Q+max(N,Q,5)+1), -C 2*N*(N+2*Q)+max(1,4*Q*Q+ -C max(2*Q,3*N*N+max(2*N*Q,10*N*N+12*N+5)), -C Q*(3*N+3*Q+max(2*N,4*Q+max(N,Q))))). -C -C BWORK LOGICAL array, dimension (2*N) -C -C Error Indicator -C -C INFO INTEGER -C = 0: successful exit; -C < 0: if INFO = -i, the i-th argument had an illegal -C value; -C = 1: if the matrix | A-j*omega*I B2 | had not full -C | C1 D12 | -C column rank in respect to the tolerance EPS; -C = 2: if the matrix | A-j*omega*I B1 | had not full row -C | C2 D21 | -C rank in respect to the tolerance EPS; -C = 3: if the matrix D12 had not full column rank in -C respect to the tolerance TOL; -C = 4: if the matrix D21 had not full row rank in respect -C to the tolerance TOL; -C = 5: if the singular value decomposition (SVD) algorithm -C did not converge (when computing the SVD of one of -C the matrices |A B2 |, |A B1 |, D12 or D21). -C |C1 D12| |C2 D21| -C = 6: if the controller is not admissible (too small value -C of gamma); -C = 7: if the X-Riccati equation was not solved -C successfully (the controller is not admissible or -C there are numerical difficulties); -C = 8: if the Y-Riccati equation was not solved -C successfully (the controller is not admissible or -C there are numerical difficulties); -C = 9: if the determinant of Im2 + Tu*D11HAT*Ty*D22 is -C zero [3]. -C -C METHOD -C -C The routine implements the Glover's and Doyle's 1988 formulas [1], -C [2] modified to improve the efficiency as described in [3]. -C -C REFERENCES -C -C [1] Glover, K. and Doyle, J.C. -C State-space formulae for all stabilizing controllers that -C satisfy an Hinf norm bound and relations to risk sensitivity. -C Systems and Control Letters, vol. 11, pp. 167-172, 1988. -C -C [2] Balas, G.J., Doyle, J.C., Glover, K., Packard, A., and -C Smith, R. -C mu-Analysis and Synthesis Toolbox. -C The MathWorks Inc., Natick, Mass., 1995. -C -C [3] Petkov, P.Hr., Gu, D.W., and Konstantinov, M.M. -C Fortran 77 routines for Hinf and H2 design of continuous-time -C linear control systems. -C Rep. 98-14, Department of Engineering, Leicester University, -C Leicester, U.K., 1998. -C -C NUMERICAL ASPECTS -C -C The accuracy of the result depends on the condition numbers of the -C input and output transformations and on the condition numbers of -C the two Riccati equations, as given by the values of RCOND(1), -C RCOND(2), RCOND(3) and RCOND(4), respectively. -C -C CONTRIBUTORS -C -C P.Hr. Petkov, D.W. Gu and M.M. Konstantinov, October 1998. -C -C REVISIONS -C -C V. Sima, Research Institute for Informatics, Bucharest, May 1999, -C Sept. 1999, Feb. 2000. -C -C KEYWORDS -C -C Algebraic Riccati equation, H-infinity optimal control, robust -C control. -C -C ****************************************************************** -C -C .. Parameters .. - DOUBLE PRECISION ZERO, ONE - PARAMETER ( ZERO = 0.0D+0, ONE = 1.0D+0 ) -C .. -C .. Scalar Arguments .. - INTEGER INFO, LDA, LDAK, LDB, LDBK, LDC, LDCK, LDD, - $ LDDK, LDWORK, M, N, NCON, NMEAS, NP - DOUBLE PRECISION GAMMA, TOL -C .. -C .. Array Arguments .. - LOGICAL BWORK( * ) - INTEGER IWORK( * ) - DOUBLE PRECISION A( LDA, * ), AK( LDAK, * ), B( LDB, * ), - $ BK( LDBK, * ), C( LDC, * ), CK( LDCK, * ), - $ D( LDD, * ), DK( LDDK, * ), DWORK( * ), - $ RCOND( 4 ) -C .. -C .. Local Scalars .. - INTEGER INFO2, IWC, IWD, IWF, IWH, IWRK, IWTU, IWTY, - $ IWX, IWY, LW1, LW2, LW3, LW4, LW5, LW6, - $ LWAMAX, M1, M2, MINWRK, ND1, ND2, NP1, NP2 - DOUBLE PRECISION TOLL -C .. -C .. External Functions .. - DOUBLE PRECISION DLAMCH - EXTERNAL DLAMCH -C .. -C .. External Subroutines .. - EXTERNAL DLACPY, SB10PD, SB10QD, SB10RD, XERBLA -C .. -C .. Intrinsic Functions .. - INTRINSIC DBLE, INT, MAX, SQRT -C .. -C .. Executable Statements .. -C -C Decode and Test input parameters. -C - M1 = M - NCON - M2 = NCON - NP1 = NP - NMEAS - NP2 = NMEAS -C - INFO = 0 - IF( N.LT.0 ) THEN - INFO = -1 - ELSE IF( M.LT.0 ) THEN - INFO = -2 - ELSE IF( NP.LT.0 ) THEN - INFO = -3 - ELSE IF( NCON.LT.0 .OR. M1.LT.0 .OR. M2.GT.NP1 ) THEN - INFO = -4 - ELSE IF( NMEAS.LT.0 .OR. NP1.LT.0 .OR. NP2.GT.M1 ) THEN - INFO = -5 - ELSE IF( GAMMA.LT.ZERO ) THEN - INFO = -6 - ELSE IF( LDA.LT.MAX( 1, N ) ) THEN - INFO = -8 - ELSE IF( LDB.LT.MAX( 1, N ) ) THEN - INFO = -10 - ELSE IF( LDC.LT.MAX( 1, NP ) ) THEN - INFO = -12 - ELSE IF( LDD.LT.MAX( 1, NP ) ) THEN - INFO = -14 - ELSE IF( LDAK.LT.MAX( 1, N ) ) THEN - INFO = -16 - ELSE IF( LDBK.LT.MAX( 1, N ) ) THEN - INFO = -18 - ELSE IF( LDCK.LT.MAX( 1, M2 ) ) THEN - INFO = -20 - ELSE IF( LDDK.LT.MAX( 1, M2 ) ) THEN - INFO = -22 - ELSE -C -C Compute workspace. -C - ND1 = NP1 - M2 - ND2 = M1 - NP2 - LW1 = ( N + NP1 + 1 )*( N + M2 ) + MAX( 3*( N + M2 ) + N + NP1, - $ 5*( N + M2 ) ) - LW2 = ( N + NP2 )*( N + M1 + 1 ) + MAX( 3*( N + NP2 ) + N + - $ M1, 5*( N + NP2 ) ) - LW3 = M2 + NP1*NP1 + MAX( NP1*MAX( N, M1 ), 3*M2 + NP1, 5*M2 ) - LW4 = NP2 + M1*M1 + MAX( MAX( N, NP1 )*M1, 3*NP2 + M1, 5*NP2 ) - LW5 = 2*N*N + N*( M + NP ) + - $ MAX( 1, M*M + MAX( 2*M1, 3*N*N + - $ MAX( N*M, 10*N*N + 12*N + 5 ) ), - $ NP*NP + MAX( 2*NP1, 3*N*N + - $ MAX( N*NP, 10*N*N + 12*N + 5 ) ) ) - LW6 = 2*N*N + N*( M + NP ) + - $ MAX( 1, M2*NP2 + NP2*NP2 + M2*M2 + - $ MAX( ND1*ND1 + MAX( 2*ND1, ( ND1 + ND2 )*NP2 ), - $ ND2*ND2 + MAX( 2*ND2, ND2*M2 ), 3*N, - $ N*( 2*NP2 + M2 ) + - $ MAX( 2*N*M2, M2*NP2 + - $ MAX( M2*M2 + 3*M2, NP2*( 2*NP2 + - $ M2 + MAX( NP2, N ) ) ) ) ) ) - MINWRK = N*M + NP*( N + M ) + M2*M2 + NP2*NP2 + - $ MAX( 1, LW1, LW2, LW3, LW4, LW5, LW6 ) - IF( LDWORK.LT.MINWRK ) - $ INFO = -27 - END IF - IF( INFO.NE.0 ) THEN - CALL XERBLA( 'SB10FD', -INFO ) - RETURN - END IF -C -C Quick return if possible. -C - IF( N.EQ.0 .OR. M.EQ.0 .OR. NP.EQ.0 .OR. M1.EQ.0 .OR. M2.EQ.0 - $ .OR. NP1.EQ.0 .OR. NP2.EQ.0 ) THEN - RCOND( 1 ) = ONE - RCOND( 2 ) = ONE - RCOND( 3 ) = ONE - RCOND( 4 ) = ONE - DWORK( 1 ) = ONE - RETURN - END IF -C - TOLL = TOL - IF( TOLL.LE.ZERO ) THEN -C -C Set the default value of the tolerance. -C - TOLL = SQRT( DLAMCH( 'Epsilon' ) ) - END IF -C -C Workspace usage. -C - IWC = 1 + N*M - IWD = IWC + NP*N - IWTU = IWD + NP*M - IWTY = IWTU + M2*M2 - IWRK = IWTY + NP2*NP2 -C - CALL DLACPY( 'Full', N, M, B, LDB, DWORK, N ) - CALL DLACPY( 'Full', NP, N, C, LDC, DWORK( IWC ), NP ) - CALL DLACPY( 'Full', NP, M, D, LDD, DWORK( IWD ), NP ) -C -C Transform the system so that D12 and D21 satisfy the formulas -C in the computation of the Hinf (sub)optimal controller. -C - CALL SB10PD( N, M, NP, NCON, NMEAS, A, LDA, DWORK, N, - $ DWORK( IWC ), NP, DWORK( IWD ), NP, DWORK( IWTU ), - $ M2, DWORK( IWTY ), NP2, RCOND, TOLL, DWORK( IWRK ), - $ LDWORK-IWRK+1, INFO2 ) - IF( INFO2.GT.0 ) THEN - INFO = INFO2 - RETURN - END IF - LWAMAX = INT( DWORK( IWRK ) ) + IWRK - 1 -C - IWX = IWRK - IWY = IWX + N*N - IWF = IWY + N*N - IWH = IWF + M*N - IWRK = IWH + N*NP -C -C Compute the (sub)optimal state feedback and output injection -C matrices. -C - CALL SB10QD( N, M, NP, NCON, NMEAS, GAMMA, A, LDA, DWORK, N, - $ DWORK( IWC ), NP, DWORK( IWD ), NP, DWORK( IWF ), - $ M, DWORK( IWH ), N, DWORK( IWX ), N, DWORK( IWY ), - $ N, RCOND(3), IWORK, DWORK( IWRK ), LDWORK-IWRK+1, - $ BWORK, INFO2 ) - IF( INFO2.GT.0 ) THEN - INFO = INFO2 + 5 - RETURN - END IF - LWAMAX = MAX( INT( DWORK( IWRK ) ) + IWRK - 1, LWAMAX ) -C -C Compute the Hinf (sub)optimal controller. -C - CALL SB10RD( N, M, NP, NCON, NMEAS, GAMMA, A, LDA, DWORK, N, - $ DWORK( IWC ), NP, DWORK( IWD ), NP, DWORK( IWF ), - $ M, DWORK( IWH ), N, DWORK( IWTU ), M2, DWORK( IWTY ), - $ NP2, DWORK( IWX ), N, DWORK( IWY ), N, AK, LDAK, BK, - $ LDBK, CK, LDCK, DK, LDDK, IWORK, DWORK( IWRK ), - $ LDWORK-IWRK+1, INFO2 ) - IF( INFO2.EQ.1 ) THEN - INFO = 6 - RETURN - ELSE IF( INFO2.EQ.2 ) THEN - INFO = 9 - RETURN - END IF - LWAMAX = MAX( INT( DWORK( IWRK ) ) + IWRK - 1, LWAMAX ) -C - DWORK( 1 ) = DBLE( LWAMAX ) - RETURN -C *** Last line of SB10FD *** - END diff --git a/mex/sources/libslicot/SB10HD.f b/mex/sources/libslicot/SB10HD.f deleted file mode 100644 index 5e350a98c..000000000 --- a/mex/sources/libslicot/SB10HD.f +++ /dev/null @@ -1,390 +0,0 @@ - SUBROUTINE SB10HD( N, M, NP, NCON, NMEAS, A, LDA, B, LDB, C, LDC, - $ D, LDD, AK, LDAK, BK, LDBK, CK, LDCK, DK, LDDK, - $ RCOND, TOL, IWORK, DWORK, LDWORK, BWORK, INFO ) -C -C SLICOT RELEASE 5.0. -C -C Copyright (c) 2002-2009 NICONET e.V. -C -C This program is free software: you can redistribute it and/or -C modify it under the terms of the GNU General Public License as -C published by the Free Software Foundation, either version 2 of -C the License, or (at your option) any later version. -C -C This program is distributed in the hope that it will be useful, -C but WITHOUT ANY WARRANTY; without even the implied warranty of -C MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the -C GNU General Public License for more details. -C -C You should have received a copy of the GNU General Public License -C along with this program. If not, see -C . -C -C PURPOSE -C -C To compute the matrices of the H2 optimal n-state controller -C -C | AK | BK | -C K = |----|----| -C | CK | DK | -C -C for the system -C -C | A | B1 B2 | | A | B | -C P = |----|---------| = |---|---| , -C | C1 | 0 D12 | | C | D | -C | C2 | D21 D22 | -C -C where B2 has as column size the number of control inputs (NCON) -C and C2 has as row size the number of measurements (NMEAS) being -C provided to the controller. -c -C It is assumed that -C -C (A1) (A,B2) is stabilizable and (C2,A) is detectable, -C -C (A2) The block D11 of D is zero, -C -C (A3) D12 is full column rank and D21 is full row rank. -C -C ARGUMENTS -C -C Input/Output Parameters -C -C N (input) INTEGER -C The order of the system. N >= 0. -C -C M (input) INTEGER -C The column size of the matrix B. M >= 0. -C -C NP (input) INTEGER -C The row size of the matrix C. NP >= 0. -C -C NCON (input) INTEGER -C The number of control inputs (M2). M >= NCON >= 0, -C NP-NMEAS >= NCON. -C -C NMEAS (input) INTEGER -C The number of measurements (NP2). NP >= NMEAS >= 0, -C M-NCON >= NMEAS. -C -C A (input) DOUBLE PRECISION array, dimension (LDA,N) -C The leading N-by-N part of this array must contain the -C system state matrix A. -C -C LDA INTEGER -C The leading dimension of the array A. LDA >= max(1,N). -C -C B (input) DOUBLE PRECISION array, dimension (LDB,M) -C The leading N-by-M part of this array must contain the -C system input matrix B. -C -C LDB INTEGER -C The leading dimension of the array B. LDB >= max(1,N). -C -C C (input) DOUBLE PRECISION array, dimension (LDC,N) -C The leading NP-by-N part of this array must contain the -C system output matrix C. -C -C LDC INTEGER -C The leading dimension of the array C. LDC >= max(1,NP). -C -C D (input) DOUBLE PRECISION array, dimension (LDD,M) -C The leading NP-by-M part of this array must contain the -C system input/output matrix D. -C -C LDD INTEGER -C The leading dimension of the array D. LDD >= max(1,NP). -C -C AK (output) DOUBLE PRECISION array, dimension (LDAK,N) -C The leading N-by-N part of this array contains the -C controller state matrix AK. -C -C LDAK INTEGER -C The leading dimension of the array AK. LDAK >= max(1,N). -C -C BK (output) DOUBLE PRECISION array, dimension (LDBK,NMEAS) -C The leading N-by-NMEAS part of this array contains the -C controller input matrix BK. -C -C LDBK INTEGER -C The leading dimension of the array BK. LDBK >= max(1,N). -C -C CK (output) DOUBLE PRECISION array, dimension (LDCK,N) -C The leading NCON-by-N part of this array contains the -C controller output matrix CK. -C -C LDCK INTEGER -C The leading dimension of the array CK. -C LDCK >= max(1,NCON). -C -C DK (output) DOUBLE PRECISION array, dimension (LDDK,NMEAS) -C The leading NCON-by-NMEAS part of this array contains the -C controller input/output matrix DK. -C -C LDDK INTEGER -C The leading dimension of the array DK. -C LDDK >= max(1,NCON). -C -C RCOND (output) DOUBLE PRECISION array, dimension (4) -C RCOND(1) contains the reciprocal condition number of the -C control transformation matrix; -C RCOND(2) contains the reciprocal condition number of the -C measurement transformation matrix; -C RCOND(3) contains an estimate of the reciprocal condition -C number of the X-Riccati equation; -C RCOND(4) contains an estimate of the reciprocal condition -C number of the Y-Riccati equation. -C -C Tolerances -C -C TOL DOUBLE PRECISION -C Tolerance used for controlling the accuracy of the applied -C transformations for computing the normalized form in -C SLICOT Library routine SB10UD. Transformation matrices -C whose reciprocal condition numbers are less than TOL are -C not allowed. If TOL <= 0, then a default value equal to -C sqrt(EPS) is used, where EPS is the relative machine -C precision. -C -C Workspace -C -C IWORK INTEGER array, dimension max(2*N,N*N) -C -C DWORK DOUBLE PRECISION array, dimension (LDWORK) -C On exit, if INFO = 0, DWORK(1) contains the optimal -C LDWORK. -C -C LDWORK INTEGER -C The dimension of the array DWORK. -C LDWORK >= N*M + NP*(N+M) + M2*M2 + NP2*NP2 + -C max(max(M2 + NP1*NP1 + -C max(NP1*N,3*M2+NP1,5*M2), -C NP2 + M1*M1 + -C max(M1*N,3*NP2+M1,5*NP2), -C N*M2,NP2*N,NP2*M2,1), -C N*(14*N+12+M2+NP2)+5), -C where M1 = M - M2 and NP1 = NP - NP2. -C For good performance, LDWORK must generally be larger. -C Denoting Q = max(M1,M2,NP1,NP2), an upper bound is -C 2*Q*(3*Q+2*N)+max(1,Q*(Q+max(N,5)+1),N*(14*N+12+2*Q)+5). -C -C BWORK LOGICAL array, dimension (2*N) -C -C Error Indicator -C -C INFO INTEGER -C = 0: successful exit; -C < 0: if INFO = -i, the i-th argument had an illegal -C value; -C = 1: if the matrix D12 had not full column rank in -C respect to the tolerance TOL; -C = 2: if the matrix D21 had not full row rank in respect -C to the tolerance TOL; -C = 3: if the singular value decomposition (SVD) algorithm -C did not converge (when computing the SVD of one of -C the matrices D12 or D21). -C = 4: if the X-Riccati equation was not solved -C successfully; -C = 5: if the Y-Riccati equation was not solved -C successfully. -C -C METHOD -C -C The routine implements the formulas given in [1], [2]. -C -C REFERENCES -C -C [1] Zhou, K., Doyle, J.C., and Glover, K. -C Robust and Optimal Control. -C Prentice-Hall, Upper Saddle River, NJ, 1996. -C -C [2] Balas, G.J., Doyle, J.C., Glover, K., Packard, A., and -C Smith, R. -C mu-Analysis and Synthesis Toolbox. -C The MathWorks Inc., Natick, Mass., 1995. -C -C NUMERICAL ASPECTS -C -C The accuracy of the result depends on the condition numbers of the -C input and output transformations and on the condition numbers of -C the two Riccati equations, as given by the values of RCOND(1), -C RCOND(2), RCOND(3) and RCOND(4), respectively. -C -C CONTRIBUTORS -C -C P.Hr. Petkov, D.W. Gu and M.M. Konstantinov, Oct. 1998. -C -C REVISIONS -C -C V. Sima, Research Institute for Informatics, Bucharest, May 1999, -C Sept. 1999, Jan. 2000, Feb. 2000. -C -C KEYWORDS -C -C Algebraic Riccati equation, H2 optimal control, optimal regulator, -C robust control. -C -C ********************************************************************* -C -C .. Parameters .. - DOUBLE PRECISION ZERO, ONE - PARAMETER ( ZERO = 0.0D+0, ONE = 1.0D+0 ) -C .. -C .. Scalar Arguments .. - INTEGER INFO, LDA, LDAK, LDB, LDBK, LDC, LDCK, LDD, - $ LDDK, LDWORK, M, N, NCON, NMEAS, NP - DOUBLE PRECISION TOL -C .. -C .. Array Arguments .. - LOGICAL BWORK( * ) - INTEGER IWORK( * ) - DOUBLE PRECISION A( LDA, * ), AK( LDAK, * ), B( LDB, * ), - $ BK( LDBK, * ), C( LDC, * ), CK( LDCK, * ), - $ D( LDD, * ), DK( LDDK, * ), DWORK( * ), - $ RCOND( 4 ) -C .. -C .. Local Scalars .. - INTEGER INFO2, IWC, IWD, IWF, IWH, IWRK, IWTU, IWTY, - $ IWY, LWAMAX, M1, M2, MINWRK, NP1, NP2 - DOUBLE PRECISION TOLL -C .. -C .. External Functions .. - DOUBLE PRECISION DLAMCH - EXTERNAL DLAMCH -C .. -C .. External Subroutines .. - EXTERNAL DLACPY, SB10UD, SB10VD, SB10WD, XERBLA -C .. -C .. Intrinsic Functions .. - INTRINSIC DBLE, INT, MAX, SQRT -C .. -C .. Executable Statements .. -C -C Decode and Test input parameters. -C - M1 = M - NCON - M2 = NCON - NP1 = NP - NMEAS - NP2 = NMEAS -C - INFO = 0 - IF( N.LT.0 ) THEN - INFO = -1 - ELSE IF( M.LT.0 ) THEN - INFO = -2 - ELSE IF( NP.LT.0 ) THEN - INFO = -3 - ELSE IF( NCON.LT.0 .OR. M1.LT.0 .OR. M2.GT.NP1 ) THEN - INFO = -4 - ELSE IF( NMEAS.LT.0 .OR. NP1.LT.0 .OR. NP2.GT.M1 ) THEN - INFO = -5 - ELSE IF( LDA.LT.MAX( 1, N ) ) THEN - INFO = -7 - ELSE IF( LDB.LT.MAX( 1, N ) ) THEN - INFO = -9 - ELSE IF( LDC.LT.MAX( 1, NP ) ) THEN - INFO = -11 - ELSE IF( LDD.LT.MAX( 1, NP ) ) THEN - INFO = -13 - ELSE IF( LDAK.LT.MAX( 1, N ) ) THEN - INFO = -15 - ELSE IF( LDBK.LT.MAX( 1, N ) ) THEN - INFO = -17 - ELSE IF( LDCK.LT.MAX( 1, M2 ) ) THEN - INFO = -19 - ELSE IF( LDDK.LT.MAX( 1, M2 ) ) THEN - INFO = -21 - ELSE -C -C Compute workspace. -C - MINWRK = N*M + NP*(N+M) + M2*M2 + NP2*NP2 + - $ MAX( MAX( M2 + NP1*NP1 + - $ MAX( NP1*N, 3*M2 + NP1, 5*M2 ), - $ NP2 + M1*M1 + - $ MAX( M1*N, 3*NP2 + M1, 5*NP2 ), - $ N*M2, NP2*N, NP2*M2, 1 ), - $ N*( 14*N + 12 + M2 + NP2 ) + 5 ) - IF( LDWORK.LT.MINWRK ) - $ INFO = -26 - END IF - IF( INFO.NE.0 ) THEN - CALL XERBLA( 'SB10HD', -INFO ) - RETURN - END IF -C -C Quick return if possible. -C - IF( N.EQ.0 .OR. M.EQ.0 .OR. NP.EQ.0 .OR. M1.EQ.0 .OR. M2.EQ.0 - $ .OR. NP1.EQ.0 .OR. NP2.EQ.0 ) THEN - RCOND( 1 ) = ONE - RCOND( 2 ) = ONE - RCOND( 3 ) = ONE - RCOND( 4 ) = ONE - DWORK( 1 ) = ONE - RETURN - END IF -C - TOLL = TOL - IF( TOLL.LE.ZERO ) THEN -C -C Set the default value of the tolerance for rank tests. -C - TOLL = SQRT( DLAMCH( 'Epsilon' ) ) - END IF -C -C Workspace usage. -C - IWC = N*M + 1 - IWD = IWC + NP*N - IWTU = IWD + NP*M - IWTY = IWTU + M2*M2 - IWRK = IWTY + NP2*NP2 -C - CALL DLACPY( 'Full', N, M, B, LDB, DWORK, N ) - CALL DLACPY( 'Full', NP, N, C, LDC, DWORK( IWC ), NP ) - CALL DLACPY( 'Full', NP, M, D, LDD, DWORK( IWD ), NP ) -C -C Transform the system so that D12 and D21 satisfy the formulas -C in the computation of the H2 optimal controller. -C - CALL SB10UD( N, M, NP, NCON, NMEAS, DWORK, N, DWORK( IWC ), NP, - $ DWORK( IWD ), NP, DWORK( IWTU ), M2, DWORK( IWTY ), - $ NP2, RCOND, TOLL, DWORK( IWRK ), LDWORK-IWRK+1, - $ INFO2 ) - IF( INFO2.GT.0 ) THEN - INFO = INFO2 - RETURN - END IF - LWAMAX = INT( DWORK( IWRK ) ) + IWRK - 1 -C - IWY = IWRK - IWF = IWY + N*N - IWH = IWF + M2*N - IWRK = IWH + N*NP2 -C -C Compute the optimal state feedback and output injection matrices. -C AK is used to store X. -C - CALL SB10VD( N, M, NP, NCON, NMEAS, A, LDA, DWORK, N, - $ DWORK( IWC ), NP, DWORK( IWF ), M2, DWORK( IWH ), N, - $ AK, LDAK, DWORK( IWY ), N, RCOND( 3 ), IWORK, - $ DWORK( IWRK ), LDWORK-IWRK+1, BWORK, INFO2 ) - IF( INFO2.GT.0 ) THEN - INFO = INFO2 + 3 - RETURN - END IF - LWAMAX = MAX( INT( DWORK( IWRK ) ) + IWRK - 1, LWAMAX ) -C -C Compute the H2 optimal controller. -C - CALL SB10WD( N, M, NP, NCON, NMEAS, A, LDA, DWORK, N, - $ DWORK( IWC ), NP, DWORK( IWD ), NP, DWORK( IWF ), M2, - $ DWORK( IWH ), N, DWORK( IWTU ), M2, DWORK( IWTY ), - $ NP2, AK, LDAK, BK, LDBK, CK, LDCK, DK, LDDK, INFO2 ) -C - DWORK( 1 ) = DBLE( LWAMAX ) - RETURN -C *** Last line of SB10HD *** - END diff --git a/mex/sources/libslicot/SB10ID.f b/mex/sources/libslicot/SB10ID.f deleted file mode 100644 index 2ea302e96..000000000 --- a/mex/sources/libslicot/SB10ID.f +++ /dev/null @@ -1,584 +0,0 @@ - SUBROUTINE SB10ID( N, M, NP, A, LDA, B, LDB, C, LDC, D, LDD, - $ FACTOR, NK, AK, LDAK, BK, LDBK, CK, LDCK, - $ DK, LDDK, RCOND, IWORK, DWORK, LDWORK, BWORK, - $ INFO ) -C -C SLICOT RELEASE 5.0. -C -C Copyright (c) 2002-2009 NICONET e.V. -C -C This program is free software: you can redistribute it and/or -C modify it under the terms of the GNU General Public License as -C published by the Free Software Foundation, either version 2 of -C the License, or (at your option) any later version. -C -C This program is distributed in the hope that it will be useful, -C but WITHOUT ANY WARRANTY; without even the implied warranty of -C MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the -C GNU General Public License for more details. -C -C You should have received a copy of the GNU General Public License -C along with this program. If not, see -C . -C -C PURPOSE -C -C To compute the matrices of the positive feedback controller -C -C | Ak | Bk | -C K = |----|----| -C | Ck | Dk | -C -C for the shaped plant -C -C | A | B | -C G = |---|---| -C | C | D | -C -C in the McFarlane/Glover Loop Shaping Design Procedure. -C -C ARGUMENTS -C -C Input/Output Parameters -C -C N (input) INTEGER -C The order of the plant. N >= 0. -C -C M (input) INTEGER -C The column size of the matrix B. M >= 0. -C -C NP (input) INTEGER -C The row size of the matrix C. NP >= 0. -C -C A (input) DOUBLE PRECISION array, dimension (LDA,N) -C The leading N-by-N part of this array must contain the -C system state matrix A of the shaped plant. -C -C LDA INTEGER -C The leading dimension of the array A. LDA >= max(1,N). -C -C B (input) DOUBLE PRECISION array, dimension (LDB,M) -C The leading N-by-M part of this array must contain the -C system input matrix B of the shaped plant. -C -C LDB INTEGER -C The leading dimension of the array B. LDB >= max(1,N). -C -C C (input) DOUBLE PRECISION array, dimension (LDC,N) -C The leading NP-by-N part of this array must contain the -C system output matrix C of the shaped plant. -C -C LDC INTEGER -C The leading dimension of the array C. LDC >= max(1,NP). -C -C D (input) DOUBLE PRECISION array, dimension (LDD,M) -C The leading NP-by-M part of this array must contain the -C system matrix D of the shaped plant. -C -C LDD INTEGER -C The leading dimension of the array D. LDD >= max(1,NP). -C -C FACTOR (input) DOUBLE PRECISION -C = 1 implies that an optimal controller is required; -C > 1 implies that a suboptimal controller is required, -C achieving a performance FACTOR less than optimal. -C FACTOR >= 1. -C -C NK (output) INTEGER -C The order of the positive feedback controller. NK <= N. -C -C AK (output) DOUBLE PRECISION array, dimension (LDAK,N) -C The leading NK-by-NK part of this array contains the -C controller state matrix Ak. -C -C LDAK INTEGER -C The leading dimension of the array AK. LDAK >= max(1,N). -C -C BK (output) DOUBLE PRECISION array, dimension (LDBK,NP) -C The leading NK-by-NP part of this array contains the -C controller input matrix Bk. -C -C LDBK INTEGER -C The leading dimension of the array BK. LDBK >= max(1,N). -C -C CK (output) DOUBLE PRECISION array, dimension (LDCK,N) -C The leading M-by-NK part of this array contains the -C controller output matrix Ck. -C -C LDCK INTEGER -C The leading dimension of the array CK. LDCK >= max(1,M). -C -C DK (output) DOUBLE PRECISION array, dimension (LDDK,NP) -C The leading M-by-NP part of this array contains the -C controller matrix Dk. -C -C LDDK INTEGER -C The leading dimension of the array DK. LDDK >= max(1,M). -C -C RCOND (output) DOUBLE PRECISION array, dimension (2) -C RCOND(1) contains an estimate of the reciprocal condition -C number of the X-Riccati equation; -C RCOND(2) contains an estimate of the reciprocal condition -C number of the Z-Riccati equation. -C -C Workspace -C -C IWORK INTEGER array, dimension max(2*N,N*N,M,NP) -C -C DWORK DOUBLE PRECISION array, dimension (LDWORK) -C On exit, if INFO = 0, DWORK(1) contains the optimal value -C of LDWORK. -C -C LDWORK INTEGER -C The dimension of the array DWORK. -C LDWORK >= 4*N*N + M*M + NP*NP + 2*M*N + N*NP + 4*N + -C max( 6*N*N + 5 + max(1,4*N*N+8*N), N*NP + 2*N ). -C For good performance, LDWORK must generally be larger. -C An upper bound of LDWORK in the above formula is -C LDWORK >= 10*N*N + M*M + NP*NP + 2*M*N + 2*N*NP + 4*N + -C 5 + max(1,4*N*N+8*N). -C -C BWORK LOGICAL array, dimension (2*N) -C -C Error Indicator -C -C INFO INTEGER -C = 0: successful exit; -C < 0: if INFO = -i, the i-th argument had an illegal -C value; -C = 1: the X-Riccati equation is not solved successfully; -C = 2: the Z-Riccati equation is not solved successfully; -C = 3: the iteration to compute eigenvalues or singular -C values failed to converge; -C = 4: the matrix Ip - D*Dk is singular; -C = 5: the matrix Im - Dk*D is singular; -C = 6: the closed-loop system is unstable. -C -C METHOD -C -C The routine implements the formulas given in [1]. -C -C REFERENCES -C -C [1] McFarlane, D. and Glover, K. -C A loop shaping design procedure using H_infinity synthesis. -C IEEE Trans. Automat. Control, vol. AC-37, no. 6, pp. 759-769, -C 1992. -C -C NUMERICAL ASPECTS -C -C The accuracy of the results depends on the conditioning of the -C two Riccati equations solved in the controller design (see the -C output parameter RCOND). -C -C CONTRIBUTORS -C -C P.Hr. Petkov, D.W. Gu and M.M. Konstantinov, October 2000. -C -C REVISIONS -C -C V. Sima, Research Institute for Informatics, Bucharest, Oct. 2000, -C Feb. 2001. -C -C KEYWORDS -C -C H_infinity control, Loop-shaping design, Robust control. -C -C ****************************************************************** -C -C .. Parameters .. - DOUBLE PRECISION ZERO, ONE - PARAMETER ( ZERO = 0.0D+0, ONE = 1.0D+0 ) -C .. -C .. Scalar Arguments .. - INTEGER INFO, LDA, LDAK, LDB, LDBK, LDC, LDCK, LDD, - $ LDDK, LDWORK, M, N, NK, NP - DOUBLE PRECISION FACTOR -C .. -C .. Array Arguments .. - INTEGER IWORK( * ) - LOGICAL BWORK( * ) - DOUBLE PRECISION A( LDA, * ), AK( LDAK, * ), B( LDB, * ), - $ BK( LDBK, * ), C( LDC, * ), CK( LDCK, * ), - $ D( LDD, * ), DK( LDDK, * ), DWORK( * ), - $ RCOND( 2 ) -C .. -C .. Local Scalars .. - CHARACTER*1 HINV - INTEGER I, I1, I2, I3, I4, I5, I6, I7, I8, I9, I10, - $ I11, I12, I13, INFO2, IWRK, J, LWA, LWAMAX, - $ MINWRK, N2, NS, SDIM - DOUBLE PRECISION SEP, FERR, GAMMA -C .. -C .. External Functions .. - LOGICAL SELECT - EXTERNAL SELECT -C .. -C .. External Subroutines .. - EXTERNAL DGEES, DGEMM, DLACPY, DLASET, DPOTRF, DPOTRS, - $ DSYRK, DTRSM, MB02VD, SB02RD, SB10JD, XERBLA -C .. -C .. Intrinsic Functions .. - INTRINSIC DBLE, INT, MAX, SQRT -C .. -C .. Executable Statements .. -C -C Decode and Test input parameters. -C - INFO = 0 - IF( N.LT.0 ) THEN - INFO = -1 - ELSE IF( M.LT.0 ) THEN - INFO = -2 - ELSE IF( NP.LT.0 ) THEN - INFO = -3 - ELSE IF( LDA.LT.MAX( 1, N ) ) THEN - INFO = -5 - ELSE IF( LDB.LT.MAX( 1, N ) ) THEN - INFO = -7 - ELSE IF( LDC.LT.MAX( 1, NP ) ) THEN - INFO = -9 - ELSE IF( LDD.LT.MAX( 1, NP ) ) THEN - INFO = -11 - ELSE IF( FACTOR.LT.ONE ) THEN - INFO = -12 - ELSE IF( LDAK.LT.MAX( 1, N ) ) THEN - INFO = -15 - ELSE IF( LDBK.LT.MAX( 1, N ) ) THEN - INFO = -17 - ELSE IF( LDCK.LT.MAX( 1, M ) ) THEN - INFO = -19 - ELSE IF( LDDK.LT.MAX( 1, M ) ) THEN - INFO = -21 - END IF -C -C Compute workspace. -C - MINWRK = 4*N*N + M*M + NP*NP + 2*M*N + N*NP + 4*N + - $ MAX( 6*N*N + 5 + MAX( 1, 4*N*N + 8*N ), N*NP + 2*N ) - IF( LDWORK.LT.MINWRK ) THEN - INFO = -25 - END IF - IF( INFO.NE.0 ) THEN - CALL XERBLA( 'SB10ID', -INFO ) - RETURN - END IF -C -C Quick return if possible. -C - IF( N.EQ.0 .OR. M.EQ.0 .OR. NP.EQ.0 ) THEN - RCOND( 1 ) = ONE - RCOND( 2 ) = ONE - DWORK( 1 ) = ONE - RETURN - END IF -C -C Workspace usage. -C - I1 = N*N - I2 = I1 + N*N - I3 = I2 + M*N - I4 = I3 + M*N - I5 = I4 + M*M - I6 = I5 + NP*NP - I7 = I6 + NP*N - I8 = I7 + N*N - I9 = I8 + N*N - I10 = I9 + N*N - I11 = I10 + N*N - I12 = I11 + 2*N - I13 = I12 + 2*N -C - IWRK = I13 + 4*N*N -C -C Compute D'*C . -C - CALL DGEMM( 'T', 'N', M, N, NP, ONE, D, LDD, C, LDC, ZERO, - $ DWORK( I2+1 ), M ) -C -C Compute S = Im + D'*D . -C - CALL DLASET( 'U', M, M, ZERO, ONE, DWORK( I4+1 ), M ) - CALL DSYRK( 'U', 'T', M, NP, ONE, D, LDD, ONE, DWORK( I4+1 ), M ) -C -C Factorize S, S = T'*T, with T upper triangular. -C - CALL DPOTRF( 'U', M, DWORK( I4+1 ), M, INFO2 ) -C -C -1 -C Compute S D'*C . -C - CALL DPOTRS( 'U', M, N, DWORK( I4+1 ), M, DWORK( I2+1 ), M, - $ INFO2 ) -C -C -1 -C Compute B*T . -C - CALL DLACPY( 'F', N, M, B, LDB, DWORK( I3+1 ), N ) - CALL DTRSM( 'R', 'U', 'N', 'N', N, M, ONE, DWORK( I4+1 ), M, - $ DWORK( I3+1 ), N ) -C -C Compute R = Ip + D*D' . -C - CALL DLASET( 'U', NP, NP, ZERO, ONE, DWORK( I5+1 ), NP ) - CALL DSYRK( 'U', 'N', NP, M, ONE, D, LDD, ONE, DWORK( I5+1 ), NP ) -C -C Factorize R, R = U'*U, with U upper triangular. -C - CALL DPOTRF( 'U', NP, DWORK( I5+1 ), NP, INFO2 ) -C -C -T -C Compute U C . -C - CALL DLACPY( 'F', NP, N, C, LDC, DWORK( I6+1 ), NP ) - CALL DTRSM( 'L', 'U', 'T', 'N', NP, N, ONE, DWORK( I5+1 ), NP, - $ DWORK( I6+1 ), NP ) -C -C -1 -C Compute Ar = A - B*S D'*C . -C - CALL DLACPY( 'F', N, N, A, LDA, DWORK( I7+1 ), N ) - CALL DGEMM( 'N', 'N', N, N, M, -ONE, B, LDB, DWORK( I2+1 ), M, - $ ONE, DWORK( I7+1 ), N ) -C -C -1 -C Compute the upper triangle of Cr = C'*R *C . -C - CALL DSYRK( 'U', 'T', N, NP, ONE, DWORK( I6+1 ), NP, ZERO, - $ DWORK( I8+1 ), N ) -C -C -1 -C Compute the upper triangle of Dr = B*S B' . -C - CALL DSYRK( 'U', 'N', N, M, ONE, DWORK( I3+1 ), N, ZERO, - $ DWORK( I9+1 ), N ) -C -C Solution of the Riccati equation Ar'*X + X*Ar + Cr - X*Dr*X = 0 . -C Workspace: need 10*N*N + M*M + NP*NP + 2*M*N + N*NP + 4*N + -C 5 + max(1,4*N*N+8*N). -C prefer larger. -C AK is used as workspace. -C - N2 = 2*N - CALL SB02RD( 'A', 'C', HINV, 'N', 'U', 'G', 'S', 'N', 'O', N, - $ DWORK( I7+1 ), N, DWORK( I10+1 ), N, AK, LDAK, - $ DWORK( I9+1 ), N, DWORK( I8+1 ), N, DWORK, N, SEP, - $ RCOND( 1 ), FERR, DWORK( I11+1 ), DWORK( I12+1 ), - $ DWORK( I13+1 ), N2, IWORK, DWORK( IWRK+1 ), - $ LDWORK-IWRK, BWORK, INFO2 ) - IF( INFO2.NE.0 ) THEN - INFO = 1 - RETURN - END IF - LWA = INT( DWORK( IWRK+1 ) ) + IWRK - LWAMAX = MAX( MINWRK, LWA ) -C -C Solution of the Riccati equation Ar*Z + Z*Ar' + Dr - Z*Cr*Z = 0 . -C - CALL SB02RD( 'A', 'C', HINV, 'T', 'U', 'G', 'S', 'N', 'O', N, - $ DWORK( I7+1 ), N, DWORK( I10+1 ), N, AK, LDAK, - $ DWORK( I8+1 ), N, DWORK( I9+1 ), N, DWORK( I1+1 ), - $ N, SEP, RCOND( 2 ), FERR, DWORK( I11+1 ), - $ DWORK( I12+1 ), DWORK( I13+1 ), N2, IWORK, - $ DWORK( IWRK+1 ), LDWORK-IWRK, BWORK, INFO2 ) - IF( INFO2.NE.0 ) THEN - INFO = 2 - RETURN - END IF - LWA = INT( DWORK( IWRK+1 ) ) + IWRK - LWAMAX = MAX( LWA, LWAMAX ) -C -C -1 -1 -C Compute F1 = -( S D'*C + S B'*X ) . -C - CALL DTRSM( 'R', 'U', 'T', 'N', N, M, ONE, DWORK( I4+1 ), M, - $ DWORK( I3+1 ), N ) - CALL DGEMM( 'T', 'N', M, N, N, -ONE, DWORK( I3+1 ), N, DWORK, N, - $ -ONE, DWORK( I2+1 ), M ) -C -C Compute gamma . -C - CALL DGEMM( 'N', 'N', N, N, N, ONE, DWORK, N, DWORK( I1+1 ), N, - $ ZERO, DWORK( I7+1 ), N ) - CALL DGEES( 'N', 'N', SELECT, N, DWORK( I7+1 ), N, SDIM, - $ DWORK( I11+1 ), DWORK( I12+1 ), DWORK( IWRK+1 ), N, - $ DWORK( IWRK+1 ), LDWORK-IWRK, BWORK, INFO2 ) - IF( INFO2.NE.0 ) THEN - INFO = 3 - RETURN - END IF - LWA = INT( DWORK( IWRK+1 ) ) + IWRK - LWAMAX = MAX( LWA, LWAMAX ) - GAMMA = ZERO - DO 10 I = 1, N - GAMMA = MAX( GAMMA, DWORK( I11+I ) ) - 10 CONTINUE - GAMMA = FACTOR*SQRT( ONE + GAMMA ) -C -C Workspace usage. -C Workspace: need 4*N*N + M*N + N*NP. -C - I4 = I3 + N*N - I5 = I4 + N*N -C -C Compute Ac = A + B*F1 . -C - CALL DLACPY( 'F', N, N, A, LDA, DWORK( I4+1 ), N ) - CALL DGEMM( 'N', 'N', N, N, M, ONE, B, LDB, DWORK( I2+1 ), M, - $ ONE, DWORK( I4+1 ), N ) -C -C Compute W1' = (1-gamma^2)*In + Z*X . -C - CALL DLASET( 'F', N, N, ZERO, ONE-GAMMA*GAMMA, DWORK( I3+1 ), N ) - CALL DGEMM( 'N', 'N', N, N, N, ONE, DWORK( I1+1 ), N, DWORK, N, - $ ONE, DWORK( I3+1 ), N ) -C -C Compute Bcp = gamma^2*Z*C' . -C - CALL DGEMM( 'N', 'T', N, NP, N, GAMMA*GAMMA, DWORK( I1+1 ), N, C, - $ LDC, ZERO, BK, LDBK ) -C -C Compute C + D*F1 . -C - CALL DLACPY( 'F', NP, N, C, LDC, DWORK( I5+1 ), NP ) - CALL DGEMM( 'N', 'N', NP, N, M, ONE, D, LDD, DWORK( I2+1 ), M, - $ ONE, DWORK( I5+1 ), NP ) -C -C Compute Acp = W1'*Ac + gamma^2*Z*C'*(C+D*F1) . -C - CALL DGEMM( 'N', 'N', N, N, N, ONE, DWORK( I3+1 ), N, - $ DWORK( I4+1 ), N, ZERO, AK, LDAK ) - CALL DGEMM( 'N', 'N', N, N, NP, ONE, BK, LDBK, - $ DWORK( I5+1 ), NP, ONE, AK, LDAK ) -C -C Compute Ccp = B'*X . -C - CALL DGEMM( 'T', 'N', M, N, N, ONE, B, LDB, DWORK, N, ZERO, - $ CK, LDCK ) -C -C Set Dcp = -D' . -C - DO 30 I = 1, M - DO 20 J = 1, NP - DK( I, J ) = -D( J, I ) - 20 CONTINUE - 30 CONTINUE -C - IWRK = I4 -C -C Reduce the generalized state-space description to a regular one. -C Workspace: need 3*N*N + M*N. -C Additional workspace: need 2*N*N + 2*N + N*MAX(5,N+M+NP). -C prefer larger. -C - CALL SB10JD( N, NP, M, AK, LDAK, BK, LDBK, CK, LDCK, DK, LDDK, - $ DWORK( I3+1 ), N, NK, DWORK( IWRK+1 ), LDWORK-IWRK, - $ INFO2 ) - IF( INFO2.NE.0 ) THEN - INFO = 3 - RETURN - END IF - LWA = INT( DWORK( IWRK+1 ) ) + IWRK - LWAMAX = MAX( LWA, LWAMAX ) -C -C Workspace usage. -C Workspace: need 4*N*N + M*M + NP*NP + 2*M*N + 2*N*NP. -C (NK <= N.) -C - I2 = NP*NP - I3 = I2 + NK*NP - I4 = I3 + M*M - I5 = I4 + N*M - I6 = I5 + NP*NK - I7 = I6 + M*N -C - IWRK = I7 + ( N + NK )*( N + NK ) -C -C Compute Ip - D*Dk . -C - CALL DLASET( 'Full', NP, NP, ZERO, ONE, DWORK, NP ) - CALL DGEMM( 'N', 'N', NP, NP, M, -ONE, D, LDD, DK, LDDK, ONE, - $ DWORK, NP ) -C -C -1 -C Compute Bk*(Ip-D*Dk) . -C - CALL DLACPY( 'F', NK, NP, BK, LDBK, DWORK( I2+1 ), NK ) - CALL MB02VD( 'N', NK, NP, DWORK, NP, IWORK, DWORK( I2+1 ), NK, - $ INFO2 ) - IF( INFO2.NE.0 ) THEN - INFO = 4 - RETURN - END IF -C -C Compute Im - Dk*D . -C - CALL DLASET( 'Full', M, M, ZERO, ONE, DWORK( I3+1 ), M ) - CALL DGEMM( 'N', 'N', M, M, NP, -ONE, DK, LDDK, D, LDD, ONE, - $ DWORK( I3+1 ), M ) -C -C -1 -C Compute B*(Im-Dk*D) . -C - CALL DLACPY( 'F', N, M, B, LDB, DWORK( I4+1 ), N ) - CALL MB02VD( 'N', N, M, DWORK( I3+1 ), M, IWORK, DWORK( I4+1 ), N, - $ INFO2 ) - IF( INFO2.NE.0 ) THEN - INFO = 5 - RETURN - END IF -C -C Compute D*Ck . -C - CALL DGEMM( 'N', 'N', NP, NK, M, ONE, D, LDD, CK, LDCK, ZERO, - $ DWORK( I5+1 ), NP ) -C -C Compute Dk*C . -C - CALL DGEMM( 'N', 'N', M, N, NP, ONE, DK, LDDK, C, LDC, ZERO, - $ DWORK( I6+1 ), M ) -C -C Compute the closed-loop state matrix. -C - CALL DLACPY( 'F', N, N, A, LDA, DWORK( I7+1 ), N+NK ) - CALL DGEMM( 'N', 'N', N, N, M, ONE, DWORK( I4+1 ), N, - $ DWORK( I6+1 ), M, ONE, DWORK( I7+1 ), N+NK ) - CALL DGEMM( 'N', 'N', NK, N, NP, ONE, DWORK( I2+1 ), NK, C, LDC, - $ ZERO, DWORK( I7+N+1 ), N+NK ) - CALL DGEMM( 'N', 'N', N, NK, M, ONE, DWORK( I4+1 ), N, CK, LDCK, - $ ZERO, DWORK( I7+(N+NK)*N+1 ), N+NK ) - CALL DLACPY( 'F', NK, NK, AK, LDAK, DWORK( I7+(N+NK)*N+N+1 ), - $ N+NK ) - CALL DGEMM( 'N', 'N', NK, NK, NP, ONE, DWORK( I2+1 ), NK, - $ DWORK( I5+1 ), NP, ONE, DWORK( I7+(N+NK)*N+N+1 ), - $ N+NK ) -C -C Compute the closed-loop poles. -C Additional workspace: need 3*(N+NK); prefer larger. -C The fact that M > 0, NP > 0, and NK <= N is used here. -C - CALL DGEES( 'N', 'N', SELECT, N+NK, DWORK( I7+1 ), N+NK, SDIM, - $ DWORK, DWORK( N+NK+1 ), DWORK( IWRK+1 ), N, - $ DWORK( IWRK+1 ), LDWORK-IWRK, BWORK, INFO2 ) - IF( INFO2.NE.0 ) THEN - INFO = 3 - RETURN - END IF - LWA = INT( DWORK( IWRK+1 ) ) + IWRK - LWAMAX = MAX( LWA, LWAMAX ) -C -C Check the stability of the closed-loop system. -C - NS = 0 - DO 40 I = 1, N+NK - IF( DWORK( I ).GE.ZERO ) NS = NS + 1 - 40 CONTINUE - IF( NS.GT.0 ) THEN - INFO = 6 - RETURN - END IF -C - DWORK( 1 ) = DBLE( LWAMAX ) - RETURN -C *** Last line of SB10ID *** - END diff --git a/mex/sources/libslicot/SB10JD.f b/mex/sources/libslicot/SB10JD.f deleted file mode 100644 index 938b65088..000000000 --- a/mex/sources/libslicot/SB10JD.f +++ /dev/null @@ -1,355 +0,0 @@ - SUBROUTINE SB10JD( N, M, NP, A, LDA, B, LDB, C, LDC, D, LDD, E, - $ LDE, NSYS, DWORK, LDWORK, INFO ) -C -C SLICOT RELEASE 5.0. -C -C Copyright (c) 2002-2009 NICONET e.V. -C -C This program is free software: you can redistribute it and/or -C modify it under the terms of the GNU General Public License as -C published by the Free Software Foundation, either version 2 of -C the License, or (at your option) any later version. -C -C This program is distributed in the hope that it will be useful, -C but WITHOUT ANY WARRANTY; without even the implied warranty of -C MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the -C GNU General Public License for more details. -C -C You should have received a copy of the GNU General Public License -C along with this program. If not, see -C . -C -C PURPOSE -C -C To convert the descriptor state-space system -C -C E*dx/dt = A*x + B*u -C y = C*x + D*u -C -C into regular state-space form -C -C dx/dt = Ad*x + Bd*u -C y = Cd*x + Dd*u . -C -C ARGUMENTS -C -C Input/Output Parameters -C -C N (input) INTEGER -C The order of the descriptor system. N >= 0. -C -C M (input) INTEGER -C The column size of the matrix B. M >= 0. -C -C NP (input) INTEGER -C The row size of the matrix C. NP >= 0. -C -C A (input/output) DOUBLE PRECISION array, dimension (LDA,N) -C On entry, the leading N-by-N part of this array must -C contain the state matrix A of the descriptor system. -C On exit, the leading NSYS-by-NSYS part of this array -C contains the state matrix Ad of the converted system. -C -C LDA INTEGER -C The leading dimension of the array A. LDA >= max(1,N). -C -C B (input/output) DOUBLE PRECISION array, dimension (LDB,M) -C On entry, the leading N-by-M part of this array must -C contain the input matrix B of the descriptor system. -C On exit, the leading NSYS-by-M part of this array -C contains the input matrix Bd of the converted system. -C -C LDB INTEGER -C The leading dimension of the array B. LDB >= max(1,N). -C -C C (input/output) DOUBLE PRECISION array, dimension (LDC,N) -C On entry, the leading NP-by-N part of this array must -C contain the output matrix C of the descriptor system. -C On exit, the leading NP-by-NSYS part of this array -C contains the output matrix Cd of the converted system. -C -C LDC INTEGER -C The leading dimension of the array C. LDC >= max(1,NP). -C -C D (input/output) DOUBLE PRECISION array, dimension (LDD,M) -C On entry, the leading NP-by-M part of this array must -C contain the matrix D of the descriptor system. -C On exit, the leading NP-by-M part of this array contains -C the matrix Dd of the converted system. -C -C LDD INTEGER -C The leading dimension of the array D. LDD >= max(1,NP). -C -C E (input/output) DOUBLE PRECISION array, dimension (LDE,N) -C On entry, the leading N-by-N part of this array must -C contain the matrix E of the descriptor system. -C On exit, this array contains no useful information. -C -C LDE INTEGER -C The leading dimension of the array E. LDE >= max(1,N). -C -C NSYS (output) INTEGER -C The order of the converted state-space system. -C -C Workspace -C -C DWORK DOUBLE PRECISION array, dimension (LDWORK) -C On exit, if INFO = 0, DWORK(1) contains the optimal value -C of LDWORK. -C -C LDWORK INTEGER -C The dimension of the array DWORK. -C LDWORK >= max( 1, 2*N*N + 2*N + N*MAX( 5, N + M + NP ) ). -C For good performance, LDWORK must generally be larger. -C -C Error Indicator -C -C INFO INTEGER -C = 0: successful exit; -C < 0: if INFO = -i, the i-th argument had an illegal -C value; -C = 1: the iteration for computing singular value -C decomposition did not converge. -C -C METHOD -C -C The routine performs the transformations described in [1]. -C -C REFERENCES -C -C [1] Chiang, R.Y. and Safonov, M.G. -C Robust Control Toolbox User's Guide. -C The MathWorks Inc., Natick, Mass., 1992. -C -C CONTRIBUTORS -C -C P.Hr. Petkov, D.W. Gu and M.M. Konstantinov, October 1999. -C -C REVISIONS -C -C V. Sima, Research Institute for Informatics, Bucharest, Oct. 2000, -C Feb. 2001. -C -C KEYWORDS -C -C Descriptor systems, state-space models. -C -C ****************************************************************** -C -C .. Parameters .. - DOUBLE PRECISION ZERO, ONE - PARAMETER ( ZERO = 0.0D+0, ONE = 1.0D+0 ) -C .. -C .. Scalar Arguments .. - INTEGER INFO, LDA, LDB, LDC, LDD, LDE, LDWORK, M, N, - $ NP, NSYS -C .. -C .. Array Arguments .. - DOUBLE PRECISION A( LDA, * ), B( LDB, * ), C( LDC, * ), - $ D( LDD, * ), DWORK( * ), E( LDE, * ) -C .. -C .. Local Scalars .. - INTEGER I, IA12, IA21, IB2, IC2, INFO2, IS, ISA, IU, - $ IV, IWRK, J, K, LWA, LWAMAX, MINWRK, NS1 - DOUBLE PRECISION EPS, SCALE, TOL -C .. -C .. External Functions .. - DOUBLE PRECISION DLAMCH - EXTERNAL DLAMCH -C .. -C .. External Subroutines .. - EXTERNAL DGEMM, DGESVD, DLACPY, DLASET, DSCAL, XERBLA -C .. -C .. Intrinsic Functions .. - INTRINSIC DBLE, INT, MAX, SQRT -C .. -C .. Executable Statements .. -C -C Decode and Test input parameters. -C - INFO = 0 - IF( N.LT.0 ) THEN - INFO = -1 - ELSE IF( M.LT.0 ) THEN - INFO = -2 - ELSE IF( NP.LT.0 ) THEN - INFO = -3 - ELSE IF( LDA.LT.MAX( 1, N ) ) THEN - INFO = -5 - ELSE IF( LDB.LT.MAX( 1, N ) ) THEN - INFO = -7 - ELSE IF( LDC.LT.MAX( 1, NP ) ) THEN - INFO = -9 - ELSE IF( LDD.LT.MAX( 1, NP ) ) THEN - INFO = -11 - ELSE IF( LDE.LT.MAX( 1, N ) ) THEN - INFO = -13 - END IF -C -C Compute workspace. -C - MINWRK = MAX( 1, 2*N*( N + 1 ) + N*MAX( 5, N + M + NP ) ) - IF( LDWORK.LT.MINWRK ) THEN - INFO = -16 - END IF - IF( INFO.NE.0 ) THEN - CALL XERBLA( 'SB10JD', -INFO ) - RETURN - END IF -C -C Quick return if possible. -C - IF( N.EQ.0 ) THEN - NSYS = 0 - DWORK( 1 ) = ONE - RETURN - END IF -C -C Set tol. -C - EPS = DLAMCH( 'Epsilon' ) - TOL = SQRT( EPS ) -C -C Workspace usage. -C - IS = 0 - IU = IS + N - IV = IU + N*N -C - IWRK = IV + N*N -C -C Compute the SVD of E. -C Additional workspace: need 5*N; prefer larger. -C - CALL DGESVD( 'S', 'S', N, N, E, LDE, DWORK( IS+1 ), DWORK( IU+1 ), - $ N, DWORK( IV+1 ), N, DWORK( IWRK+1 ), LDWORK-IWRK, - $ INFO2 ) - IF( INFO2.NE.0 ) THEN - INFO = 1 - RETURN - END IF - LWAMAX = MAX( MINWRK, INT( DWORK( IWRK+1 ) + IWRK ) ) -C -C Determine the rank of E. -C - NS1 = 0 - DO 10 I = 1, N - IF( DWORK( IS+I ).GT.TOL ) NS1 = NS1 + 1 - 10 CONTINUE - IF( NS1.GT.0 ) THEN -C -C Transform A. -C Additional workspace: need N*max(N,M,NP). -C - CALL DGEMM( 'T', 'N', N, N, N, ONE, DWORK( IU+1 ), N, A, LDA, - $ ZERO, DWORK( IWRK+1 ), N ) - CALL DGEMM( 'N', 'T', N, N, N, ONE, DWORK( IWRK+1 ), N, - $ DWORK( IV+1 ), N, ZERO, A, LDA ) -C -C Transform B. -C - CALL DLACPY( 'Full', N, M, B, LDB, DWORK( IWRK+1 ), N ) - CALL DGEMM( 'T', 'N', N, M, N, ONE, DWORK( IU+1 ), N, - $ DWORK( IWRK+1 ), N, ZERO, B, LDB ) -C -C Transform C. -C - CALL DLACPY( 'Full', NP, N, C, LDC, DWORK( IWRK+1 ), NP ) - CALL DGEMM( 'N', 'T', NP, N, N, ONE, DWORK( IWRK+1 ), NP, - $ DWORK( IV+1 ), N, ZERO, C, LDC ) -C - K = N - NS1 - IF( K.GT.0 ) THEN - ISA = IU + K*K - IV = ISA + K - IWRK = IV + K*MAX( K, NS1 ) -C -C Compute the SVD of A22. -C Additional workspace: need 5*K; prefer larger. -C - CALL DGESVD( 'S', 'S', K, K, A( NS1+1, NS1+1 ), LDA, - $ DWORK( ISA+1 ), DWORK( IU+1 ), K, - $ DWORK( IV+1 ), K, DWORK( IWRK+1 ), LDWORK-IWRK, - $ INFO2 ) - IF( INFO2.NE.0 ) THEN - INFO = 1 - RETURN - END IF - IA12 = IWRK - IB2 = IA12 + NS1*K - IC2 = IB2 + K*M -C - LWA = INT( DWORK( IWRK+1 ) ) + IWRK - LWAMAX = MAX( LWA, LWAMAX, IC2 + K*NP ) -C -C Compute the transformed A12. -C - CALL DGEMM( 'N', 'T', NS1, K, K, ONE, A( 1, NS1+1 ), LDA, - $ DWORK( IV+1 ), K, ZERO, DWORK( IA12+1 ), NS1 ) -C -C Compute CC2. -C - CALL DGEMM( 'N', 'T', NP, K, K, ONE, C( 1, NS1+1 ), LDC, - $ DWORK( IV+1 ), K, ZERO, DWORK( IC2+1 ), NP ) -C -C Compute the transformed A21. -C - IA21 = IV - CALL DGEMM( 'T', 'N', K, NS1, K, ONE, DWORK( IU+1 ), K, - $ A( NS1+1, 1 ), LDA, ZERO, DWORK( IA21+1 ), K ) -C -C Compute BB2. -C - CALL DGEMM( 'T', 'N', K, M, K, ONE, DWORK( IU+1 ), K, - $ B( NS1+1, 1 ), LDB, ZERO, DWORK( IB2+1 ), K ) -C -C Compute A12*pinv(A22) and CC2*pinv(A22). -C - DO 20 J = 1, K - SCALE = ZERO - IF( DWORK( ISA+J ).GT.TOL ) SCALE = ONE/DWORK( ISA+J ) - CALL DSCAL( NS1, SCALE, DWORK( IA12+(J-1)*NS1+1 ), 1 ) - CALL DSCAL( NP, SCALE, DWORK( IC2+(J-1)*NP+1 ), 1 ) - 20 CONTINUE -C -C Compute Ad. -C - CALL DGEMM( 'N', 'N', NS1, NS1, K, -ONE, DWORK( IA12+1 ), - $ NS1, DWORK( IA21+1 ), K, ONE, A, LDA ) -C -C Compute Bd. -C - CALL DGEMM( 'N', 'N', NS1, M, K, -ONE, DWORK( IA12+1 ), NS1, - $ DWORK( IB2+1 ), K, ONE, B, LDB ) -C -C Compute Cd. -C - CALL DGEMM( 'N', 'N', NP, NS1, K, -ONE, DWORK( IC2+1 ), NP, - $ DWORK( IA21+1 ), K, ONE, C, LDC ) -C -C Compute Dd. -C - CALL DGEMM( 'N', 'N', NP, M, K, -ONE, DWORK( IC2+1 ), NP, - $ DWORK( IB2+1 ), K, ONE, D, LDD ) - END IF - DO 30 I = 1, NS1 - SCALE = ONE/SQRT( DWORK( IS+I ) ) - CALL DSCAL( NS1, SCALE, A( I, 1 ), LDA ) - CALL DSCAL( M, SCALE, B( I, 1 ), LDB ) - 30 CONTINUE - DO 40 J = 1, NS1 - SCALE = ONE/SQRT( DWORK( IS+J ) ) - CALL DSCAL( NS1, SCALE, A( 1, J ), 1 ) - CALL DSCAL( NP, SCALE, C( 1, J ), 1 ) - 40 CONTINUE - NSYS = NS1 - ELSE - CALL DLASET( 'F', N, N, ZERO, -ONE/EPS, A, LDA ) - CALL DLASET( 'F', N, M, ZERO, ZERO, B, LDB ) - CALL DLASET( 'F', NP, N, ZERO, ZERO, C, LDC ) - NSYS = N - END IF - DWORK( 1 ) = DBLE( LWAMAX ) - RETURN -C *** Last line of SB10JD *** - END diff --git a/mex/sources/libslicot/SB10KD.f b/mex/sources/libslicot/SB10KD.f deleted file mode 100644 index 38f1cef01..000000000 --- a/mex/sources/libslicot/SB10KD.f +++ /dev/null @@ -1,650 +0,0 @@ - SUBROUTINE SB10KD( N, M, NP, A, LDA, B, LDB, C, LDC, FACTOR, - $ AK, LDAK, BK, LDBK, CK, LDCK, DK, LDDK, RCOND, - $ IWORK, DWORK, LDWORK, BWORK, INFO ) -C -C SLICOT RELEASE 5.0. -C -C Copyright (c) 2002-2009 NICONET e.V. -C -C This program is free software: you can redistribute it and/or -C modify it under the terms of the GNU General Public License as -C published by the Free Software Foundation, either version 2 of -C the License, or (at your option) any later version. -C -C This program is distributed in the hope that it will be useful, -C but WITHOUT ANY WARRANTY; without even the implied warranty of -C MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the -C GNU General Public License for more details. -C -C You should have received a copy of the GNU General Public License -C along with this program. If not, see -C . -C -C PURPOSE -C -C To compute the matrices of the positive feedback controller -C -C | Ak | Bk | -C K = |----|----| -C | Ck | Dk | -C -C for the shaped plant -C -C | A | B | -C G = |---|---| -C | C | 0 | -C -C in the Discrete-Time Loop Shaping Design Procedure. -C -C ARGUMENTS -C -C Input/Output Parameters -C -C N (input) INTEGER -C The order of the plant. N >= 0. -C -C M (input) INTEGER -C The column size of the matrix B. M >= 0. -C -C NP (input) INTEGER -C The row size of the matrix C. NP >= 0. -C -C A (input) DOUBLE PRECISION array, dimension (LDA,N) -C The leading N-by-N part of this array must contain the -C system state matrix A of the shaped plant. -C -C LDA INTEGER -C The leading dimension of the array A. LDA >= max(1,N). -C -C B (input) DOUBLE PRECISION array, dimension (LDB,M) -C The leading N-by-M part of this array must contain the -C system input matrix B of the shaped plant. -C -C LDB INTEGER -C The leading dimension of the array B. LDB >= max(1,N). -C -C C (input) DOUBLE PRECISION array, dimension (LDC,N) -C The leading NP-by-N part of this array must contain the -C system output matrix C of the shaped plant. -C -C LDC INTEGER -C The leading dimension of the array C. LDC >= max(1,NP). -C -C FACTOR (input) DOUBLE PRECISION -C = 1 implies that an optimal controller is required; -C > 1 implies that a suboptimal controller is required -C achieving a performance FACTOR less than optimal. -C FACTOR >= 1. -C -C AK (output) DOUBLE PRECISION array, dimension (LDAK,N) -C The leading N-by-N part of this array contains the -C controller state matrix Ak. -C -C LDAK INTEGER -C The leading dimension of the array AK. LDAK >= max(1,N). -C -C BK (output) DOUBLE PRECISION array, dimension (LDBK,NP) -C The leading N-by-NP part of this array contains the -C controller input matrix Bk. -C -C LDBK INTEGER -C The leading dimension of the array BK. LDBK >= max(1,N). -C -C CK (output) DOUBLE PRECISION array, dimension (LDCK,N) -C The leading M-by-N part of this array contains the -C controller output matrix Ck. -C -C LDCK INTEGER -C The leading dimension of the array CK. LDCK >= max(1,M). -C -C DK (output) DOUBLE PRECISION array, dimension (LDDK,NP) -C The leading M-by-NP part of this array contains the -C controller matrix Dk. -C -C LDDK INTEGER -C The leading dimension of the array DK. LDDK >= max(1,M). -C -C RCOND (output) DOUBLE PRECISION array, dimension (4) -C RCOND(1) contains an estimate of the reciprocal condition -C number of the linear system of equations from -C which the solution of the P-Riccati equation is -C obtained; -C RCOND(2) contains an estimate of the reciprocal condition -C number of the linear system of equations from -C which the solution of the Q-Riccati equation is -C obtained; -C RCOND(3) contains an estimate of the reciprocal condition -C number of the linear system of equations from -C which the solution of the X-Riccati equation is -C obtained; -C RCOND(4) contains an estimate of the reciprocal condition -C number of the matrix Rx + Bx'*X*Bx (see the -C comments in the code). -C -C Workspace -C -C IWORK INTEGER array, dimension 2*max(N,NP+M) -C -C DWORK DOUBLE PRECISION array, dimension (LDWORK) -C On exit, if INFO = 0, DWORK(1) contains the optimal value -C of LDWORK. -C -C LDWORK INTEGER -C The dimension of the array DWORK. -C LDWORK >= 15*N*N + 6*N + -C max( 14*N+23, 16*N, 2*N+NP+M, 3*(NP+M) ) + -C max( N*N, 11*N*NP + 2*M*M + 8*NP*NP + 8*M*N + -C 4*M*NP + NP ). -C For good performance, LDWORK must generally be larger. -C -C BWORK LOGICAL array, dimension (2*N) -C -C Error Indicator -C -C INFO INTEGER -C = 0: successful exit; -C < 0: if INFO = -i, the i-th argument had an illegal -C value; -C = 1: the P-Riccati equation is not solved successfully; -C = 2: the Q-Riccati equation is not solved successfully; -C = 3: the X-Riccati equation is not solved successfully; -C = 4: the iteration to compute eigenvalues failed to -C converge; -C = 5: the matrix Rx + Bx'*X*Bx is singular; -C = 6: the closed-loop system is unstable. -C -C METHOD -C -C The routine implements the method presented in [1]. -C -C REFERENCES -C -C [1] McFarlane, D. and Glover, K. -C A loop shaping design procedure using H_infinity synthesis. -C IEEE Trans. Automat. Control, vol. AC-37, no. 6, pp. 759-769, -C 1992. -C -C NUMERICAL ASPECTS -C -C The accuracy of the results depends on the conditioning of the -C two Riccati equations solved in the controller design. For -C better conditioning it is advised to take FACTOR > 1. -C -C CONTRIBUTORS -C -C P.Hr. Petkov, D.W. Gu and M.M. Konstantinov, October 2000. -C -C REVISIONS -C -C V. Sima, Katholieke University Leuven, January 2001, -C February 2001. -C -C KEYWORDS -C -C H_infinity control, Loop-shaping design, Robust control. -C -C ****************************************************************** -C -C .. Parameters .. - DOUBLE PRECISION ZERO, ONE - PARAMETER ( ZERO = 0.0D+0, ONE = 1.0D+0 ) -C .. -C .. Scalar Arguments .. - INTEGER INFO, LDA, LDAK, LDB, LDBK, LDC, LDCK, LDDK, - $ LDWORK, M, N, NP - DOUBLE PRECISION FACTOR -C .. -C .. Array Arguments .. - INTEGER IWORK( * ) - LOGICAL BWORK( * ) - DOUBLE PRECISION A( LDA, * ), AK( LDAK, * ), B( LDB, * ), - $ BK( LDBK, * ), C( LDC, * ), CK( LDCK, * ), - $ DK( LDDK, * ), DWORK( * ), RCOND( 4 ) -C .. -C .. Local Scalars .. - INTEGER I, I1, I2, I3, I4, I5, I6, I7, I8, I9, I10, - $ I11, I12, I13, I14, I15, I16, I17, I18, I19, - $ I20, I21, I22, I23, I24, I25, I26, INFO2, - $ IWRK, J, LWA, LWAMAX, MINWRK, N2, NS, SDIM - DOUBLE PRECISION GAMMA, RNORM -C .. -C .. External Functions .. - LOGICAL SELECT - DOUBLE PRECISION DLANSY, DLAPY2 - EXTERNAL DLANSY, DLAPY2, SELECT -C .. -C .. External Subroutines .. - EXTERNAL DGEMM, DGEES, DLACPY, DLASET, DPOTRF, DPOTRS, - $ DSYCON, DSYEV, DSYRK, DSYTRF, DSYTRS, SB02OD, - $ XERBLA -C .. -C .. Intrinsic Functions .. - INTRINSIC DBLE, INT, MAX, SQRT -C .. -C .. Executable Statements .. -C -C Decode and Test input parameters. -C - INFO = 0 - IF( N.LT.0 ) THEN - INFO = -1 - ELSE IF( M.LT.0 ) THEN - INFO = -2 - ELSE IF( NP.LT.0 ) THEN - INFO = -3 - ELSE IF( LDA.LT.MAX( 1, N ) ) THEN - INFO = -5 - ELSE IF( LDB.LT.MAX( 1, N ) ) THEN - INFO = -7 - ELSE IF( LDC.LT.MAX( 1, NP ) ) THEN - INFO = -9 - ELSE IF( FACTOR.LT.ONE ) THEN - INFO = -10 - ELSE IF( LDAK.LT.MAX( 1, N ) ) THEN - INFO = -12 - ELSE IF( LDBK.LT.MAX( 1, N ) ) THEN - INFO = -14 - ELSE IF( LDCK.LT.MAX( 1, M ) ) THEN - INFO = -16 - ELSE IF( LDDK.LT.MAX( 1, M ) ) THEN - INFO = -18 - END IF -C -C Compute workspace. -C - MINWRK = 15*N*N + 6*N + MAX( 14*N+23, 16*N, 2*N+NP+M, 3*(NP+M) ) + - $ MAX( N*N, 11*N*NP + 2*M*M + 8*NP*NP + 8*M*N + - $ 4*M*NP + NP ) - IF( LDWORK.LT.MINWRK ) THEN - INFO = -22 - END IF - IF( INFO.NE.0 ) THEN - CALL XERBLA( 'SB10KD', -INFO ) - RETURN - END IF -C -C Quick return if possible. -C - IF( N.EQ.0 .OR. M.EQ.0 .OR. NP.EQ.0 ) THEN - RCOND( 1 ) = ONE - RCOND( 2 ) = ONE - RCOND( 3 ) = ONE - RCOND( 4 ) = ONE - DWORK( 1 ) = ONE - RETURN - END IF -C -C Workspace usage. -C - N2 = 2*N - I1 = N*N - I2 = I1 + N*N - I3 = I2 + N*N - I4 = I3 + N*N - I5 = I4 + N2 - I6 = I5 + N2 - I7 = I6 + N2 - I8 = I7 + N2*N2 - I9 = I8 + N2*N2 -C - IWRK = I9 + N2*N2 - LWAMAX = 0 -C -C Compute Cr = C'*C . -C - CALL DSYRK( 'U', 'T', N, NP, ONE, C, LDC, ZERO, DWORK( I2+1 ), N ) -C -C Compute Dr = B*B' . -C - CALL DSYRK( 'U', 'N', N, M, ONE, B, LDB, ZERO, DWORK( I3+1 ), N ) -C -1 -C Solution of the Riccati equation A'*P*(In + Dr*P) *A - P + Cr = 0. -C - CALL SB02OD( 'D', 'G', 'N', 'U', 'Z', 'S', N, M, NP, A, LDA, - $ DWORK( I3+1 ), N, DWORK( I2+1 ), N, DWORK, M, DWORK, - $ N, RCOND( 1 ), DWORK, N, DWORK( I4+1 ), - $ DWORK( I5+1 ), DWORK( I6+1 ), DWORK( I7+1 ), N2, - $ DWORK( I8+1 ), N2, DWORK( I9+1 ), N2, -ONE, IWORK, - $ DWORK( IWRK+1 ), LDWORK-IWRK, BWORK, INFO2 ) - IF( INFO2.NE.0 ) THEN - INFO = 1 - RETURN - END IF - LWA = INT( DWORK( IWRK+1 ) ) + IWRK - LWAMAX = MAX( LWA, LWAMAX ) -C -C Transpose A in AK (used as workspace). -C - DO 40 J = 1, N - DO 30 I = 1, N - AK( I,J ) = A( J,I ) - 30 CONTINUE - 40 CONTINUE -C -1 -C Solution of the Riccati equation A*Q*(In + Cr*Q) *A' - Q + Dr = 0. -C - CALL SB02OD( 'D', 'G', 'N', 'U', 'Z', 'S', N, M, NP, AK, LDAK, - $ DWORK( I2+1 ), N, DWORK( I3+1 ), N, DWORK, M, DWORK, - $ N, RCOND( 2 ), DWORK( I1+1 ), N, DWORK( I4+1 ), - $ DWORK( I5+1 ), DWORK( I6+1 ), DWORK( I7+1 ), N2, - $ DWORK( I8+1 ), N2, DWORK( I9+1 ), N2, -ONE, IWORK, - $ DWORK( IWRK+1 ), LDWORK-IWRK, BWORK, INFO2 ) - IF( INFO2.NE.0 ) THEN - INFO = 2 - RETURN - END IF - LWA = INT( DWORK( IWRK+1 ) ) + IWRK - LWAMAX = MAX( LWA, LWAMAX ) -C -C Compute gamma. -C - CALL DGEMM( 'N', 'N', N, N, N, ONE, DWORK( I1+1 ), N, DWORK, N, - $ ZERO, AK, LDAK ) - CALL DGEES( 'N', 'N', SELECT, N, AK, LDAK, SDIM, DWORK( I6+1 ), - $ DWORK( I7+1 ), DWORK( IWRK+1 ), N, DWORK( IWRK+1 ), - $ LDWORK-IWRK, BWORK, INFO2 ) - IF( INFO2.NE.0 ) THEN - INFO = 4 - RETURN - END IF - LWA = INT( DWORK( IWRK+1 ) ) + IWRK - LWAMAX = MAX( LWA, LWAMAX ) - GAMMA = ZERO - DO 50 I = 1, N - GAMMA = MAX( GAMMA, DWORK( I6+I ) ) - 50 CONTINUE - GAMMA = FACTOR*SQRT( ONE + GAMMA ) -C -C Workspace usage. -C - I3 = I2 + N*NP - I4 = I3 + NP*NP - I5 = I4 + NP*NP - I6 = I5 + NP*NP - I7 = I6 + NP - I8 = I7 + NP*NP - I9 = I8 + NP*NP - I10 = I9 + NP*NP - I11 = I10 + N*NP - I12 = I11 + N*NP - I13 = I12 + ( NP+M )*( NP+M ) - I14 = I13 + N*( NP+M ) - I15 = I14 + N*( NP+M ) - I16 = I15 + N*N - I17 = I16 + N2 - I18 = I17 + N2 - I19 = I18 + N2 - I20 = I19 + ( N2+NP+M )*( N2+NP+M ) - I21 = I20 + ( N2+NP+M )*N2 -C - IWRK = I21 + N2*N2 -C -C Compute Q*C' . -C - CALL DGEMM( 'N', 'T', N, NP, N, ONE, DWORK( I1+1 ), N, C, LDC, - $ ZERO, DWORK( I2+1 ), N ) -C -C Compute Ip + C*Q*C' . -C - CALL DLASET( 'Full', NP, NP, ZERO, ONE, DWORK( I3+1 ), NP ) - CALL DGEMM( 'N', 'N', NP, NP, N, ONE, C, LDC, DWORK( I2+1 ), N, - $ ONE, DWORK( I3+1 ), NP ) -C -C Compute the eigenvalues and eigenvectors of Ip + C'*Q*C -C - CALL DLACPY( 'U', NP, NP, DWORK( I3+1 ), NP, DWORK( I5+1 ), NP ) - CALL DSYEV( 'V', 'U', NP, DWORK( I5+1 ), NP, DWORK( I6+1 ), - $ DWORK( IWRK+1 ), LDWORK-IWRK, INFO2 ) - IF( INFO2.NE.0 ) THEN - INFO = 4 - RETURN - END IF - LWA = INT( DWORK( IWRK+1 ) ) + IWRK - LWAMAX = MAX( LWA, LWAMAX ) -C -1 -C Compute ( Ip + C'*Q*C ) . -C - DO 70 J = 1, NP - DO 60 I = 1, NP - DWORK( I9+I+(J-1)*NP ) = DWORK( I5+J+(I-1)*NP ) / - $ DWORK( I6+I ) - 60 CONTINUE - 70 CONTINUE - CALL DGEMM( 'N', 'N', NP, NP, NP, ONE, DWORK( I5+1 ), NP, - $ DWORK( I9+1 ), NP, ZERO, DWORK( I4+1 ), NP ) -C -C Compute Z2 . -C - DO 90 J = 1, NP - DO 80 I = 1, NP - DWORK( I9+I+(J-1)*NP ) = DWORK( I5+J+(I-1)*NP ) / - $ SQRT( DWORK( I6+I ) ) - 80 CONTINUE - 90 CONTINUE - CALL DGEMM( 'N', 'N', NP, NP, NP, ONE, DWORK( I5+1 ), NP, - $ DWORK( I9+1 ), NP, ZERO, DWORK( I7+1 ), NP ) -C -1 -C Compute Z2 . -C - DO 110 J = 1, NP - DO 100 I = 1, NP - DWORK( I9+I+(J-1)*NP ) = DWORK( I5+J+(I-1)*NP )* - $ SQRT( DWORK( I6+I ) ) - 100 CONTINUE - 110 CONTINUE - CALL DGEMM( 'N', 'N', NP, NP, NP, ONE, DWORK( I5+1 ), NP, - $ DWORK( I9+1 ), NP, ZERO, DWORK( I8+1 ), NP ) -C -C Compute A*Q*C' . -C - CALL DGEMM( 'N', 'N', N, NP, N, ONE, A, LDA, DWORK( I2+1 ), N, - $ ZERO, DWORK( I10+1 ), N ) -C -1 -C Compute H = -A*Q*C'*( Ip + C*Q*C' ) . -C - CALL DGEMM( 'N', 'N', N, NP, NP, -ONE, DWORK( I10+1 ), N, - $ DWORK( I4+1 ), NP, ZERO, DWORK( I11+1 ), N ) -C -C Compute Rx . -C - CALL DLASET( 'F', NP+M, NP+M, ZERO, ONE, DWORK( I12+1 ), NP+M ) - DO 130 J = 1, NP - DO 120 I = 1, NP - DWORK( I12+I+(J-1)*(NP+M) ) = DWORK( I3+I+(J-1)*NP ) - 120 CONTINUE - DWORK( I12+J+(J-1)*(NP+M) ) = DWORK( I3+J+(J-1)*NP ) - - $ GAMMA*GAMMA - 130 CONTINUE -C -C Compute Bx . -C - CALL DGEMM( 'N', 'N', N, NP, NP, -ONE, DWORK( I11+1 ), N, - $ DWORK( I8+1 ), NP, ZERO, DWORK( I13+1 ), N ) - DO 150 J = 1, M - DO 140 I = 1, N - DWORK( I13+N*NP+I+(J-1)*N ) = B( I, J ) - 140 CONTINUE - 150 CONTINUE -C -C Compute Sx . -C - CALL DGEMM( 'T', 'N', N, NP, NP, ONE, C, LDC, DWORK( I8+1 ), NP, - $ ZERO, DWORK( I14+1 ), N ) - CALL DLASET( 'F', N, M, ZERO, ZERO, DWORK( I14+N*NP+1 ), N ) -C -C Solve the Riccati equation -C -1 -C X = A'*X*A + Cx - (Sx + A'*X*Bx)*(Rx + Bx'*X*B ) *(Sx'+Bx'*X*A). -C - CALL SB02OD( 'D', 'B', 'C', 'U', 'N', 'S', N, NP+M, NP, A, LDA, - $ DWORK( I13+1 ), N, C, LDC, DWORK( I12+1 ), NP+M, - $ DWORK( I14+1 ), N, RCOND( 3 ), DWORK( I15+1 ), N, - $ DWORK( I16+1 ), DWORK( I17+1 ), DWORK( I18+1 ), - $ DWORK( I19+1 ), N2+NP+M, DWORK( I20+1 ), N2+NP+M, - $ DWORK( I21+1 ), N2, -ONE, IWORK, DWORK( IWRK+1 ), - $ LDWORK-IWRK, BWORK, INFO2 ) - IF( INFO2.NE.0 ) THEN - INFO = 3 - RETURN - END IF - LWA = INT( DWORK( IWRK+1 ) ) + IWRK - LWAMAX = MAX( LWA, LWAMAX ) -C - I22 = I16 - I23 = I22 + ( NP+M )*N - I24 = I23 + ( NP+M )*( NP+M ) - I25 = I24 + ( NP+M )*N - I26 = I25 + M*N -C - IWRK = I25 -C -C Compute Bx'*X . -C - CALL DGEMM( 'T', 'N', NP+M, N, N, ONE, DWORK( I13+1 ), N, - $ DWORK( I15+1 ), N, ZERO, DWORK( I22+1 ), NP+M ) -C -C Compute Rx + Bx'*X*Bx . -C - CALL DLACPY( 'F', NP+M, NP+M, DWORK( I12+1 ), NP+M, - $ DWORK( I23+1 ), NP+M ) - CALL DGEMM( 'N', 'N', NP+M, NP+M, N, ONE, DWORK( I22+1 ), NP+M, - $ DWORK( I13+1 ), N, ONE, DWORK( I23+1 ), NP+M ) -C -C Compute -( Sx' + Bx'*X*A ) . -C - DO 170 J = 1, N - DO 160 I = 1, NP+M - DWORK( I24+I+(J-1)*(NP+M) ) = DWORK( I14+J+(I-1)*N ) - 160 CONTINUE - 170 CONTINUE - CALL DGEMM( 'N', 'N', NP+M, N, N, -ONE, DWORK( I22+1 ), NP+M, - $ A, LDA, -ONE, DWORK( I24+1 ), NP+M ) -C -C Factorize Rx + Bx'*X*Bx . -C - RNORM = DLANSY( '1', 'U', NP+M, DWORK( I23+1 ), NP+M, - $ DWORK( IWRK+1 ) ) - CALL DSYTRF( 'U', NP+M, DWORK( I23+1 ), NP+M, IWORK, - $ DWORK( IWRK+1 ), LDWORK-IWRK, INFO2 ) - IF( INFO2.NE.0 ) THEN - INFO = 5 - RETURN - END IF - LWA = INT( DWORK( IWRK+1 ) ) + IWRK - LWAMAX = MAX( LWA, LWAMAX ) - CALL DSYCON( 'U', NP+M, DWORK( I23+1 ), NP+M, IWORK, RNORM, - $ RCOND( 4 ), DWORK( IWRK+1 ), IWORK( NP+M+1), INFO2 ) -C -1 -C Compute F = -( Rx + Bx'*X*Bx ) ( Sx' + Bx'*X*A ) . -C - CALL DSYTRS( 'U', NP+M, N, DWORK( I23+1 ), NP+M, IWORK, - $ DWORK( I24+1 ), NP+M, INFO2 ) -C -C Compute B'*X . -C - CALL DGEMM( 'T', 'N', M, N, N, ONE, B, LDB, DWORK( I15+1 ), N, - $ ZERO, DWORK( I25+1 ), M ) -C -C Compute Im + B'*X*B . -C - CALL DLASET( 'F', M, M, ZERO, ONE, DWORK( I23+1 ), M ) - CALL DGEMM( 'N', 'N', M, M, N, ONE, DWORK( I25+1 ), M, B, LDB, - $ ONE, DWORK( I23+1 ), M ) -C -C Factorize Im + B'*X*B . -C - CALL DPOTRF( 'U', M, DWORK( I23+1 ), M, INFO2 ) -C -1 -C Compute ( Im + B'*X*B ) B'*X . -C - CALL DPOTRS( 'U', M, N, DWORK( I23+1 ), M, DWORK( I25+1 ), M, - $ INFO2 ) -C -1 -C Compute Dk = ( Im + B'*X*B ) B'*X*H . -C - CALL DGEMM( 'N', 'N', M, NP, N, ONE, DWORK( I25+1 ), M, - $ DWORK( I11+1 ), N, ZERO, DK, LDDK ) -C -C Compute Bk = -H + B*Dk . -C - CALL DLACPY( 'F', N, NP, DWORK( I11+1 ), N, BK, LDBK ) - CALL DGEMM( 'N', 'N', N, NP, M, ONE, B, LDB, DK, LDDK, -ONE, - $ BK, LDBK ) -C -1 -C Compute Dk*Z2 . -C - CALL DGEMM( 'N', 'N', M, NP, NP, ONE, DK, LDDK, DWORK( I8+1 ), - $ NP, ZERO, DWORK( I26+1 ), M ) -C -C Compute F1 + Z2*C . -C - CALL DLACPY( 'F', NP, N, DWORK( I24+1 ), NP+M, DWORK( I12+1 ), - $ NP ) - CALL DGEMM( 'N', 'N', NP, N, NP, ONE, DWORK( I7+1 ), NP, C, LDC, - $ ONE, DWORK( I12+1 ), NP ) -C -1 -C Compute Ck = F2 - Dk*Z2 *( F1 + Z2*C ) . -C - CALL DLACPY( 'F', M, N, DWORK( I24+NP+1 ), NP+M, CK, LDCK ) - CALL DGEMM( 'N', 'N', M, N, NP, -ONE, DWORK( I26+1 ), M, - $ DWORK( I12+1 ), NP, ONE, CK, LDCK ) -C -C Compute Ak = A + H*C + B*Ck . -C - CALL DLACPY( 'F', N, N, A, LDA, AK, LDAK ) - CALL DGEMM( 'N', 'N', N, N, NP, ONE, DWORK( I11+1 ), N, C, LDC, - $ ONE, AK, LDAK ) - CALL DGEMM( 'N', 'N', N, N, M, ONE, B, LDB, CK, LDCK, ONE, AK, - $ LDAK ) -C -C Workspace usage. -C - I1 = M*N - I2 = I1 + N2*N2 - I3 = I2 + N2 -C - IWRK = I3 + N2 -C -C Compute Dk*C . -C - CALL DGEMM( 'N', 'N', M, N, NP, ONE, DK, LDDK, C, LDC, ZERO, - $ DWORK, M ) -C -C Compute the closed-loop state matrix. -C - CALL DLACPY( 'F', N, N, A, LDA, DWORK( I1+1 ), N2 ) - CALL DGEMM( 'N', 'N', N, N, M, -ONE, B, LDB, DWORK, M, ONE, - $ DWORK( I1+1 ), N2 ) - CALL DGEMM( 'N', 'N', N, N, NP, -ONE, BK, LDBK, C, LDC, ZERO, - $ DWORK( I1+N+1 ), N2 ) - CALL DGEMM( 'N', 'N', N, N, M, ONE, B, LDB, CK, LDCK, ZERO, - $ DWORK( I1+N2*N+1 ), N2 ) - CALL DLACPY( 'F', N, N, AK, LDAK, DWORK( I1+N2*N+N+1 ), N2 ) -C -C Compute the closed-loop poles. -C - CALL DGEES( 'N', 'N', SELECT, N2, DWORK( I1+1 ), N2, SDIM, - $ DWORK( I2+1 ), DWORK( I3+1 ), DWORK( IWRK+1 ), N, - $ DWORK( IWRK+1 ), LDWORK-IWRK, BWORK, INFO2 ) - IF( INFO2.NE.0 ) THEN - INFO = 4 - RETURN - END IF - LWA = INT( DWORK( IWRK+1 ) ) + IWRK - LWAMAX = MAX( LWA, LWAMAX ) -C -C Check the stability of the closed-loop system. -C - NS = 0 - DO 180 I = 1, N2 - IF( DLAPY2( DWORK( I2+I ), DWORK( I3+I ) ).GT.ONE ) NS = NS + 1 - 180 CONTINUE - IF( NS.GT.0 ) THEN - INFO = 6 - RETURN - END IF -C - DWORK( 1 ) = DBLE( LWAMAX ) - RETURN -C *** Last line of SB10KD *** - END diff --git a/mex/sources/libslicot/SB10LD.f b/mex/sources/libslicot/SB10LD.f deleted file mode 100644 index b2d7d06b3..000000000 --- a/mex/sources/libslicot/SB10LD.f +++ /dev/null @@ -1,438 +0,0 @@ - SUBROUTINE SB10LD( N, M, NP, NCON, NMEAS, A, LDA, B, LDB, C, LDC, - $ D, LDD, AK, LDAK, BK, LDBK, CK, LDCK, DK, LDDK, - $ AC, LDAC, BC, LDBC, CC, LDCC, DC, LDDC, IWORK, - $ DWORK, LDWORK, INFO ) -C -C SLICOT RELEASE 5.0. -C -C Copyright (c) 2002-2009 NICONET e.V. -C -C This program is free software: you can redistribute it and/or -C modify it under the terms of the GNU General Public License as -C published by the Free Software Foundation, either version 2 of -C the License, or (at your option) any later version. -C -C This program is distributed in the hope that it will be useful, -C but WITHOUT ANY WARRANTY; without even the implied warranty of -C MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the -C GNU General Public License for more details. -C -C You should have received a copy of the GNU General Public License -C along with this program. If not, see -C . -C -C PURPOSE -C -C To compute the matrices of the closed-loop system -C -C | AC | BC | -C G = |----|----|, -C | CC | DC | -C -C from the matrices of the open-loop system -C -C | A | B | -C P = |---|---| -C | C | D | -C -C and the matrices of the controller -C -C | AK | BK | -C K = |----|----|. -C | CK | DK | -C -C ARGUMENTS -C -C Input/Output Parameters -C -C N (input) INTEGER -C The order of the system. N >= 0. -C -C M (input) INTEGER -C The column size of the matrix B. M >= 0. -C -C NP (input) INTEGER -C The row size of the matrix C. NP >= 0. -C -C NCON (input) INTEGER -C The number of control inputs (M2). M >= NCON >= 0. -C NP-NMEAS >= NCON. -C -C NMEAS (input) INTEGER -C The number of measurements (NP2). NP >= NMEAS >= 0. -C M-NCON >= NMEAS. -C -C A (input) DOUBLE PRECISION array, dimension (LDA,N) -C The leading N-by-N part of this array must contain the -C system state matrix A. -C -C LDA INTEGER -C The leading dimension of the array A. LDA >= max(1,N). -C -C B (input) DOUBLE PRECISION array, dimension (LDB,M) -C The leading N-by-M part of this array must contain the -C system input matrix B. -C -C LDB INTEGER -C The leading dimension of the array B. LDB >= max(1,N). -C -C C (input) DOUBLE PRECISION array, dimension (LDC,N) -C The leading NP-by-N part of this array must contain the -C system output matrix C. -C -C LDC INTEGER -C The leading dimension of the array C. LDC >= max(1,NP). -C -C D (input) DOUBLE PRECISION array, dimension (LDD,M) -C The leading NP-by-M part of this array must contain the -C system input/output matrix D. -C -C LDD INTEGER -C The leading dimension of the array D. LDD >= max(1,NP). -C -C AK (input) DOUBLE PRECISION array, dimension (LDAK,N) -C The leading N-by-N part of this array must contain the -C controller state matrix AK. -C -C LDAK INTEGER -C The leading dimension of the array AK. LDAK >= max(1,N). -C -C BK (input) DOUBLE PRECISION array, dimension (LDBK,NMEAS) -C The leading N-by-NMEAS part of this array must contain the -C controller input matrix BK. -C -C LDBK INTEGER -C The leading dimension of the array BK. LDBK >= max(1,N). -C -C CK (input) DOUBLE PRECISION array, dimension (LDCK,N) -C The leading NCON-by-N part of this array must contain the -C controller output matrix CK. -C -C LDCK INTEGER -C The leading dimension of the array CK. -C LDCK >= max(1,NCON). -C -C DK (input) DOUBLE PRECISION array, dimension (LDDK,NMEAS) -C The leading NCON-by-NMEAS part of this array must contain -C the controller input/output matrix DK. -C -C LDDK INTEGER -C The leading dimension of the array DK. -C LDDK >= max(1,NCON). -C -C AC (output) DOUBLE PRECISION array, dimension (LDAC,2*N) -C The leading 2*N-by-2*N part of this array contains the -C closed-loop system state matrix AC. -C -C LDAC INTEGER -C The leading dimension of the array AC. -C LDAC >= max(1,2*N). -C -C BC (output) DOUBLE PRECISION array, dimension (LDBC,M-NCON) -C The leading 2*N-by-(M-NCON) part of this array contains -C the closed-loop system input matrix BC. -C -C LDBC INTEGER -C The leading dimension of the array BC. -C LDBC >= max(1,2*N). -C -C CC (output) DOUBLE PRECISION array, dimension (LDCC,2*N) -C The leading (NP-NMEAS)-by-2*N part of this array contains -C the closed-loop system output matrix CC. -C -C LDCC INTEGER -C The leading dimension of the array CC. -C LDCC >= max(1,NP-NMEAS). -C -C DC (output) DOUBLE PRECISION array, dimension (LDDC,M-NCON) -C The leading (NP-NMEAS)-by-(M-NCON) part of this array -C contains the closed-loop system input/output matrix DC. -C -C LDDC INTEGER -C The leading dimension of the array DC. -C LDDC >= max(1,NP-NMEAS). -C -C Workspace -C -C IWORK INTEGER array, dimension 2*max(NCON,NMEAS) -C -C DWORK DOUBLE PRECISION array, dimension (LDWORK) -C On exit, if INFO = 0, DWORK(1) contains the optimal -C LDWORK. -C -C LDWORK INTEGER -C The dimension of the array DWORK. -C LDWORK >= 2*M*M+NP*NP+2*M*N+M*NP+2*N*NP. -C For good performance, LDWORK must generally be larger. -C -C Error Indicactor -C -C INFO INTEGER -C = 0: successful exit; -C < 0: if INFO = -i, the i-th argument had an illegal -C value; -C = 1: if the matrix Inp2 - D22*DK is singular to working -C precision; -C = 2: if the matrix Im2 - DK*D22 is singular to working -C precision. -C -C METHOD -C -C The routine implements the formulas given in [1]. -C -C REFERENCES -C -C [1] Balas, G.J., Doyle, J.C., Glover, K., Packard, A., and -C Smith, R. -C mu-Analysis and Synthesis Toolbox. -C The MathWorks Inc., Natick, Mass., 1995. -C -C NUMERICAL ASPECTS -C -C The accuracy of the result depends on the condition numbers of the -C matrices Inp2 - D22*DK and Im2 - DK*D22. -C -C CONTRIBUTORS -C -C P.Hr. Petkov, D.W. Gu and M.M. Konstantinov, October 1998. -C -C REVISIONS -C -C V. Sima, Research Institute for Informatics, Bucharest, May 1999. -C A. Markovski, Technical University, Sofia, April, 2003. -C -C KEYWORDS -C -C Closed loop systems, feedback control, robust control. -C -C ****************************************************************** -C -C .. Parameters .. - DOUBLE PRECISION ZERO, ONE - PARAMETER ( ZERO = 0.0D+0, ONE = 1.0D+0 ) -C -C .. Scalar Arguments .. - INTEGER INFO, LDA, LDAC, LDAK, LDB, LDBC, LDBK, LDC, - $ LDCC, LDCK, LDD, LDDC, LDDK, LDWORK, M, N, - $ NCON, NMEAS, NP -C .. -C .. Array Arguments .. - INTEGER IWORK( * ) - DOUBLE PRECISION A( LDA, * ), AC( LDAC, * ), AK( LDAK, * ), - $ B( LDB, * ), BC( LDBC, * ), BK( LDBK, * ), - $ C( LDC, * ), CC( LDCC, * ), CK( LDCK, * ), - $ D( LDD, * ), DC( LDDC, * ), DK( LDDK, * ), - $ DWORK( * ) -C .. -C .. Local Scalars .. - INTEGER INFO2, IW2, IW3, IW4, IW5, IW6, IW7, IW8, IWRK, - $ LWAMAX, M1, M2, MINWRK, N2, NP1, NP2 - DOUBLE PRECISION ANORM, EPS, RCOND -C .. -C .. External Functions .. - DOUBLE PRECISION DLAMCH, DLANGE - EXTERNAL DLAMCH, DLANGE -C .. -C .. External Subroutines .. - EXTERNAL DGECON, DGEMM, DGETRF, DGETRI, DLACPY, DLASET, - $ XERBLA -C .. -C .. Executable Statements .. -C -C Decode and Test input parameters. -C - N2 = 2*N - M1 = M - NCON - M2 = NCON - NP1 = NP - NMEAS - NP2 = NMEAS -C - INFO = 0 - IF( N.LT.0 ) THEN - INFO = -1 - ELSE IF( M.LT.0 ) THEN - INFO = -2 - ELSE IF( NP.LT.0 ) THEN - INFO = -3 - ELSE IF( NCON.LT.0 .OR. M1.LT.0 .OR. M2.GT.NP1 ) THEN - INFO = -4 - ELSE IF( NMEAS.LT.0 .OR. NP1.LT.0 .OR. NP2.GT.M1 ) THEN - INFO = -5 - ELSE IF( LDA.LT.MAX( 1, N ) ) THEN - INFO = -7 - ELSE IF( LDB.LT.MAX( 1, N ) ) THEN - INFO = -9 - ELSE IF( LDC.LT.MAX( 1, NP ) ) THEN - INFO = -11 - ELSE IF( LDD.LT.MAX( 1, NP ) ) THEN - INFO = -13 - ELSE IF( LDAK.LT.MAX( 1, N ) ) THEN - INFO = -15 - ELSE IF( LDBK.LT.MAX( 1, N ) ) THEN - INFO = -17 - ELSE IF( LDCK.LT.MAX( 1, M2 ) ) THEN - INFO = -19 - ELSE IF( LDDK.LT.MAX( 1, M2 ) ) THEN - INFO = -21 - ELSE IF( LDAC.LT.MAX( 1, N2 ) ) THEN - INFO = -23 - ELSE IF( LDBC.LT.MAX( 1, N2 ) ) THEN - INFO = -25 - ELSE IF( LDCC.LT.MAX( 1, NP1 ) ) THEN - INFO = -27 - ELSE IF( LDDC.LT.MAX( 1, NP1 ) ) THEN - INFO = -29 - ELSE -C -C Compute workspace. -C - MINWRK = 2*M*M + NP*NP + 2*M*N + M*NP + 2*N*NP - IF( LDWORK.LT.MINWRK ) - $ INFO = -32 - END IF - IF( INFO.NE.0 ) THEN - CALL XERBLA( 'SB10LD', -INFO ) - RETURN - END IF -C -C Quick return if possible. -C - IF( N.EQ.0 .OR. M.EQ.0 .OR. NP.EQ.0 .OR. M1.EQ.0 .OR. M2.EQ.0 - $ .OR. NP1.EQ.0 .OR. NP2.EQ.0 ) THEN - DWORK( 1 ) = ONE - RETURN - END IF -C -C Get the machine precision. -C - EPS = DLAMCH( 'Epsilon' ) -C -C Workspace usage. -C - IW2 = NP2*NP2 + 1 - IW3 = IW2 + M2*M2 - IW4 = IW3 + NP2*N - IW5 = IW4 + M2*N - IW6 = IW5 + NP2*M1 - IW7 = IW6 + M2*M1 - IW8 = IW7 + M2*N - IWRK = IW8 + NP2*N -C -C Compute inv(Inp2 - D22*DK) . -C - CALL DLASET( 'Full', NP2, NP2, ZERO, ONE, DWORK, NP2 ) - CALL DGEMM( 'N', 'N', NP2, NP2, M2, -ONE, D( NP1+1, M1+1 ), - $ LDD, DK, LDDK, ONE, DWORK, NP2 ) - ANORM = DLANGE( '1', NP2, NP2, DWORK, NP2, DWORK( IWRK ) ) - CALL DGETRF( NP2, NP2, DWORK, NP2, IWORK, INFO2 ) - IF( INFO2.GT.0 ) THEN - INFO = 1 - RETURN - END IF - CALL DGECON( '1', NP2, DWORK, NP2, ANORM, RCOND, DWORK( IWRK ), - $ IWORK( NP2+1 ), INFO ) - LWAMAX = INT( DWORK( IWRK ) ) + IWRK - 1 -C -C Return if the matrix is singular to working precision. -C - IF( RCOND.LT.EPS ) THEN - INFO = 1 - RETURN - END IF - CALL DGETRI( NP2, DWORK, NP2, IWORK, DWORK( IWRK ), LDWORK-IWRK+1, - $ INFO2 ) - LWAMAX = MAX( INT( DWORK( IWRK ) ) + IWRK - 1, LWAMAX ) -C -C Compute inv(Im2 - DK*D22) . -C - CALL DLASET( 'Full', M2, M2, ZERO, ONE, DWORK( IW2 ), M2 ) - CALL DGEMM( 'N', 'N', M2, M2, NP2, -ONE, DK, LDDK, - $ D( NP1+1, M1+1 ), LDD, ONE, DWORK( IW2 ), M2 ) - ANORM = DLANGE( '1', M2, M2, DWORK( IW2 ), M2, DWORK( IWRK ) ) - CALL DGETRF( M2, M2, DWORK( IW2 ), M2, IWORK, INFO2 ) - IF( INFO2.GT.0 ) THEN - INFO = 2 - RETURN - END IF - CALL DGECON( '1', M2, DWORK( IW2 ), M2, ANORM, RCOND, - $ DWORK( IWRK ), IWORK( M2+1 ), INFO ) - LWAMAX = MAX( INT( DWORK( IWRK ) ) + IWRK - 1, LWAMAX ) -C -C Return if the matrix is singular to working precision. -C - IF( RCOND.LT.EPS ) THEN - INFO = 2 - RETURN - END IF - CALL DGETRI( M2, DWORK( IW2 ), M2, IWORK, DWORK( IWRK ), - $ LDWORK-IWRK+1, INFO2 ) - LWAMAX = MAX( INT( DWORK( IWRK ) ) + IWRK - 1, LWAMAX ) -C -C Compute inv(Inp2 - D22*DK)*C2 . -C - CALL DGEMM( 'N', 'N', NP2, N, NP2, ONE, DWORK, NP2, C( NP1+1, 1 ), - $ LDC, ZERO, DWORK( IW3 ), NP2 ) -C -C Compute DK*inv(Inp2 - D22*DK)*C2 . -C - CALL DGEMM( 'N', 'N', M2, N, NP2, ONE, DK, LDDK, DWORK( IW3 ), - $ NP2, ZERO, DWORK( IW4 ), M2 ) -C -C Compute inv(Inp2 - D22*DK)*D21 . -C - CALL DGEMM( 'N', 'N', NP2, M1, NP2, ONE, DWORK, NP2, - $ D( NP1+1, 1 ), LDD, ZERO, DWORK( IW5 ), NP2 ) -C -C Compute DK*inv(Inp2 - D22*DK)*D21 . -C - CALL DGEMM( 'N', 'N', M2, M1, NP2, ONE, DK, LDDK, DWORK( IW5 ), - $ NP2, ZERO, DWORK( IW6 ), M2 ) -C -C Compute inv(Im2 - DK*D22)*CK . -C - CALL DGEMM( 'N', 'N', M2, N, M2, ONE, DWORK( IW2 ), M2, CK, LDCK, - $ ZERO, DWORK( IW7 ), M2 ) -C -C Compute D22*inv(Im2 - DK*D22)*CK . -C - CALL DGEMM( 'N', 'N', NP2, N, M2, ONE, D( NP1+1, M1+1 ), LDD, - $ DWORK( IW7 ), M2, ZERO, DWORK( IW8 ), NP2 ) -C -C Compute AC . -C - CALL DLACPY( 'Full', N, N, A, LDA, AC, LDAC ) - CALL DGEMM( 'N', 'N', N, N, M2, ONE, B( 1, M1+1 ), LDB, - $ DWORK( IW4 ), M2, ONE, AC, LDAC ) - CALL DGEMM( 'N', 'N', N, N, M2, ONE, B( 1, M1+1 ), LDB, - $ DWORK( IW7 ), M2, ZERO, AC( 1, N+1 ), LDAC ) - CALL DGEMM( 'N', 'N', N, N, NP2, ONE, BK, LDBK, DWORK( IW3 ), NP2, - $ ZERO, AC( N+1, 1 ), LDAC ) - CALL DLACPY( 'Full', N, N, AK, LDAK, AC( N+1, N+1 ), LDAC ) - CALL DGEMM( 'N', 'N', N, N, NP2, ONE, BK, LDBK, DWORK( IW8 ), NP2, - $ ONE, AC( N+1, N+1 ), LDAC ) -C -C Compute BC . -C - CALL DLACPY( 'Full', N, M1, B, LDB, BC, LDBC ) - CALL DGEMM( 'N', 'N', N, M1, M2, ONE, B( 1, M1+1 ), LDB, - $ DWORK( IW6 ), M2, ONE, BC, LDBC ) - CALL DGEMM( 'N', 'N', N, M1, NP2, ONE, BK, LDBK, DWORK( IW5 ), - $ NP2, ZERO, BC( N+1, 1 ), LDBC ) -C -C Compute CC . -C - CALL DLACPY( 'Full', NP1, N, C, LDC, CC, LDCC ) - CALL DGEMM( 'N', 'N', NP1, N, M2, ONE, D( 1, M1+1 ), LDD, - $ DWORK( IW4 ), M2, ONE, CC, LDCC ) - CALL DGEMM( 'N', 'N', NP1, N, M2, ONE, D( 1, M1+1 ), LDD, - $ DWORK( IW7 ), M2, ZERO, CC( 1, N+1 ), LDCC ) -C -C Compute DC . -C - CALL DLACPY( 'Full', NP1, M1, D, LDD, DC, LDDC ) - CALL DGEMM( 'N', 'N', NP1, M1, M2, ONE, D( 1, M1+1 ), LDD, - $ DWORK( IW6 ), M2, ONE, DC, LDDC ) -C - RETURN -C *** Last line of SB10LD *** - END diff --git a/mex/sources/libslicot/SB10MD.f b/mex/sources/libslicot/SB10MD.f deleted file mode 100644 index 46ea3d84b..000000000 --- a/mex/sources/libslicot/SB10MD.f +++ /dev/null @@ -1,670 +0,0 @@ - SUBROUTINE SB10MD( NC, MP, LENDAT, F, ORD, MNB, NBLOCK, ITYPE, - $ QUTOL, A, LDA, B, LDB, C, LDC, D, LDD, OMEGA, - $ TOTORD, AD, LDAD, BD, LDBD, CD, LDCD, DD, LDDD, - $ MJU, IWORK, LIWORK, DWORK, LDWORK, ZWORK, - $ LZWORK, INFO ) -C -C SLICOT RELEASE 5.0. -C -C Copyright (c) 2002-2009 NICONET e.V. -C -C This program is free software: you can redistribute it and/or -C modify it under the terms of the GNU General Public License as -C published by the Free Software Foundation, either version 2 of -C the License, or (at your option) any later version. -C -C This program is distributed in the hope that it will be useful, -C but WITHOUT ANY WARRANTY; without even the implied warranty of -C MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the -C GNU General Public License for more details. -C -C You should have received a copy of the GNU General Public License -C along with this program. If not, see -C . -C -C PURPOSE -C -C To perform the D-step in the D-K iteration. It handles -C continuous-time case. -C -C ARGUMENTS -C -C Input/Output Parameters -C -C NC (input) INTEGER -C The order of the matrix A. NC >= 0. -C -C MP (input) INTEGER -C The order of the matrix D. MP >= 0. -C -C LENDAT (input) INTEGER -C The length of the vector OMEGA. LENDAT >= 2. -C -C F (input) INTEGER -C The number of the measurements and controls, i.e., -C the size of the block I_f in the D-scaling system. -C F >= 0. -C -C ORD (input/output) INTEGER -C The MAX order of EACH block in the fitting procedure. -C ORD <= LENDAT-1. -C On exit, if ORD < 1 then ORD = 1. -C -C MNB (input) INTEGER -C The number of diagonal blocks in the block structure of -C the uncertainty, and the length of the vectors NBLOCK -C and ITYPE. 1 <= MNB <= MP. -C -C NBLOCK (input) INTEGER array, dimension (MNB) -C The vector of length MNB containing the block structure -C of the uncertainty. NBLOCK(I), I = 1:MNB, is the size of -C each block. -C -C ITYPE (input) INTEGER array, dimension (MNB) -C The vector of length MNB indicating the type of each -C block. -C For I = 1 : MNB, -C ITYPE(I) = 1 indicates that the corresponding block is a -C real block. IN THIS CASE ONLY MJU(JW) WILL BE ESTIMATED -C CORRECTLY, BUT NOT D(S)! -C ITYPE(I) = 2 indicates that the corresponding block is a -C complex block. THIS IS THE ONLY ALLOWED VALUE NOW! -C NBLOCK(I) must be equal to 1 if ITYPE(I) is equal to 1. -C -C QUTOL (input) DOUBLE PRECISION -C The acceptable mean relative error between the D(jw) and -C the frequency responce of the estimated block -C [ADi,BDi;CDi,DDi]. When it is reached, the result is -C taken as good enough. -C A good value is QUTOL = 2.0. -C If QUTOL < 0 then only mju(jw) is being estimated, -C not D(s). -C -C A (input/output) DOUBLE PRECISION array, dimension (LDA,NC) -C On entry, the leading NC-by-NC part of this array must -C contain the A matrix of the closed-loop system. -C On exit, if MP > 0, the leading NC-by-NC part of this -C array contains an upper Hessenberg matrix similar to A. -C -C LDA INTEGER -C The leading dimension of the array A. LDA >= MAX(1,NC). -C -C B (input/output) DOUBLE PRECISION array, dimension (LDB,MP) -C On entry, the leading NC-by-MP part of this array must -C contain the B matrix of the closed-loop system. -C On exit, the leading NC-by-MP part of this array contains -C the transformed B matrix corresponding to the Hessenberg -C form of A. -C -C LDB INTEGER -C The leading dimension of the array B. LDB >= MAX(1,NC). -C -C C (input/output) DOUBLE PRECISION array, dimension (LDC,NC) -C On entry, the leading MP-by-NC part of this array must -C contain the C matrix of the closed-loop system. -C On exit, the leading MP-by-NC part of this array contains -C the transformed C matrix corresponding to the Hessenberg -C form of A. -C -C LDC INTEGER -C The leading dimension of the array C. LDC >= MAX(1,MP). -C -C D (input) DOUBLE PRECISION array, dimension (LDD,MP) -C The leading MP-by-MP part of this array must contain the -C D matrix of the closed-loop system. -C -C LDD INTEGER -C The leading dimension of the array D. LDD >= MAX(1,MP). -C -C OMEGA (input) DOUBLE PRECISION array, dimension (LENDAT) -C The vector with the frequencies. -C -C TOTORD (output) INTEGER -C The TOTAL order of the D-scaling system. -C TOTORD is set to zero, if QUTOL < 0. -C -C AD (output) DOUBLE PRECISION array, dimension (LDAD,MP*ORD) -C The leading TOTORD-by-TOTORD part of this array contains -C the A matrix of the D-scaling system. -C Not referenced if QUTOL < 0. -C -C LDAD INTEGER -C The leading dimension of the array AD. -C LDAD >= MAX(1,MP*ORD), if QUTOL >= 0; -C LDAD >= 1, if QUTOL < 0. -C -C BD (output) DOUBLE PRECISION array, dimension (LDBD,MP+F) -C The leading TOTORD-by-(MP+F) part of this array contains -C the B matrix of the D-scaling system. -C Not referenced if QUTOL < 0. -C -C LDBD INTEGER -C The leading dimension of the array BD. -C LDBD >= MAX(1,MP*ORD), if QUTOL >= 0; -C LDBD >= 1, if QUTOL < 0. -C -C CD (output) DOUBLE PRECISION array, dimension (LDCD,MP*ORD) -C The leading (MP+F)-by-TOTORD part of this array contains -C the C matrix of the D-scaling system. -C Not referenced if QUTOL < 0. -C -C LDCD INTEGER -C The leading dimension of the array CD. -C LDCD >= MAX(1,MP+F), if QUTOL >= 0; -C LDCD >= 1, if QUTOL < 0. -C -C DD (output) DOUBLE PRECISION array, dimension (LDDD,MP+F) -C The leading (MP+F)-by-(MP+F) part of this array contains -C the D matrix of the D-scaling system. -C Not referenced if QUTOL < 0. -C -C LDDD INTEGER -C The leading dimension of the array DD. -C LDDD >= MAX(1,MP+F), if QUTOL >= 0; -C LDDD >= 1, if QUTOL < 0. -C -C MJU (output) DOUBLE PRECISION array, dimension (LENDAT) -C The vector with the upper bound of the structured -C singular value (mju) for each frequency in OMEGA. -C -C Workspace -C -C IWORK INTEGER array, dimension (LIWORK) -C -C LIWORK INTEGER -C The length of the array IWORK. -C LIWORK >= MAX( NC, 4*MNB-2, MP, 2*ORD+1 ), if QUTOL >= 0; -C LIWORK >= MAX( NC, 4*MNB-2, MP ), if QUTOL < 0. -C -C DWORK DOUBLE PRECISION array, dimension (LDWORK) -C On exit, if INFO = 0, DWORK(1) returns the optimal value -C of LDWORK, DWORK(2) returns the optimal value of LZWORK, -C and DWORK(3) returns an estimate of the minimum reciprocal -C of the condition numbers (with respect to inversion) of -C the generated Hessenberg matrices. -C -C LDWORK INTEGER -C The length of the array DWORK. -C LDWORK >= MAX( 3, LWM, LWD ), where -C LWM = LWA + MAX( NC + MAX( NC, MP-1 ), -C 2*MP*MP*MNB - MP*MP + 9*MNB*MNB + -C MP*MNB + 11*MP + 33*MNB - 11 ); -C LWD = LWB + MAX( 2, LW1, LW2, LW3, LW4, 2*ORD ), -C if QUTOL >= 0; -C LWD = 0, if QUTOL < 0; -C LWA = MP*LENDAT + 2*MNB + MP - 1; -C LWB = LENDAT*(MP + 2) + ORD*(ORD + 2) + 1; -C LW1 = 2*LENDAT + 4*HNPTS; HNPTS = 2048; -C LW2 = LENDAT + 6*HNPTS; MN = MIN( 2*LENDAT, 2*ORD+1 ); -C LW3 = 2*LENDAT*(2*ORD + 1) + MAX( 2*LENDAT, 2*ORD + 1 ) + -C MAX( MN + 6*ORD + 4, 2*MN + 1 ); -C LW4 = MAX( ORD*ORD + 5*ORD, 6*ORD + 1 + MIN( 1, ORD ) ). -C -C ZWORK COMPLEX*16 array, dimension (LZWORK) -C -C LZWORK INTEGER -C The length of the array ZWORK. -C LZWORK >= MAX( LZM, LZD ), where -C LZM = MAX( MP*MP + NC*MP + NC*NC + 2*NC, -C 6*MP*MP*MNB + 13*MP*MP + 6*MNB + 6*MP - 3 ); -C LZD = MAX( LENDAT*(2*ORD + 3), ORD*ORD + 3*ORD + 1 ), -C if QUTOL >= 0; -C LZD = 0, if QUTOL < 0. -C -C Error indicator -C -C INFO (output) INTEGER -C = 0: successful exit; -C < 0: if INFO = -i, the i-th argument had an illegal -C value; -C = 1: if one or more values w in OMEGA are (close to -C some) poles of the closed-loop system, i.e., the -C matrix jw*I - A is (numerically) singular; -C = 2: the block sizes must be positive integers; -C = 3: the sum of block sizes must be equal to MP; -C = 4: the size of a real block must be equal to 1; -C = 5: the block type must be either 1 or 2; -C = 6: errors in solving linear equations or in matrix -C inversion; -C = 7: errors in computing eigenvalues or singular values. -C = 1i: INFO on exit from SB10YD is i. (1i means 10 + i.) -C -C METHOD -C -C I. First, W(jw) for the given closed-loop system is being -C estimated. -C II. Now, AB13MD SLICOT subroutine can obtain the D(jw) scaling -C system with respect to NBLOCK and ITYPE, and colaterally, -C mju(jw). -C If QUTOL < 0 then the estimations stop and the routine exits. -C III. Now that we have D(jw), SB10YD subroutine can do block-by- -C block fit. For each block it tries with an increasing order -C of the fit, starting with 1 until the -C (mean quadratic error + max quadratic error)/2 -C between the Dii(jw) and the estimated frequency responce -C of the block becomes less than or equal to the routine -C argument QUTOL, or the order becomes equal to ORD. -C IV. Arrange the obtained blocks in the AD, BD, CD and DD -C matrices and estimate the total order of D(s), TOTORD. -C V. Add the system I_f to the system obtained in IV. -C -C REFERENCES -C -C [1] Balas, G., Doyle, J., Glover, K., Packard, A. and Smith, R. -C Mu-analysis and Synthesis toolbox - User's Guide, -C The Mathworks Inc., Natick, MA, USA, 1998. -C -C CONTRIBUTORS -C -C Asparuh Markovski, Technical University of Sofia, July 2003. -C -C REVISIONS -C -C V. Sima, Research Institute for Informatics, Bucharest, Aug. 2003. -C A. Markovski, V. Sima, October 2003. -C -C KEYWORDS -C -C Frequency response, H-infinity optimal control, robust control, -C structured singular value. -C -C ****************************************************************** -C -C .. Parameters .. - DOUBLE PRECISION ZERO, ONE, TWO, THREE - PARAMETER ( ZERO = 0.0D+0, ONE = 1.0D+0, TWO = 2.0D+0, - $ THREE = 3.0D+0 ) - INTEGER HNPTS - PARAMETER ( HNPTS = 2048 ) -C .. -C .. Scalar Arguments .. - INTEGER F, INFO, LDA, LDAD, LDB, LDBD, LDC, LDCD, LDD, - $ LDDD, LDWORK, LENDAT, LIWORK, LZWORK, MNB, MP, - $ NC, ORD, TOTORD - DOUBLE PRECISION QUTOL -C .. -C .. Array Arguments .. - INTEGER ITYPE(*), IWORK(*), NBLOCK(*) - DOUBLE PRECISION A(LDA, *), AD(LDAD, *), B(LDB, *), BD(LDBD, *), - $ C(LDC, *), CD(LDCD, *), D(LDD, *), DD(LDDD, *), - $ DWORK(*), MJU(*), OMEGA(*) - COMPLEX*16 ZWORK(*) -C .. -C .. Local Scalars .. - CHARACTER BALEIG, INITA - INTEGER CLWMAX, CORD, DLWMAX, I, IC, ICWRK, IDWRK, II, - $ INFO2, IWAD, IWB, IWBD, IWCD, IWDD, IWGJOM, - $ IWIFRD, IWRFRD, IWX, K, LCSIZE, LDSIZE, LORD, - $ LW1, LW2, LW3, LW4, LWA, LWB, MAXCWR, MAXWRK, - $ MN, W - DOUBLE PRECISION MAQE, MEQE, MOD1, MOD2, RCND, RCOND, RQE, TOL, - $ TOLER - COMPLEX*16 FREQ -C .. -C .. External Functions .. - DOUBLE PRECISION DLAMCH - EXTERNAL DLAMCH -C .. -C .. External Subroutines .. - EXTERNAL AB13MD, DCOPY, DLACPY, DLASET, DSCAL, SB10YD, - $ TB05AD, XERBLA -C .. -C .. Intrinsic Functions .. - INTRINSIC ABS, DCMPLX, INT, MAX, MIN, SQRT -C -C Decode and test input parameters. -C -C @@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@ -C Workspace usage 1. -C -C real -C - IWX = 1 + MP*LENDAT - IWGJOM = IWX + 2*MNB - 1 - IDWRK = IWGJOM + MP - LDSIZE = LDWORK - IDWRK + 1 -C -C complex -C - IWB = MP*MP + 1 - ICWRK = IWB + NC*MP - LCSIZE = LZWORK - ICWRK + 1 -C - INFO = 0 - IF ( NC.LT.0 ) THEN - INFO = -1 - ELSE IF( MP.LT.0 ) THEN - INFO = -2 - ELSE IF( LENDAT.LT.2 ) THEN - INFO = -3 - ELSE IF( F.LT.0 ) THEN - INFO = -4 - ELSE IF( ORD.GT.LENDAT - 1 ) THEN - INFO = -5 - ELSE IF( MNB.LT.1 .OR. MNB.GT.MP ) THEN - INFO = -6 - ELSE IF( LDA.LT.MAX( 1, NC ) ) THEN - INFO = -11 - ELSE IF( LDB.LT.MAX( 1, NC ) ) THEN - INFO = -13 - ELSE IF( LDC.LT.MAX( 1, MP ) ) THEN - INFO = -15 - ELSE IF( LDD.LT.MAX( 1, MP ) ) THEN - INFO = -17 - ELSE IF( LDAD.LT.1 .OR. ( QUTOL.GE.ZERO .AND. LDAD.LT.MP*ORD ) ) - $ THEN - INFO = -21 - ELSE IF( LDBD.LT.1 .OR. ( QUTOL.GE.ZERO .AND. LDBD.LT.MP*ORD ) ) - $ THEN - INFO = -23 - ELSE IF( LDCD.LT.1 .OR. ( QUTOL.GE.ZERO .AND. LDCD.LT.MP + F ) ) - $ THEN - INFO = -25 - ELSE IF( LDDD.LT.1 .OR. ( QUTOL.GE.ZERO .AND. LDDD.LT.MP + F ) ) - $ THEN - INFO = -27 - ELSE -C -C Compute workspace. -C - II = MAX( NC, 4*MNB - 2, MP ) - MN = MIN( 2*LENDAT, 2*ORD + 1 ) - LWA = IDWRK - 1 - LWB = LENDAT*( MP + 2 ) + ORD*( ORD + 2 ) + 1 - LW1 = 2*LENDAT + 4*HNPTS - LW2 = LENDAT + 6*HNPTS - LW3 = 2*LENDAT*( 2*ORD + 1 ) + MAX( 2*LENDAT, 2*ORD + 1 ) + - $ MAX( MN + 6*ORD + 4, 2*MN + 1 ) - LW4 = MAX( ORD*ORD + 5*ORD, 6*ORD + 1 + MIN( 1, ORD ) ) -C - DLWMAX = LWA + MAX( NC + MAX( NC, MP - 1 ), - $ 2*MP*MP*MNB - MP*MP + 9*MNB*MNB + MP*MNB + - $ 11*MP + 33*MNB - 11 ) -C - CLWMAX = MAX( ICWRK - 1 + NC*NC + 2*NC, - $ 6*MP*MP*MNB + 13*MP*MP + 6*MNB + 6*MP - 3 ) -C - IF ( QUTOL.GE.ZERO ) THEN - II = MAX( II, 2*ORD + 1 ) - DLWMAX = MAX( DLWMAX, - $ LWB + MAX( 2, LW1, LW2, LW3, LW4, 2*ORD ) ) - CLWMAX = MAX( CLWMAX, LENDAT*( 2*ORD + 3 ), - $ ORD*( ORD + 3 ) + 1 ) - END IF - IF ( LIWORK.LT.II ) THEN - INFO = -30 - ELSE IF ( LDWORK.LT.MAX( 3, DLWMAX ) ) THEN - INFO = -32 - ELSE IF ( LZWORK.LT.CLWMAX ) THEN - INFO = -34 - END IF - END IF -C - IF ( INFO.NE.0 ) THEN -C -C Error return. -C - CALL XERBLA( 'SB10MD', -INFO ) - RETURN - END IF -C - ORD = MAX( 1, ORD ) - TOTORD = 0 -C -C Quick return if possible. -C - IF( NC.EQ.0 .OR. MP.EQ.0 ) THEN - DWORK(1) = THREE - DWORK(2) = ZERO - DWORK(3) = ONE - RETURN - END IF -C - TOLER = SQRT( DLAMCH( 'Epsilon' ) ) -C - BALEIG = 'C' - RCOND = ONE - MAXCWR = CLWMAX -C -C @@@ 1. Estimate W(jw) for the closed-loop system, @@@ -C @@@ D(jw) and mju(jw) for each frequency. @@@ -C - DO 30 W = 1, LENDAT - FREQ = DCMPLX( ZERO, OMEGA(W) ) - IF ( W.EQ.1 ) THEN - INITA = 'G' - ELSE - INITA = 'H' - END IF -C -C Compute C*inv(jw*I-A)*B. -C Integer workspace: need NC. -C Real workspace: need LWA + NC + MAX(NC,MP-1); -C prefer larger, -C where LWA = MP*LENDAT + 2*MNB + MP - 1. -C Complex workspace: need MP*MP + NC*MP + NC*NC + 2*NC. -C - CALL TB05AD( BALEIG, INITA, NC, MP, MP, FREQ, A, LDA, B, LDB, - $ C, LDC, RCND, ZWORK, MP, DWORK, DWORK, ZWORK(IWB), - $ NC, IWORK, DWORK(IDWRK), LDSIZE, ZWORK(ICWRK), - $ LCSIZE, INFO2 ) -C - IF ( INFO2.GT.0 ) THEN - INFO = 1 - RETURN - END IF -C - RCOND = MIN( RCOND, RCND ) - IF ( W.EQ.1 ) - $ MAXWRK = INT( DWORK(IDWRK) + IDWRK - 1 ) - IC = 0 -C -C D + C*inv(jw*I-A)*B -C - DO 20 K = 1, MP - DO 10 I = 1, MP - IC = IC + 1 - ZWORK(IC) = ZWORK(IC) + DCMPLX ( D(I,K), ZERO ) - 10 CONTINUE - 20 CONTINUE -C -C Estimate D(jw) and mju(jw). -C Integer workspace: need MAX(4*MNB-2,MP). -C Real workspace: need LWA + 2*MP*MP*MNB - MP*MP + 9*MNB*MNB -C + MP*MNB + 11*MP + 33*MNB - 11; -C prefer larger. -C Complex workspace: need 6*MP*MP*MNB + 13*MP*MP + 6*MNB + -C 6*MP - 3. -C - CALL AB13MD( 'N', MP, ZWORK, MP, MNB, NBLOCK, ITYPE, - $ DWORK(IWX), MJU(W), DWORK((W-1)*MP+1), - $ DWORK(IWGJOM), IWORK, DWORK(IDWRK), LDSIZE, - $ ZWORK(IWB), LZWORK-IWB+1, INFO2 ) -C - IF ( INFO2.NE.0 ) THEN - INFO = INFO2 + 1 - RETURN - END IF -C - IF ( W.EQ.1 ) THEN - MAXWRK = MAX( MAXWRK, INT( DWORK(IDWRK) ) + IDWRK - 1 ) - MAXCWR = MAX( MAXCWR, INT( ZWORK(IWB) ) + IWB - 1 ) - END IF -C -C Normalize D(jw) through it's last entry. -C - IF ( DWORK(W*MP).NE.ZERO ) - $ CALL DSCAL( MP, ONE/DWORK(W*MP), DWORK((W-1)*MP+1), 1 ) -C - 30 CONTINUE -C -C Quick return if needed. -C - IF ( QUTOL.LT.ZERO ) THEN - DWORK(1) = MAXWRK - DWORK(2) = MAXCWR - DWORK(3) = RCOND - RETURN - END IF -C -C @@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@ -C Workspace usage 2. -C -C real -C - IWRFRD = IWX - IWIFRD = IWRFRD + LENDAT - IWAD = IWIFRD + LENDAT - IWBD = IWAD + ORD*ORD - IWCD = IWBD + ORD - IWDD = IWCD + ORD - IDWRK = IWDD + 1 - LDSIZE = LDWORK - IDWRK + 1 -C -C complex -C - ICWRK = ORD + 2 - LCSIZE = LZWORK - ICWRK + 1 - INITA = 'H' -C -C Use default tolerance for SB10YD. -C - TOL = -ONE -C -C @@@ 2. Clear imag parts of D(jw) for SB10YD. @@@ -C - DO 40 I = 1, LENDAT - DWORK(IWIFRD+I-1) = ZERO - 40 CONTINUE -C -C @@@ 3. Clear AD, BD, CD and initialize DD with I_(mp+f). @@@ -C - CALL DLASET( 'Full', MP*ORD, MP*ORD, ZERO, ZERO, AD, LDAD ) - CALL DLASET( 'Full', MP*ORD, MP+F, ZERO, ZERO, BD, LDBD ) - CALL DLASET( 'Full', MP+F, MP*ORD, ZERO, ZERO, CD, LDCD ) - CALL DLASET( 'Full', MP+F, MP+F, ZERO, ONE, DD, LDDD ) -C -C @@@ 4. Block by block frequency identification. @@@ -C - DO 80 II = 1, MP -C - CALL DCOPY( LENDAT, DWORK(II), MP, DWORK(IWRFRD), 1 ) -C -C Increase CORD from 1 to ORD for every block, if needed. -C - CORD = 1 -C - 50 CONTINUE - LORD = CORD -C -C Now, LORD is the desired order. -C Integer workspace: need 2*N+1, where N = LORD. -C Real workspace: need LWB + MAX( 2, LW1, LW2, LW3, LW4), -C where -C LWB = LENDAT*(MP+2) + -C ORD*(ORD+2) + 1, -C HNPTS = 2048, and -C LW1 = 2*LENDAT + 4*HNPTS; -C LW2 = LENDAT + 6*HNPTS; -C MN = min( 2*LENDAT, 2*N+1 ) -C LW3 = 2*LENDAT*(2*N+1) + -C max( 2*LENDAT, 2*N+1 ) + -C max( MN + 6*N + 4, 2*MN+1 ); -C LW4 = max( N*N + 5*N, -C 6*N + 1 + min( 1,N ) ); -C prefer larger. -C Complex workspace: need LENDAT*(2*N+3). -C - CALL SB10YD( 0, 1, LENDAT, DWORK(IWRFRD), DWORK(IWIFRD), - $ OMEGA, LORD, DWORK(IWAD), ORD, DWORK(IWBD), - $ DWORK(IWCD), DWORK(IWDD), TOL, IWORK, - $ DWORK(IDWRK), LDSIZE, ZWORK, LZWORK, INFO2 ) -C -C At this point, LORD is the actual order reached by SB10YD, -C 0 <= LORD <= CORD. -C [ADi,BDi; CDi,DDi] is a minimal realization with ADi in -C upper Hessenberg form. -C The leading LORD-by-LORD part of ORD-by-ORD DWORK(IWAD) -C contains ADi, the leading LORD-by-1 part of ORD-by-1 -C DWORK(IWBD) contains BDi, the leading 1-by-LORD part of -C 1-by-ORD DWORK(IWCD) contains CDi, DWORK(IWDD) contains DDi. -C - IF ( INFO2.NE.0 ) THEN - INFO = 10 + INFO2 - RETURN - END IF -C -C Compare the original D(jw) with the fitted one. -C - MEQE = ZERO - MAQE = ZERO -C - DO 60 W = 1, LENDAT - FREQ = DCMPLX( ZERO, OMEGA(W) ) -C -C Compute CD*inv(jw*I-AD)*BD. -C Integer workspace: need LORD. -C Real workspace: need LWB + 2*LORD; -C prefer larger. -C Complex workspace: need 1 + ORD + LORD*LORD + 2*LORD. -C - CALL TB05AD( BALEIG, INITA, LORD, 1, 1, FREQ, - $ DWORK(IWAD), ORD, DWORK(IWBD), ORD, - $ DWORK(IWCD), 1, RCND, ZWORK, 1, - $ DWORK(IDWRK), DWORK(IDWRK), ZWORK(2), ORD, - $ IWORK, DWORK(IDWRK), LDSIZE, ZWORK(ICWRK), - $ LCSIZE, INFO2 ) -C - IF ( INFO2.GT.0 ) THEN - INFO = 1 - RETURN - END IF -C - RCOND = MIN( RCOND, RCND ) - IF ( W.EQ.1 ) - $ MAXWRK = MAX( MAXWRK, INT( DWORK(IDWRK) ) + IDWRK - 1) -C -C DD + CD*inv(jw*I-AD)*BD -C - ZWORK(1) = ZWORK(1) + DCMPLX( DWORK(IWDD), ZERO ) -C - MOD1 = ABS( DWORK(IWRFRD+W-1) ) - MOD2 = ABS( ZWORK(1) ) - RQE = ABS( ( MOD1 - MOD2 )/( MOD1 + TOLER ) ) - MEQE = MEQE + RQE - MAQE = MAX( MAQE, RQE ) -C - 60 CONTINUE -C - MEQE = MEQE/LENDAT -C - IF ( ( ( MEQE + MAQE )/TWO.LE.QUTOL ) .OR. - $ ( CORD.EQ.ORD ) ) THEN - GOTO 70 - END IF -C - CORD = CORD + 1 - GOTO 50 -C - 70 TOTORD = TOTORD + LORD -C -C Copy ad(ii), bd(ii) and cd(ii) to AD, BD and CD, respectively. -C - CALL DLACPY( 'Full', LORD, LORD, DWORK(IWAD), ORD, - $ AD(TOTORD-LORD+1,TOTORD-LORD+1), LDAD ) - CALL DCOPY( LORD, DWORK(IWBD), 1, BD(TOTORD-LORD+1,II), 1 ) - CALL DCOPY( LORD, DWORK(IWCD), 1, CD(II,TOTORD-LORD+1), LDCD ) -C -C Copy dd(ii) to DD. -C - DD(II,II) = DWORK(IWDD) -C - 80 CONTINUE -C - DWORK(1) = MAXWRK - DWORK(2) = MAXCWR - DWORK(3) = RCOND - RETURN -C -C *** Last line of SB10MD *** - END diff --git a/mex/sources/libslicot/SB10PD.f b/mex/sources/libslicot/SB10PD.f deleted file mode 100644 index 617bdd29b..000000000 --- a/mex/sources/libslicot/SB10PD.f +++ /dev/null @@ -1,505 +0,0 @@ - SUBROUTINE SB10PD( N, M, NP, NCON, NMEAS, A, LDA, B, LDB, C, LDC, - $ D, LDD, TU, LDTU, TY, LDTY, RCOND, TOL, DWORK, - $ LDWORK, INFO ) -C -C SLICOT RELEASE 5.0. -C -C Copyright (c) 2002-2009 NICONET e.V. -C -C This program is free software: you can redistribute it and/or -C modify it under the terms of the GNU General Public License as -C published by the Free Software Foundation, either version 2 of -C the License, or (at your option) any later version. -C -C This program is distributed in the hope that it will be useful, -C but WITHOUT ANY WARRANTY; without even the implied warranty of -C MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the -C GNU General Public License for more details. -C -C You should have received a copy of the GNU General Public License -C along with this program. If not, see -C . -C -C PURPOSE -C -C To reduce the matrices D12 and D21 of the linear time-invariant -C system -C -C | A | B1 B2 | | A | B | -C P = |----|---------| = |---|---| -C | C1 | D11 D12 | | C | D | -C | C2 | D21 D22 | -C -C to unit diagonal form, to transform the matrices B, C, and D11 to -C satisfy the formulas in the computation of an H2 and H-infinity -C (sub)optimal controllers and to check the rank conditions. -C -C ARGUMENTS -C -C Input/Output Parameters -C -C N (input) INTEGER -C The order of the system. N >= 0. -C -C M (input) INTEGER -C The column size of the matrix B. M >= 0. -C -C NP (input) INTEGER -C The row size of the matrix C. NP >= 0. -C -C NCON (input) INTEGER -C The number of control inputs (M2). M >= NCON >= 0, -C NP-NMEAS >= NCON. -C -C NMEAS (input) INTEGER -C The number of measurements (NP2). NP >= NMEAS >= 0, -C M-NCON >= NMEAS. -C -C A (input) DOUBLE PRECISION array, dimension (LDA,N) -C The leading N-by-N part of this array must contain the -C system state matrix A. -C -C LDA INTEGER -C The leading dimension of the array A. LDA >= max(1,N). -C -C B (input/output) DOUBLE PRECISION array, dimension (LDB,M) -C On entry, the leading N-by-M part of this array must -C contain the system input matrix B. -C On exit, the leading N-by-M part of this array contains -C the transformed system input matrix B. -C -C LDB INTEGER -C The leading dimension of the array B. LDB >= max(1,N). -C -C C (input/output) DOUBLE PRECISION array, dimension (LDC,N) -C On entry, the leading NP-by-N part of this array must -C contain the system output matrix C. -C On exit, the leading NP-by-N part of this array contains -C the transformed system output matrix C. -C -C LDC INTEGER -C The leading dimension of the array C. LDC >= max(1,NP). -C -C D (input/output) DOUBLE PRECISION array, dimension (LDD,M) -C On entry, the leading NP-by-M part of this array must -C contain the system input/output matrix D. The -C NMEAS-by-NCON trailing submatrix D22 is not referenced. -C On exit, the leading (NP-NMEAS)-by-(M-NCON) part of this -C array contains the transformed submatrix D11. -C The transformed submatrices D12 = [ 0 Im2 ]' and -C D21 = [ 0 Inp2 ] are not stored. The corresponding part -C of this array contains no useful information. -C -C LDD INTEGER -C The leading dimension of the array D. LDD >= max(1,NP). -C -C TU (output) DOUBLE PRECISION array, dimension (LDTU,M2) -C The leading M2-by-M2 part of this array contains the -C control transformation matrix TU. -C -C LDTU INTEGER -C The leading dimension of the array TU. LDTU >= max(1,M2). -C -C TY (output) DOUBLE PRECISION array, dimension (LDTY,NP2) -C The leading NP2-by-NP2 part of this array contains the -C measurement transformation matrix TY. -C -C LDTY INTEGER -C The leading dimension of the array TY. -C LDTY >= max(1,NP2). -C -C RCOND (output) DOUBLE PRECISION array, dimension (2) -C RCOND(1) contains the reciprocal condition number of the -C control transformation matrix TU; -C RCOND(2) contains the reciprocal condition number of the -C measurement transformation matrix TY. -C RCOND is set even if INFO = 3 or INFO = 4; if INFO = 3, -C then RCOND(2) was not computed, but it is set to 0. -C -C Tolerances -C -C TOL DOUBLE PRECISION -C Tolerance used for controlling the accuracy of the applied -C transformations. Transformation matrices TU and TY whose -C reciprocal condition numbers are less than TOL are not -C allowed. If TOL <= 0, then a default value equal to -C sqrt(EPS) is used, where EPS is the relative machine -C precision. -C -C Workspace -C -C DWORK DOUBLE PRECISION array, dimension (LDWORK) -C On exit, if INFO = 0, DWORK(1) contains the optimal -C LDWORK. -C -C LDWORK INTEGER -C The dimension of the array DWORK. -C LDWORK >= MAX(1,LW1,LW2,LW3,LW4), where -C LW1 = (N+NP1+1)*(N+M2) + MAX(3*(N+M2)+N+NP1,5*(N+M2)), -C LW2 = (N+NP2)*(N+M1+1) + MAX(3*(N+NP2)+N+M1,5*(N+NP2)), -C LW3 = M2 + NP1*NP1 + MAX(NP1*MAX(N,M1),3*M2+NP1,5*M2), -C LW4 = NP2 + M1*M1 + MAX(MAX(N,NP1)*M1,3*NP2+M1,5*NP2), -C with M1 = M - M2 and NP1 = NP - NP2. -C For good performance, LDWORK must generally be larger. -C Denoting Q = MAX(M1,M2,NP1,NP2), an upper bound is -C MAX(1,(N+Q)*(N+Q+6),Q*(Q+MAX(N,Q,5)+1). -C -C Error Indicator -C -C INFO INTEGER -C = 0: successful exit; -C < 0: if INFO = -i, the i-th argument had an illegal -C value; -C = 1: if the matrix | A B2 | had not full column rank -C | C1 D12 | -C in respect to the tolerance EPS; -C = 2: if the matrix | A B1 | had not full row rank in -C | C2 D21 | -C respect to the tolerance EPS; -C = 3: if the matrix D12 had not full column rank in -C respect to the tolerance TOL; -C = 4: if the matrix D21 had not full row rank in respect -C to the tolerance TOL; -C = 5: if the singular value decomposition (SVD) algorithm -C did not converge (when computing the SVD of one of -C the matrices |A B2 |, |A B1 |, D12 or D21). -C |C1 D12| |C2 D21| -C -C METHOD -C -C The routine performs the transformations described in [2]. -C -C REFERENCES -C -C [1] Glover, K. and Doyle, J.C. -C State-space formulae for all stabilizing controllers that -C satisfy an Hinf norm bound and relations to risk sensitivity. -C Systems and Control Letters, vol. 11, pp. 167-172, 1988. -C -C [2] Balas, G.J., Doyle, J.C., Glover, K., Packard, A., and -C Smith, R. -C mu-Analysis and Synthesis Toolbox. -C The MathWorks Inc., Natick, Mass., 1995. -C -C NUMERICAL ASPECTS -C -C The precision of the transformations can be controlled by the -C condition numbers of the matrices TU and TY as given by the -C values of RCOND(1) and RCOND(2), respectively. An error return -C with INFO = 3 or INFO = 4 will be obtained if the condition -C number of TU or TY, respectively, would exceed 1/TOL. -C -C CONTRIBUTORS -C -C P.Hr. Petkov, D.W. Gu and M.M. Konstantinov, October 1998. -C -C REVISIONS -C -C V. Sima, Research Institute for Informatics, Bucharest, May 1999, -C Feb. 2000. -C -C KEYWORDS -C -C H-infinity optimal control, robust control, singular value -C decomposition. -C -C ****************************************************************** -C -C .. Parameters .. - DOUBLE PRECISION ZERO, ONE - PARAMETER ( ZERO = 0.0D+0, ONE = 1.0D+0 ) -C .. -C .. Scalar Arguments .. - INTEGER INFO, LDA, LDB, LDC, LDD, LDTU, LDTY, LDWORK, - $ M, N, NCON, NMEAS, NP - DOUBLE PRECISION TOL -C .. -C .. Array Arguments .. - DOUBLE PRECISION A( LDA, * ), B( LDB, * ), C( LDC, * ), - $ D( LDD, * ), DWORK( * ), RCOND( 2 ), - $ TU( LDTU, * ), TY( LDTY, * ) -C .. -C .. Local Scalars .. - INTEGER IEXT, INFO2, IQ, IWRK, J, LWAMAX, M1, M2, - $ MINWRK, ND1, ND2, NP1, NP2 - DOUBLE PRECISION EPS, TOLL -C .. -C .. External Functions .. - DOUBLE PRECISION DLAMCH - EXTERNAL DLAMCH -C .. -C .. External Subroutines .. - EXTERNAL DGEMM, DGESVD, DLACPY, DSCAL, DSWAP, XERBLA -C .. -C .. Intrinsic Functions .. - INTRINSIC DBLE, INT, MAX, SQRT -C .. -C .. Executable Statements .. -C -C Decode and Test input parameters. -C - M1 = M - NCON - M2 = NCON - NP1 = NP - NMEAS - NP2 = NMEAS -C - INFO = 0 - IF( N.LT.0 ) THEN - INFO = -1 - ELSE IF( M.LT.0 ) THEN - INFO = -2 - ELSE IF( NP.LT.0 ) THEN - INFO = -3 - ELSE IF( NCON.LT.0 .OR. M1.LT.0 .OR. M2.GT.NP1 ) THEN - INFO = -4 - ELSE IF( NMEAS.LT.0 .OR. NP1.LT.0 .OR. NP2.GT.M1 ) THEN - INFO = -5 - ELSE IF( LDA.LT.MAX( 1, N ) ) THEN - INFO = -7 - ELSE IF( LDB.LT.MAX( 1, N ) ) THEN - INFO = -9 - ELSE IF( LDC.LT.MAX( 1, NP ) ) THEN - INFO = -11 - ELSE IF( LDD.LT.MAX( 1, NP ) ) THEN - INFO = -13 - ELSE IF( LDTU.LT.MAX( 1, M2 ) ) THEN - INFO = -15 - ELSE IF( LDTY.LT.MAX( 1, NP2 ) ) THEN - INFO = -17 - ELSE -C -C Compute workspace. -C - MINWRK = MAX( 1, - $ ( N + NP1 + 1 )*( N + M2 ) + - $ MAX( 3*( N + M2 ) + N + NP1, 5*( N + M2 ) ), - $ ( N + NP2 )*( N + M1 + 1 ) + - $ MAX( 3*( N + NP2 ) + N + M1, 5*( N + NP2 ) ), - $ M2 + NP1*NP1 + MAX( NP1*MAX( N, M1 ), 3*M2 + NP1, - $ 5*M2 ), - $ NP2 + M1*M1 + MAX( MAX( N, NP1 )*M1, 3*NP2 + M1, - $ 5*NP2 ) ) - IF( LDWORK.LT.MINWRK ) - $ INFO = -21 - END IF - IF( INFO.NE.0 ) THEN - CALL XERBLA( 'SB10PD', -INFO ) - RETURN - END IF -C -C Quick return if possible. -C - IF( N.EQ.0 .OR. M.EQ.0 .OR. NP.EQ.0 .OR. M1.EQ.0 .OR. M2.EQ.0 - $ .OR. NP1.EQ.0 .OR. NP2.EQ.0 ) THEN - RCOND( 1 ) = ONE - RCOND( 2 ) = ONE - DWORK( 1 ) = ONE - RETURN - END IF -C - ND1 = NP1 - M2 - ND2 = M1 - NP2 - EPS = DLAMCH( 'Epsilon' ) - TOLL = TOL - IF( TOLL.LE.ZERO ) THEN -C -C Set the default value of the tolerance for condition tests. -C - TOLL = SQRT( EPS ) - END IF -C -C Determine if |A-jwI B2 | has full column rank at w = 0. -C | C1 D12| -C Workspace: need (N+NP1+1)*(N+M2) + -C max(3*(N+M2)+N+NP1,5*(N+M2)); -C prefer larger. -C - IEXT = N + M2 + 1 - IWRK = IEXT + ( N + NP1 )*( N + M2 ) - CALL DLACPY( 'Full', N, N, A, LDA, DWORK( IEXT ), N+NP1 ) - CALL DLACPY( 'Full', NP1, N, C, LDC, DWORK( IEXT+N ), N+NP1 ) - CALL DLACPY( 'Full', N, M2, B( 1, M1+1 ), LDB, - $ DWORK( IEXT+(N+NP1)*N ), N+NP1 ) - CALL DLACPY( 'Full', NP1, M2, D( 1, M1+1 ), LDD, - $ DWORK( IEXT+(N+NP1)*N+N ), N+NP1 ) - CALL DGESVD( 'N', 'N', N+NP1, N+M2, DWORK( IEXT ), N+NP1, DWORK, - $ TU, LDTU, TY, LDTY, DWORK( IWRK ), LDWORK-IWRK+1, - $ INFO2 ) - IF( INFO2.NE.0 ) THEN - INFO = 5 - RETURN - END IF - IF( DWORK( N+M2 )/DWORK( 1 ).LE.EPS ) THEN - INFO = 1 - RETURN - END IF - LWAMAX = INT( DWORK( IWRK ) ) + IWRK - 1 -C -C Determine if |A-jwI B1 | has full row rank at w = 0. -C | C2 D21| -C Workspace: need (N+NP2)*(N+M1+1) + -C max(3*(N+NP2)+N+M1,5*(N+NP2)); -C prefer larger. -C - IEXT = N + NP2 + 1 - IWRK = IEXT + ( N + NP2 )*( N + M1 ) - CALL DLACPY( 'Full', N, N, A, LDA, DWORK( IEXT ), N+NP2 ) - CALL DLACPY( 'Full', NP2, N, C( NP1+1, 1), LDC, DWORK( IEXT+N ), - $ N+NP2 ) - CALL DLACPY( 'Full', N, M1, B, LDB, DWORK( IEXT+(N+NP2)*N ), - $ N+NP2 ) - CALL DLACPY( 'Full', NP2, M1, D( NP1+1, 1 ), LDD, - $ DWORK( IEXT+(N+NP2)*N+N ), N+NP2 ) - CALL DGESVD( 'N', 'N', N+NP2, N+M1, DWORK( IEXT ), N+NP2, DWORK, - $ TU, LDTU, TY, LDTY, DWORK( IWRK ), LDWORK-IWRK+1, - $ INFO2 ) - IF( INFO2.NE.0 ) THEN - INFO = 5 - RETURN - END IF - IF( DWORK( N+NP2 )/DWORK( 1 ).LE.EPS ) THEN - INFO = 2 - RETURN - END IF - LWAMAX = MAX( INT( DWORK( IWRK ) ) + IWRK - 1, LWAMAX ) -C -C Determine SVD of D12, D12 = U12 S12 V12', and check if D12 has -C full column rank. V12' is stored in TU. -C Workspace: need M2 + NP1*NP1 + max(3*M2+NP1,5*M2); -C prefer larger. -C - IQ = M2 + 1 - IWRK = IQ + NP1*NP1 -C - CALL DGESVD( 'A', 'A', NP1, M2, D( 1, M1+1 ), LDD, DWORK, - $ DWORK( IQ ), NP1, TU, LDTU, DWORK( IWRK ), - $ LDWORK-IWRK+1, INFO2 ) - IF( INFO2.NE.0 ) THEN - INFO = 5 - RETURN - END IF -C - RCOND( 1 ) = DWORK( M2 )/DWORK( 1 ) - IF( RCOND( 1 ).LE.TOLL ) THEN - RCOND( 2 ) = ZERO - INFO = 3 - RETURN - END IF - LWAMAX = MAX( INT( DWORK( IWRK ) ) + IWRK - 1, LWAMAX ) -C -C Determine Q12. -C - IF( ND1.GT.0 ) THEN - CALL DLACPY( 'Full', NP1, M2, DWORK( IQ ), NP1, D( 1, M1+1 ), - $ LDD ) - CALL DLACPY( 'Full', NP1, ND1, DWORK( IQ+NP1*M2 ), NP1, - $ DWORK( IQ ), NP1 ) - CALL DLACPY( 'Full', NP1, M2, D( 1, M1+1 ), LDD, - $ DWORK( IQ+NP1*ND1 ), NP1 ) - END IF -C -C Determine Tu by transposing in-situ and scaling. -C - DO 10 J = 1, M2 - 1 - CALL DSWAP( J, TU( J+1, 1 ), LDTU, TU( 1, J+1 ), 1 ) - 10 CONTINUE -C - DO 20 J = 1, M2 - CALL DSCAL( M2, ONE/DWORK( J ), TU( 1, J ), 1 ) - 20 CONTINUE -C -C Determine C1 =: Q12'*C1. -C Workspace: M2 + NP1*NP1 + NP1*N. -C - CALL DGEMM( 'T', 'N', NP1, N, NP1, ONE, DWORK( IQ ), NP1, C, LDC, - $ ZERO, DWORK( IWRK ), NP1 ) - CALL DLACPY( 'Full', NP1, N, DWORK( IWRK ), NP1, C, LDC ) - LWAMAX = MAX( IWRK + NP1*N - 1, LWAMAX ) -C -C Determine D11 =: Q12'*D11. -C Workspace: M2 + NP1*NP1 + NP1*M1. -C - CALL DGEMM( 'T', 'N', NP1, M1, NP1, ONE, DWORK( IQ ), NP1, D, LDD, - $ ZERO, DWORK( IWRK ), NP1 ) - CALL DLACPY( 'Full', NP1, M1, DWORK( IWRK ), NP1, D, LDD ) - LWAMAX = MAX( IWRK + NP1*M1 - 1, LWAMAX ) -C -C Determine SVD of D21, D21 = U21 S21 V21', and check if D21 has -C full row rank. U21 is stored in TY. -C Workspace: need NP2 + M1*M1 + max(3*NP2+M1,5*NP2); -C prefer larger. -C - IQ = NP2 + 1 - IWRK = IQ + M1*M1 -C - CALL DGESVD( 'A', 'A', NP2, M1, D( NP1+1, 1 ), LDD, DWORK, TY, - $ LDTY, DWORK( IQ ), M1, DWORK( IWRK ), LDWORK-IWRK+1, - $ INFO2 ) - IF( INFO2.NE.0 ) THEN - INFO = 5 - RETURN - END IF -C - RCOND( 2 ) = DWORK( NP2 )/DWORK( 1 ) - IF( RCOND( 2 ).LE.TOLL ) THEN - INFO = 4 - RETURN - END IF - LWAMAX = MAX( INT( DWORK( IWRK ) ) + IWRK - 1, LWAMAX ) -C -C Determine Q21. -C - IF( ND2.GT.0 ) THEN - CALL DLACPY( 'Full', NP2, M1, DWORK( IQ ), M1, D( NP1+1, 1 ), - $ LDD ) - CALL DLACPY( 'Full', ND2, M1, DWORK( IQ+NP2 ), M1, DWORK( IQ ), - $ M1 ) - CALL DLACPY( 'Full', NP2, M1, D( NP1+1, 1 ), LDD, - $ DWORK( IQ+ND2 ), M1 ) - END IF -C -C Determine Ty by scaling and transposing in-situ. -C - DO 30 J = 1, NP2 - CALL DSCAL( NP2, ONE/DWORK( J ), TY( 1, J ), 1 ) - 30 CONTINUE -C - DO 40 J = 1, NP2 - 1 - CALL DSWAP( J, TY( J+1, 1 ), LDTY, TY( 1, J+1 ), 1 ) - 40 CONTINUE -C -C Determine B1 =: B1*Q21'. -C Workspace: NP2 + M1*M1 + N*M1. -C - CALL DGEMM( 'N', 'T', N, M1, M1, ONE, B, LDB, DWORK( IQ ), M1, - $ ZERO, DWORK( IWRK ), N ) - CALL DLACPY( 'Full', N, M1, DWORK( IWRK ), N, B, LDB ) - LWAMAX = MAX( IWRK + N*M1 - 1, LWAMAX ) -C -C Determine D11 =: D11*Q21'. -C Workspace: NP2 + M1*M1 + NP1*M1. -C - CALL DGEMM( 'N', 'T', NP1, M1, M1, ONE, D, LDD, DWORK( IQ ), M1, - $ ZERO, DWORK( IWRK ), NP1 ) - CALL DLACPY( 'Full', NP1, M1, DWORK( IWRK ), NP1, D, LDD ) - LWAMAX = MAX( IWRK + NP1*M1 - 1, LWAMAX ) -C -C Determine B2 =: B2*Tu. -C Workspace: N*M2. -C - CALL DGEMM( 'N', 'N', N, M2, M2, ONE, B( 1, M1+1 ), LDB, TU, LDTU, - $ ZERO, DWORK, N ) - CALL DLACPY( 'Full', N, M2, DWORK, N, B( 1, M1+1 ), LDB ) -C -C Determine C2 =: Ty*C2. -C Workspace: NP2*N. -C - CALL DGEMM( 'N', 'N', NP2, N, NP2, ONE, TY, LDTY, - $ C( NP1+1, 1 ), LDC, ZERO, DWORK, NP2 ) - CALL DLACPY( 'Full', NP2, N, DWORK, NP2, C( NP1+1, 1 ), LDC ) -C - LWAMAX = MAX( N*MAX( M2, NP2 ), LWAMAX ) - DWORK( 1 ) = DBLE( LWAMAX ) - RETURN -C *** Last line of SB10PD *** - END diff --git a/mex/sources/libslicot/SB10QD.f b/mex/sources/libslicot/SB10QD.f deleted file mode 100644 index 6b64f8396..000000000 --- a/mex/sources/libslicot/SB10QD.f +++ /dev/null @@ -1,602 +0,0 @@ - SUBROUTINE SB10QD( N, M, NP, NCON, NMEAS, GAMMA, A, LDA, B, LDB, - $ C, LDC, D, LDD, F, LDF, H, LDH, X, LDX, Y, LDY, - $ XYCOND, IWORK, DWORK, LDWORK, BWORK, INFO ) -C -C SLICOT RELEASE 5.0. -C -C Copyright (c) 2002-2009 NICONET e.V. -C -C This program is free software: you can redistribute it and/or -C modify it under the terms of the GNU General Public License as -C published by the Free Software Foundation, either version 2 of -C the License, or (at your option) any later version. -C -C This program is distributed in the hope that it will be useful, -C but WITHOUT ANY WARRANTY; without even the implied warranty of -C MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the -C GNU General Public License for more details. -C -C You should have received a copy of the GNU General Public License -C along with this program. If not, see -C . -C -C PURPOSE -C -C To compute the state feedback and the output injection -C matrices for an H-infinity (sub)optimal n-state controller, -C using Glover's and Doyle's 1988 formulas, for the system -C -C | A | B1 B2 | | A | B | -C P = |----|---------| = |---|---| -C | C1 | D11 D12 | | C | D | -C | C2 | D21 D22 | -C -C and for a given value of gamma, where B2 has as column size the -C number of control inputs (NCON) and C2 has as row size the number -C of measurements (NMEAS) being provided to the controller. -C -C It is assumed that -C -C (A1) (A,B2) is stabilizable and (C2,A) is detectable, -C -C (A2) D12 is full column rank with D12 = | 0 | and D21 is -C | I | -C full row rank with D21 = | 0 I | as obtained by the -C subroutine SB10PD, -C -C (A3) | A-j*omega*I B2 | has full column rank for all omega, -C | C1 D12 | -C -C -C (A4) | A-j*omega*I B1 | has full row rank for all omega. -C | C2 D21 | -C -C -C ARGUMENTS -C -C Input/Output Parameters -C -C N (input) INTEGER -C The order of the system. N >= 0. -C -C M (input) INTEGER -C The column size of the matrix B. M >= 0. -C -C NP (input) INTEGER -C The row size of the matrix C. NP >= 0. -C -C NCON (input) INTEGER -C The number of control inputs (M2). M >= NCON >= 0, -C NP-NMEAS >= NCON. -C -C NMEAS (input) INTEGER -C The number of measurements (NP2). NP >= NMEAS >= 0, -C M-NCON >= NMEAS. -C -C GAMMA (input) DOUBLE PRECISION -C The value of gamma. It is assumed that gamma is -C sufficiently large so that the controller is admissible. -C GAMMA >= 0. -C -C A (input) DOUBLE PRECISION array, dimension (LDA,N) -C The leading N-by-N part of this array must contain the -C system state matrix A. -C -C LDA INTEGER -C The leading dimension of the array A. LDA >= max(1,N). -C -C B (input) DOUBLE PRECISION array, dimension (LDB,M) -C The leading N-by-M part of this array must contain the -C system input matrix B. -C -C LDB INTEGER -C The leading dimension of the array B. LDB >= max(1,N). -C -C C (input) DOUBLE PRECISION array, dimension (LDC,N) -C The leading NP-by-N part of this array must contain the -C system output matrix C. -C -C LDC INTEGER -C The leading dimension of the array C. LDC >= max(1,NP). -C -C D (input) DOUBLE PRECISION array, dimension (LDD,M) -C The leading NP-by-M part of this array must contain the -C system input/output matrix D. -C -C LDD INTEGER -C The leading dimension of the array D. LDD >= max(1,NP). -C -C F (output) DOUBLE PRECISION array, dimension (LDF,N) -C The leading M-by-N part of this array contains the state -C feedback matrix F. -C -C LDF INTEGER -C The leading dimension of the array F. LDF >= max(1,M). -C -C H (output) DOUBLE PRECISION array, dimension (LDH,NP) -C The leading N-by-NP part of this array contains the output -C injection matrix H. -C -C LDH INTEGER -C The leading dimension of the array H. LDH >= max(1,N). -C -C X (output) DOUBLE PRECISION array, dimension (LDX,N) -C The leading N-by-N part of this array contains the matrix -C X, solution of the X-Riccati equation. -C -C LDX INTEGER -C The leading dimension of the array X. LDX >= max(1,N). -C -C Y (output) DOUBLE PRECISION array, dimension (LDY,N) -C The leading N-by-N part of this array contains the matrix -C Y, solution of the Y-Riccati equation. -C -C LDY INTEGER -C The leading dimension of the array Y. LDY >= max(1,N). -C -C XYCOND (output) DOUBLE PRECISION array, dimension (2) -C XYCOND(1) contains an estimate of the reciprocal condition -C number of the X-Riccati equation; -C XYCOND(2) contains an estimate of the reciprocal condition -C number of the Y-Riccati equation. -C -C Workspace -C -C IWORK INTEGER array, dimension max(2*max(N,M-NCON,NP-NMEAS),N*N) -C -C DWORK DOUBLE PRECISION array, dimension (LDWORK) -C On exit, if INFO = 0, DWORK(1) contains the optimal -C LDWORK. -C -C LDWORK INTEGER -C The dimension of the array DWORK. -C LDWORK >= max(1,M*M + max(2*M1,3*N*N + -C max(N*M,10*N*N+12*N+5)), -C NP*NP + max(2*NP1,3*N*N + -C max(N*NP,10*N*N+12*N+5))), -C where M1 = M - M2 and NP1 = NP - NP2. -C For good performance, LDWORK must generally be larger. -C Denoting Q = MAX(M1,M2,NP1,NP2), an upper bound is -C max(1,4*Q*Q+max(2*Q,3*N*N + max(2*N*Q,10*N*N+12*N+5))). -C -C BWORK LOGICAL array, dimension (2*N) -C -C Error Indicator -C -C INFO INTEGER -C = 0: successful exit; -C < 0: if INFO = -i, the i-th argument had an illegal -C value; -C = 1: if the controller is not admissible (too small value -C of gamma); -C = 2: if the X-Riccati equation was not solved -C successfully (the controller is not admissible or -C there are numerical difficulties); -C = 3: if the Y-Riccati equation was not solved -C successfully (the controller is not admissible or -C there are numerical difficulties). -C -C METHOD -C -C The routine implements the Glover's and Doyle's formulas [1],[2] -C modified as described in [3]. The X- and Y-Riccati equations -C are solved with condition and accuracy estimates [4]. -C -C REFERENCES -C -C [1] Glover, K. and Doyle, J.C. -C State-space formulae for all stabilizing controllers that -C satisfy an Hinf norm bound and relations to risk sensitivity. -C Systems and Control Letters, vol. 11, pp. 167-172, 1988. -C -C [2] Balas, G.J., Doyle, J.C., Glover, K., Packard, A., and -C Smith, R. -C mu-Analysis and Synthesis Toolbox. -C The MathWorks Inc., Natick, Mass., 1995. -C -C [3] Petkov, P.Hr., Gu, D.W., and Konstantinov, M.M. -C Fortran 77 routines for Hinf and H2 design of continuous-time -C linear control systems. -C Rep. 98-14, Department of Engineering, Leicester University, -C Leicester, U.K., 1998. -C -C [4] Petkov, P.Hr., Konstantinov, M.M., and Mehrmann, V. -C DGRSVX and DMSRIC: Fortan 77 subroutines for solving -C continuous-time matrix algebraic Riccati equations with -C condition and accuracy estimates. -C Preprint SFB393/98-16, Fak. f. Mathematik, Tech. Univ. -C Chemnitz, May 1998. -C -C NUMERICAL ASPECTS -C -C The precision of the solution of the matrix Riccati equations -C can be controlled by the values of the condition numbers -C XYCOND(1) and XYCOND(2) of these equations. -C -C FURTHER COMMENTS -C -C The Riccati equations are solved by the Schur approach -C implementing condition and accuracy estimates. -C -C CONTRIBUTORS -C -C P.Hr. Petkov, D.W. Gu and M.M. Konstantinov, October 1998. -C -C REVISIONS -C -C V. Sima, Research Institute for Informatics, Bucharest, May 1999, -C Sept. 1999. -C -C KEYWORDS -C -C Algebraic Riccati equation, H-infinity optimal control, robust -C control. -C -C ****************************************************************** -C -C .. Parameters .. - DOUBLE PRECISION ZERO, ONE - PARAMETER ( ZERO = 0.0D+0, ONE = 1.0D+0 ) -C -C .. Scalar Arguments .. - INTEGER INFO, LDA, LDB, LDC, LDD, LDF, LDH, LDWORK, - $ LDX, LDY, M, N, NCON, NMEAS, NP - DOUBLE PRECISION GAMMA -C .. -C .. Array Arguments .. - INTEGER IWORK( * ) - DOUBLE PRECISION A( LDA, * ), B( LDB, * ), C( LDC, * ), - $ D( LDD, * ), DWORK( * ), F( LDF, * ), - $ H( LDH, * ), X( LDX, * ), XYCOND( 2 ), - $ Y( LDY, * ) - LOGICAL BWORK( * ) -C -C .. -C .. Local Scalars .. - INTEGER INFO2, IW2, IWA, IWG, IWI, IWQ, IWR, IWRK, IWS, - $ IWT, IWV, LWAMAX, M1, M2, MINWRK, N2, ND1, ND2, - $ NN, NP1, NP2 - DOUBLE PRECISION ANORM, EPS, FERR, RCOND, SEP -C .. -C .. External Functions .. -C - DOUBLE PRECISION DLAMCH, DLANSY - EXTERNAL DLAMCH, DLANSY -C .. -C .. External Subroutines .. - EXTERNAL DGEMM, DLACPY, DLASET, DSYCON, DSYMM, DSYRK, - $ DSYTRF, DSYTRI, MB01RU, MB01RX, SB02RD, XERBLA -C .. -C .. Intrinsic Functions .. - INTRINSIC DBLE, INT, MAX -C .. -C .. Executable Statements .. -C -C Decode and Test input parameters. -C - M1 = M - NCON - M2 = NCON - NP1 = NP - NMEAS - NP2 = NMEAS - NN = N*N -C - INFO = 0 - IF( N.LT.0 ) THEN - INFO = -1 - ELSE IF( M.LT.0 ) THEN - INFO = -2 - ELSE IF( NP.LT.0 ) THEN - INFO = -3 - ELSE IF( NCON.LT.0 .OR. M1.LT.0 .OR. M2.GT.NP1 ) THEN - INFO = -4 - ELSE IF( NMEAS.LT.0 .OR. NP1.LT.0 .OR. NP2.GT.M1 ) THEN - INFO = -5 - ELSE IF( GAMMA.LT.ZERO ) THEN - INFO = -6 - ELSE IF( LDA.LT.MAX( 1, N ) ) THEN - INFO = -8 - ELSE IF( LDB.LT.MAX( 1, N ) ) THEN - INFO = -10 - ELSE IF( LDC.LT.MAX( 1, NP ) ) THEN - INFO = -12 - ELSE IF( LDD.LT.MAX( 1, NP ) ) THEN - INFO = -14 - ELSE IF( LDF.LT.MAX( 1, M ) ) THEN - INFO = -16 - ELSE IF( LDH.LT.MAX( 1, N ) ) THEN - INFO = -18 - ELSE IF( LDX.LT.MAX( 1, N ) ) THEN - INFO = -20 - ELSE IF( LDY.LT.MAX( 1, N ) ) THEN - INFO = -22 - ELSE -C -C Compute workspace. -C - MINWRK = MAX( 1, M*M + MAX( 2*M1, 3*NN + - $ MAX( N*M, 10*NN + 12*N + 5 ) ), - $ NP*NP + MAX( 2*NP1, 3*NN + - $ MAX( N*NP, 10*NN + 12*N + 5 ) ) ) - IF( LDWORK.LT.MINWRK ) - $ INFO = -26 - END IF - IF( INFO.NE.0 ) THEN - CALL XERBLA( 'SB10QD', -INFO ) - RETURN - END IF -C -C Quick return if possible. -C - IF( N.EQ.0 .OR. M.EQ.0 .OR. NP.EQ.0 .OR. M1.EQ.0 .OR. M2.EQ.0 - $ .OR. NP1.EQ.0 .OR. NP2.EQ.0 ) THEN - XYCOND( 1 ) = ONE - XYCOND( 2 ) = ONE - DWORK( 1 ) = ONE - RETURN - END IF - ND1 = NP1 - M2 - ND2 = M1 - NP2 - N2 = 2*N -C -C Get the machine precision. -C - EPS = DLAMCH( 'Epsilon' ) -C -C Workspace usage. -C - IWA = M*M + 1 - IWQ = IWA + NN - IWG = IWQ + NN - IW2 = IWG + NN -C -C Compute |D1111'||D1111 D1112| - gamma^2*Im1 . -C |D1112'| -C - CALL DLASET( 'L', M1, M1, ZERO, -GAMMA*GAMMA, DWORK, M ) - IF( ND1.GT.0 ) - $ CALL DSYRK( 'L', 'T', M1, ND1, ONE, D, LDD, ONE, DWORK, M ) -C -C Compute inv(|D1111'|*|D1111 D1112| - gamma^2*Im1) . -C |D1112'| -C - IWRK = IWA - ANORM = DLANSY( 'I', 'L', M1, DWORK, M, DWORK( IWRK ) ) - CALL DSYTRF( 'L', M1, DWORK, M, IWORK, DWORK( IWRK ), - $ LDWORK-IWRK+1, INFO2 ) - IF( INFO2.GT.0 ) THEN - INFO = 1 - RETURN - END IF -C - LWAMAX = INT( DWORK( IWRK ) ) + IWRK - 1 - CALL DSYCON( 'L', M1, DWORK, M, IWORK, ANORM, RCOND, - $ DWORK( IWRK ), IWORK( M1+1 ), INFO2 ) - IF( RCOND.LT.EPS ) THEN - INFO = 1 - RETURN - END IF -C -C Compute inv(R) block by block. -C - CALL DSYTRI( 'L', M1, DWORK, M, IWORK, DWORK( IWRK ), INFO2 ) -C -C Compute -|D1121 D1122|*inv(|D1111'|*|D1111 D1112| - gamma^2*Im1) . -C |D1112'| -C - CALL DSYMM( 'R', 'L', M2, M1, -ONE, DWORK, M, D( ND1+1, 1 ), LDD, - $ ZERO, DWORK( M1+1 ), M ) -C -C Compute |D1121 D1122|*inv(|D1111'|*|D1111 D1112| - -C |D1112'| -C -C gamma^2*Im1)*|D1121'| + Im2 . -C |D1122'| -C - CALL DLASET( 'Lower', M2, M2, ZERO, ONE, DWORK( M1*(M+1)+1 ), M ) - CALL MB01RX( 'Right', 'Lower', 'Transpose', M2, M1, ONE, -ONE, - $ DWORK( M1*(M+1)+1 ), M, D( ND1+1, 1 ), LDD, - $ DWORK( M1+1 ), M, INFO2 ) -C -C Compute D11'*C1 . -C - CALL DGEMM( 'T', 'N', M1, N, NP1, ONE, D, LDD, C, LDC, ZERO, - $ DWORK( IW2 ), M ) -C -C Compute D1D'*C1 . -C - CALL DLACPY( 'Full', M2, N, C( ND1+1, 1 ), LDC, DWORK( IW2+M1 ), - $ M ) -C -C Compute inv(R)*D1D'*C1 in F . -C - CALL DSYMM( 'L', 'L', M, N, ONE, DWORK, M, DWORK( IW2 ), M, ZERO, - $ F, LDF ) -C -C Compute Ax = A - B*inv(R)*D1D'*C1 . -C - CALL DLACPY( 'Full', N, N, A, LDA, DWORK( IWA ), N ) - CALL DGEMM( 'N', 'N', N, N, M, -ONE, B, LDB, F, LDF, ONE, - $ DWORK( IWA ), N ) -C -C Compute Cx = C1'*C1 - C1'*D1D*inv(R)*D1D'*C1 . -C - IF( ND1.EQ.0 ) THEN - CALL DLASET( 'L', N, N, ZERO, ZERO, DWORK( IWQ ), N ) - ELSE - CALL DSYRK( 'L', 'T', N, NP1, ONE, C, LDC, ZERO, - $ DWORK( IWQ ), N ) - CALL MB01RX( 'Left', 'Lower', 'Transpose', N, M, ONE, -ONE, - $ DWORK( IWQ ), N, DWORK( IW2 ), M, F, LDF, INFO2 ) - END IF -C -C Compute Dx = B*inv(R)*B' . -C - IWRK = IW2 - CALL MB01RU( 'Lower', 'NoTranspose', N, M, ZERO, ONE, - $ DWORK( IWG ), N, B, LDB, DWORK, M, DWORK( IWRK ), - $ M*N, INFO2 ) -C -C Solution of the Riccati equation Ax'*X + X*Ax + Cx - X*Dx*X = 0 . -C Workspace: need M*M + 13*N*N + 12*N + 5; -C prefer larger. -C - IWT = IW2 - IWV = IWT + NN - IWR = IWV + NN - IWI = IWR + N2 - IWS = IWI + N2 - IWRK = IWS + 4*NN -C - CALL SB02RD( 'All', 'Continuous', 'NotUsed', 'NoTranspose', - $ 'Lower', 'GeneralScaling', 'Stable', 'NotFactored', - $ 'Original', N, DWORK( IWA ), N, DWORK( IWT ), N, - $ DWORK( IWV ), N, DWORK( IWG ), N, DWORK( IWQ ), N, - $ X, LDX, SEP, XYCOND( 1 ), FERR, DWORK( IWR ), - $ DWORK( IWI ), DWORK( IWS ), N2, IWORK, DWORK( IWRK ), - $ LDWORK-IWRK+1, BWORK, INFO2 ) - IF( INFO2.GT.0 ) THEN - INFO = 2 - RETURN - END IF -C - LWAMAX = MAX( INT( DWORK( IWRK ) ) + IWRK - 1, LWAMAX ) -C -C Compute F = -inv(R)*|D1D'*C1 + B'*X| . -C - IWRK = IW2 - CALL DGEMM( 'T', 'N', M, N, N, ONE, B, LDB, X, LDX, ZERO, - $ DWORK( IWRK ), M ) - CALL DSYMM( 'L', 'L', M, N, -ONE, DWORK, M, DWORK( IWRK ), M, - $ -ONE, F, LDF ) -C -C Workspace usage. -C - IWA = NP*NP + 1 - IWQ = IWA + NN - IWG = IWQ + NN - IW2 = IWG + NN -C -C Compute |D1111|*|D1111' D1121'| - gamma^2*Inp1 . -C |D1121| -C - CALL DLASET( 'U', NP1, NP1, ZERO, -GAMMA*GAMMA, DWORK, NP ) - IF( ND2.GT.0 ) - $ CALL DSYRK( 'U', 'N', NP1, ND2, ONE, D, LDD, ONE, DWORK, NP ) -C -C Compute inv(|D1111|*|D1111' D1121'| - gamma^2*Inp1) . -C |D1121| -C - IWRK = IWA - ANORM = DLANSY( 'I', 'U', NP1, DWORK, NP, DWORK( IWRK ) ) - CALL DSYTRF( 'U', NP1, DWORK, NP, IWORK, DWORK( IWRK ), - $ LDWORK-IWRK+1, INFO2 ) - IF( INFO2.GT.0 ) THEN - INFO = 1 - RETURN - END IF -C - LWAMAX = MAX( INT( DWORK( IWRK ) ) + IWRK - 1, LWAMAX ) - CALL DSYCON( 'U', NP1, DWORK, NP, IWORK, ANORM, RCOND, - $ DWORK( IWRK ), IWORK( NP1+1 ), INFO2 ) - IF( RCOND.LT.EPS ) THEN - INFO = 1 - RETURN - END IF -C -C Compute inv(RT) . -C - CALL DSYTRI( 'U', NP1, DWORK, NP, IWORK, DWORK( IWRK ), INFO2 ) -C -C Compute -inv(|D1111||D1111' D1121'| - gamma^2*Inp1)*|D1112| . -C |D1121| |D1122| -C - CALL DSYMM( 'L', 'U', NP1, NP2, -ONE, DWORK, NP, D( 1, ND2+1 ), - $ LDD, ZERO, DWORK( NP1*NP+1 ), NP ) -C -C Compute [D1112' D1122']*inv(|D1111||D1111' D1121'| - -C |D1121| -C -C gamma^2*Inp1)*|D1112| + Inp2 . -C |D1122| -C - CALL DLASET( 'Full', NP2, NP2, ZERO, ONE, DWORK( NP1*(NP+1)+1 ), - $ NP ) - CALL MB01RX( 'Left', 'Upper', 'Transpose', NP2, NP1, ONE, -ONE, - $ DWORK( NP1*(NP+1)+1 ), NP, D( 1, ND2+1 ), LDD, - $ DWORK( NP1*NP+1 ), NP, INFO2 ) -C -C Compute B1*D11' . -C - CALL DGEMM( 'N', 'T', N, NP1, M1, ONE, B, LDB, D, LDD, ZERO, - $ DWORK( IW2 ), N ) -C -C Compute B1*DD1' . -C - CALL DLACPY( 'Full', N, NP2, B( 1, ND2+1 ), LDB, - $ DWORK( IW2+NP1*N ), N ) -C -C Compute B1*DD1'*inv(RT) in H . -C - CALL DSYMM( 'R', 'U', N, NP, ONE, DWORK, NP, DWORK( IW2 ), N, - $ ZERO, H, LDH ) -C -C Compute Ay = A - B1*DD1'*inv(RT)*C . -C - CALL DLACPY( 'Full', N, N, A, LDA, DWORK( IWA ), N ) - CALL DGEMM( 'N', 'N', N, N, NP, -ONE, H, LDH, C, LDC, ONE, - $ DWORK( IWA ), N ) -C -C Compute Cy = B1*B1' - B1*DD1'*inv(RT)*DD1*B1' . -C - IF( ND2.EQ.0 ) THEN - CALL DLASET( 'U', N, N, ZERO, ZERO, DWORK( IWQ ), N ) - ELSE - CALL DSYRK( 'U', 'N', N, M1, ONE, B, LDB, ZERO, DWORK( IWQ ), - $ N ) - CALL MB01RX( 'Right', 'Upper', 'Transpose', N, NP, ONE, -ONE, - $ DWORK( IWQ ), N, H, LDH, DWORK( IW2 ), N, INFO2 ) - END IF -C -C Compute Dy = C'*inv(RT)*C . -C - IWRK = IW2 - CALL MB01RU( 'Upper', 'Transpose', N, NP, ZERO, ONE, DWORK( IWG ), - $ N, C, LDC, DWORK, NP, DWORK( IWRK), N*NP, INFO2 ) -C -C Solution of the Riccati equation Ay*Y + Y*Ay' + Cy - Y*Dy*Y = 0 . -C Workspace: need NP*NP + 13*N*N + 12*N + 5; -C prefer larger. -C - IWT = IW2 - IWV = IWT + NN - IWR = IWV + NN - IWI = IWR + N2 - IWS = IWI + N2 - IWRK = IWS + 4*NN -C - CALL SB02RD( 'All', 'Continuous', 'NotUsed', 'Transpose', - $ 'Upper', 'GeneralScaling', 'Stable', 'NotFactored', - $ 'Original', N, DWORK( IWA ), N, DWORK( IWT ), N, - $ DWORK( IWV ), N, DWORK( IWG ), N, DWORK( IWQ ), N, - $ Y, LDY, SEP, XYCOND( 2 ), FERR, DWORK( IWR ), - $ DWORK( IWI ), DWORK( IWS ), N2, IWORK, DWORK( IWRK ), - $ LDWORK-IWRK+1, BWORK, INFO2 ) - IF( INFO2.GT.0 ) THEN - INFO = 3 - RETURN - END IF -C - LWAMAX = MAX( INT( DWORK( IWRK ) ) + IWRK - 1, LWAMAX ) -C -C Compute H = -|B1*DD1' + Y*C'|*inv(RT) . -C - IWRK = IW2 - CALL DGEMM( 'N', 'T', N, NP, N, ONE, Y, LDY, C, LDC, ZERO, - $ DWORK( IWRK ), N ) - CALL DSYMM( 'R', 'U', N, NP, -ONE, DWORK, NP, DWORK( IWRK ), N, - $ -ONE, H, LDH ) -C - DWORK( 1 ) = DBLE( LWAMAX ) - RETURN -C *** Last line of SB10QD *** - END diff --git a/mex/sources/libslicot/SB10RD.f b/mex/sources/libslicot/SB10RD.f deleted file mode 100644 index 86d483bb3..000000000 --- a/mex/sources/libslicot/SB10RD.f +++ /dev/null @@ -1,706 +0,0 @@ - SUBROUTINE SB10RD( N, M, NP, NCON, NMEAS, GAMMA, A, LDA, B, LDB, - $ C, LDC, D, LDD, F, LDF, H, LDH, TU, LDTU, TY, - $ LDTY, X, LDX, Y, LDY, AK, LDAK, BK, LDBK, CK, - $ LDCK, DK, LDDK, IWORK, DWORK, LDWORK, INFO ) -C -C SLICOT RELEASE 5.0. -C -C Copyright (c) 2002-2009 NICONET e.V. -C -C This program is free software: you can redistribute it and/or -C modify it under the terms of the GNU General Public License as -C published by the Free Software Foundation, either version 2 of -C the License, or (at your option) any later version. -C -C This program is distributed in the hope that it will be useful, -C but WITHOUT ANY WARRANTY; without even the implied warranty of -C MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the -C GNU General Public License for more details. -C -C You should have received a copy of the GNU General Public License -C along with this program. If not, see -C . -C -C PURPOSE -C -C To compute the matrices of an H-infinity (sub)optimal controller -C -C | AK | BK | -C K = |----|----|, -C | CK | DK | -C -C from the state feedback matrix F and output injection matrix H as -C determined by the SLICOT Library routine SB10QD. -C -C ARGUMENTS -C -C Input/Output Parameters -C -C N (input) INTEGER -C The order of the system. N >= 0. -C -C M (input) INTEGER -C The column size of the matrix B. M >= 0. -C -C NP (input) INTEGER -C The row size of the matrix C. NP >= 0. -C -C NCON (input) INTEGER -C The number of control inputs (M2). M >= NCON >= 0. -C NP-NMEAS >= NCON. -C -C NMEAS (input) INTEGER -C The number of measurements (NP2). NP >= NMEAS >= 0. -C M-NCON >= NMEAS. -C -C GAMMA (input) DOUBLE PRECISION -C The value of gamma. It is assumed that gamma is -C sufficiently large so that the controller is admissible. -C GAMMA >= 0. -C -C A (input) DOUBLE PRECISION array, dimension (LDA,N) -C The leading N-by-N part of this array must contain the -C system state matrix A. -C -C LDA INTEGER -C The leading dimension of the array A. LDA >= max(1,N). -C -C B (input) DOUBLE PRECISION array, dimension (LDB,M) -C The leading N-by-M part of this array must contain the -C system input matrix B. -C -C LDB INTEGER -C The leading dimension of the array B. LDB >= max(1,N). -C -C C (input) DOUBLE PRECISION array, dimension (LDC,N) -C The leading NP-by-N part of this array must contain the -C system output matrix C. -C -C LDC INTEGER -C The leading dimension of the array C. LDC >= max(1,NP). -C -C D (input) DOUBLE PRECISION array, dimension (LDD,M) -C The leading NP-by-M part of this array must contain the -C system input/output matrix D. -C -C LDD INTEGER -C The leading dimension of the array D. LDD >= max(1,NP). -C -C F (input) DOUBLE PRECISION array, dimension (LDF,N) -C The leading M-by-N part of this array must contain the -C state feedback matrix F. -C -C LDF INTEGER -C The leading dimension of the array F. LDF >= max(1,M). -C -C H (input) DOUBLE PRECISION array, dimension (LDH,NP) -C The leading N-by-NP part of this array must contain the -C output injection matrix H. -C -C LDH INTEGER -C The leading dimension of the array H. LDH >= max(1,N). -C -C TU (input) DOUBLE PRECISION array, dimension (LDTU,M2) -C The leading M2-by-M2 part of this array must contain the -C control transformation matrix TU, as obtained by the -C SLICOT Library routine SB10PD. -C -C LDTU INTEGER -C The leading dimension of the array TU. LDTU >= max(1,M2). -C -C TY (input) DOUBLE PRECISION array, dimension (LDTY,NP2) -C The leading NP2-by-NP2 part of this array must contain the -C measurement transformation matrix TY, as obtained by the -C SLICOT Library routine SB10PD. -C -C LDTY INTEGER -C The leading dimension of the array TY. -C LDTY >= max(1,NP2). -C -C X (input) DOUBLE PRECISION array, dimension (LDX,N) -C The leading N-by-N part of this array must contain the -C matrix X, solution of the X-Riccati equation, as obtained -C by the SLICOT Library routine SB10QD. -C -C LDX INTEGER -C The leading dimension of the array X. LDX >= max(1,N). -C -C Y (input) DOUBLE PRECISION array, dimension (LDY,N) -C The leading N-by-N part of this array must contain the -C matrix Y, solution of the Y-Riccati equation, as obtained -C by the SLICOT Library routine SB10QD. -C -C LDY INTEGER -C The leading dimension of the array Y. LDY >= max(1,N). -C -C AK (output) DOUBLE PRECISION array, dimension (LDAK,N) -C The leading N-by-N part of this array contains the -C controller state matrix AK. -C -C LDAK INTEGER -C The leading dimension of the array AK. LDAK >= max(1,N). -C -C BK (output) DOUBLE PRECISION array, dimension (LDBK,NMEAS) -C The leading N-by-NMEAS part of this array contains the -C controller input matrix BK. -C -C LDBK INTEGER -C The leading dimension of the array BK. LDBK >= max(1,N). -C -C CK (output) DOUBLE PRECISION array, dimension (LDCK,N) -C The leading NCON-by-N part of this array contains the -C controller output matrix CK. -C -C LDCK INTEGER -C The leading dimension of the array CK. -C LDCK >= max(1,NCON). -C -C DK (output) DOUBLE PRECISION array, dimension (LDDK,NMEAS) -C The leading NCON-by-NMEAS part of this array contains the -C controller input/output matrix DK. -C -C LDDK INTEGER -C The leading dimension of the array DK. -C LDDK >= max(1,NCON). -C -C Workspace -C -C IWORK INTEGER array, dimension (LIWORK), where -C LIWORK = max(2*(max(NP,M)-M2-NP2,M2,N),NP2) -C -C DWORK DOUBLE PRECISION array, dimension (LDWORK) -C On exit, if INFO = 0, DWORK(1) contains the optimal -C LDWORK. -C -C LDWORK INTEGER -C The dimension of the array DWORK. -C LDWORK >= max(1, M2*NP2 + NP2*NP2 + M2*M2 + -C max(D1*D1 + max(2*D1, (D1+D2)*NP2), -C D2*D2 + max(2*D2, D2*M2), 3*N, -C N*(2*NP2 + M2) + -C max(2*N*M2, M2*NP2 + -C max(M2*M2+3*M2, NP2*(2*NP2+ -C M2+max(NP2,N)))))) -C where D1 = NP1 - M2, D2 = M1 - NP2, -C NP1 = NP - NP2, M1 = M - M2. -C For good performance, LDWORK must generally be larger. -C Denoting Q = max(M1,M2,NP1,NP2), an upper bound is -C max( 1, Q*(3*Q + 3*N + max(2*N, 4*Q + max(Q, N)))). -C -C Error Indicator -C -C INFO INTEGER -C = 0: successful exit; -C < 0: if INFO = -i, the i-th argument had an illegal -C value; -C = 1: if the controller is not admissible (too small value -C of gamma); -C = 2: if the determinant of Im2 + Tu*D11HAT*Ty*D22 is zero. -C -C METHOD -C -C The routine implements the Glover's and Doyle's formulas [1],[2]. -C -C REFERENCES -C -C [1] Glover, K. and Doyle, J.C. -C State-space formulae for all stabilizing controllers that -C satisfy an Hinf norm bound and relations to risk sensitivity. -C Systems and Control Letters, vol. 11, pp. 167-172, 1988. -C -C [2] Balas, G.J., Doyle, J.C., Glover, K., Packard, A., and -C Smith, R. -C mu-Analysis and Synthesis Toolbox. -C The MathWorks Inc., Natick, Mass., 1995. -C -C NUMERICAL ASPECTS -C -C The accuracy of the result depends on the condition numbers of the -C input and output transformations. -C -C CONTRIBUTORS -C -C P.Hr. Petkov, D.W. Gu and M.M. Konstantinov, October 1998. -C -C REVISIONS -C -C V. Sima, Research Institute for Informatics, Bucharest, May 1999, -C Sept. 1999, Oct. 2001. -C -C KEYWORDS -C -C Algebraic Riccati equation, H-infinity optimal control, robust -C control. -C -C ********************************************************************* -C -C .. Parameters .. - DOUBLE PRECISION ZERO, ONE - PARAMETER ( ZERO = 0.0D+0, ONE = 1.0D+0 ) -C .. -C .. Scalar Arguments .. - INTEGER INFO, LDA, LDAK, LDB, LDBK, LDC, LDCK, LDD, - $ LDDK, LDF, LDH, LDTU, LDTY, LDWORK, LDX, LDY, - $ M, N, NCON, NMEAS, NP - DOUBLE PRECISION GAMMA -C .. -C .. Array Arguments .. - INTEGER IWORK( * ) - DOUBLE PRECISION A( LDA, * ), AK( LDAK, * ), B( LDB, * ), - $ BK( LDBK, * ), C( LDC, * ), CK( LDCK, * ), - $ D( LDD, * ), DK( LDDK, * ), DWORK( * ), - $ F( LDF, * ), H( LDH, * ), TU( LDTU, * ), - $ TY( LDTY, * ), X( LDX, * ), Y( LDY, * ) -C .. -C .. Local Scalars .. - INTEGER I, ID11, ID12, ID21, IJ, INFO2, IW1, IW2, IW3, - $ IW4, IWB, IWC, IWRK, J, LWAMAX, M1, M2, MINWRK, - $ ND1, ND2, NP1, NP2 - DOUBLE PRECISION ANORM, EPS, RCOND -C .. -C .. External Functions .. - DOUBLE PRECISION DLAMCH, DLANGE, DLANSY - EXTERNAL DLAMCH, DLANGE, DLANSY -C .. -C .. External Subroutines .. - EXTERNAL DGECON, DGEMM, DGETRF, DGETRI, DGETRS, DLACPY, - $ DLASET, DPOTRF, DSYCON, DSYRK, DSYTRF, DSYTRS, - $ DTRMM, MA02AD, MB01RX, XERBLA -C .. -C .. Intrinsic Functions .. - INTRINSIC DBLE, INT, MAX -C .. -C .. Executable Statements .. -C -C Decode and Test input parameters. -C - M1 = M - NCON - M2 = NCON - NP1 = NP - NMEAS - NP2 = NMEAS -C - INFO = 0 - IF( N.LT.0 ) THEN - INFO = -1 - ELSE IF( M.LT.0 ) THEN - INFO = -2 - ELSE IF( NP.LT.0 ) THEN - INFO = -3 - ELSE IF( NCON.LT.0 .OR. M1.LT.0 .OR. M2.GT.NP1 ) THEN - INFO = -4 - ELSE IF( NMEAS.LT.0 .OR. NP1.LT.0 .OR. NP2.GT.M1 ) THEN - INFO = -5 - ELSE IF( GAMMA.LT.ZERO ) THEN - INFO = -6 - ELSE IF( LDA.LT.MAX( 1, N ) ) THEN - INFO = -8 - ELSE IF( LDB.LT.MAX( 1, N ) ) THEN - INFO = -10 - ELSE IF( LDC.LT.MAX( 1, NP ) ) THEN - INFO = -12 - ELSE IF( LDD.LT.MAX( 1, NP ) ) THEN - INFO = -14 - ELSE IF( LDF.LT.MAX( 1, M ) ) THEN - INFO = -16 - ELSE IF( LDH.LT.MAX( 1, N ) ) THEN - INFO = -18 - ELSE IF( LDTU.LT.MAX( 1, M2 ) ) THEN - INFO = -20 - ELSE IF( LDTY.LT.MAX( 1, NP2 ) ) THEN - INFO = -22 - ELSE IF( LDX.LT.MAX( 1, N ) ) THEN - INFO = -24 - ELSE IF( LDY.LT.MAX( 1, N ) ) THEN - INFO = -26 - ELSE IF( LDAK.LT.MAX( 1, N ) ) THEN - INFO = -28 - ELSE IF( LDBK.LT.MAX( 1, N ) ) THEN - INFO = -30 - ELSE IF( LDCK.LT.MAX( 1, M2 ) ) THEN - INFO = -32 - ELSE IF( LDDK.LT.MAX( 1, M2 ) ) THEN - INFO = -34 - ELSE -C -C Compute workspace. -C - ND1 = NP1 - M2 - ND2 = M1 - NP2 - MINWRK = MAX( 1, M2*NP2 + NP2*NP2 + M2*M2 + - $ MAX( ND1*ND1 + MAX( 2*ND1, ( ND1 + ND2 )*NP2 ), - $ ND2*ND2 + MAX( 2*ND2, ND2*M2 ), 3*N, - $ N*( 2*NP2 + M2 ) + - $ MAX( 2*N*M2, M2*NP2 + - $ MAX( M2*M2 + 3*M2, NP2*( 2*NP2 + - $ M2 + MAX( NP2, N ) ) ) ) ) ) - IF( LDWORK.LT.MINWRK ) - $ INFO = -37 - END IF - IF( INFO.NE.0 ) THEN - CALL XERBLA( 'SB10RD', -INFO ) - RETURN - END IF -C -C Quick return if possible. -C - IF( N.EQ.0 .OR. M.EQ.0 .OR. NP.EQ.0 .OR. M1.EQ.0 .OR. M2.EQ.0 - $ .OR. NP1.EQ.0 .OR. NP2.EQ.0 ) THEN - DWORK( 1 ) = ONE - RETURN - END IF -C -C Get the machine precision. -C - EPS = DLAMCH( 'Epsilon' ) -C -C Workspace usage. -C - ID11 = 1 - ID21 = ID11 + M2*NP2 - ID12 = ID21 + NP2*NP2 - IW1 = ID12 + M2*M2 - IW2 = IW1 + ND1*ND1 - IW3 = IW2 + ND1*NP2 - IWRK = IW2 -C -C Set D11HAT := -D1122 . -C - IJ = ID11 - DO 20 J = 1, NP2 - DO 10 I = 1, M2 - DWORK( IJ ) = -D( ND1+I, ND2+J ) - IJ = IJ + 1 - 10 CONTINUE - 20 CONTINUE -C -C Set D21HAT := Inp2 . -C - CALL DLASET( 'Upper', NP2, NP2, ZERO, ONE, DWORK( ID21 ), NP2 ) -C -C Set D12HAT := Im2 . -C - CALL DLASET( 'Lower', M2, M2, ZERO, ONE, DWORK( ID12 ), M2 ) -C -C Compute D11HAT, D21HAT, D12HAT . -C - LWAMAX = 0 - IF( ND1.GT.0 ) THEN - IF( ND2.EQ.0 ) THEN -C -C Compute D21HAT'*D21HAT = Inp2 - D1112'*D1112/gamma^2 . -C - CALL DSYRK( 'U', 'T', NP2, ND1, -ONE/GAMMA**2, D, LDD, ONE, - $ DWORK( ID21 ), NP2 ) - ELSE -C -C Compute gdum = gamma^2*Ind1 - D1111*D1111' . -C - CALL DLASET( 'U', ND1, ND1, ZERO, GAMMA**2, DWORK( IW1 ), - $ ND1 ) - CALL DSYRK( 'U', 'N', ND1, ND2, -ONE, D, LDD, ONE, - $ DWORK( IW1 ), ND1 ) - ANORM = DLANSY( 'I', 'U', ND1, DWORK( IW1 ), ND1, - $ DWORK( IWRK ) ) - CALL DSYTRF( 'U', ND1, DWORK( IW1 ), ND1, IWORK, - $ DWORK( IWRK ), LDWORK-IWRK+1, INFO2 ) - IF( INFO2.GT.0 ) THEN - INFO = 1 - RETURN - END IF - LWAMAX = INT( DWORK( IWRK ) ) + IWRK - 1 - CALL DSYCON( 'U', ND1, DWORK( IW1 ), ND1, IWORK, ANORM, - $ RCOND, DWORK( IWRK ), IWORK( ND1+1 ), INFO2 ) -C -C Return if the matrix is singular to working precision. -C - IF( RCOND.LT.EPS ) THEN - INFO = 1 - RETURN - END IF -C -C Compute inv(gdum)*D1112 . -C - CALL DLACPY( 'Full', ND1, NP2, D( 1, ND2+1 ), LDD, - $ DWORK( IW2 ), ND1 ) - CALL DSYTRS( 'U', ND1, NP2, DWORK( IW1 ), ND1, IWORK, - $ DWORK( IW2 ), ND1, INFO2 ) -C -C Compute D11HAT = -D1121*D1111'*inv(gdum)*D1112 - D1122 . -C - CALL DGEMM( 'T', 'N', ND2, NP2, ND1, ONE, D, LDD, - $ DWORK( IW2 ), ND1, ZERO, DWORK( IW3 ), ND2 ) - CALL DGEMM( 'N', 'N', M2, NP2, ND2, -ONE, D( ND1+1, 1 ), - $ LDD, DWORK( IW3 ), ND2, ONE, DWORK( ID11 ), M2 ) -C -C Compute D21HAT'*D21HAT = Inp2 - D1112'*inv(gdum)*D1112 . -C - CALL MB01RX( 'Left', 'Upper', 'Transpose', NP2, ND1, ONE, - $ -ONE, DWORK( ID21 ), NP2, D( 1, ND2+1 ), LDD, - $ DWORK( IW2 ), ND1, INFO2 ) -C - IW2 = IW1 + ND2*ND2 - IWRK = IW2 -C -C Compute gdum = gamma^2*Ind2 - D1111'*D1111 . -C - CALL DLASET( 'L', ND2, ND2, ZERO, GAMMA**2, DWORK( IW1 ), - $ ND2 ) - CALL DSYRK( 'L', 'T', ND2, ND1, -ONE, D, LDD, ONE, - $ DWORK( IW1 ), ND2 ) - ANORM = DLANSY( 'I', 'L', ND2, DWORK( IW1 ), ND2, - $ DWORK( IWRK ) ) - CALL DSYTRF( 'L', ND2, DWORK( IW1 ), ND2, IWORK, - $ DWORK( IWRK ), LDWORK-IWRK+1, INFO2 ) - IF( INFO2.GT.0 ) THEN - INFO = 1 - RETURN - END IF - LWAMAX = MAX( INT( DWORK( IWRK ) ) + IWRK - 1, LWAMAX ) - CALL DSYCON( 'L', ND2, DWORK( IW1 ), ND2, IWORK, ANORM, - $ RCOND, DWORK( IWRK ), IWORK( ND2+1 ), INFO2 ) -C -C Return if the matrix is singular to working precision. -C - IF( RCOND.LT.EPS ) THEN - INFO = 1 - RETURN - END IF -C -C Compute inv(gdum)*D1121' . -C - CALL MA02AD( 'Full', M2, ND2, D( ND1+1, 1 ), LDD, - $ DWORK( IW2 ), ND2 ) - CALL DSYTRS( 'L', ND2, M2, DWORK( IW1 ), ND2, IWORK, - $ DWORK( IW2 ), ND2, INFO2 ) -C -C Compute D12HAT*D12HAT' = Im2 - D1121*inv(gdum)*D1121' . -C - CALL MB01RX( 'Left', 'Lower', 'NoTranspose', M2, ND2, ONE, - $ -ONE, DWORK( ID12 ), M2, D( ND1+1, 1 ), LDD, - $ DWORK( IW2 ), ND2, INFO2 ) - END IF - ELSE - IF( ND2.GT.0 ) THEN -C -C Compute D12HAT*D12HAT' = Im2 - D1121*D1121'/gamma^2 . -C - CALL DSYRK( 'L', 'N', M2, ND2, -ONE/GAMMA**2, D, LDD, ONE, - $ DWORK( ID12 ), M2 ) - END IF - END IF -C -C Compute D21HAT using Cholesky decomposition. -C - CALL DPOTRF( 'U', NP2, DWORK( ID21 ), NP2, INFO2 ) - IF( INFO2.GT.0 ) THEN - INFO = 1 - RETURN - END IF -C -C Compute D12HAT using Cholesky decomposition. -C - CALL DPOTRF( 'L', M2, DWORK( ID12 ), M2, INFO2 ) - IF( INFO2.GT.0 ) THEN - INFO = 1 - RETURN - END IF -C _ -C Compute Z = In - Y*X/gamma^2 and its LU factorization in AK . -C - IWRK = IW1 - CALL DLASET( 'Full', N, N, ZERO, ONE, AK, LDAK ) - CALL DGEMM( 'N', 'N', N, N, N, -ONE/GAMMA**2, Y, LDY, X, LDX, - $ ONE, AK, LDAK ) - ANORM = DLANGE( '1', N, N, AK, LDAK, DWORK( IWRK ) ) - CALL DGETRF( N, N, AK, LDAK, IWORK, INFO2 ) - IF( INFO2.GT.0 ) THEN - INFO = 1 - RETURN - END IF - CALL DGECON( '1', N, AK, LDAK, ANORM, RCOND, DWORK( IWRK ), - $ IWORK( N+1 ), INFO ) -C -C Return if the matrix is singular to working precision. -C - IF( RCOND.LT.EPS ) THEN - INFO = 1 - RETURN - END IF -C - IWB = IW1 - IWC = IWB + N*NP2 - IW1 = IWC + ( M2 + NP2 )*N - IW2 = IW1 + N*M2 -C -C Compute C2' + F12' in BK . -C - DO 40 J = 1, N - DO 30 I = 1, NP2 - BK( J, I ) = C( NP1 + I, J ) + F( ND2 + I, J ) - 30 CONTINUE - 40 CONTINUE -C _ -C Compute the transpose of (C2 + F12)*Z , with Z = inv(Z) . -C - CALL DGETRS( 'Transpose', N, NP2, AK, LDAK, IWORK, BK, LDBK, - $ INFO2 ) -C -C Compute the transpose of F2*Z . -C - CALL MA02AD( 'Full', M2, N, F( M1+1, 1 ), LDF, DWORK( IW1 ), N ) - CALL DGETRS( 'Transpose', N, M2, AK, LDAK, IWORK, DWORK( IW1 ), N, - $ INFO2 ) -C -C Compute the transpose of C1HAT = F2*Z - D11HAT*(C2 + F12)*Z . -C - CALL DGEMM( 'N', 'T', N, M2, NP2, -ONE, BK, LDBK, DWORK( ID11 ), - $ M2, ONE, DWORK( IW1 ), N ) -C -C Compute CHAT . -C - CALL DGEMM( 'N', 'T', M2, N, M2, ONE, TU, LDTU, DWORK( IW1 ), N, - $ ZERO, DWORK( IWC ), M2+NP2 ) - CALL MA02AD( 'Full', N, NP2, BK, LDBK, DWORK( IWC+M2 ), M2+NP2 ) - CALL DTRMM( 'L', 'U', 'N', 'N', NP2, N, -ONE, DWORK( ID21 ), NP2, - $ DWORK( IWC+M2 ), M2+NP2 ) -C -C Compute B2 + H12 . -C - IJ = IW2 - DO 60 J = 1, M2 - DO 50 I = 1, N - DWORK( IJ ) = B( I, M1 + J ) + H( I, ND1 + J ) - IJ = IJ + 1 - 50 CONTINUE - 60 CONTINUE -C -C Compute A + HC in AK . -C - CALL DLACPY( 'Full', N, N, A, LDA, AK, LDAK ) - CALL DGEMM( 'N', 'N', N, N, NP, ONE, H, LDH, C, LDC, ONE, AK, - $ LDAK ) -C -C Compute AHAT = A + HC + (B2 + H12)*C1HAT in AK . -C - CALL DGEMM( 'N', 'T', N, N, M2, ONE, DWORK( IW2 ), N, - $ DWORK( IW1 ), N, ONE, AK, LDAK ) -C -C Compute B1HAT = -H2 + (B2 + H12)*D11HAT in BK . -C - CALL DLACPY( 'Full', N, NP2, H( 1, NP1+1 ), LDH, BK, LDBK ) - CALL DGEMM( 'N', 'N', N, NP2, M2, ONE, DWORK( IW2 ), N, - $ DWORK( ID11 ), M2, -ONE, BK, LDBK ) -C -C Compute the first block of BHAT, BHAT1 . -C - CALL DGEMM( 'N', 'N', N, NP2, NP2, ONE, BK, LDBK, TY, LDTY, ZERO, - $ DWORK( IWB ), N ) -C -C Compute Tu*D11HAT . -C - CALL DGEMM( 'N', 'N', M2, NP2, M2, ONE, TU, LDTU, DWORK( ID11 ), - $ M2, ZERO, DWORK( IW1 ), M2 ) -C -C Compute Tu*D11HAT*Ty in DK . -C - CALL DGEMM( 'N', 'N', M2, NP2, NP2, ONE, DWORK( IW1 ), M2, TY, - $ LDTY, ZERO, DK, LDDK ) -C -C Compute P = Im2 + Tu*D11HAT*Ty*D22 and its condition. -C - IW2 = IW1 + M2*NP2 - IWRK = IW2 + M2*M2 - CALL DLASET( 'Full', M2, M2, ZERO, ONE, DWORK( IW2 ), M2 ) - CALL DGEMM( 'N', 'N', M2, M2, NP2, ONE, DK, LDDK, - $ D( NP1+1, M1+1 ), LDD, ONE, DWORK( IW2 ), M2 ) - ANORM = DLANGE( '1', M2, M2, DWORK( IW2 ), M2, DWORK( IWRK ) ) - CALL DGETRF( M2, M2, DWORK( IW2 ), M2, IWORK, INFO2 ) - IF( INFO2.GT.0 ) THEN - INFO = 2 - RETURN - END IF - CALL DGECON( '1', M2, DWORK( IW2 ), M2, ANORM, RCOND, - $ DWORK( IWRK ), IWORK( M2+1 ), INFO2 ) -C -C Return if the matrix is singular to working precision. -C - IF( RCOND.LT.EPS ) THEN - INFO = 2 - RETURN - END IF -C -C Find the controller matrix CK, CK = inv(P)*CHAT(1:M2,:) . -C - CALL DLACPY( 'Full', M2, N, DWORK( IWC ), M2+NP2, CK, LDCK ) - CALL DGETRS( 'NoTranspose', M2, N, DWORK( IW2 ), M2, IWORK, CK, - $ LDCK, INFO2 ) -C -C Find the controller matrices AK, BK, and DK, exploiting the -C special structure of the relations. -C -C Compute Q = Inp2 + D22*Tu*D11HAT*Ty and its LU factorization. -C - IW3 = IW2 + NP2*NP2 - IW4 = IW3 + NP2*M2 - IWRK = IW4 + NP2*NP2 - CALL DLASET( 'Full', NP2, NP2, ZERO, ONE, DWORK( IW2 ), NP2 ) - CALL DGEMM( 'N', 'N', NP2, NP2, M2, ONE, D( NP1+1, M1+1 ), LDD, - $ DK, LDDK, ONE, DWORK( IW2 ), NP2 ) - CALL DGETRF( NP2, NP2, DWORK( IW2 ), NP2, IWORK, INFO2 ) - IF( INFO2.GT.0 ) THEN - INFO = 2 - RETURN - END IF -C -C Compute A1 = inv(Q)*D22 and inv(Q) . -C - CALL DLACPY( 'Full', NP2, M2, D( NP1+1, M1+1 ), LDD, DWORK( IW3 ), - $ NP2 ) - CALL DGETRS( 'NoTranspose', NP2, M2, DWORK( IW2 ), NP2, IWORK, - $ DWORK( IW3 ), NP2, INFO2 ) - CALL DGETRI( NP2, DWORK( IW2 ), NP2, IWORK, DWORK( IWRK ), - $ LDWORK-IWRK+1, INFO2 ) - LWAMAX = MAX( INT( DWORK( IWRK ) ) + IWRK - 1, LWAMAX ) -C -C Compute A2 = ( inv(Ty) - inv(Q)*inv(Ty) - -C A1*Tu*D11HAT )*inv(D21HAT) . -C - CALL DLACPY( 'Full', NP2, NP2, TY, LDTY, DWORK( IW4 ), NP2 ) - CALL DGETRF( NP2, NP2, DWORK( IW4 ), NP2, IWORK, INFO2 ) - CALL DGETRI( NP2, DWORK( IW4 ), NP2, IWORK, DWORK( IWRK ), - $ LDWORK-IWRK+1, INFO2 ) -C - CALL DLACPY( 'Full', NP2, NP2, DWORK( IW4 ), NP2, DWORK( IWRK ), - $ NP2 ) - CALL DGEMM( 'N', 'N', NP2, NP2, NP2, -ONE, DWORK( IW2), NP2, - $ DWORK( IWRK ), NP2, ONE, DWORK( IW4 ), NP2 ) - CALL DGEMM( 'N', 'N', NP2, NP2, M2, -ONE, DWORK( IW3), NP2, - $ DWORK( IW1 ), M2, ONE, DWORK( IW4 ), NP2 ) - CALL DTRMM( 'R', 'U', 'N', 'N', NP2, NP2, ONE, DWORK( ID21 ), NP2, - $ DWORK( IW4 ), NP2 ) -C -C Compute [ A1 A2 ]*CHAT . -C - CALL DGEMM( 'N', 'N', NP2, N, M2+NP2, ONE, DWORK( IW3 ), NP2, - $ DWORK( IWC ), M2+NP2, ZERO, DWORK( IWRK ), NP2 ) -C -C Compute AK := AHAT - BHAT1*[ A1 A2 ]*CHAT . -C - CALL DGEMM( 'N', 'N', N, N, NP2, -ONE, DWORK( IWB ), N, - $ DWORK( IWRK ), NP2, ONE, AK, LDAK ) -C -C Compute BK := BHAT1*inv(Q) . -C - CALL DGEMM( 'N', 'N', N, NP2, NP2, ONE, DWORK( IWB ), N, - $ DWORK( IW2 ), NP2, ZERO, BK, LDBK ) -C -C Compute DK := Tu*D11HAT*Ty*inv(Q) . -C - CALL DGEMM( 'N', 'N', M2, NP2, NP2, ONE, DK, LDDK, DWORK( IW2 ), - $ NP2, ZERO, DWORK( IW3 ), M2 ) - CALL DLACPY( 'Full', M2, NP2, DWORK( IW3 ), M2, DK, LDDK ) -C - DWORK( 1 ) = DBLE( LWAMAX ) - RETURN -C *** Last line of SB10RD *** - END diff --git a/mex/sources/libslicot/SB10SD.f b/mex/sources/libslicot/SB10SD.f deleted file mode 100644 index ee99c78f2..000000000 --- a/mex/sources/libslicot/SB10SD.f +++ /dev/null @@ -1,629 +0,0 @@ - SUBROUTINE SB10SD( N, M, NP, NCON, NMEAS, A, LDA, B, LDB, C, LDC, - $ D, LDD, AK, LDAK, BK, LDBK, CK, LDCK, DK, LDDK, - $ X, LDX, Y, LDY, RCOND, TOL, IWORK, DWORK, - $ LDWORK, BWORK, INFO ) -C -C SLICOT RELEASE 5.0. -C -C Copyright (c) 2002-2009 NICONET e.V. -C -C This program is free software: you can redistribute it and/or -C modify it under the terms of the GNU General Public License as -C published by the Free Software Foundation, either version 2 of -C the License, or (at your option) any later version. -C -C This program is distributed in the hope that it will be useful, -C but WITHOUT ANY WARRANTY; without even the implied warranty of -C MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the -C GNU General Public License for more details. -C -C You should have received a copy of the GNU General Public License -C along with this program. If not, see -C . -C -C PURPOSE -C -C To compute the matrices of the H2 optimal controller -C -C | AK | BK | -C K = |----|----|, -C | CK | DK | -C -C for the normalized discrete-time system -C -C | A | B1 B2 | | A | B | -C P = |----|---------| = |---|---| -C | C1 | D11 D12 | | C | D | -C | C2 | D21 0 | -C -C where B2 has as column size the number of control inputs (NCON) -C and C2 has as row size the number of measurements (NMEAS) being -C provided to the controller. -C -C It is assumed that -C -C (A1) (A,B2) is stabilizable and (C2,A) is detectable, -C -C (A2) D12 is full column rank with D12 = | 0 | and D21 is -C | I | -C full row rank with D21 = | 0 I | as obtained by the -C SLICOT Library routine SB10PD, -C -C j*Theta -C (A3) | A-e *I B2 | has full column rank for all -C | C1 D12 | -C -C 0 <= Theta < 2*Pi , -C -C -C j*Theta -C (A4) | A-e *I B1 | has full row rank for all -C | C2 D21 | -C -C 0 <= Theta < 2*Pi . -C -C ARGUMENTS -C -C Input/Output Parameters -C -C N (input) INTEGER -C The order of the system. N >= 0. -C -C M (input) INTEGER -C The column size of the matrix B. M >= 0. -C -C NP (input) INTEGER -C The row size of the matrix C. NP >= 0. -C -C NCON (input) INTEGER -C The number of control inputs (M2). M >= NCON >= 0, -C NP-NMEAS >= NCON. -C -C NMEAS (input) INTEGER -C The number of measurements (NP2). NP >= NMEAS >= 0, -C M-NCON >= NMEAS. -C -C A (input) DOUBLE PRECISION array, dimension (LDA,N) -C The leading N-by-N part of this array must contain the -C system state matrix A. -C -C LDA INTEGER -C The leading dimension of the array A. LDA >= max(1,N). -C -C B (input) DOUBLE PRECISION array, dimension (LDB,M) -C The leading N-by-M part of this array must contain the -C system input matrix B. -C -C LDB INTEGER -C The leading dimension of the array B. LDB >= max(1,N). -C -C C (input) DOUBLE PRECISION array, dimension (LDC,N) -C The leading NP-by-N part of this array must contain the -C system output matrix C. -C -C LDC INTEGER -C The leading dimension of the array C. LDC >= max(1,NP). -C -C D (input) DOUBLE PRECISION array, dimension (LDD,M) -C The leading NP-by-M part of this array must contain the -C system input/output matrix D. Only the leading -C (NP-NP2)-by-(M-M2) submatrix D11 is used. -C -C LDD INTEGER -C The leading dimension of the array D. LDD >= max(1,NP). -C -C AK (output) DOUBLE PRECISION array, dimension (LDAK,N) -C The leading N-by-N part of this array contains the -C controller state matrix AK. -C -C LDAK INTEGER -C The leading dimension of the array AK. LDAK >= max(1,N). -C -C BK (output) DOUBLE PRECISION array, dimension (LDBK,NMEAS) -C The leading N-by-NMEAS part of this array contains the -C controller input matrix BK. -C -C LDBK INTEGER -C The leading dimension of the array BK. LDBK >= max(1,N). -C -C CK (output) DOUBLE PRECISION array, dimension (LDCK,N) -C The leading NCON-by-N part of this array contains the -C controller output matrix CK. -C -C LDCK INTEGER -C The leading dimension of the array CK. -C LDCK >= max(1,NCON). -C -C DK (output) DOUBLE PRECISION array, dimension (LDDK,NMEAS) -C The leading NCON-by-NMEAS part of this array contains the -C controller input/output matrix DK. -C -C LDDK INTEGER -C The leading dimension of the array DK. -C LDDK >= max(1,NCON). -C -C X (output) DOUBLE PRECISION array, dimension (LDX,N) -C The leading N-by-N part of this array contains the matrix -C X, solution of the X-Riccati equation. -C -C LDX INTEGER -C The leading dimension of the array X. LDX >= max(1,N). -C -C Y (output) DOUBLE PRECISION array, dimension (LDY,N) -C The leading N-by-N part of this array contains the matrix -C Y, solution of the Y-Riccati equation. -C -C LDY INTEGER -C The leading dimension of the array Y. LDY >= max(1,N). -C -C RCOND (output) DOUBLE PRECISION array, dimension (4) -C RCOND contains estimates of the reciprocal condition -C numbers of the matrices which are to be inverted and the -C reciprocal condition numbers of the Riccati equations -C which have to be solved during the computation of the -C controller. (See the description of the algorithm in [2].) -C RCOND(1) contains the reciprocal condition number of the -C matrix Im2 + B2'*X2*B2; -C RCOND(2) contains the reciprocal condition number of the -C matrix Ip2 + C2*Y2*C2'; -C RCOND(3) contains the reciprocal condition number of the -C X-Riccati equation; -C RCOND(4) contains the reciprocal condition number of the -C Y-Riccati equation. -C -C Tolerances -C -C TOL DOUBLE PRECISION -C Tolerance used in determining the nonsingularity of the -C matrices which must be inverted. If TOL <= 0, then a -C default value equal to sqrt(EPS) is used, where EPS is the -C relative machine precision. -C -C Workspace -C -C IWORK INTEGER array, dimension max(M2,2*N,N*N,NP2) -C -C DWORK DOUBLE PRECISION array, dimension (LDWORK) -C On exit, if INFO = 0, DWORK(1) contains the optimal -C LDWORK. -C -C LDWORK INTEGER -C The dimension of the array DWORK. -C LDWORK >= max(1, 14*N*N+6*N+max(14*N+23,16*N), -C M2*(N+M2+max(3,M1)), NP2*(N+NP2+3)), -C where M1 = M - M2. -C For good performance, LDWORK must generally be larger. -C -C BWORK LOGICAL array, dimension (2*N) -C -C Error Indicator -C -C INFO INTEGER -C = 0: successful exit; -C < 0: if INFO = -i, the i-th argument had an illegal -C value; -C = 1: if the X-Riccati equation was not solved -C successfully; -C = 2: if the matrix Im2 + B2'*X2*B2 is not positive -C definite, or it is numerically singular (with -C respect to the tolerance TOL); -C = 3: if the Y-Riccati equation was not solved -C successfully; -C = 4: if the matrix Ip2 + C2*Y2*C2' is not positive -C definite, or it is numerically singular (with -C respect to the tolerance TOL). -C -C METHOD -C -C The routine implements the formulas given in [1]. The X- and -C Y-Riccati equations are solved with condition estimates. -C -C REFERENCES -C -C [1] Zhou, K., Doyle, J.C., and Glover, K. -C Robust and Optimal Control. -C Prentice-Hall, Upper Saddle River, NJ, 1996. -C -C [2] Petkov, P.Hr., Gu, D.W., and Konstantinov, M.M. -C Fortran 77 routines for Hinf and H2 design of linear -C discrete-time control systems. -C Report 99-8, Department of Engineering, Leicester University, -C April 1999. -C -C NUMERICAL ASPECTS -C -C The accuracy of the result depends on the condition numbers of the -C matrices which are to be inverted and on the condition numbers of -C the matrix Riccati equations which are to be solved in the -C computation of the controller. (The corresponding reciprocal -C condition numbers are given in the output array RCOND.) -C -C CONTRIBUTORS -C -C P.Hr. Petkov, D.W. Gu and M.M. Konstantinov, April 1999. -C -C REVISIONS -C -C V. Sima, Research Institute for Informatics, Bucharest, May 1999, -C January 2003. -C -C KEYWORDS -C -C Algebraic Riccati equation, H2 optimal control, LQG, LQR, optimal -C regulator, robust control. -C -C ****************************************************************** -C -C .. Parameters .. - DOUBLE PRECISION ZERO, ONE - PARAMETER ( ZERO = 0.0D+0, ONE = 1.0D+0 ) -C .. -C .. Scalar Arguments .. - INTEGER INFO, LDA, LDAK, LDB, LDBK, LDC, LDCK, LDD, - $ LDDK, LDWORK, LDX, LDY, M, N, NCON, NMEAS, NP - DOUBLE PRECISION TOL -C .. -C .. Array Arguments .. - INTEGER IWORK( * ) - DOUBLE PRECISION A( LDA, * ), AK( LDAK, * ), B( LDB, * ), - $ BK( LDBK, * ), C( LDC, * ), CK( LDCK, * ), - $ D( LDD, * ), DK( LDDK, * ), DWORK( * ), - $ RCOND( * ), X( LDX, * ), Y( LDY, * ) - LOGICAL BWORK( * ) -C .. -C .. Local Scalars .. - INTEGER INFO2, IW2, IWB, IWC, IWG, IWI, IWQ, IWR, IWRK, - $ IWS, IWT, IWU, IWV, J, LWAMAX, M1, M2, MINWRK, - $ ND1, ND2, NP1, NP2 - DOUBLE PRECISION ANORM, FERR, RCOND2, SEPD, TOLL -C .. -C .. External functions .. - DOUBLE PRECISION DLAMCH, DLANSY - EXTERNAL DLAMCH, DLANSY -C .. -C .. External Subroutines .. - EXTERNAL DGEMM, DLACPY, DLASET, DPOCON, DPOTRF, DPOTRS, - $ DSWAP, DSYRK, DTRSM, MB01RX, SB02OD, SB02SD, - $ XERBLA -C .. -C .. Intrinsic Functions .. - INTRINSIC DBLE, INT, MAX -C .. -C .. Executable Statements .. -C -C Decode and Test input parameters. -C - M1 = M - NCON - M2 = NCON - NP1 = NP - NMEAS - NP2 = NMEAS -C - INFO = 0 - IF( N.LT.0 ) THEN - INFO = -1 - ELSE IF( M.LT.0 ) THEN - INFO = -2 - ELSE IF( NP.LT.0 ) THEN - INFO = -3 - ELSE IF( NCON.LT.0 .OR. M1.LT.0 .OR. M2.GT.NP1 ) THEN - INFO = -4 - ELSE IF( NMEAS.LT.0 .OR. NP1.LT.0 .OR. NP2.GT.M1 ) THEN - INFO = -5 - ELSE IF( LDA.LT.MAX( 1, N ) ) THEN - INFO = -7 - ELSE IF( LDB.LT.MAX( 1, N ) ) THEN - INFO = -9 - ELSE IF( LDC.LT.MAX( 1, NP ) ) THEN - INFO = -11 - ELSE IF( LDD.LT.MAX( 1, NP ) ) THEN - INFO = -13 - ELSE IF( LDAK.LT.MAX( 1, N ) ) THEN - INFO = -15 - ELSE IF( LDBK.LT.MAX( 1, N ) ) THEN - INFO = -17 - ELSE IF( LDCK.LT.MAX( 1, M2 ) ) THEN - INFO = -19 - ELSE IF( LDDK.LT.MAX( 1, M2 ) ) THEN - INFO = -21 - ELSE IF( LDX.LT.MAX( 1, N ) ) THEN - INFO = -23 - ELSE IF( LDY.LT.MAX( 1, N ) ) THEN - INFO = -25 - ELSE -C -C Compute workspace. -C - MINWRK = MAX( 1, 14*N*N + 6*N + MAX( 14*N + 23, 16*N ), - $ M2*( N + M2 + MAX( 3, M1 ) ), NP2*( N + NP2 + 3 ) ) - IF( LDWORK.LT.MINWRK ) - $ INFO = -30 - END IF - IF( INFO.NE.0 ) THEN - CALL XERBLA( 'SB10SD', -INFO ) - RETURN - END IF -C -C Quick return if possible. -C - IF( N.EQ.0 .OR. M.EQ.0 .OR. NP.EQ.0 .OR. M1.EQ.0 .OR. M2.EQ.0 - $ .OR. NP1.EQ.0 .OR. NP2.EQ.0 ) THEN - RCOND( 1 ) = ONE - RCOND( 2 ) = ONE - RCOND( 3 ) = ONE - RCOND( 4 ) = ONE - DWORK( 1 ) = ONE - RETURN - END IF -C - ND1 = NP1 - M2 - ND2 = M1 - NP2 - TOLL = TOL - IF( TOLL.LE.ZERO ) THEN -C -C Set the default value of the tolerance for nonsingularity test. -C - TOLL = SQRT( DLAMCH( 'Epsilon' ) ) - END IF -C -C Workspace usage. -C - IWQ = 1 - IWG = IWQ + N*N - IWR = IWG + N*N - IWI = IWR + 2*N - IWB = IWI + 2*N - IWS = IWB + 2*N - IWT = IWS + 4*N*N - IWU = IWT + 4*N*N - IWRK = IWU + 4*N*N - IWC = IWR - IWV = IWC + N*N -C -C Compute Ax = A - B2*D12'*C1 in AK . -C - CALL DLACPY( 'Full', N, N, A, LDA, AK, LDAK ) - CALL DGEMM( 'N', 'N', N, N, M2, -ONE, B( 1, M1+1 ), LDB, - $ C( ND1+1, 1), LDC, ONE, AK, LDAK ) -C -C Compute Cx = C1'*C1 - C1'*D12*D12'*C1 . -C - IF( ND1.GT.0 ) THEN - CALL DSYRK( 'L', 'T', N, ND1, ONE, C, LDC, ZERO, DWORK( IWQ ), - $ N ) - ELSE - CALL DLASET( 'L', N, N, ZERO, ZERO, DWORK( IWQ ), N ) - END IF -C -C Compute Dx = B2*B2' . -C - CALL DSYRK( 'L', 'N', N, M2, ONE, B( 1, M1+1 ), LDB, ZERO, - $ DWORK( IWG ), N ) -C -C Solution of the discrete-time Riccati equation -C Ax'*inv(In + X2*Dx)*X2*Ax - X2 + Cx = 0 . -C Workspace: need 14*N*N + 6*N + max(14*N+23,16*N); -C prefer larger. -C - CALL SB02OD( 'D', 'G', 'N', 'L', 'Z', 'S', N, M2, NP1, AK, LDAK, - $ DWORK( IWG ), N, DWORK( IWQ ), N, DWORK( IWRK ), M, - $ DWORK( IWRK ), N, RCOND2, X, LDX, DWORK( IWR ), - $ DWORK( IWI ), DWORK( IWB ), DWORK( IWS ), 2*N, - $ DWORK( IWT ), 2*N, DWORK( IWU ), 2*N, TOLL, IWORK, - $ DWORK( IWRK ), LDWORK-IWRK+1, BWORK, INFO2 ) - IF( INFO2.GT.0 ) THEN - INFO = 1 - RETURN - END IF - LWAMAX = INT( DWORK( IWRK ) ) + IWRK - 1 -C -C Condition estimation. -C Workspace: need 4*N*N + max(N*N+5*N,max(3,2*N*N)+N*N); -C prefer larger. -C - IWRK = IWV + N*N - CALL SB02SD( 'C', 'N', 'N', 'L', 'O', N, AK, LDAK, DWORK( IWC ), - $ N, DWORK( IWV ), N, DWORK( IWG ), N, DWORK( IWQ ), N, - $ X, LDX, SEPD, RCOND( 3 ), FERR, IWORK, DWORK( IWRK ), - $ LDWORK-IWRK+1, INFO2 ) - IF( INFO2.GT.0 ) RCOND( 3 ) = ZERO - LWAMAX = MAX( INT( DWORK( IWRK ) ) + IWRK - 1, LWAMAX ) -C -C Workspace usage. -C - IW2 = M2*N + 1 - IWRK = IW2 + M2*M2 -C -C Compute B2'*X2 . -C - CALL DGEMM( 'T', 'N', M2, N, N, ONE, B( 1, M1+1 ), LDB, X, LDX, - $ ZERO, DWORK, M2 ) -C -C Compute Im2 + B2'*X2*B2 . -C - CALL DLASET( 'L', M2, M2, ZERO, ONE, DWORK( IW2 ), M2 ) - CALL MB01RX( 'Left', 'Lower', 'N', M2, N, ONE, ONE, DWORK( IW2 ), - $ M2, DWORK, M2, B( 1, M1+1 ), LDB, INFO2 ) -C -C Compute the Cholesky factorization of Im2 + B2'*X2*B2 . -C Workspace: need M2*N + M2*M2 + max(3*M2,M2*M1); -C prefer larger. -C - ANORM = DLANSY( 'I', 'L', M2, DWORK( IW2 ), M2, DWORK( IWRK ) ) - CALL DPOTRF( 'L', M2, DWORK( IW2 ), M2, INFO2 ) - IF( INFO2.GT.0 ) THEN - INFO = 2 - RETURN - END IF - CALL DPOCON( 'L', M2, DWORK( IW2 ), M2, ANORM, RCOND( 1 ), - $ DWORK( IWRK ), IWORK, INFO2 ) -C -C Return if the matrix is singular to working precision. -C - IF( RCOND( 1 ).LT.TOLL ) THEN - INFO = 2 - RETURN - END IF -C -C Compute -( B2'*X2*A + D12'*C1 ) in CK . -C - CALL DLACPY( 'Full', M2, N, C( ND1+1, 1 ), LDC, CK, LDCK ) - CALL DGEMM( 'N', 'N', M2, N, N, -ONE, DWORK, M2, A, LDA, -ONE, CK, - $ LDCK ) -C -C Compute F2 = -inv( Im2 + B2'*X2*B2 )*( B2'*X2*A + D12'*C1 ) . -C - CALL DPOTRS( 'L', M2, N, DWORK( IW2 ), M2, CK, LDCK, INFO2 ) -C -C Compute -( B2'*X2*B1 + D12'*D11 ) . -C - CALL DLACPY( 'Full', M2, M1, D( ND1+1, 1 ), LDD, DWORK( IWRK ), - $ M2 ) - CALL DGEMM( 'N', 'N', M2, M1, N, -ONE, DWORK, M2, B, LDB, -ONE, - $ DWORK( IWRK ), M2 ) -C -C Compute F0 = -inv( Im2 + B2'*X2*B2 )*( B2'*X2*B1 + D12'*D11 ) . -C - CALL DPOTRS( 'L', M2, M1, DWORK( IW2 ), M2, DWORK( IWRK ), M2, - $ INFO2 ) -C -C Save F0*D21' in DK . -C - CALL DLACPY( 'Full', M2, NP2, DWORK( IWRK+ND2*M2 ), M2, DK, - $ LDDK ) -C -C Workspace usage. -C - IWRK = IWU + 4*N*N -C -C Compute Ay = A - B1*D21'*C2 in AK . -C - CALL DLACPY( 'Full', N, N, A, LDA, AK, LDAK ) - CALL DGEMM( 'N', 'N', N, N, NP2, -ONE, B( 1, ND2+1 ), LDB, - $ C( NP1+1, 1 ), LDC, ONE, AK, LDAK ) -C -C Transpose Ay in-situ. -C - DO 20 J = 1, N - 1 - CALL DSWAP( J, AK( J+1, 1 ), LDAK, AK( 1, J+1 ), 1 ) - 20 CONTINUE -C -C Compute Cy = B1*B1' - B1*D21'*D21*B1' . -C - IF( ND2.GT.0 ) THEN - CALL DSYRK( 'U', 'N', N, ND2, ONE, B, LDB, ZERO, DWORK( IWQ ), - $ N ) - ELSE - CALL DLASET( 'U', N, N, ZERO, ZERO, DWORK( IWQ ), N ) - END IF -C -C Compute Dy = C2'*C2 . -C - CALL DSYRK( 'U', 'T', N, NP2, ONE, C( NP1+1, 1 ), LDC, ZERO, - $ DWORK( IWG ), N ) -C -C Solution of the discrete-time Riccati equation -C Ay*inv( In + Y2*Dy )*Y2*Ay' - Y2 + Cy = 0 . -C - CALL SB02OD( 'D', 'G', 'N', 'U', 'Z', 'S', N, NP2, M1, AK, LDAK, - $ DWORK( IWG ), N, DWORK( IWQ ), N, DWORK( IWRK ), M, - $ DWORK( IWRK ), N, RCOND2, Y, LDY, DWORK( IWR ), - $ DWORK( IWI ), DWORK( IWB ), DWORK( IWS ), 2*N, - $ DWORK( IWT ), 2*N, DWORK( IWU ), 2*N, TOLL, IWORK, - $ DWORK( IWRK ), LDWORK-IWRK+1, BWORK, INFO2 ) - IF( INFO2.GT.0 ) THEN - INFO = 3 - RETURN - END IF - LWAMAX = MAX( INT( DWORK( IWRK ) ) + IWRK - 1, LWAMAX ) -C -C Condition estimation. -C - IWRK = IWV + N*N - CALL SB02SD( 'C', 'N', 'N', 'U', 'O', N, AK, LDAK, DWORK( IWC ), - $ N, DWORK( IWV ), N, DWORK( IWG ), N, DWORK( IWQ ), N, - $ Y, LDY, SEPD, RCOND( 4 ), FERR, IWORK, DWORK( IWRK ), - $ LDWORK-IWRK+1, INFO2 ) - IF( INFO2.GT.0 ) RCOND( 4 ) = ZERO - LWAMAX = MAX( INT( DWORK( IWRK ) ) + IWRK - 1, LWAMAX ) -C -C Workspace usage. -C - IW2 = N*NP2 + 1 - IWRK = IW2 + NP2*NP2 -C -C Compute Y2*C2' . -C - CALL DGEMM( 'N', 'T', N, NP2, N, ONE, Y, LDY, C( NP1+1, 1 ), LDC, - $ ZERO, DWORK, N ) -C -C Compute Ip2 + C2*Y2*C2' . -C - CALL DLASET( 'U', NP2, NP2, ZERO, ONE, DWORK( IW2 ), NP2 ) - CALL MB01RX( 'Left', 'Upper', 'N', NP2, N, ONE, ONE, DWORK( IW2 ), - $ NP2, C( NP1+1, 1 ), LDC, DWORK, N, INFO2 ) -C -C Compute the Cholesky factorization of Ip2 + C2*Y2*C2' . -C - ANORM = DLANSY( 'I', 'U', NP2, DWORK( IW2 ), NP2, DWORK( IWRK ) ) - CALL DPOTRF( 'U', NP2, DWORK( IW2 ), NP2, INFO2 ) - IF( INFO2.GT.0 ) THEN - INFO = 4 - RETURN - END IF - CALL DPOCON( 'U', NP2, DWORK( IW2 ), NP2, ANORM, RCOND( 2 ), - $ DWORK( IWRK ), IWORK, INFO2 ) -C -C Return if the matrix is singular to working precision. -C - IF( RCOND( 2 ).LT.TOLL ) THEN - INFO = 4 - RETURN - END IF -C -C Compute A*Y2*C2' + B1*D21' in BK . -C - CALL DLACPY ( 'Full', N, NP2, B( 1, ND2+1 ), LDB, BK, LDBK ) - CALL DGEMM( 'N', 'N', N, NP2, N, ONE, A, LDA, DWORK, N, ONE, - $ BK, LDBK ) -C -C Compute L2 = -( A*Y2*C2' + B1*D21' )*inv( Ip2 + C2*Y2*C2' ) . -C - CALL DTRSM( 'R', 'U', 'N', 'N', N, NP2, -ONE, DWORK( IW2 ), NP2, - $ BK, LDBK ) - CALL DTRSM( 'R', 'U', 'T', 'N', N, NP2, ONE, DWORK( IW2 ), NP2, - $ BK, LDBK ) -C -C Compute F2*Y2*C2' + F0*D21' . -C - CALL DGEMM( 'N', 'N', M2, NP2, N, ONE, CK, LDCK, DWORK, N, ONE, - $ DK, LDDK ) -C -C Compute DK = L0 = ( F2*Y2*C2' + F0*D21' )*inv( Ip2 + C2*Y2*C2' ) . -C - CALL DTRSM( 'R', 'U', 'N', 'N', M2, NP2, ONE, DWORK( IW2 ), NP2, - $ DK, LDDK ) - CALL DTRSM( 'R', 'U', 'T', 'N', M2, NP2, ONE, DWORK( IW2 ), NP2, - $ DK, LDDK ) -C -C Compute CK = F2 - L0*C2 . -C - CALL DGEMM( 'N', 'N', M2, N, NP2, -ONE, DK, LDDK, C( NP1+1, 1), - $ LDC, ONE, CK, LDCK ) -C -C Find AK = A + B2*( F2 - L0*C2 ) + L2*C2 . -C - CALL DLACPY( 'Full', N, N, A, LDA, AK, LDAK ) - CALL DGEMM( 'N', 'N', N, N, M2, ONE, B(1, M1+1 ), LDB, CK, LDCK, - $ ONE, AK, LDAK ) - CALL DGEMM( 'N', 'N', N, N, NP2, ONE, BK, LDBK, C( NP1+1, 1), - $ LDC, ONE, AK, LDAK ) -C -C Find BK = -L2 + B2*L0 . -C - CALL DGEMM( 'N', 'N', N, NP2, M2, ONE, B( 1, M1+1 ), LDB, DK, - $ LDDK, -ONE, BK, LDBK ) -C - DWORK( 1 ) = DBLE( LWAMAX ) - RETURN -C *** Last line of SB10SD *** - END diff --git a/mex/sources/libslicot/SB10TD.f b/mex/sources/libslicot/SB10TD.f deleted file mode 100644 index e8d193b41..000000000 --- a/mex/sources/libslicot/SB10TD.f +++ /dev/null @@ -1,350 +0,0 @@ - SUBROUTINE SB10TD( N, M, NP, NCON, NMEAS, D, LDD, TU, LDTU, TY, - $ LDTY, AK, LDAK, BK, LDBK, CK, LDCK, DK, LDDK, - $ RCOND, TOL, IWORK, DWORK, LDWORK, INFO ) -C -C SLICOT RELEASE 5.0. -C -C Copyright (c) 2002-2009 NICONET e.V. -C -C This program is free software: you can redistribute it and/or -C modify it under the terms of the GNU General Public License as -C published by the Free Software Foundation, either version 2 of -C the License, or (at your option) any later version. -C -C This program is distributed in the hope that it will be useful, -C but WITHOUT ANY WARRANTY; without even the implied warranty of -C MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the -C GNU General Public License for more details. -C -C You should have received a copy of the GNU General Public License -C along with this program. If not, see -C . -C -C PURPOSE -C -C To compute the matrices of the H2 optimal discrete-time controller -C -C | AK | BK | -C K = |----|----|, -C | CK | DK | -C -C from the matrices of the controller for the normalized system, -C as determined by the SLICOT Library routine SB10SD. -C -C ARGUMENTS -C -C Input/Output Parameters -C -C N (input) INTEGER -C The order of the system. N >= 0. -C -C M (input) INTEGER -C The column size of the matrix B. M >= 0. -C -C NP (input) INTEGER -C The row size of the matrix C. NP >= 0. -C -C NCON (input) INTEGER -C The number of control inputs (M2). M >= NCON >= 0. -C NP-NMEAS >= NCON. -C -C NMEAS (input) INTEGER -C The number of measurements (NP2). NP >= NMEAS >= 0. -C M-NCON >= NMEAS. -C -C D (input) DOUBLE PRECISION array, dimension (LDD,M) -C The leading NP-by-M part of this array must contain the -C system input/output matrix D. Only the trailing -C NMEAS-by-NCON submatrix D22 is used. -C -C LDD INTEGER -C The leading dimension of the array D. LDD >= max(1,NP). -C -C TU (input) DOUBLE PRECISION array, dimension (LDTU,M2) -C The leading M2-by-M2 part of this array must contain the -C control transformation matrix TU, as obtained by the -C SLICOT Library routine SB10PD. -C -C LDTU INTEGER -C The leading dimension of the array TU. LDTU >= max(1,M2). -C -C TY (input) DOUBLE PRECISION array, dimension (LDTY,NP2) -C The leading NP2-by-NP2 part of this array must contain the -C measurement transformation matrix TY, as obtained by the -C SLICOT Library routine SB10PD. -C -C LDTY INTEGER -C The leading dimension of the array TY. -C LDTY >= max(1,NP2). -C -C AK (input/output) DOUBLE PRECISION array, dimension (LDAK,N) -C On entry, the leading N-by-N part of this array must -C contain controller state matrix for the normalized system -C as obtained by the SLICOT Library routine SB10SD. -C On exit, the leading N-by-N part of this array contains -C controller state matrix AK. -C -C LDAK INTEGER -C The leading dimension of the array AK. LDAK >= max(1,N). -C -C BK (input/output) DOUBLE PRECISION array, dimension -C (LDBK,NMEAS) -C On entry, the leading N-by-NMEAS part of this array must -C contain controller input matrix for the normalized system -C as obtained by the SLICOT Library routine SB10SD. -C On exit, the leading N-by-NMEAS part of this array -C contains controller input matrix BK. -C -C LDBK INTEGER -C The leading dimension of the array BK. LDBK >= max(1,N). -C -C CK (input/output) DOUBLE PRECISION array, dimension (LDCK,N) -C On entry, the leading NCON-by-N part of this array must -C contain controller output matrix for the normalized -C system as obtained by the SLICOT Library routine SB10SD. -C On exit, the leading NCON-by-N part of this array contains -C controller output matrix CK. -C -C LDCK INTEGER -C The leading dimension of the array CK. -C LDCK >= max(1,NCON). -C -C DK (input/output) DOUBLE PRECISION array, dimension -C (LDDK,NMEAS) -C On entry, the leading NCON-by-NMEAS part of this array -C must contain controller matrix DK for the normalized -C system as obtained by the SLICOT Library routine SB10SD. -C On exit, the leading NCON-by-NMEAS part of this array -C contains controller input/output matrix DK. -C -C LDDK INTEGER -C The leading dimension of the array DK. -C LDDK >= max(1,NCON). -C -C RCOND (output) DOUBLE PRECISION -C RCOND contains an estimate of the reciprocal condition -C number of the matrix Im2 + DKHAT*D22 which must be -C inverted in the computation of the controller. -C -C Tolerances -C -C TOL DOUBLE PRECISION -C Tolerance used in determining the nonsingularity of the -C matrix which must be inverted. If TOL <= 0, then a default -C value equal to sqrt(EPS) is used, where EPS is the -C relative machine precision. -C -C Workspace -C -C IWORK INTEGER array, dimension (2*M2) -C -C DWORK DOUBLE PRECISION array, dimension (LDWORK) -C -C LDWORK INTEGER -C The dimension of the array DWORK. -C LDWORK >= max(N*M2,N*NP2,M2*NP2,M2*M2+4*M2). -C -C Error Indicator -C -C INFO INTEGER -C = 0: successful exit; -C < 0: if INFO = -i, the i-th argument had an illegal -C value; -C = 1: if the matrix Im2 + DKHAT*D22 is singular, or the -C estimated condition number is larger than or equal -C to 1/TOL. -C -C METHOD -C -C The routine implements the formulas given in [1]. -C -C REFERENCES -C -C [1] Zhou, K., Doyle, J.C., and Glover, K. -C Robust and Optimal Control. -C Prentice-Hall, Upper Saddle River, NJ, 1996. -C -C [2] Petkov, P.Hr., Gu, D.W., and Konstantinov, M.M. -C Fortran 77 routines for Hinf and H2 design of linear -C discrete-time control systems. -C Report 99-8, Department of Engineering, Leicester University, -C April 1999. -C -C NUMERICAL ASPECTS -C -C The accuracy of the result depends on the condition numbers of the -C input and output transformations and of the matrix Im2 + -C DKHAT*D22. -C -C CONTRIBUTORS -C -C P.Hr. Petkov, D.W. Gu and M.M. Konstantinov, April 1999. -C -C REVISIONS -C -C V. Sima, Research Institute for Informatics, Bucharest, May 1999, -C Jan. 2000. -C -C KEYWORDS -C -C Algebraic Riccati equation, H2 optimal control, LQG, LQR, optimal -C regulator, robust control. -C -C ****************************************************************** -C -C .. Parameters .. - DOUBLE PRECISION ZERO, ONE - PARAMETER ( ZERO = 0.0D+0, ONE = 1.0D+0 ) -C .. -C .. Scalar Arguments .. - INTEGER INFO, LDAK, LDBK, LDCK, LDD, LDDK, LDTU, LDTY, - $ LDWORK, M, N, NCON, NMEAS, NP - DOUBLE PRECISION RCOND, TOL -C .. -C .. Array Arguments .. - INTEGER IWORK( * ) - DOUBLE PRECISION AK( LDAK, * ), BK( LDBK, * ), CK( LDCK, * ), - $ D( LDD, * ), DK( LDDK, * ), DWORK( * ), - $ TU( LDTU, * ), TY( LDTY, * ) -C .. -C .. Local Scalars .. - INTEGER INFO2, IWRK, M1, M2, MINWRK, NP1, NP2 - DOUBLE PRECISION ANORM, TOLL -C .. -C .. External Functions - DOUBLE PRECISION DLAMCH, DLANGE - EXTERNAL DLAMCH, DLANGE -C .. -C .. External Subroutines .. - EXTERNAL DGECON, DGEMM, DGETRF, DGETRS, DLACPY, DLASET, - $ XERBLA -C .. -C .. Intrinsic Functions .. - INTRINSIC MAX, SQRT -C .. -C .. Executable Statements .. -C -C Decode and Test input parameters. -C - M1 = M - NCON - M2 = NCON - NP1 = NP - NMEAS - NP2 = NMEAS -C - INFO = 0 - IF( N.LT.0 ) THEN - INFO = -1 - ELSE IF( M.LT.0 ) THEN - INFO = -2 - ELSE IF( NP.LT.0 ) THEN - INFO = -3 - ELSE IF( NCON.LT.0 .OR. M1.LT.0 .OR. M2.GT.NP1 ) THEN - INFO = -4 - ELSE IF( NMEAS.LT.0 .OR. NP1.LT.0 .OR. NP2.GT.M1 ) THEN - INFO = -5 - ELSE IF( LDD.LT.MAX( 1, NP ) ) THEN - INFO = -7 - ELSE IF( LDTU.LT.MAX( 1, M2 ) ) THEN - INFO = -9 - ELSE IF( LDTY.LT.MAX( 1, NP2 ) ) THEN - INFO = -11 - ELSE IF( LDAK.LT.MAX( 1, N ) ) THEN - INFO = -13 - ELSE IF( LDBK.LT.MAX( 1, N ) ) THEN - INFO = -15 - ELSE IF( LDCK.LT.MAX( 1, M2 ) ) THEN - INFO = -17 - ELSE IF( LDDK.LT.MAX( 1, M2 ) ) THEN - INFO = -19 - ELSE -C -C Compute workspace. -C - MINWRK = MAX ( N*M2, N*NP2, M2*NP2, M2*( M2 + 4 ) ) - IF( LDWORK.LT.MINWRK ) - $ INFO = -24 - END IF - IF( INFO.NE.0 ) THEN - CALL XERBLA( 'SB10TD', -INFO ) - RETURN - END IF -C -C Quick return if possible. -C - IF( N.EQ.0 .OR. M.EQ.0 .OR. NP.EQ.0 .OR. M1.EQ.0 .OR. M2.EQ.0 - $ .OR. NP1.EQ.0 .OR. NP2.EQ.0 ) THEN - RCOND = ONE - RETURN - END IF -C - TOLL = TOL - IF( TOLL.LE.ZERO ) THEN -C -C Set the default value of the tolerance for nonsingularity test. -C - TOLL = SQRT( DLAMCH( 'Epsilon' ) ) - END IF -C -C Find BKHAT . -C - CALL DGEMM( 'N', 'N', N, NP2, NP2, ONE, BK, LDBK, TY, LDTY, ZERO, - $ DWORK, N ) - CALL DLACPY ('Full', N, NP2, DWORK, N, BK, LDBK ) -C -C Find CKHAT . -C - CALL DGEMM( 'N', 'N', M2, N, M2, ONE, TU, LDTU, CK, LDCK, ZERO, - $ DWORK, M2 ) - CALL DLACPY ('Full', M2, N, DWORK, M2, CK, LDCK ) -C -C Compute DKHAT . -C - CALL DGEMM( 'N', 'N', M2, NP2, M2, ONE, TU, LDTU, DK, LDDK, ZERO, - $ DWORK, M2 ) - CALL DGEMM( 'N', 'N', M2, NP2, NP2, ONE, DWORK, M2, TY, LDTY, - $ ZERO, DK, LDDK ) -C -C Compute Im2 + DKHAT*D22 . -C - IWRK = M2*M2 + 1 - CALL DLASET( 'Full', M2, M2, ZERO, ONE, DWORK, M2 ) - CALL DGEMM( 'N', 'N', M2, M2, NP2, ONE, DK, LDDK, - $ D( NP1+1, M1+1 ), LDD, ONE, DWORK, M2 ) - ANORM = DLANGE( '1', M2, M2, DWORK, M2, DWORK( IWRK ) ) - CALL DGETRF( M2, M2, DWORK, M2, IWORK, INFO2 ) - IF( INFO2.GT.0 ) THEN - INFO = 1 - RETURN - END IF - CALL DGECON( '1', M2, DWORK, M2, ANORM, RCOND, DWORK( IWRK ), - $ IWORK( M2+1 ), INFO2 ) -C -C Return if the matrix is singular to working precision. -C - IF( RCOND.LT.TOLL ) THEN - INFO = 1 - RETURN - END IF -C -C Compute CK . -C - CALL DGETRS( 'N', M2, N, DWORK, M2, IWORK, CK, LDCK, INFO2 ) -C -C Compute DK . -C - CALL DGETRS( 'N', M2, NP2, DWORK, M2, IWORK, DK, LDDK, INFO2 ) -C -C Compute AK . -C - CALL DGEMM( 'N', 'N', N, M2, NP2, ONE, BK, LDBK, D( NP1+1, M1+1 ), - $ LDD, ZERO, DWORK, N ) - CALL DGEMM( 'N', 'N', N, N, M2, -ONE, DWORK, N, CK, LDCK, ONE, AK, - $ LDAK ) -C -C Compute BK . -C - CALL DGEMM( 'N', 'N', N, NP2, M2, -ONE, DWORK, N, DK, LDDK, - $ ONE, BK, LDBK ) - RETURN -C *** Last line of SB10TD *** - END diff --git a/mex/sources/libslicot/SB10UD.f b/mex/sources/libslicot/SB10UD.f deleted file mode 100644 index b5919d442..000000000 --- a/mex/sources/libslicot/SB10UD.f +++ /dev/null @@ -1,419 +0,0 @@ - SUBROUTINE SB10UD( N, M, NP, NCON, NMEAS, B, LDB, C, LDC, D, LDD, - $ TU, LDTU, TY, LDTY, RCOND, TOL, DWORK, LDWORK, - $ INFO ) -C -C SLICOT RELEASE 5.0. -C -C Copyright (c) 2002-2009 NICONET e.V. -C -C This program is free software: you can redistribute it and/or -C modify it under the terms of the GNU General Public License as -C published by the Free Software Foundation, either version 2 of -C the License, or (at your option) any later version. -C -C This program is distributed in the hope that it will be useful, -C but WITHOUT ANY WARRANTY; without even the implied warranty of -C MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the -C GNU General Public License for more details. -C -C You should have received a copy of the GNU General Public License -C along with this program. If not, see -C . -C -C PURPOSE -C -C To reduce the matrices D12 and D21 of the linear time-invariant -C system -C -C | A | B1 B2 | | A | B | -C P = |----|---------| = |---|---| -C | C1 | 0 D12 | | C | D | -C | C2 | D21 D22 | -C -C to unit diagonal form, and to transform the matrices B and C to -C satisfy the formulas in the computation of the H2 optimal -C controller. -C -C ARGUMENTS -C -C Input/Output Parameters -C -C N (input) INTEGER -C The order of the system. N >= 0. -C -C M (input) INTEGER -C The column size of the matrix B. M >= 0. -C -C NP (input) INTEGER -C The row size of the matrix C. NP >= 0. -C -C NCON (input) INTEGER -C The number of control inputs (M2). M >= NCON >= 0, -C NP-NMEAS >= NCON. -C -C NMEAS (input) INTEGER -C The number of measurements (NP2). NP >= NMEAS >= 0, -C M-NCON >= NMEAS. -C -C B (input/output) DOUBLE PRECISION array, dimension (LDB,M) -C On entry, the leading N-by-M part of this array must -C contain the system input matrix B. -C On exit, the leading N-by-M part of this array contains -C the transformed system input matrix B. -C -C LDB INTEGER -C The leading dimension of the array B. LDB >= max(1,N). -C -C C (input/output) DOUBLE PRECISION array, dimension (LDC,N) -C On entry, the leading NP-by-N part of this array must -C contain the system output matrix C. -C On exit, the leading NP-by-N part of this array contains -C the transformed system output matrix C. -C -C LDC INTEGER -C The leading dimension of the array C. LDC >= max(1,NP). -C -C D (input/output) DOUBLE PRECISION array, dimension (LDD,M) -C On entry, the leading NP-by-M part of this array must -C contain the system input/output matrix D. -C The (NP-NMEAS)-by-(M-NCON) leading submatrix D11 is not -C referenced. -C On exit, the trailing NMEAS-by-NCON part (in the leading -C NP-by-M part) of this array contains the transformed -C submatrix D22. -C The transformed submatrices D12 = [ 0 Im2 ]' and -C D21 = [ 0 Inp2 ] are not stored. The corresponding part -C of this array contains no useful information. -C -C LDD INTEGER -C The leading dimension of the array D. LDD >= max(1,NP). -C -C TU (output) DOUBLE PRECISION array, dimension (LDTU,M2) -C The leading M2-by-M2 part of this array contains the -C control transformation matrix TU. -C -C LDTU INTEGER -C The leading dimension of the array TU. LDTU >= max(1,M2). -C -C TY (output) DOUBLE PRECISION array, dimension (LDTY,NP2) -C The leading NP2-by-NP2 part of this array contains the -C measurement transformation matrix TY. -C -C LDTY INTEGER -C The leading dimension of the array TY. -C LDTY >= max(1,NP2). -C -C RCOND (output) DOUBLE PRECISION array, dimension (2) -C RCOND(1) contains the reciprocal condition number of the -C control transformation matrix TU; -C RCOND(2) contains the reciprocal condition number of the -C measurement transformation matrix TY. -C RCOND is set even if INFO = 1 or INFO = 2; if INFO = 1, -C then RCOND(2) was not computed, but it is set to 0. -C -C Tolerances -C -C TOL DOUBLE PRECISION -C Tolerance used for controlling the accuracy of the applied -C transformations. Transformation matrices TU and TY whose -C reciprocal condition numbers are less than TOL are not -C allowed. If TOL <= 0, then a default value equal to -C sqrt(EPS) is used, where EPS is the relative machine -C precision. -C -C Workspace -C -C DWORK DOUBLE PRECISION array, dimension (LDWORK) -C On exit, if INFO = 0, DWORK(1) contains the optimal -C LDWORK. -C -C LDWORK INTEGER -C The dimension of the array DWORK. -C LDWORK >= MAX( M2 + NP1*NP1 + MAX(NP1*N,3*M2+NP1,5*M2), -C NP2 + M1*M1 + MAX(M1*N,3*NP2+M1,5*NP2), -C N*M2, NP2*N, NP2*M2, 1 ) -C where M1 = M - M2 and NP1 = NP - NP2. -C For good performance, LDWORK must generally be larger. -C Denoting Q = MAX(M1,M2,NP1,NP2), an upper bound is -C MAX(1,Q*(Q+MAX(N,5)+1)). -C -C Error Indicator -C -C INFO INTEGER -C = 0: successful exit; -C < 0: if INFO = -i, the i-th argument had an illegal -C value; -C = 1: if the matrix D12 had not full column rank in -C respect to the tolerance TOL; -C = 2: if the matrix D21 had not full row rank in respect -C to the tolerance TOL; -C = 3: if the singular value decomposition (SVD) algorithm -C did not converge (when computing the SVD of D12 or -C D21). -C -C METHOD -C -C The routine performs the transformations described in [1], [2]. -C -C REFERENCES -C -C [1] Zhou, K., Doyle, J.C., and Glover, K. -C Robust and Optimal Control. -C Prentice-Hall, Upper Saddle River, NJ, 1996. -C -C [2] Balas, G.J., Doyle, J.C., Glover, K., Packard, A., and -C Smith, R. -C mu-Analysis and Synthesis Toolbox. -C The MathWorks Inc., Natick, Mass., 1995. -C -C NUMERICAL ASPECTS -C -C The precision of the transformations can be controlled by the -C condition numbers of the matrices TU and TY as given by the -C values of RCOND(1) and RCOND(2), respectively. An error return -C with INFO = 1 or INFO = 2 will be obtained if the condition -C number of TU or TY, respectively, would exceed 1/TOL. -C -C CONTRIBUTORS -C -C P.Hr. Petkov, D.W. Gu and M.M. Konstantinov, October 1998. -C -C REVISIONS -C -C V. Sima, Research Institute for Informatics, Bucharest, May 1999, -C Feb. 2000. -C -C KEYWORDS -C -C Algebraic Riccati equation, H2 optimal control, LQG, LQR, optimal -C regulator, robust control. -C -C ****************************************************************** -C -C .. Parameters .. - DOUBLE PRECISION ZERO, ONE - PARAMETER ( ZERO = 0.0D+0, ONE = 1.0D+0 ) -C .. -C .. Scalar Arguments .. - INTEGER INFO, LDB, LDC, LDD, LDTU, LDTY, LDWORK, M, N, - $ NCON, NMEAS, NP - DOUBLE PRECISION TOL -C .. -C .. Array Arguments .. - DOUBLE PRECISION B( LDB, * ), C( LDC, * ), D( LDD, * ), - $ DWORK( * ), RCOND( 2 ), TU( LDTU, * ), - $ TY( LDTY, * ) -C .. -C .. Local Scalars .. - INTEGER INFO2, IQ, IWRK, J, LWAMAX, M1, M2, MINWRK, - $ ND1, ND2, NP1, NP2 - DOUBLE PRECISION TOLL -C .. -C .. External Functions - DOUBLE PRECISION DLAMCH - EXTERNAL DLAMCH -C .. -C .. External Subroutines .. - EXTERNAL DGEMM, DGESVD, DLACPY, DSCAL, DSWAP, XERBLA -C .. -C .. Intrinsic Functions .. - INTRINSIC DBLE, INT, MAX, SQRT -C .. -C .. Executable Statements .. -C -C Decode and Test input parameters. -C - M1 = M - NCON - M2 = NCON - NP1 = NP - NMEAS - NP2 = NMEAS -C - INFO = 0 - IF( N.LT.0 ) THEN - INFO = -1 - ELSE IF( M.LT.0 ) THEN - INFO = -2 - ELSE IF( NP.LT.0 ) THEN - INFO = -3 - ELSE IF( NCON.LT.0 .OR. M1.LT.0 .OR. M2.GT.NP1 ) THEN - INFO = -4 - ELSE IF( NMEAS.LT.0 .OR. NP1.LT.0 .OR. NP2.GT.M1 ) THEN - INFO = -5 - ELSE IF( LDB.LT.MAX( 1, N ) ) THEN - INFO = -7 - ELSE IF( LDC.LT.MAX( 1, NP ) ) THEN - INFO = -9 - ELSE IF( LDD.LT.MAX( 1, NP ) ) THEN - INFO = -11 - ELSE IF( LDTU.LT.MAX( 1, M2 ) ) THEN - INFO = -13 - ELSE IF( LDTY.LT.MAX( 1, NP2 ) ) THEN - INFO = -15 - ELSE -C -C Compute workspace. -C - MINWRK = MAX( 1, M2 + NP1*NP1 + MAX( NP1*N, 3*M2 + NP1, - $ 5*M2 ), - $ NP2 + M1*M1 + MAX( M1*N, 3*NP2 + M1, 5*NP2 ), - $ N*M2, NP2*N, NP2*M2 ) - IF( LDWORK.LT.MINWRK ) - $ INFO = -19 - END IF - IF( INFO.NE.0 ) THEN - CALL XERBLA( 'SB10UD', -INFO ) - RETURN - END IF -C -C Quick return if possible. -C - IF( N.EQ.0 .OR. M.EQ.0 .OR. NP.EQ.0 .OR. M1.EQ.0 .OR. M2.EQ.0 - $ .OR. NP1.EQ.0 .OR. NP2.EQ.0 ) THEN - RCOND( 1 ) = ONE - RCOND( 2 ) = ONE - DWORK( 1 ) = ONE - RETURN - END IF -C - ND1 = NP1 - M2 - ND2 = M1 - NP2 - TOLL = TOL - IF( TOLL.LE.ZERO ) THEN -C -C Set the default value of the tolerance for condition tests. -C - TOLL = SQRT( DLAMCH( 'Epsilon' ) ) - END IF -C -C Determine SVD of D12, D12 = U12 S12 V12', and check if D12 has -C full column rank. V12' is stored in TU. -C Workspace: need M2 + NP1*NP1 + max(3*M2+NP1,5*M2); -C prefer larger. -C - IQ = M2 + 1 - IWRK = IQ + NP1*NP1 -C - CALL DGESVD( 'A', 'A', NP1, M2, D( 1, M1+1 ), LDD, DWORK, - $ DWORK( IQ ), NP1, TU, LDTU, DWORK( IWRK ), - $ LDWORK-IWRK+1, INFO2 ) - IF( INFO2.NE.0 ) THEN - INFO = 3 - RETURN - END IF -C - RCOND( 1 ) = DWORK( M2 )/DWORK( 1 ) - IF( RCOND( 1 ).LE.TOLL ) THEN - RCOND( 2 ) = ZERO - INFO = 1 - RETURN - END IF - LWAMAX = INT( DWORK( IWRK ) ) + IWRK - 1 -C -C Determine Q12. -C - IF( ND1.GT.0 ) THEN - CALL DLACPY( 'Full', NP1, M2, DWORK( IQ ), NP1, D( 1, M1+1 ), - $ LDD ) - CALL DLACPY( 'Full', NP1, ND1, DWORK( IQ+NP1*M2 ), NP1, - $ DWORK( IQ ), NP1 ) - CALL DLACPY( 'Full', NP1, M2, D( 1, M1+1 ), LDD, - $ DWORK( IQ+NP1*ND1 ), NP1 ) - END IF -C -C Determine Tu by transposing in-situ and scaling. -C - DO 10 J = 1, M2 - 1 - CALL DSWAP( J, TU( J+1, 1 ), LDTU, TU( 1, J+1 ), 1 ) - 10 CONTINUE -C - DO 20 J = 1, M2 - CALL DSCAL( M2, ONE/DWORK( J ), TU( 1, J ), 1 ) - 20 CONTINUE -C -C Determine C1 =: Q12'*C1. -C Workspace: M2 + NP1*NP1 + NP1*N. -C - CALL DGEMM( 'T', 'N', NP1, N, NP1, ONE, DWORK( IQ ), NP1, C, LDC, - $ ZERO, DWORK( IWRK ), NP1 ) - CALL DLACPY( 'Full', NP1, N, DWORK( IWRK ), NP1, C, LDC ) - LWAMAX = MAX( IWRK + NP1*N - 1, LWAMAX ) -C -C Determine SVD of D21, D21 = U21 S21 V21', and check if D21 has -C full row rank. U21 is stored in TY. -C Workspace: need NP2 + M1*M1 + max(3*NP2+M1,5*NP2); -C prefer larger. -C - IQ = NP2 + 1 - IWRK = IQ + M1*M1 -C - CALL DGESVD( 'A', 'A', NP2, M1, D( NP1+1, 1 ), LDD, DWORK, TY, - $ LDTY, DWORK( IQ ), M1, DWORK( IWRK ), LDWORK-IWRK+1, - $ INFO2 ) - IF( INFO2.NE.0 ) THEN - INFO = 3 - RETURN - END IF -C - RCOND( 2 ) = DWORK( NP2 )/DWORK( 1 ) - IF( RCOND( 2 ).LE.TOLL ) THEN - INFO = 2 - RETURN - END IF - LWAMAX = MAX( INT( DWORK( IWRK ) ) + IWRK - 1, LWAMAX ) -C -C Determine Q21. -C - IF( ND2.GT.0 ) THEN - CALL DLACPY( 'Full', NP2, M1, DWORK( IQ ), M1, D( NP1+1, 1 ), - $ LDD ) - CALL DLACPY( 'Full', ND2, M1, DWORK( IQ+NP2 ), M1, DWORK( IQ ), - $ M1 ) - CALL DLACPY( 'Full', NP2, M1, D( NP1+1, 1 ), LDD, - $ DWORK( IQ+ND2 ), M1 ) - END IF -C -C Determine Ty by scaling and transposing in-situ. -C - DO 30 J = 1, NP2 - CALL DSCAL( NP2, ONE/DWORK( J ), TY( 1, J ), 1 ) - 30 CONTINUE -C - DO 40 J = 1, NP2 - 1 - CALL DSWAP( J, TY( J+1, 1 ), LDTY, TY( 1, J+1 ), 1 ) - 40 CONTINUE -C -C Determine B1 =: B1*Q21'. -C Workspace: NP2 + M1*M1 + N*M1. -C - CALL DGEMM( 'N', 'T', N, M1, M1, ONE, B, LDB, DWORK( IQ ), M1, - $ ZERO, DWORK( IWRK ), N ) - CALL DLACPY( 'Full', N, M1, DWORK( IWRK ), N, B, LDB ) - LWAMAX = MAX( IWRK + N*M1 - 1, LWAMAX ) -C -C Determine B2 =: B2*Tu. -C Workspace: N*M2. -C - CALL DGEMM( 'N', 'N', N, M2, M2, ONE, B( 1, M1+1 ), LDB, TU, LDTU, - $ ZERO, DWORK, N ) - CALL DLACPY( 'Full', N, M2, DWORK, N, B( 1, M1+1 ), LDB ) -C -C Determine C2 =: Ty*C2. -C Workspace: NP2*N. -C - CALL DGEMM( 'N', 'N', NP2, N, NP2, ONE, TY, LDTY, - $ C( NP1+1, 1 ), LDC, ZERO, DWORK, NP2 ) - CALL DLACPY( 'Full', NP2, N, DWORK, NP2, C( NP1+1, 1 ), LDC ) -C -C Determine D22 =: Ty*D22*Tu. -C Workspace: NP2*M2. -C - CALL DGEMM( 'N', 'N', NP2, M2, NP2, ONE, TY, LDTY, - $ D( NP1+1, M1+1 ), LDD, ZERO, DWORK, NP2 ) - CALL DGEMM( 'N', 'N', NP2, M2, M2, ONE, DWORK, NP2, TU, LDTU, - $ ZERO, D( NP1+1, M1+1 ), LDD ) -C - LWAMAX = MAX( N*MAX( M2, NP2 ), NP2*M2, LWAMAX ) - DWORK( 1 ) = DBLE( LWAMAX ) - RETURN -C *** Last line of SB10UD *** - END diff --git a/mex/sources/libslicot/SB10VD.f b/mex/sources/libslicot/SB10VD.f deleted file mode 100644 index 913a5ab29..000000000 --- a/mex/sources/libslicot/SB10VD.f +++ /dev/null @@ -1,393 +0,0 @@ - SUBROUTINE SB10VD( N, M, NP, NCON, NMEAS, A, LDA, B, LDB, C, LDC, - $ F, LDF, H, LDH, X, LDX, Y, LDY, XYCOND, IWORK, - $ DWORK, LDWORK, BWORK, INFO ) -C -C SLICOT RELEASE 5.0. -C -C Copyright (c) 2002-2009 NICONET e.V. -C -C This program is free software: you can redistribute it and/or -C modify it under the terms of the GNU General Public License as -C published by the Free Software Foundation, either version 2 of -C the License, or (at your option) any later version. -C -C This program is distributed in the hope that it will be useful, -C but WITHOUT ANY WARRANTY; without even the implied warranty of -C MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the -C GNU General Public License for more details. -C -C You should have received a copy of the GNU General Public License -C along with this program. If not, see -C . -C -C PURPOSE -C -C To compute the state feedback and the output injection -C matrices for an H2 optimal n-state controller for the system -C -C | A | B1 B2 | | A | B | -C P = |----|---------| = |---|---| -C | C1 | 0 D12 | | C | D | -C | C2 | D21 D22 | -C -C where B2 has as column size the number of control inputs (NCON) -C and C2 has as row size the number of measurements (NMEAS) being -C provided to the controller. -C -C It is assumed that -C -C (A1) (A,B2) is stabilizable and (C2,A) is detectable, -C -C (A2) D12 is full column rank with D12 = | 0 | and D21 is -C | I | -C full row rank with D21 = | 0 I | as obtained by the -C SLICOT Library routine SB10UD. Matrix D is not used -C explicitly. -C -C ARGUMENTS -C -C Input/Output Parameters -C -C N (input) INTEGER -C The order of the system. N >= 0. -C -C M (input) INTEGER -C The column size of the matrix B. M >= 0. -C -C NP (input) INTEGER -C The row size of the matrix C. NP >= 0. -C -C NCON (input) INTEGER -C The number of control inputs (M2). M >= NCON >= 0, -C NP-NMEAS >= NCON. -C -C NMEAS (input) INTEGER -C The number of measurements (NP2). NP >= NMEAS >= 0, -C M-NCON >= NMEAS. -C -C A (input) DOUBLE PRECISION array, dimension (LDA,N) -C The leading N-by-N part of this array must contain the -C system state matrix A. -C -C LDA INTEGER -C The leading dimension of the array A. LDA >= max(1,N). -C -C B (input) DOUBLE PRECISION array, dimension (LDB,M) -C The leading N-by-M part of this array must contain the -C system input matrix B. -C -C LDB INTEGER -C The leading dimension of the array B. LDB >= max(1,N). -C -C C (input) DOUBLE PRECISION array, dimension (LDC,N) -C The leading NP-by-N part of this array must contain the -C system output matrix C. -C -C LDC INTEGER -C The leading dimension of the array C. LDC >= max(1,NP). -C -C F (output) DOUBLE PRECISION array, dimension (LDF,N) -C The leading NCON-by-N part of this array contains the -C state feedback matrix F. -C -C LDF INTEGER -C The leading dimension of the array F. LDF >= max(1,NCON). -C -C H (output) DOUBLE PRECISION array, dimension (LDH,NMEAS) -C The leading N-by-NMEAS part of this array contains the -C output injection matrix H. -C -C LDH INTEGER -C The leading dimension of the array H. LDH >= max(1,N). -C -C X (output) DOUBLE PRECISION array, dimension (LDX,N) -C The leading N-by-N part of this array contains the matrix -C X, solution of the X-Riccati equation. -C -C LDX INTEGER -C The leading dimension of the array X. LDX >= max(1,N). -C -C Y (output) DOUBLE PRECISION array, dimension (LDY,N) -C The leading N-by-N part of this array contains the matrix -C Y, solution of the Y-Riccati equation. -C -C LDY INTEGER -C The leading dimension of the array Y. LDY >= max(1,N). -C -C XYCOND (output) DOUBLE PRECISION array, dimension (2) -C XYCOND(1) contains an estimate of the reciprocal condition -C number of the X-Riccati equation; -C XYCOND(2) contains an estimate of the reciprocal condition -C number of the Y-Riccati equation. -C -C Workspace -C -C IWORK INTEGER array, dimension max(2*N,N*N) -C -C DWORK DOUBLE PRECISION array, dimension (LDWORK) -C On exit, if INFO = 0, DWORK(1) contains the optimal -C LDWORK. -C -C LDWORK INTEGER -C The dimension of the array DWORK. -C LDWORK >= 13*N*N + 12*N + 5. -C For good performance, LDWORK must generally be larger. -C -C BWORK LOGICAL array, dimension (2*N) -C -C Error Indicator -C -C INFO INTEGER -C = 0: successful exit; -C < 0: if INFO = -i, the i-th argument had an illegal -C value; -C = 1: if the X-Riccati equation was not solved -C successfully; -C = 2: if the Y-Riccati equation was not solved -C successfully. -C -C METHOD -C -C The routine implements the formulas given in [1], [2]. The X- -C and Y-Riccati equations are solved with condition and accuracy -C estimates [3]. -C -C REFERENCES -C -C [1] Zhou, K., Doyle, J.C., and Glover, K. -C Robust and Optimal Control. -C Prentice-Hall, Upper Saddle River, NJ, 1996. -C -C [2] Balas, G.J., Doyle, J.C., Glover, K., Packard, A., and -C Smith, R. -C mu-Analysis and Synthesis Toolbox. -C The MathWorks Inc., Natick, Mass., 1995. -C -C [3] Petkov, P.Hr., Konstantinov, M.M., and Mehrmann, V. -C DGRSVX and DMSRIC: Fortan 77 subroutines for solving -C continuous-time matrix algebraic Riccati equations with -C condition and accuracy estimates. -C Preprint SFB393/98-16, Fak. f. Mathematik, Tech. Univ. -C Chemnitz, May 1998. -C -C NUMERICAL ASPECTS -C -C The precision of the solution of the matrix Riccati equations -C can be controlled by the values of the condition numbers -C XYCOND(1) and XYCOND(2) of these equations. -C -C FURTHER COMMENTS -C -C The Riccati equations are solved by the Schur approach -C implementing condition and accuracy estimates. -C -C CONTRIBUTORS -C -C P.Hr. Petkov, D.W. Gu and M.M. Konstantinov, October 1998. -C -C REVISIONS -C -C V. Sima, Research Institute for Informatics, Bucharest, May 1999. -C -C KEYWORDS -C -C Algebraic Riccati equation, H2 optimal control, LQG, LQR, optimal -C regulator, robust control. -C -C ****************************************************************** -C -C .. Parameters .. - DOUBLE PRECISION ZERO, ONE - PARAMETER ( ZERO = 0.0D+0, ONE = 1.0D+0 ) -C .. -C .. Scalar Arguments .. - INTEGER INFO, LDA, LDB, LDC, LDF, LDH, LDWORK, LDX, - $ LDY, M, N, NCON, NMEAS, NP -C .. -C .. Array Arguments .. - LOGICAL BWORK( * ) - INTEGER IWORK( * ) - DOUBLE PRECISION A( LDA, * ), B( LDB, * ), C( LDC, * ), - $ DWORK( * ), F( LDF, * ), H( LDH, * ), - $ X( LDX, * ), XYCOND( 2 ), Y( LDY, * ) -C .. -C .. Local Scalars .. - INTEGER INFO2, IWG, IWI, IWQ, IWR, IWRK, IWS, IWT, IWV, - $ LWAMAX, M1, M2, MINWRK, N2, ND1, ND2, NP1, NP2 - DOUBLE PRECISION FERR, SEP -C .. -C .. External Functions .. -C - DOUBLE PRECISION DLANSY - EXTERNAL DLANSY -C .. -C .. External Subroutines .. - EXTERNAL DGEMM, DLACPY, DLASET, DSYRK, SB02RD, XERBLA -C .. -C .. Intrinsic Functions .. - INTRINSIC DBLE, INT, MAX -C .. -C .. Executable Statements .. -C -C Decode and Test input parameters. -C - M1 = M - NCON - M2 = NCON - NP1 = NP - NMEAS - NP2 = NMEAS -C - INFO = 0 - IF( N.LT.0 ) THEN - INFO = -1 - ELSE IF( M.LT.0 ) THEN - INFO = -2 - ELSE IF( NP.LT.0 ) THEN - INFO = -3 - ELSE IF( NCON.LT.0 .OR. M1.LT.0 .OR. M2.GT.NP1 ) THEN - INFO = -4 - ELSE IF( NMEAS.LT.0 .OR. NP1.LT.0 .OR. NP2.GT.M1 ) THEN - INFO = -5 - ELSE IF( LDA.LT.MAX( 1, N ) ) THEN - INFO = -7 - ELSE IF( LDB.LT.MAX( 1, N ) ) THEN - INFO = -9 - ELSE IF( LDC.LT.MAX( 1, NP ) ) THEN - INFO = -11 - ELSE IF( LDF.LT.MAX( 1, NCON ) ) THEN - INFO = -13 - ELSE IF( LDH.LT.MAX( 1, N ) ) THEN - INFO = -15 - ELSE IF( LDX.LT.MAX( 1, N ) ) THEN - INFO = -17 - ELSE IF( LDY.LT.MAX( 1, N ) ) THEN - INFO = -19 - ELSE -C -C Compute workspace. -C - MINWRK = 13*N*N + 12*N + 5 - IF( LDWORK.LT.MINWRK ) - $ INFO = -23 - END IF - IF( INFO.NE.0 ) THEN - CALL XERBLA( 'SB10VD', -INFO ) - RETURN - END IF -C -C Quick return if possible. -C - IF( N.EQ.0 .OR. M.EQ.0 .OR. NP.EQ.0 .OR. M1.EQ.0 .OR. M2.EQ.0 - $ .OR. NP1.EQ.0 .OR. NP2.EQ.0 ) THEN - DWORK( 1 ) = ONE - XYCOND( 1 ) = ONE - XYCOND( 2 ) = ONE - RETURN - END IF -C - ND1 = NP1 - M2 - ND2 = M1 - NP2 - N2 = 2*N -C -C Workspace usage. -C - IWQ = N*N + 1 - IWG = IWQ + N*N - IWT = IWG + N*N - IWV = IWT + N*N - IWR = IWV + N*N - IWI = IWR + N2 - IWS = IWI + N2 - IWRK = IWS + 4*N*N -C -C Compute Ax = A - B2*D12'*C1 . -C - CALL DLACPY ('Full', N, N, A, LDA, DWORK, N ) - CALL DGEMM( 'N', 'N', N, N, M2, -ONE, B( 1, M1+1 ), LDB, - $ C( ND1+1, 1), LDC, ONE, DWORK, N ) -C -C Compute Cx = C1'*C1 - C1'*D12*D12'*C1 . -C - IF( ND1.GT.0 ) THEN - CALL DSYRK( 'L', 'T', N, ND1, ONE, C, LDC, ZERO, DWORK( IWQ ), - $ N ) - ELSE - CALL DLASET( 'L', N, N, ZERO, ZERO, DWORK( IWQ ), N ) - END IF -C -C Compute Dx = B2*B2' . -C - CALL DSYRK( 'L', 'N', N, M2, ONE, B( 1, M1+1 ), LDB, ZERO, - $ DWORK( IWG ), N ) -C -C Solution of the Riccati equation Ax'*X + X*Ax + Cx - X*Dx*X = 0 . -C Workspace: need 13*N*N + 12*N + 5; -C prefer larger. -C - CALL SB02RD( 'All', 'Continuous', 'NotUsed', 'NoTranspose', - $ 'Lower', 'GeneralScaling', 'Stable', 'NotFactored', - $ 'Original', N, DWORK, N, DWORK( IWT ), N, - $ DWORK( IWV ), N, DWORK( IWG ), N, DWORK( IWQ ), N, - $ X, LDX, SEP, XYCOND( 1 ), FERR, DWORK( IWR ), - $ DWORK( IWI ), DWORK( IWS ), N2, IWORK, - $ DWORK( IWRK ), LDWORK-IWRK+1, BWORK, INFO2 ) - IF( INFO2.GT.0 ) THEN - INFO = 1 - RETURN - END IF -C - LWAMAX = INT( DWORK( IWRK ) ) + IWRK - 1 -C -C Compute F = -D12'*C1 - B2'*X . -C - CALL DLACPY( 'Full', M2, N, C( ND1+1, 1 ), LDC, F, LDF ) - CALL DGEMM( 'T', 'N', M2, N, N, -ONE, B( 1, M1+1 ), LDB, X, LDX, - $ -ONE, F, LDF ) -C -C Compute Ay = A - B1*D21'*C2 . -C - CALL DLACPY( 'Full', N, N, A, LDA, DWORK, N ) - CALL DGEMM( 'N', 'N', N, N, NP2, -ONE, B( 1, ND2+1 ), LDB, - $ C( NP1+1, 1 ), LDC, ONE, DWORK, N ) -C -C Compute Cy = B1*B1' - B1*D21'*D21*B1' . -C - IF( ND2.GT.0 ) THEN - CALL DSYRK( 'U', 'N', N, ND2, ONE, B, LDB, ZERO, DWORK( IWQ ), - $ N ) - ELSE - CALL DLASET( 'U', N, N, ZERO, ZERO, DWORK( IWQ ), N ) - END IF -C -C Compute Dy = C2'*C2 . -C - CALL DSYRK( 'U', 'T', N, NP2, ONE, C( NP1+1, 1 ), LDC, ZERO, - $ DWORK( IWG ), N ) -C -C Solution of the Riccati equation Ay*Y + Y*Ay' + Cy - Y*Dy*Y = 0 . -C Workspace: need 13*N*N + 12*N + 5; -C prefer larger. -C - CALL SB02RD( 'All', 'Continuous', 'NotUsed', 'Transpose', - $ 'Upper', 'GeneralScaling', 'Stable', 'NotFactored', - $ 'Original', N, DWORK, N, DWORK( IWT ), N, - $ DWORK( IWV ), N, DWORK( IWG ), N, DWORK( IWQ ), N, - $ Y, LDY, SEP, XYCOND( 2 ), FERR, DWORK( IWR ), - $ DWORK( IWI ), DWORK( IWS ), N2, IWORK, - $ DWORK( IWRK ), LDWORK-IWRK+1, BWORK, INFO2 ) - IF( INFO2.GT.0 ) THEN - INFO = 2 - RETURN - END IF -C - LWAMAX = MAX( INT( DWORK( IWRK ) ) + IWRK - 1, LWAMAX ) -C -C Compute H = -B1*D21' - Y*C2' . -C - CALL DLACPY( 'Full', N, NP2, B( 1, ND2+1 ), LDB, H, LDH ) - CALL DGEMM( 'N', 'T', N, NP2, N, -ONE, Y, LDY, C( NP1+1, 1 ), LDC, - $ -ONE, H, LDH ) -C - DWORK( 1 ) = DBLE( LWAMAX ) - RETURN -C *** Last line of SB10VD *** - END diff --git a/mex/sources/libslicot/SB10WD.f b/mex/sources/libslicot/SB10WD.f deleted file mode 100644 index e2f37b2f3..000000000 --- a/mex/sources/libslicot/SB10WD.f +++ /dev/null @@ -1,299 +0,0 @@ - SUBROUTINE SB10WD( N, M, NP, NCON, NMEAS, A, LDA, B, LDB, C, LDC, - $ D, LDD, F, LDF, H, LDH, TU, LDTU, TY, LDTY, - $ AK, LDAK, BK, LDBK, CK, LDCK, DK, LDDK, INFO ) -C -C SLICOT RELEASE 5.0. -C -C Copyright (c) 2002-2009 NICONET e.V. -C -C This program is free software: you can redistribute it and/or -C modify it under the terms of the GNU General Public License as -C published by the Free Software Foundation, either version 2 of -C the License, or (at your option) any later version. -C -C This program is distributed in the hope that it will be useful, -C but WITHOUT ANY WARRANTY; without even the implied warranty of -C MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the -C GNU General Public License for more details. -C -C You should have received a copy of the GNU General Public License -C along with this program. If not, see -C . -C -C PURPOSE -C -C To compute the matrices of the H2 optimal controller -C -C | AK | BK | -C K = |----|----|, -C | CK | DK | -C -C from the state feedback matrix F and output injection matrix H as -C determined by the SLICOT Library routine SB10VD. -C -C ARGUMENTS -C -C Input/Output Parameters -C -C N (input) INTEGER -C The order of the system. N >= 0. -C -C M (input) INTEGER -C The column size of the matrix B. M >= 0. -C -C NP (input) INTEGER -C The row size of the matrix C. NP >= 0. -C -C NCON (input) INTEGER -C The number of control inputs (M2). M >= NCON >= 0. -C NP-NMEAS >= NCON. -C -C NMEAS (input) INTEGER -C The number of measurements (NP2). NP >= NMEAS >= 0. -C M-NCON >= NMEAS. -C -C A (input) DOUBLE PRECISION array, dimension (LDA,N) -C The leading N-by-N part of this array must contain the -C system state matrix A. -C -C LDA INTEGER -C The leading dimension of the array A. LDA >= max(1,N). -C -C B (input) DOUBLE PRECISION array, dimension (LDB,M) -C The leading N-by-M part of this array must contain the -C system input matrix B. Only the submatrix -C B2 = B(:,M-M2+1:M) is used. -C -C LDB INTEGER -C The leading dimension of the array B. LDB >= max(1,N). -C -C C (input) DOUBLE PRECISION array, dimension (LDC,N) -C The leading NP-by-N part of this array must contain the -C system output matrix C. Only the submatrix -C C2 = C(NP-NP2+1:NP,:) is used. -C -C LDC INTEGER -C The leading dimension of the array C. LDC >= max(1,NP). -C -C D (input) DOUBLE PRECISION array, dimension (LDD,M) -C The leading NP-by-M part of this array must contain the -C system input/output matrix D. Only the submatrix -C D22 = D(NP-NP2+1:NP,M-M2+1:M) is used. -C -C LDD INTEGER -C The leading dimension of the array D. LDD >= max(1,NP). -C -C F (input) DOUBLE PRECISION array, dimension (LDF,N) -C The leading NCON-by-N part of this array must contain the -C state feedback matrix F. -C -C LDF INTEGER -C The leading dimension of the array F. LDF >= max(1,NCON). -C -C H (input) DOUBLE PRECISION array, dimension (LDH,NMEAS) -C The leading N-by-NMEAS part of this array must contain the -C output injection matrix H. -C -C LDH INTEGER -C The leading dimension of the array H. LDH >= max(1,N). -C -C TU (input) DOUBLE PRECISION array, dimension (LDTU,M2) -C The leading M2-by-M2 part of this array must contain the -C control transformation matrix TU, as obtained by the -C SLICOT Library routine SB10UD. -C -C LDTU INTEGER -C The leading dimension of the array TU. LDTU >= max(1,M2). -C -C TY (input) DOUBLE PRECISION array, dimension (LDTY,NP2) -C The leading NP2-by-NP2 part of this array must contain the -C measurement transformation matrix TY, as obtained by the -C SLICOT Library routine SB10UD. -C -C LDTY INTEGER -C The leading dimension of the array TY. -C LDTY >= max(1,NP2). -C -C AK (output) DOUBLE PRECISION array, dimension (LDAK,N) -C The leading N-by-N part of this array contains the -C controller state matrix AK. -C -C LDAK INTEGER -C The leading dimension of the array AK. LDAK >= max(1,N). -C -C BK (output) DOUBLE PRECISION array, dimension (LDBK,NMEAS) -C The leading N-by-NMEAS part of this array contains the -C controller input matrix BK. -C -C LDBK INTEGER -C The leading dimension of the array BK. LDBK >= max(1,N). -C -C CK (output) DOUBLE PRECISION array, dimension (LDCK,N) -C The leading NCON-by-N part of this array contains the -C controller output matrix CK. -C -C LDCK INTEGER -C The leading dimension of the array CK. -C LDCK >= max(1,NCON). -C -C DK (output) DOUBLE PRECISION array, dimension (LDDK,NMEAS) -C The leading NCON-by-NMEAS part of this array contains the -C controller input/output matrix DK. -C -C LDDK INTEGER -C The leading dimension of the array DK. -C LDDK >= max(1,NCON). -C -C Error Indicator -C -C INFO INTEGER -C = 0: successful exit; -C < 0: if INFO = -i, the i-th argument had an illegal -C value. -C -C METHOD -C -C The routine implements the formulas given in [1], [2]. -C -C REFERENCES -C -C [1] Zhou, K., Doyle, J.C., and Glover, K. -C Robust and Optimal Control. -C Prentice-Hall, Upper Saddle River, NJ, 1996. -C -C [2] Balas, G.J., Doyle, J.C., Glover, K., Packard, A., and -C Smith, R. -C mu-Analysis and Synthesis Toolbox. -C The MathWorks Inc., Natick, Mass., 1995. -C -C NUMERICAL ASPECTS -C -C The accuracy of the result depends on the condition numbers of the -C input and output transformations. -C -C CONTRIBUTORS -C -C P.Hr. Petkov, D.W. Gu and M.M. Konstantinov, October 1998. -C -C REVISIONS -C -C V. Sima, Research Institute for Informatics, Bucharest, May 1999. -C -C KEYWORDS -C -C Algebraic Riccati equation, H2 optimal control, LQG, LQR, optimal -C regulator, robust control. -C -C ****************************************************************** -C -C .. Parameters .. - DOUBLE PRECISION ZERO, ONE - PARAMETER ( ZERO = 0.0D+0, ONE = 1.0D+0 ) -C .. -C .. Scalar Arguments .. - INTEGER INFO, LDA, LDAK, LDB, LDBK, LDC, LDCK, LDD, - $ LDDK, LDF, LDH, LDTU, LDTY, M, N, NCON, NMEAS, - $ NP -C .. -C .. Array Arguments .. - DOUBLE PRECISION A( LDA, * ), AK( LDAK, * ), B( LDB, * ), - $ BK( LDBK, * ), C( LDC, * ), CK( LDCK, * ), - $ D( LDD, * ), DK( LDDK, * ), F( LDF, * ), - $ H( LDH, * ), TU( LDTU, * ), TY( LDTY, * ) -C .. -C .. Local Scalars .. - INTEGER M1, M2, NP1, NP2 -C .. -C .. External Subroutines .. - EXTERNAL DGEMM, DLACPY, DLASET, XERBLA -C .. -C .. Intrinsic Functions .. - INTRINSIC MAX -C .. -C .. Executable Statements .. -C -C Decode and Test input parameters. -C - M1 = M - NCON - M2 = NCON - NP1 = NP - NMEAS - NP2 = NMEAS -C - INFO = 0 - IF( N.LT.0 ) THEN - INFO = -1 - ELSE IF( M.LT.0 ) THEN - INFO = -2 - ELSE IF( NP.LT.0 ) THEN - INFO = -3 - ELSE IF( NCON.LT.0 .OR. M1.LT.0 .OR. M2.GT.NP1 ) THEN - INFO = -4 - ELSE IF( NMEAS.LT.0 .OR. NP1.LT.0 .OR. NP2.GT.M1 ) THEN - INFO = -5 - ELSE IF( LDA.LT.MAX( 1, N ) ) THEN - INFO = -7 - ELSE IF( LDB.LT.MAX( 1, N ) ) THEN - INFO = -9 - ELSE IF( LDC.LT.MAX( 1, NP ) ) THEN - INFO = -11 - ELSE IF( LDD.LT.MAX( 1, NP ) ) THEN - INFO = -13 - ELSE IF( LDF.LT.MAX( 1, M2 ) ) THEN - INFO = -15 - ELSE IF( LDH.LT.MAX( 1, N ) ) THEN - INFO = -17 - ELSE IF( LDTU.LT.MAX( 1, M2 ) ) THEN - INFO = -19 - ELSE IF( LDTY.LT.MAX( 1, NP2 ) ) THEN - INFO = -21 - ELSE IF( LDAK.LT.MAX( 1, N ) ) THEN - INFO = -23 - ELSE IF( LDBK.LT.MAX( 1, N ) ) THEN - INFO = -25 - ELSE IF( LDCK.LT.MAX( 1, M2 ) ) THEN - INFO = -27 - ELSE IF( LDDK.LT.MAX( 1, M2 ) ) THEN - INFO = -29 - END IF - IF( INFO.NE.0 ) THEN - CALL XERBLA( 'SB10WD', -INFO ) - RETURN - END IF -C -C Quick return if possible. -C - IF( N.EQ.0 .OR. M.EQ.0 .OR. NP.EQ.0 .OR. M1.EQ.0 .OR. M2.EQ.0 - $ .OR. NP1.EQ.0 .OR. NP2.EQ.0 ) RETURN -C -C Compute the transpose of D22*F . BK is used as workspace. -C - CALL DGEMM( 'T', 'T', N, NP2, M2, ONE, F, LDF, D( NP1+1, M1+1 ), - $ LDD, ZERO, BK, LDBK ) -C -C Find AK = A + H*C2 + B2*F + H*D22*F . -C - CALL DLACPY( 'Full', N, N, A, LDA, AK, LDAK ) - CALL DGEMM( 'N', 'N', N, N, NP2, ONE, H, LDH, C( NP1+1, 1 ), LDC, - $ ONE, AK, LDAK ) - CALL DGEMM( 'N', 'N', N, N, M2, ONE, B( 1, M1+1 ), LDB, - $ F, LDF, ONE, AK, LDAK ) - CALL DGEMM( 'N', 'T', N, N, NP2, ONE, H, LDH, BK, LDBK, ONE, AK, - $ LDAK ) -C -C Find BK = -H*Ty . -C - CALL DGEMM( 'N', 'N', N, NP2, NP2, -ONE, H, LDH, TY, LDTY, ZERO, - $ BK, LDBK ) -C -C Find CK = Tu*F . -C - CALL DGEMM( 'N', 'N', M2, N, M2, ONE, TU, LDTU, F, LDF, ZERO, CK, - $ LDCK ) -C -C Find DK . -C - CALL DLASET( 'Full', M2, NP2, ZERO, ZERO, DK, LDDK ) -C - RETURN -C *** Last line of SB10WD *** - END diff --git a/mex/sources/libslicot/SB10YD.f b/mex/sources/libslicot/SB10YD.f deleted file mode 100644 index fa84e9f01..000000000 --- a/mex/sources/libslicot/SB10YD.f +++ /dev/null @@ -1,689 +0,0 @@ - SUBROUTINE SB10YD( DISCFL, FLAG, LENDAT, RFRDAT, IFRDAT, OMEGA, N, - $ A, LDA, B, C, D, TOL, IWORK, DWORK, LDWORK, - $ ZWORK, LZWORK, INFO ) -C -C SLICOT RELEASE 5.0. -C -C Copyright (c) 2002-2009 NICONET e.V. -C -C This program is free software: you can redistribute it and/or -C modify it under the terms of the GNU General Public License as -C published by the Free Software Foundation, either version 2 of -C the License, or (at your option) any later version. -C -C This program is distributed in the hope that it will be useful, -C but WITHOUT ANY WARRANTY; without even the implied warranty of -C MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the -C GNU General Public License for more details. -C -C You should have received a copy of the GNU General Public License -C along with this program. If not, see -C . -C -C PURPOSE -C -C To fit a supplied frequency response data with a stable, minimum -C phase SISO (single-input single-output) system represented by its -C matrices A, B, C, D. It handles both discrete- and continuous-time -C cases. -C -C ARGUMENTS -C -C Input/Output parameters -C -C DISCFL (input) INTEGER -C Indicates the type of the system, as follows: -C = 0: continuous-time system; -C = 1: discrete-time system. -C -C FLAG (input) INTEGER -C If FLAG = 0, then the system zeros and poles are not -C constrained. -C If FLAG = 1, then the system zeros and poles will have -C negative real parts in the continuous-time case, or moduli -C less than 1 in the discrete-time case. Consequently, FLAG -C must be equal to 1 in mu-synthesis routines. -C -C LENDAT (input) INTEGER -C The length of the vectors RFRDAT, IFRDAT and OMEGA. -C LENDAT >= 2. -C -C RFRDAT (input) DOUBLE PRECISION array, dimension (LENDAT) -C The real part of the frequency data to be fitted. -C -C IFRDAT (input) DOUBLE PRECISION array, dimension (LENDAT) -C The imaginary part of the frequency data to be fitted. -C -C OMEGA (input) DOUBLE PRECISION array, dimension (LENDAT) -C The frequencies corresponding to RFRDAT and IFRDAT. -C These values must be nonnegative and monotonically -C increasing. Additionally, for discrete-time systems -C they must be between 0 and PI. -C -C N (input/output) INTEGER -C On entry, the desired order of the system to be fitted. -C N <= LENDAT-1. -C On exit, the order of the obtained system. The value of N -C could only be modified if N > 0 and FLAG = 1. -C -C A (output) DOUBLE PRECISION array, dimension (LDA,N) -C The leading N-by-N part of this array contains the -C matrix A. If FLAG = 1, then A is in an upper Hessenberg -C form, and corresponds to a minimal realization. -C -C LDA INTEGER -C The leading dimension of the array A. LDA >= MAX(1,N). -C -C B (output) DOUBLE PRECISION array, dimension (N) -C The computed vector B. -C -C C (output) DOUBLE PRECISION array, dimension (N) -C The computed vector C. If FLAG = 1, the first N-1 elements -C are zero (for the exit value of N). -C -C D (output) DOUBLE PRECISION array, dimension (1) -C The computed scalar D. -C -C Tolerances -C -C TOL DOUBLE PRECISION -C The tolerance to be used for determining the effective -C rank of matrices. If the user sets TOL > 0, then the given -C value of TOL is used as a lower bound for the reciprocal -C condition number; a (sub)matrix whose estimated condition -C number is less than 1/TOL is considered to be of full -C rank. If the user sets TOL <= 0, then an implicitly -C computed, default tolerance, defined by TOLDEF = SIZE*EPS, -C is used instead, where SIZE is the product of the matrix -C dimensions, and EPS is the machine precision (see LAPACK -C Library routine DLAMCH). -C -C Workspace -C -C IWORK INTEGER array, dimension max(2,2*N+1) -C -C DWORK DOUBLE PRECISION array, dimension (LDWORK) -C On exit, if INFO = 0, DWORK(1) returns the optimal value -C of LDWORK and DWORK(2) contains the optimal value of -C LZWORK. -C -C LDWORK INTEGER -C The length of the array DWORK. -C LDWORK = max( 2, LW1, LW2, LW3, LW4 ), where -C LW1 = 2*LENDAT + 4*HNPTS; HNPTS = 2048; -C LW2 = LENDAT + 6*HNPTS; -C MN = min( 2*LENDAT, 2*N+1 ) -C LW3 = 2*LENDAT*(2*N+1) + max( 2*LENDAT, 2*N+1 ) + -C max( MN + 6*N + 4, 2*MN + 1 ), if N > 0; -C LW3 = 4*LENDAT + 5 , if N = 0; -C LW4 = max( N*N + 5*N, 6*N + 1 + min( 1,N ) ), if FLAG = 1; -C LW4 = 0, if FLAG = 0. -C For optimum performance LDWORK should be larger. -C -C ZWORK COMPLEX*16 array, dimension (LZWORK) -C -C LZWORK INTEGER -C The length of the array ZWORK. -C LZWORK = LENDAT*(2*N+3), if N > 0; -C LZWORK = LENDAT, if N = 0. -C -C Error indicator -C -C INFO INTEGER -C = 0: successful exit; -C < 0: if INFO = -i, the i-th argument had an illegal -C value; -C = 1: if the discrete --> continuous transformation cannot -C be made; -C = 2: if the system poles cannot be found; -C = 3: if the inverse system cannot be found, i.e., D is -C (close to) zero; -C = 4: if the system zeros cannot be found; -C = 5: if the state-space representation of the new -C transfer function T(s) cannot be found; -C = 6: if the continuous --> discrete transformation cannot -C be made. -C -C METHOD -C -C First, if the given frequency data are corresponding to a -C continuous-time system, they are changed to a discrete-time -C system using a bilinear transformation with a scaled alpha. -C Then, the magnitude is obtained from the supplied data. -C Then, the frequency data are linearly interpolated around -C the unit-disc. -C Then, Oppenheim and Schafer complex cepstrum method is applied -C to get frequency data corresponding to a stable, minimum- -C phase system. This is done in the following steps: -C - Obtain LOG (magnitude) -C - Obtain IFFT of the result (DG01MD SLICOT subroutine); -C - halve the data at 0; -C - Obtain FFT of the halved data (DG01MD SLICOT subroutine); -C - Obtain EXP of the result. -C Then, the new frequency data are interpolated back to the -C original frequency. -C Then, based on these newly obtained data, the system matrices -C A, B, C, D are constructed; the very identification is -C performed by Least Squares Method using DGELSY LAPACK subroutine. -C If needed, a discrete-to-continuous time transformation is -C applied on the system matrices by AB04MD SLICOT subroutine. -C Finally, if requested, the poles and zeros of the system are -C checked. If some of them have positive real parts in the -C continuous-time case (or are not inside the unit disk in the -C complex plane in the discrete-time case), they are exchanged with -C their negatives (or reciprocals, respectively), to preserve the -C frequency response, while getting a minimum phase and stable -C system. This is done by SB10ZP SLICOT subroutine. -C -C REFERENCES -C -C [1] Oppenheim, A.V. and Schafer, R.W. -C Discrete-Time Signal Processing. -C Prentice-Hall Signal Processing Series, 1989. -C -C [2] Balas, G., Doyle, J., Glover, K., Packard, A., and Smith, R. -C Mu-analysis and Synthesis toolbox - User's Guide, -C The Mathworks Inc., Natick, MA, USA, 1998. -C -C CONTRIBUTORS -C -C Asparuh Markovski, Technical University of Sofia, July 2003. -C -C REVISIONS -C -C V. Sima, Research Institute for Informatics, Bucharest, Aug. 2003. -C A. Markovski, Technical University of Sofia, October 2003. -C -C KEYWORDS -C -C Bilinear transformation, frequency response, least-squares -C approximation, stability. -C -C ****************************************************************** -C -C .. Parameters .. - COMPLEX*16 ZZERO, ZONE - PARAMETER ( ZZERO = ( 0.0D+0, 0.0D+0 ), - $ ZONE = ( 1.0D+0, 0.0D+0 ) ) - DOUBLE PRECISION ZERO, ONE, TWO, FOUR, TEN - PARAMETER ( ZERO = 0.0D+0, ONE = 1.0D+0, TWO = 2.0D+0, - $ FOUR = 4.0D+0, TEN = 1.0D+1 ) - INTEGER HNPTS - PARAMETER ( HNPTS = 2048 ) -C .. -C .. Scalar Arguments .. - INTEGER DISCFL, FLAG, INFO, LDA, LDWORK, LENDAT, - $ LZWORK, N - DOUBLE PRECISION TOL -C .. -C .. Array Arguments .. - INTEGER IWORK(*) - DOUBLE PRECISION A(LDA, *), B(*), C(*), D(*), DWORK(*), - $ IFRDAT(*), OMEGA(*), RFRDAT(*) - COMPLEX*16 ZWORK(*) -C .. -C .. Local Scalars .. - INTEGER CLWMAX, DLWMAX, I, II, INFO2, IP1, IP2, ISTART, - $ ISTOP, IWA0, IWAB, IWBMAT, IWBP, IWBX, IWDME, - $ IWDOMO, IWMAG, IWS, IWVAR, IWXI, IWXR, IWYMAG, - $ K, LW1, LW2, LW3, LW4, MN, N1, N2, P, RANK - DOUBLE PRECISION P1, P2, PI, PW, RAT, TOLB, TOLL - COMPLEX*16 XHAT(HNPTS/2) -C .. -C .. External Functions .. - DOUBLE PRECISION DLAMCH, DLAPY2 - EXTERNAL DLAMCH, DLAPY2 -C .. -C .. External Subroutines .. - EXTERNAL AB04MD, DCOPY, DG01MD, DGELSY, DLASET, DSCAL, - $ SB10ZP, XERBLA -C .. -C .. Intrinsic Functions .. - INTRINSIC ACOS, ATAN, COS, DBLE, DCMPLX, DIMAG, EXP, LOG, - $ MAX, MIN, SIN, SQRT -C -C Test input parameters and workspace. -C - PI = FOUR*ATAN( ONE ) - PW = OMEGA(1) - N1 = N + 1 - N2 = N + N1 -C - INFO = 0 - IF( DISCFL.NE.0 .AND. DISCFL.NE.1 ) THEN - INFO = -1 - ELSE IF( FLAG.NE.0 .AND. FLAG.NE.1 ) THEN - INFO = -2 - ELSE IF ( LENDAT.LT.2 ) THEN - INFO = -3 - ELSE IF ( PW.LT.ZERO ) THEN - INFO = -6 - ELSE IF( N.GT.LENDAT - 1 ) THEN - INFO = -7 - ELSE IF( LDA.LT.MAX( 1, N ) ) THEN - INFO = -9 - ELSE -C - DO 10 K = 2, LENDAT - IF ( OMEGA(K).LT.PW ) - $ INFO = -6 - PW = OMEGA(K) - 10 CONTINUE -C - IF ( DISCFL.EQ.1 .AND. OMEGA(LENDAT).GT.PI ) - $ INFO = -6 - END IF -C - IF ( INFO.EQ.0 ) THEN -C -C Workspace. -C - LW1 = 2*LENDAT + 4*HNPTS - LW2 = LENDAT + 6*HNPTS - MN = MIN( 2*LENDAT, N2 ) -C - IF ( N.GT.0 ) THEN - LW3 = 2*LENDAT*N2 + MAX( 2*LENDAT, N2 ) + - $ MAX( MN + 6*N + 4, 2*MN + 1 ) - ELSE - LW3 = 4*LENDAT + 5 - END IF -C - IF ( FLAG.EQ.0 ) THEN - LW4 = 0 - ELSE - LW4 = MAX( N*N + 5*N, 6*N + 1 + MIN ( 1, N ) ) - END IF -C - DLWMAX = MAX( 2, LW1, LW2, LW3, LW4 ) -C - IF ( N.GT.0 ) THEN - CLWMAX = LENDAT*( N2 + 2 ) - ELSE - CLWMAX = LENDAT - END IF -C - IF ( LDWORK.LT.DLWMAX ) THEN - INFO = -16 - ELSE IF ( LZWORK.LT.CLWMAX ) THEN - INFO = -18 - END IF - END IF -C - IF ( INFO.NE.0 ) THEN -C -C Error return. -C - CALL XERBLA( 'SB10YD', -INFO ) - RETURN - END IF -C -C Set tolerances. -C - TOLB = DLAMCH( 'Epsilon' ) - TOLL = TOL - IF ( TOLL.LE.ZERO ) - $ TOLL = FOUR*DBLE( LENDAT*N )*TOLB -C -C @@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@ -C -C Workspace usage 1. -C Workspace: need 2*LENDAT + 4*HNPTS. -C - IWDOMO = 1 - IWDME = IWDOMO + LENDAT - IWYMAG = IWDME + 2*HNPTS - IWMAG = IWYMAG + 2*HNPTS -C -C Bilinear transformation. -C - IF ( DISCFL.EQ.0 ) THEN - PW = SQRT( OMEGA(1)*OMEGA(LENDAT) + SQRT( TOLB ) ) -C - DO 20 K = 1, LENDAT - DWORK(IWDME+K-1) = ( OMEGA(K)/PW )**2 - DWORK(IWDOMO+K-1) = - $ ACOS( ( ONE - DWORK(IWDME+K-1) )/ - $ ( ONE + DWORK(IWDME+K-1) ) ) - 20 CONTINUE -C - ELSE - CALL DCOPY( LENDAT, OMEGA, 1, DWORK(IWDOMO), 1 ) - END IF -C -C Linear interpolation. -C - DO 30 K = 1, LENDAT - DWORK(IWMAG+K-1) = DLAPY2( RFRDAT(K), IFRDAT(K) ) - DWORK(IWMAG+K-1) = ( ONE/LOG( TEN ) ) * LOG( DWORK(IWMAG+K-1) ) - 30 CONTINUE -C - DO 40 K = 1, HNPTS - DWORK(IWDME+K-1) = ( K - 1 )*PI/HNPTS - DWORK(IWYMAG+K-1) = ZERO -C - IF ( DWORK(IWDME+K-1).LT.DWORK(IWDOMO) ) THEN - DWORK(IWYMAG+K-1) = DWORK(IWMAG) - ELSE IF ( DWORK(IWDME+K-1).GE.DWORK(IWDOMO+LENDAT-1) ) THEN - DWORK(IWYMAG+K-1) = DWORK(IWMAG+LENDAT-1) - END IF -C - 40 CONTINUE -C - DO 60 I = 2, LENDAT - P1 = HNPTS*DWORK(IWDOMO+I-2)/PI + ONE -C - IP1 = INT( P1 ) - IF ( DBLE( IP1 ).NE.P1 ) - $ IP1 = IP1 + 1 -C - P2 = HNPTS*DWORK(IWDOMO+I-1)/PI + ONE -C - IP2 = INT( P2 ) - IF ( DBLE( IP2 ).NE.P2 ) - $ IP2 = IP2 + 1 -C - DO 50 P = IP1, IP2 - 1 - RAT = DWORK(IWDME+P-1) - DWORK(IWDOMO+I-2) - RAT = RAT/( DWORK(IWDOMO+I-1) - DWORK(IWDOMO+I-2) ) - DWORK(IWYMAG+P-1) = ( ONE - RAT )*DWORK(IWMAG+I-2) + - $ RAT*DWORK(IWMAG+I-1) - 50 CONTINUE -C - 60 CONTINUE -C - DO 70 K = 1, HNPTS - DWORK(IWYMAG+K-1) = EXP( LOG( TEN )*DWORK(IWYMAG+K-1) ) - 70 CONTINUE -C -C Duplicate data around disc. -C - DO 80 K = 1, HNPTS - DWORK(IWDME+HNPTS+K-1) = TWO*PI - DWORK(IWDME+HNPTS-K) - DWORK(IWYMAG+HNPTS+K-1) = DWORK(IWYMAG+HNPTS-K) - 80 CONTINUE -C -C Complex cepstrum to get min phase: -C LOG (Magnitude) -C - DO 90 K = 1, 2*HNPTS - DWORK(IWYMAG+K-1) = TWO*LOG( DWORK(IWYMAG+K-1) ) - 90 CONTINUE -C -C @@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@ -C -C Workspace usage 2. -C Workspace: need LENDAT + 6*HNPTS. -C - IWXR = IWYMAG - IWXI = IWMAG -C - DO 100 K = 1, 2*HNPTS - DWORK(IWXI+K-1) = ZERO - 100 CONTINUE -C -C IFFT -C - CALL DG01MD( 'I', 2*HNPTS, DWORK(IWXR), DWORK(IWXI), INFO2 ) -C -C Rescale, because DG01MD doesn't do it. -C - CALL DSCAL( HNPTS, ONE/( TWO*HNPTS ), DWORK(IWXR), 1 ) - CALL DSCAL( HNPTS, ONE/( TWO*HNPTS ), DWORK(IWXI), 1 ) -C -C Halve the result at 0. -C - DWORK(IWXR) = DWORK(IWXR)/TWO - DWORK(IWXI) = DWORK(IWXI)/TWO -C -C FFT -C - CALL DG01MD( 'D', HNPTS, DWORK(IWXR), DWORK(IWXI), INFO2 ) -C -C Get the EXP of the result. -C - DO 110 K = 1, HNPTS/2 - XHAT(K) = EXP( DWORK(IWXR+K-1) )* - $ DCMPLX ( COS( DWORK(IWXI+K-1)), SIN( DWORK(IWXI+K-1) ) ) - DWORK(IWDME+K-1) = DWORK(IWDME+2*K-2) - 110 CONTINUE -C -C Interpolate back to original frequency data. -C - ISTART = 1 - ISTOP = LENDAT -C - DO 120 I = 1, LENDAT - ZWORK(I) = ZZERO - IF ( DWORK(IWDOMO+I-1).LE.DWORK(IWDME) ) THEN - ZWORK(I) = XHAT(1) - ISTART = I + 1 - ELSE IF ( DWORK(IWDOMO+I-1).GE.DWORK(IWDME+HNPTS/2-1) ) - $ THEN - ZWORK(I) = XHAT(HNPTS/2) - ISTOP = ISTOP - 1 - END IF - 120 CONTINUE -C - DO 140 I = ISTART, ISTOP - II = HNPTS/2 - 130 CONTINUE - IF ( DWORK(IWDME+II-1).GE.DWORK(IWDOMO+I-1) ) - $ P = II - II = II - 1 - IF ( II.GT.0 ) - $ GOTO 130 - RAT = ( DWORK(IWDOMO+I-1) - DWORK(IWDME+P-2) )/ - $ ( DWORK(IWDME+P-1) - DWORK(IWDME+P-2) ) - ZWORK(I) = RAT*XHAT(P) + ( ONE - RAT )*XHAT(P-1) - 140 CONTINUE -C -C CASE N > 0. -C This is the only allowed case in mu-synthesis subroutines. -C - IF ( N.GT.0 ) THEN -C -C Preparation for frequency identification. -C -C @@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@ -C -C Complex workspace usage 1. -C Complex workspace: need 2*LENDAT + LENDAT*(N+1). -C - IWA0 = 1 + LENDAT - IWVAR = IWA0 + LENDAT*N1 -C - DO 150 K = 1, LENDAT - IF ( DISCFL.EQ.0 ) THEN - ZWORK(IWVAR+K-1) = DCMPLX( COS( DWORK(IWDOMO+K-1) ), - $ SIN( DWORK(IWDOMO+K-1) ) ) - ELSE - ZWORK(IWVAR+K-1) = DCMPLX( COS( OMEGA(K) ), - $ SIN( OMEGA(K) ) ) - END IF - 150 CONTINUE -C -C Array for DGELSY. -C - DO 160 K = 1, N2 - IWORK(K) = 0 - 160 CONTINUE -C -C Constructing A0. -C - DO 170 K = 1, LENDAT - ZWORK(IWA0+N*LENDAT+K-1) = ZONE - 170 CONTINUE -C - DO 190 I = 1, N - DO 180 K = 1, LENDAT - ZWORK(IWA0+(N-I)*LENDAT+K-1) = - $ ZWORK(IWA0+(N1-I)*LENDAT+K-1)*ZWORK(IWVAR+K-1) - 180 CONTINUE - 190 CONTINUE -C -C @@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@ -C -C Complex workspace usage 2. -C Complex workspace: need 2*LENDAT + LENDAT*(2*N+1). -C - IWBP = IWVAR - IWAB = IWBP + LENDAT -C -C Constructing BP. -C - DO 200 K = 1, LENDAT - ZWORK(IWBP+K-1) = ZWORK(IWA0+K-1)*ZWORK(K) - 200 CONTINUE -C -C Constructing AB. -C - DO 220 I = 1, N - DO 210 K = 1, LENDAT - ZWORK(IWAB+(I-1)*LENDAT+K-1) = -ZWORK(K)* - $ ZWORK(IWA0+I*LENDAT+K-1) - 210 CONTINUE - 220 CONTINUE -C -C @@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@ -C -C Workspace usage 3. -C Workspace: need LW3 = 2*LENDAT*(2*N+1) + max(2*LENDAT,2*N+1). -C - IWBX = 1 + 2*LENDAT*N2 - IWS = IWBX + MAX( 2*LENDAT, N2 ) -C -C Constructing AX. -C - DO 240 I = 1, N1 - DO 230 K = 1, LENDAT - DWORK(2*(I-1)*LENDAT+K) = - $ DBLE( ZWORK(IWA0+(I-1)*LENDAT+K-1) ) - DWORK((2*I-1)*LENDAT+K) = - $ DIMAG( ZWORK(IWA0+(I-1)*LENDAT+K-1) ) - 230 CONTINUE - 240 CONTINUE -C - DO 260 I = 1, N - DO 250 K = 1, LENDAT - DWORK(2*N1*LENDAT+2*(I-1)*LENDAT+K) = - $ DBLE( ZWORK(IWAB+(I-1)*LENDAT+K-1) ) - DWORK(2*N1*LENDAT+(2*I-1)*LENDAT+K) = - $ DIMAG( ZWORK(IWAB+(I-1)*LENDAT+K-1) ) - 250 CONTINUE - 260 CONTINUE -C -C Constructing BX. -C - DO 270 K = 1, LENDAT - DWORK(IWBX+K-1) = DBLE( ZWORK(IWBP+K-1) ) - DWORK(IWBX+LENDAT+K-1) = DIMAG( ZWORK(IWBP+K-1) ) - 270 CONTINUE -C -C Estimating X. -C Workspace: need LW3 + max( MN+3*(2*N+1)+1, 2*MN+1 ), -C where MN = min( 2*LENDAT, 2*N+1 ); -C prefer larger. -C - CALL DGELSY( 2*LENDAT, N2, 1, DWORK, 2*LENDAT, DWORK(IWBX), - $ MAX( 2*LENDAT, N2 ), IWORK, TOLL, RANK, - $ DWORK(IWS), LDWORK-IWS+1, INFO2 ) - DLWMAX = MAX( DLWMAX, INT( DWORK(IWS) + IWS - 1 ) ) -C -C Constructing A matrix. -C - DO 280 K = 1, N - A(K,1) = -DWORK(IWBX+N1+K-1) - 280 CONTINUE -C - IF ( N.GT.1 ) - $ CALL DLASET( 'Full', N, N-1, ZERO, ONE, A(1,2), LDA ) -C -C Constructing B matrix. -C - DO 290 K = 1, N - B(K) = DWORK(IWBX+N1+K-1)*DWORK(IWBX) - DWORK(IWBX+K) - 290 CONTINUE -C -C Constructing C matrix. -C - C(1) = -ONE -C - DO 300 K = 2, N - C(K) = ZERO - 300 CONTINUE -C -C Constructing D matrix. -C - D(1) = DWORK(IWBX) -C -C Transform to continuous-time case, if needed. -C Workspace: need max(1,N); -C prefer larger. -C - IF ( DISCFL.EQ.0 ) THEN - CALL AB04MD( 'D', N, 1, 1, ONE, PW, A, LDA, B, LDA, C, 1, - $ D, 1, IWORK, DWORK, LDWORK, INFO2 ) - IF ( INFO2.NE.0 ) THEN - INFO = 1 - RETURN - END IF - DLWMAX = MAX( DLWMAX, INT( DWORK(1) ) ) - END IF -C -C Make all the real parts of the poles and the zeros negative. -C - IF ( FLAG.EQ.1 ) THEN -C -C Workspace: need max(N*N + 5*N, 6*N + 1 + min(1,N)); -C prefer larger. - CALL SB10ZP( DISCFL, N, A, LDA, B, C, D, IWORK, DWORK, - $ LDWORK, INFO ) - IF ( INFO.NE.0 ) - $ RETURN - DLWMAX = MAX( DLWMAX, INT( DWORK(1) ) ) - END IF -C - ELSE -C -C CASE N = 0. -C -C @@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@ -C -C Workspace usage 4. -C Workspace: need 4*LENDAT. -C - IWBMAT = 1 + 2*LENDAT - IWS = IWBMAT + 2*LENDAT -C -C Constructing AMAT and BMAT. -C - DO 310 K = 1, LENDAT - DWORK(K) = ONE - DWORK(K+LENDAT) = ZERO - DWORK(IWBMAT+K-1) = DBLE( ZWORK(K) ) - DWORK(IWBMAT+LENDAT+K-1) = DIMAG( ZWORK(K) ) - 310 CONTINUE -C -C Estimating D matrix. -C Workspace: need 4*LENDAT + 5; -C prefer larger. -C - IWORK(1) = 0 - CALL DGELSY( 2*LENDAT, 1, 1, DWORK, 2*LENDAT, DWORK(IWBMAT), - $ 2*LENDAT, IWORK, TOLL, RANK, DWORK(IWS), - $ LDWORK-IWS+1, INFO2 ) - DLWMAX = MAX( DLWMAX, INT( DWORK(IWS) + IWS - 1 ) ) -C - D(1) = DWORK(IWBMAT) -C - END IF -C -C @@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@ -C - DWORK(1) = DLWMAX - DWORK(2) = CLWMAX - RETURN -C -C *** Last line of SB10YD *** - END diff --git a/mex/sources/libslicot/SB10ZD.f b/mex/sources/libslicot/SB10ZD.f deleted file mode 100644 index f70c834dd..000000000 --- a/mex/sources/libslicot/SB10ZD.f +++ /dev/null @@ -1,914 +0,0 @@ - SUBROUTINE SB10ZD( N, M, NP, A, LDA, B, LDB, C, LDC, D, LDD, - $ FACTOR, AK, LDAK, BK, LDBK, CK, LDCK, DK, - $ LDDK, RCOND, TOL, IWORK, DWORK, LDWORK, BWORK, - $ INFO ) -C -C SLICOT RELEASE 5.0. -C -C Copyright (c) 2002-2009 NICONET e.V. -C -C This program is free software: you can redistribute it and/or -C modify it under the terms of the GNU General Public License as -C published by the Free Software Foundation, either version 2 of -C the License, or (at your option) any later version. -C -C This program is distributed in the hope that it will be useful, -C but WITHOUT ANY WARRANTY; without even the implied warranty of -C MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the -C GNU General Public License for more details. -C -C You should have received a copy of the GNU General Public License -C along with this program. If not, see -C . -C -C PURPOSE -C -C To compute the matrices of the positive feedback controller -C -C | Ak | Bk | -C K = |----|----| -C | Ck | Dk | -C -C for the shaped plant -C -C | A | B | -C G = |---|---| -C | C | D | -C -C in the Discrete-Time Loop Shaping Design Procedure. -C -C ARGUMENTS -C -C Input/Output Parameters -C -C N (input) INTEGER -C The order of the plant. N >= 0. -C -C M (input) INTEGER -C The column size of the matrix B. M >= 0. -C -C NP (input) INTEGER -C The row size of the matrix C. NP >= 0. -C -C A (input) DOUBLE PRECISION array, dimension (LDA,N) -C The leading N-by-N part of this array must contain the -C system state matrix A of the shaped plant. -C -C LDA INTEGER -C The leading dimension of the array A. LDA >= max(1,N). -C -C B (input) DOUBLE PRECISION array, dimension (LDB,M) -C The leading N-by-M part of this array must contain the -C system input matrix B of the shaped plant. -C -C LDB INTEGER -C The leading dimension of the array B. LDB >= max(1,N). -C -C C (input) DOUBLE PRECISION array, dimension (LDC,N) -C The leading NP-by-N part of this array must contain the -C system output matrix C of the shaped plant. -C -C LDC INTEGER -C The leading dimension of the array C. LDC >= max(1,NP). -C -C D (input) DOUBLE PRECISION array, dimension (LDD,M) -C The leading NP-by-M part of this array must contain the -C system input/output matrix D of the shaped plant. -C -C LDD INTEGER -C The leading dimension of the array D. LDD >= max(1,NP). -C -C FACTOR (input) DOUBLE PRECISION -C = 1 implies that an optimal controller is required -C (not recommended); -C > 1 implies that a suboptimal controller is required -C achieving a performance FACTOR less than optimal. -C FACTOR >= 1. -C -C AK (output) DOUBLE PRECISION array, dimension (LDAK,N) -C The leading N-by-N part of this array contains the -C controller state matrix Ak. -C -C LDAK INTEGER -C The leading dimension of the array AK. LDAK >= max(1,N). -C -C BK (output) DOUBLE PRECISION array, dimension (LDBK,NP) -C The leading N-by-NP part of this array contains the -C controller input matrix Bk. -C -C LDBK INTEGER -C The leading dimension of the array BK. LDBK >= max(1,N). -C -C CK (output) DOUBLE PRECISION array, dimension (LDCK,N) -C The leading M-by-N part of this array contains the -C controller output matrix Ck. -C -C LDCK INTEGER -C The leading dimension of the array CK. LDCK >= max(1,M). -C -C DK (output) DOUBLE PRECISION array, dimension (LDDK,NP) -C The leading M-by-NP part of this array contains the -C controller matrix Dk. -C -C LDDK INTEGER -C The leading dimension of the array DK. LDDK >= max(1,M). -C -C RCOND (output) DOUBLE PRECISION array, dimension (6) -C RCOND(1) contains an estimate of the reciprocal condition -C number of the linear system of equations from -C which the solution of the P-Riccati equation is -C obtained; -C RCOND(2) contains an estimate of the reciprocal condition -C number of the linear system of equations from -C which the solution of the Q-Riccati equation is -C obtained; -C RCOND(3) contains an estimate of the reciprocal condition -C number of the matrix (gamma^2-1)*In - P*Q; -C RCOND(4) contains an estimate of the reciprocal condition -C number of the matrix Rx + Bx'*X*Bx; -C RCOND(5) contains an estimate of the reciprocal condition -C ^ -C number of the matrix Ip + D*Dk; -C RCOND(6) contains an estimate of the reciprocal condition -C ^ -C number of the matrix Im + Dk*D. -C -C Tolerances -C -C TOL DOUBLE PRECISION -C Tolerance used for checking the nonsingularity of the -C matrices to be inverted. If TOL <= 0, then a default value -C equal to sqrt(EPS) is used, where EPS is the relative -C machine precision. TOL < 1. -C -C Workspace -C -C IWORK INTEGER array, dimension 2*max(N,M+NP) -C -C DWORK DOUBLE PRECISION array, dimension (LDWORK) -C On exit, if INFO = 0, DWORK(1) contains the optimal value -C of LDWORK. -C -C LDWORK INTEGER -C The dimension of the array DWORK. -C LDWORK >= 16*N*N + 5*M*M + 7*NP*NP + 6*M*N + 7*M*NP + -C 7*N*NP + 6*N + 2*(M + NP) + -C max(14*N+23,16*N,2*M-1,2*NP-1). -C For good performance, LDWORK must generally be larger. -C -C BWORK LOGICAL array, dimension (2*N) -C -C Error Indicator -C -C INFO (output) INTEGER -C = 0: successful exit; -C < 0: if INFO = -i, the i-th argument had an illegal -C value; -C = 1: the P-Riccati equation is not solved successfully; -C = 2: the Q-Riccati equation is not solved successfully; -C = 3: the iteration to compute eigenvalues or singular -C values failed to converge; -C = 4: the matrix (gamma^2-1)*In - P*Q is singular; -C = 5: the matrix Rx + Bx'*X*Bx is singular; -C ^ -C = 6: the matrix Ip + D*Dk is singular; -C ^ -C = 7: the matrix Im + Dk*D is singular; -C = 8: the matrix Ip - D*Dk is singular; -C = 9: the matrix Im - Dk*D is singular; -C = 10: the closed-loop system is unstable. -C -C METHOD -C -C The routine implements the formulas given in [1]. -C -C REFERENCES -C -C [1] Gu, D.-W., Petkov, P.H., and Konstantinov, M.M. -C On discrete H-infinity loop shaping design procedure routines. -C Technical Report 00-6, Dept. of Engineering, Univ. of -C Leicester, UK, 2000. -C -C NUMERICAL ASPECTS -C -C The accuracy of the results depends on the conditioning of the -C two Riccati equations solved in the controller design. For -C better conditioning it is advised to take FACTOR > 1. -C -C CONTRIBUTORS -C -C P.Hr. Petkov, D.W. Gu and M.M. Konstantinov, May 2001. -C -C REVISIONS -C -C V. Sima, Research Institute for Informatics, Bucharest, July 2001. -C -C KEYWORDS -C -C H_infinity control, Loop-shaping design, Robust control. -C -C ****************************************************************** -C -C .. Parameters .. - DOUBLE PRECISION ZERO, ONE - PARAMETER ( ZERO = 0.0D+0, ONE = 1.0D+0 ) -C .. -C .. Scalar Arguments .. - INTEGER INFO, LDA, LDAK, LDB, LDBK, LDC, LDCK, LDD, - $ LDDK, LDWORK, M, N, NP - DOUBLE PRECISION FACTOR, TOL -C .. -C .. Array Arguments .. - INTEGER IWORK( * ) - LOGICAL BWORK( * ) - DOUBLE PRECISION A ( LDA, * ), AK( LDAK, * ), B ( LDB, * ), - $ BK( LDBK, * ), C ( LDC, * ), CK( LDCK, * ), - $ D ( LDD, * ), DK( LDDK, * ), DWORK( * ), - $ RCOND( 6 ) -C .. -C .. Local Scalars .. - INTEGER I, I1, I2, I3, I4, I5, I6, I7, I8, I9, I10, - $ I11, I12, I13, I14, I15, I16, I17, I18, I19, - $ I20, I21, I22, I23, I24, I25, I26, INFO2, IWRK, - $ J, LWAMAX, MINWRK, N2, NS, SDIM - DOUBLE PRECISION ANORM, GAMMA, TOLL -C .. -C .. External Functions .. - LOGICAL SELECT - DOUBLE PRECISION DLAMCH, DLANGE, DLANSY, DLAPY2 - EXTERNAL DLAMCH, DLANGE, DLANSY, DLAPY2, SELECT -C .. -C .. External Subroutines .. - EXTERNAL DCOPY, DGECON, DGEES, DGEMM, DGETRF, DGETRS, - $ DLACPY, DLASCL, DLASET, DPOTRF, DPOTRS, DSWAP, - $ DSYCON, DSYEV, DSYRK, DSYTRF, DSYTRS, DTRSM, - $ DTRTRS, MA02AD, MB01RX, MB02VD, SB02OD, XERBLA -C .. -C .. Intrinsic Functions .. - INTRINSIC INT, MAX, SQRT -C .. -C .. Executable Statements .. -C -C Decode and Test input parameters. -C - INFO = 0 - IF( N.LT.0 ) THEN - INFO = -1 - ELSE IF( M.LT.0 ) THEN - INFO = -2 - ELSE IF( NP.LT.0 ) THEN - INFO = -3 - ELSE IF( LDA.LT.MAX( 1, N ) ) THEN - INFO = -5 - ELSE IF( LDB.LT.MAX( 1, N ) ) THEN - INFO = -7 - ELSE IF( LDC.LT.MAX( 1, NP ) ) THEN - INFO = -9 - ELSE IF( LDD.LT.MAX( 1, NP ) ) THEN - INFO = -11 - ELSE IF( FACTOR.LT.ONE ) THEN - INFO = -12 - ELSE IF( LDAK.LT.MAX( 1, N ) ) THEN - INFO = -14 - ELSE IF( LDBK.LT.MAX( 1, N ) ) THEN - INFO = -16 - ELSE IF( LDCK.LT.MAX( 1, M ) ) THEN - INFO = -18 - ELSE IF( LDDK.LT.MAX( 1, M ) ) THEN - INFO = -20 - ELSE IF( TOL.GE.ONE ) THEN - INFO = -22 - END IF -C -C Compute workspace. -C - MINWRK = 16*N*N + 5*M*M + 7*NP*NP + 6*M*N + 7*M*NP + 7*N*NP + - $ 6*N + 2*(M + NP) + MAX( 14*N+23, 16*N, 2*M-1, 2*NP-1 ) - IF( LDWORK.LT.MINWRK ) THEN - INFO = -25 - END IF - IF( INFO.NE.0 ) THEN - CALL XERBLA( 'SB10ZD', -INFO ) - RETURN - END IF -C -C Quick return if possible. -C Note that some computation could be made if one or two of the -C dimension parameters N, M, and P are zero, but the results are -C not so meaningful. -C - IF( N.EQ.0 .OR. M.EQ.0 .OR. NP.EQ.0 ) THEN - RCOND( 1 ) = ONE - RCOND( 2 ) = ONE - RCOND( 3 ) = ONE - RCOND( 4 ) = ONE - RCOND( 5 ) = ONE - RCOND( 6 ) = ONE - DWORK( 1 ) = ONE - RETURN - END IF -C -C Set the default tolerance, if needed. -C - IF( TOL.LE.ZERO ) THEN - TOLL = SQRT( DLAMCH( 'Epsilon' ) ) - ELSE - TOLL = TOL - END IF -C -C Workspace usage. -C - N2 = 2*N - I1 = 1 + N*N - I2 = I1 + N*N - I3 = I2 + NP*NP - I4 = I3 + M*M - I5 = I4 + NP*NP - I6 = I5 + M*M - I7 = I6 + M*N - I8 = I7 + M*N - I9 = I8 + N*N - I10 = I9 + N*N - I11 = I10 + N2 - I12 = I11 + N2 - I13 = I12 + N2 - I14 = I13 + N2*N2 - I15 = I14 + N2*N2 -C - IWRK = I15 + N2*N2 - LWAMAX = 0 -C -C Compute R1 = Ip + D*D' . -C - CALL DLASET( 'U', NP, NP, ZERO, ONE, DWORK( I2 ), NP ) - CALL DSYRK( 'U', 'N', NP, M, ONE, D, LDD, ONE, DWORK( I2 ), NP ) - CALL DLACPY( 'U', NP, NP, DWORK( I2 ), NP, DWORK( I4 ), NP ) -C -C Factorize R1 = R'*R . -C - CALL DPOTRF( 'U', NP, DWORK( I4 ), NP, INFO2 ) -C -1 -C Compute C'*R in BK . -C - CALL MA02AD( 'F', NP, N, C, LDC, BK, LDBK ) - CALL DTRSM( 'R', 'U', 'N', 'N', N, NP, ONE, DWORK( I4 ), NP, BK, - $ LDBK ) -C -C Compute R2 = Im + D'*D . -C - CALL DLASET( 'U', M, M, ZERO, ONE, DWORK( I3 ), M ) - CALL DSYRK( 'U', 'T', M, NP, ONE, D, LDD, ONE, DWORK( I3 ), M ) - CALL DLACPY( 'U', M, M, DWORK( I3 ), M, DWORK( I5 ), M ) -C -C Factorize R2 = U'*U . -C - CALL DPOTRF( 'U', M, DWORK( I5 ), M, INFO2 ) -C -1 -C Compute (U )'*B' . -C - CALL MA02AD( 'F', N, M, B, LDB, DWORK( I6 ), M ) - CALL DTRTRS( 'U', 'T', 'N', M, N, DWORK( I5 ), M, DWORK( I6 ), M, - $ INFO2 ) -C -C Compute D'*C . -C - CALL DGEMM( 'T', 'N', M, N, NP, ONE, D, LDD, C, LDC, ZERO, - $ DWORK( I7 ), M ) -C -1 -C Compute (U )'*D'*C . -C - CALL DTRTRS( 'U', 'T', 'N', M, N, DWORK( I5 ), M, DWORK( I7 ), M, - $ INFO2 ) -C -1 -C Compute Ar = A - B*R2 D'*C . -C - CALL DLACPY( 'F', N, N, A, LDA, DWORK( I8 ), N ) - CALL DGEMM( 'T', 'N', N, N, M, -ONE, DWORK( I6 ), M, DWORK( I7 ), - $ M, ONE, DWORK( I8 ), N ) -C -1 -C Compute Cr = C'*R1 *C . -C - CALL DSYRK( 'U', 'N', N, NP, ONE, BK, LDBK, ZERO, DWORK( I9 ), N ) -C -1 -C Compute Dr = B*R2 B' in AK . -C - CALL DSYRK( 'U', 'T', N, M, ONE, DWORK( I6 ), M, ZERO, AK, LDAK ) -C -1 -C Solution of the Riccati equation Ar'*P*(In + Dr*P) Ar - P + -C Cr = 0 . - CALL SB02OD( 'D', 'G', 'N', 'U', 'Z', 'S', N, M, NP, DWORK( I8 ), - $ N, AK, LDAK, DWORK( I9 ), N, DWORK, M, DWORK, N, - $ RCOND( 1 ), DWORK, N, DWORK( I10 ), DWORK( I11 ), - $ DWORK( I12 ), DWORK( I13 ), N2, DWORK( I14 ), N2, - $ DWORK( I15 ), N2, -ONE, IWORK, DWORK( IWRK ), - $ LDWORK-IWRK+1, BWORK, INFO2 ) - IF( INFO2.NE.0 ) THEN - INFO = 1 - RETURN - END IF - LWAMAX = MAX( LWAMAX, INT( DWORK( IWRK ) ) + IWRK - 1 ) -C -C Transpose Ar . -C - DO 10 J = 1, N - 1 - CALL DSWAP( J, DWORK( I8+J ), N, DWORK( I8+J*N ), 1 ) - 10 CONTINUE -C -1 -C Solution of the Riccati equation Ar*Q*(In + Cr*Q) *Ar' - Q + -C Dr = 0 . - CALL SB02OD( 'D', 'G', 'N', 'U', 'Z', 'S', N, M, NP, DWORK( I8 ), - $ N, DWORK( I9 ), N, AK, LDAK, DWORK, M, DWORK, N, - $ RCOND( 2 ), DWORK( I1 ), N, DWORK( I10 ), - $ DWORK( I11 ), DWORK( I12 ), DWORK( I13 ), N2, - $ DWORK( I14 ), N2, DWORK( I15 ), N2, -ONE, IWORK, - $ DWORK( IWRK ), LDWORK-IWRK+1, BWORK, INFO2 ) - IF( INFO2.NE.0 ) THEN - INFO = 2 - RETURN - END IF - LWAMAX = MAX( LWAMAX, INT( DWORK( IWRK ) ) + IWRK - 1 ) -C -C Compute gamma. -C - CALL DGEMM( 'N', 'N', N, N, N, ONE, DWORK( I1 ), N, DWORK, N, - $ ZERO, DWORK( I8 ), N ) - CALL DGEES( 'N', 'N', SELECT, N, DWORK( I8 ), N, SDIM, - $ DWORK( I10 ), DWORK( I11 ), DWORK( IWRK ), N, - $ DWORK( IWRK ), LDWORK-IWRK+1, BWORK, INFO2 ) - IF( INFO2.NE.0 ) THEN - INFO = 3 - RETURN - END IF - LWAMAX = MAX( LWAMAX, INT( DWORK( IWRK ) ) + IWRK - 1 ) - GAMMA = ZERO -C - DO 20 I = 0, N - 1 - GAMMA = MAX( GAMMA, DWORK( I10+I ) ) - 20 CONTINUE -C - GAMMA = FACTOR*SQRT( ONE + GAMMA ) -C -C Workspace usage. -C - I5 = I4 + NP*NP - I6 = I5 + M*M - I7 = I6 + NP*NP - I8 = I7 + NP*NP - I9 = I8 + NP*NP - I10 = I9 + NP - I11 = I10 + NP*NP - I12 = I11 + M*M - I13 = I12 + M -C - IWRK = I13 + M*M -C -C Compute the eigenvalues and eigenvectors of R1 . -C - CALL DLACPY( 'U', NP, NP, DWORK( I2 ), NP, DWORK( I8 ), NP ) - CALL DSYEV( 'V', 'U', NP, DWORK( I8 ), NP, DWORK( I9 ), - $ DWORK( IWRK ), LDWORK-IWRK+1, INFO2 ) - IF( INFO2.NE.0 ) THEN - INFO = 3 - RETURN - END IF - LWAMAX = MAX( LWAMAX, INT( DWORK( IWRK ) ) + IWRK - 1 ) -C -1/2 -C Compute R1 . -C - DO 40 J = 1, NP - DO 30 I = 1, NP - DWORK( I10-1+I+(J-1)*NP ) = DWORK( I8-1+J+(I-1)*NP ) / - $ SQRT( DWORK( I9+I-1 ) ) - 30 CONTINUE - 40 CONTINUE -C - CALL DGEMM( 'N', 'N', NP, NP, NP, ONE, DWORK( I8 ), NP, - $ DWORK( I10 ), NP, ZERO, DWORK( I4 ), NP ) -C -C Compute the eigenvalues and eigenvectors of R2 . -C - CALL DLACPY( 'U', M, M, DWORK( I3 ), M, DWORK( I11 ), M ) - CALL DSYEV( 'V', 'U', M, DWORK( I11 ), M, DWORK( I12 ), - $ DWORK( IWRK ), LDWORK-IWRK+1, INFO2 ) - IF( INFO2.NE.0 ) THEN - INFO = 3 - RETURN - END IF - LWAMAX = MAX( LWAMAX, INT( DWORK( IWRK ) ) + IWRK - 1 ) -C -1/2 -C Compute R2 . -C - DO 60 J = 1, M - DO 50 I = 1, M - DWORK( I13-1+I+(J-1)*M ) = DWORK( I11-1+J+(I-1)*M ) / - $ SQRT( DWORK( I12+I-1 ) ) - 50 CONTINUE - 60 CONTINUE -C - CALL DGEMM( 'N', 'N', M, M, M, ONE, DWORK( I11 ), M, DWORK( I13 ), - $ M, ZERO, DWORK( I5 ), M ) -C -C Compute R1 + C*Q*C' . -C - CALL DGEMM( 'N', 'T', N, NP, N, ONE, DWORK( I1 ), N, C, LDC, - $ ZERO, BK, LDBK ) - CALL MB01RX( 'L', 'U', 'N', NP, N, ONE, ONE, DWORK( I2 ), NP, - $ C, LDC, BK, LDBK, INFO2 ) - CALL DLACPY( 'U', NP, NP, DWORK( I2 ), NP, DWORK( I8 ), NP ) -C -C Compute the eigenvalues and eigenvectors of R1 + C*Q*C' . -C - CALL DSYEV( 'V', 'U', NP, DWORK( I8 ), NP, DWORK( I9 ), - $ DWORK( IWRK ), LDWORK-IWRK+1, INFO2 ) - IF( INFO2.NE.0 ) THEN - INFO = 3 - RETURN - END IF - LWAMAX = MAX( LWAMAX, INT( DWORK( IWRK ) ) + IWRK - 1 ) -C -1 -C Compute ( R1 + C*Q*C' ) . -C - DO 80 J = 1, NP - DO 70 I = 1, NP - DWORK( I10-1+I+(J-1)*NP ) = DWORK( I8-1+J+(I-1)*NP ) / - $ DWORK( I9+I-1 ) - 70 CONTINUE - 80 CONTINUE -C - CALL DGEMM( 'N', 'N', NP, NP, NP, ONE, DWORK( I8 ), NP, - $ DWORK( I10 ), NP, ZERO, DWORK( I6 ), NP ) -C -1 -C Compute Z2 . -C - DO 100 J = 1, NP - DO 90 I = 1, NP - DWORK( I10-1+I+(J-1)*NP ) = DWORK( I8-1+J+(I-1)*NP )* - $ SQRT( DWORK( I9+I-1 ) ) - 90 CONTINUE - 100 CONTINUE -C - CALL DGEMM( 'N', 'N', NP, NP, NP, ONE, DWORK( I8 ), NP, - $ DWORK( I10 ), NP, ZERO, DWORK( I7 ), NP ) -C -C Workspace usage. -C - I9 = I8 + N*NP - I10 = I9 + N*NP - I11 = I10 + NP*M - I12 = I11 + ( NP + M )*( NP + M ) - I13 = I12 + N*( NP + M ) - I14 = I13 + N*( NP + M ) - I15 = I14 + N*N - I16 = I15 + N*N - I17 = I16 + ( NP + M )*N - I18 = I17 + ( NP + M )*( NP + M ) - I19 = I18 + ( NP + M )*N - I20 = I19 + M*N - I21 = I20 + M*NP - I22 = I21 + NP*N - I23 = I22 + N*N - I24 = I23 + N*NP - I25 = I24 + NP*NP - I26 = I25 + M*M -C - IWRK = I26 + N*M -C -C Compute A*Q*C' + B*D' . -C - CALL DGEMM( 'N', 'T', N, NP, M, ONE, B, LDB, D, LDD, ZERO, - $ DWORK( I8 ), N ) - CALL DGEMM( 'N', 'N', N, NP, N, ONE, A, LDA, BK, LDBK, - $ ONE, DWORK( I8 ), N ) -C -1 -C Compute H = -( A*Q*C'+B*D' )*( R1 + C*Q*C' ) . -C - CALL DGEMM( 'N', 'N', N, NP, NP, -ONE, DWORK( I8 ), N, - $ DWORK( I6 ), NP, ZERO, DWORK( I9 ), N ) -C -1/2 -C Compute R1 D . -C - CALL DGEMM( 'N', 'N', NP, M, NP, ONE, DWORK( I4 ), NP, D, LDD, - $ ZERO, DWORK( I10 ), NP ) -C -C Compute Rx . -C - DO 110 J = 1, NP - CALL DCOPY( J, DWORK( I2+(J-1)*NP ), 1, - $ DWORK( I11+(J-1)*(NP+M) ), 1 ) - DWORK( I11-1+J+(J-1)*(NP+M) ) = DWORK( I2-1+J+(J-1)*NP ) - - $ GAMMA*GAMMA - 110 CONTINUE -C - CALL DGEMM( 'N', 'N', NP, M, NP, ONE, DWORK( I7 ), NP, - $ DWORK( I10 ), NP, ZERO, DWORK( I11+(NP+M)*NP ), - $ NP+M ) - CALL DLASET( 'U', M, M, ZERO, ONE, DWORK( I11+(NP+M)*NP+NP ), - $ NP+M ) -C -C Compute Bx . -C - CALL DGEMM( 'N', 'N', N, NP, NP, -ONE, DWORK( I9 ), N, - $ DWORK( I7 ), NP, ZERO, DWORK( I12 ), N ) - CALL DGEMM( 'N', 'N', N, M, M, ONE, B, LDB, DWORK( I5 ), M, - $ ZERO, DWORK( I12+N*NP ), N ) -C -C Compute Sx . -C - CALL DGEMM( 'T', 'N', N, NP, NP, ONE, C, LDC, DWORK( I7 ), NP, - $ ZERO, DWORK( I13 ), N ) - CALL DGEMM( 'T', 'N', N, M, NP, ONE, C, LDC, DWORK( I10 ), NP, - $ ZERO, DWORK( I13+N*NP ), N ) -C -C Compute (gamma^2 - 1)*In - P*Q . -C - CALL DLASET( 'F', N, N, ZERO, GAMMA*GAMMA-ONE, DWORK( I14 ), N ) - CALL DGEMM( 'N', 'N', N, N, N, -ONE, DWORK, N, DWORK( I1 ), N, - $ ONE, DWORK( I14 ), N ) -C -1 -C Compute X = ((gamma^2 - 1)*In - P*Q) *gamma^2*P . -C - CALL DLACPY( 'F', N, N, DWORK, N, DWORK( I15 ), N ) - CALL DLASCL( 'G', 0, 0, ONE, GAMMA*GAMMA, N, N, DWORK( I15 ), N, - $ INFO ) - ANORM = DLANGE( '1', N, N, DWORK( I14 ), N, DWORK( IWRK ) ) - CALL DGETRF( N, N, DWORK( I14 ), N, IWORK, INFO2 ) - IF( INFO2.GT.0 ) THEN - INFO = 4 - RETURN - END IF - CALL DGECON( '1', N, DWORK( I14 ), N, ANORM, RCOND( 3 ), - $ DWORK( IWRK ), IWORK( N+1 ), INFO2 ) -C -C Return if the matrix is singular to working precision. -C - IF( RCOND( 3 ).LT.TOLL ) THEN - INFO = 4 - RETURN - END IF - CALL DGETRS( 'N', N, N, DWORK( I14 ), N, IWORK, DWORK( I15 ), - $ N, INFO2 ) -C -C Compute Bx'*X . -C - CALL DGEMM( 'T', 'N', NP+M, N, N, ONE, DWORK( I12 ), N, - $ DWORK( I15 ), N, ZERO, DWORK( I16 ), NP+M ) -C -C Compute Rx + Bx'*X*Bx . -C - CALL DLACPY( 'U', NP+M, NP+M, DWORK( I11 ), NP+M, DWORK( I17 ), - $ NP+M ) - CALL MB01RX( 'L', 'U', 'N', NP+M, N, ONE, ONE, DWORK( I17 ), NP+M, - $ DWORK( I16 ), NP+M, DWORK( I12 ), N, INFO2 ) -C -C Compute -( Sx' + Bx'*X*A ) . -C - CALL MA02AD( 'F', N, NP+M, DWORK( I13 ), N, DWORK( I18 ), NP+M ) - CALL DGEMM( 'N', 'N', NP+M, N, N, -ONE, DWORK( I16 ), NP+M, - $ A, LDA, -ONE, DWORK( I18 ), NP+M ) -C -C Factorize Rx + Bx'*X*Bx . -C - ANORM = DLANSY( '1', 'U', NP+M, DWORK( I17 ), NP+M, - $ DWORK( IWRK ) ) - CALL DSYTRF( 'U', NP+M, DWORK( I17 ), NP+M, IWORK, - $ DWORK( IWRK ), LDWORK-IWRK, INFO2 ) - IF( INFO2.NE.0 ) THEN - INFO = 5 - RETURN - END IF - CALL DSYCON( 'U', NP+M, DWORK( I17 ), NP+M, IWORK, ANORM, - $ RCOND( 4 ), DWORK( IWRK ), IWORK( NP+M+1), INFO2 ) -C -C Return if the matrix is singular to working precision. -C - IF( RCOND( 4 ).LT.TOLL ) THEN - INFO = 5 - RETURN - END IF -C -1 -C Compute F = -( Rx + Bx'*X*Bx ) ( Sx' + Bx'*X*A ) . -C - CALL DSYTRS( 'U', NP+M, N, DWORK( I17 ), NP+M, IWORK, - $ DWORK( I18 ), NP+M, INFO2 ) -C -C Compute B'*X . -C - CALL DGEMM( 'T', 'N', M, N, N, ONE, B, LDB, DWORK( I15 ), N, - $ ZERO, DWORK( I19 ), M ) -C -C Compute -( D' - B'*X*H ) . -C - DO 130 J = 1, NP - DO 120 I = 1, M - DWORK( I20-1+I+(J-1)*M ) = -D( J, I ) - 120 CONTINUE - 130 CONTINUE -C - CALL DGEMM( 'N', 'N', M, NP, N, ONE, DWORK( I19 ), M, - $ DWORK( I9 ), N, ONE, DWORK( I20 ), M ) -C -1 -C Compute C + Z2 *F1 . -C - CALL DLACPY( 'F', NP, N, C, LDC, DWORK( I21 ), NP ) - CALL DGEMM( 'N', 'N', NP, N, NP, ONE, DWORK( I7 ), NP, - $ DWORK( I18 ), NP+M, ONE, DWORK( I21 ), NP ) -C -C Compute R2 + B'*X*B . -C - CALL MB01RX( 'L', 'U', 'N', M, N, ONE, ONE, DWORK( I3 ), M, - $ DWORK( I19 ), M, B, LDB, INFO2 ) -C -C Factorize R2 + B'*X*B . -C - CALL DPOTRF( 'U', M, DWORK( I3 ), M, INFO2 ) -C ^ -1 -C Compute Dk = -( R2 + B'*X*B ) (D' - B'*X*H) . -C - CALL DLACPY( 'F', M, NP, DWORK( I20 ), M, DK, LDDK ) - CALL DPOTRS( 'U', M, NP, DWORK( I3 ), M, DK, LDDK, INFO2 ) -C ^ ^ -C Compute Bk = -H + B*Dk . -C - CALL DLACPY( 'F', N, NP, DWORK( I9 ), N, DWORK( I23 ), N ) - CALL DGEMM( 'N', 'N', N, NP, M, ONE, B, LDB, DK, LDDK, - $ -ONE, DWORK( I23 ), N ) -C -1/2 -C Compute R2 *F2 . -C - CALL DGEMM( 'N', 'N', M, N, M, ONE, DWORK( I5 ), M, - $ DWORK( I18+NP ), NP+M, ZERO, CK, LDCK ) -C ^ -1/2 ^ -1 -C Compute Ck = R2 *F2 - Dk*( C + Z2 *F1 ) . -C - CALL DGEMM( 'N', 'N', M, N, NP, -ONE, DK, LDDK, - $ DWORK( I21 ), NP, ONE, CK, LDCK ) -C ^ ^ -C Compute Ak = A + H*C + B*Ck . -C - CALL DLACPY( 'F', N, N, A, LDA, AK, LDAK ) - CALL DGEMM( 'N', 'N', N, N, NP, ONE, DWORK( I9 ), N, C, LDC, - $ ONE, AK, LDAK ) - CALL DGEMM( 'N', 'N', N, N, M, ONE, B, LDB, CK, LDCK, - $ ONE, AK, LDAK ) -C ^ -C Compute Ip + D*Dk . -C - CALL DLASET( 'Full', NP, NP, ZERO, ONE, DWORK( I24 ), NP ) - CALL DGEMM( 'N', 'N', NP, NP, M, ONE, D, LDD, DK, LDDK, - $ ONE, DWORK( I24 ), NP ) -C ^ -C Compute Im + Dk*D . -C - CALL DLASET( 'Full', M, M, ZERO, ONE, DWORK( I25 ), M ) - CALL DGEMM( 'N', 'N', M, M, NP, ONE, DK, LDDK, D, LDD, - $ ONE, DWORK( I25 ), M ) -C ^ ^ ^ ^ -1 -C Compute Ck = M*Ck, M = (Im + Dk*D) . -C - ANORM = DLANGE( '1', M, M, DWORK( I25 ), M, DWORK( IWRK ) ) - CALL DGETRF( M, M, DWORK( I25 ), M, IWORK, INFO2 ) - IF( INFO2.NE.0 ) THEN - INFO = 7 - RETURN - END IF - CALL DGECON( '1', M, DWORK( I25 ), M, ANORM, RCOND( 6 ), - $ DWORK( IWRK ), IWORK( M+1 ), INFO2 ) -C -C Return if the matrix is singular to working precision. -C - IF( RCOND( 6 ).LT.TOLL ) THEN - INFO = 7 - RETURN - END IF - CALL DGETRS( 'N', M, N, DWORK( I25 ), M, IWORK, CK, LDCK, INFO2 ) -C ^ ^ -C Compute Dk = M*Dk . -C - CALL DGETRS( 'N', M, NP, DWORK( I25 ), M, IWORK, DK, LDDK, INFO2 ) -C ^ -C Compute Bk*D . -C - CALL DGEMM( 'N', 'N', N, M, NP, ONE, DWORK( I23 ), N, D, LDD, - $ ZERO, DWORK( I26 ), N ) -C ^ ^ -C Compute Ak = Ak - Bk*D*Ck. -C - CALL DGEMM( 'N', 'N', N, N, M, -ONE, DWORK( I26 ), N, CK, LDCK, - $ ONE, AK, LDAK ) -C ^ ^ -1 -C Compute Bk = Bk*(Ip + D*Dk) . -C - ANORM = DLANGE( '1', NP, NP, DWORK( I24 ), NP, DWORK( IWRK ) ) - CALL DLACPY( 'Full', N, NP, DWORK( I23 ), N, BK, LDBK ) - CALL MB02VD( 'N', N, NP, DWORK( I24 ), NP, IWORK, BK, LDBK, - $ INFO2 ) - IF( INFO2.NE.0 ) THEN - INFO = 6 - RETURN - END IF - CALL DGECON( '1', NP, DWORK( I24 ), NP, ANORM, RCOND( 5 ), - $ DWORK( IWRK ), IWORK( NP+1 ), INFO2 ) -C -C Return if the matrix is singular to working precision. -C - IF( RCOND( 5 ).LT.TOLL ) THEN - INFO = 6 - RETURN - END IF -C -C Workspace usage. -C - I2 = 1 + NP*NP - I3 = I2 + N*NP - I4 = I3 + M*M - I5 = I4 + N*M - I6 = I5 + NP*N - I7 = I6 + M*N - I8 = I7 + N2*N2 - I9 = I8 + N2 -C - IWRK = I9 + N2 -C -C Compute Ip - D*Dk . -C - CALL DLASET( 'Full', NP, NP, ZERO, ONE, DWORK, NP ) - CALL DGEMM( 'N', 'N', NP, NP, M, -ONE, D, LDD, DK, LDDK, ONE, - $ DWORK, NP ) -C -1 -C Compute Bk*(Ip-D*Dk) . -C - CALL DLACPY( 'Full', N, NP, BK, LDBK, DWORK( I2 ), N ) - CALL MB02VD( 'N', N, NP, DWORK, NP, IWORK, DWORK( I2 ), N, INFO2 ) - IF( INFO2.NE.0 ) THEN - INFO = 8 - RETURN - END IF -C -C Compute Im - Dk*D . -C - CALL DLASET( 'Full', M, M, ZERO, ONE, DWORK( I3 ), M ) - CALL DGEMM( 'N', 'N', M, M, NP, -ONE, DK, LDDK, D, LDD, ONE, - $ DWORK( I3 ), M ) -C -1 -C Compute B*(Im-Dk*D) . -C - CALL DLACPY( 'Full', N, M, B, LDB, DWORK( I4 ), N ) - CALL MB02VD( 'N', N, M, DWORK( I3 ), M, IWORK, DWORK( I4 ), N, - $ INFO2 ) - IF( INFO2.NE.0 ) THEN - INFO = 9 - RETURN - END IF -C -C Compute D*Ck . -C - CALL DGEMM( 'N', 'N', NP, N, M, ONE, D, LDD, CK, LDCK, ZERO, - $ DWORK( I5 ), NP ) -C -C Compute Dk*C . -C - CALL DGEMM( 'N', 'N', M, N, NP, ONE, DK, LDDK, C, LDC, ZERO, - $ DWORK( I6 ), M ) -C -C Compute the closed-loop state matrix. -C - CALL DLACPY( 'F', N, N, A, LDA, DWORK( I7 ), N2 ) - CALL DGEMM( 'N', 'N', N, N, M, ONE, DWORK( I4 ), N, - $ DWORK( I6 ), M, ONE, DWORK( I7 ), N2 ) - CALL DGEMM( 'N', 'N', N, N, M, ONE, DWORK( I4 ), N, CK, LDCK, - $ ZERO, DWORK( I7+N2*N ), N2 ) - CALL DGEMM( 'N', 'N', N, N, NP, ONE, DWORK( I2 ), N, C, LDC, - $ ZERO, DWORK( I7+N ), N2 ) - CALL DLACPY( 'F', N, N, AK, LDAK, DWORK( I7+N2*N+N ), N2 ) - CALL DGEMM( 'N', 'N', N, N, NP, ONE, DWORK( I2 ), N, - $ DWORK( I5 ), NP, ONE, DWORK( I7+N2*N+N ), N2 ) -C -C Compute the closed-loop poles. -C - CALL DGEES( 'N', 'N', SELECT, N2, DWORK( I7 ), N2, SDIM, - $ DWORK( I8 ), DWORK( I9 ), DWORK( IWRK ), N, - $ DWORK( IWRK ), LDWORK-IWRK+1, BWORK, INFO2 ) - IF( INFO2.NE.0 ) THEN - INFO = 3 - RETURN - END IF - LWAMAX = MAX( LWAMAX, INT( DWORK( IWRK ) ) + IWRK - 1 ) -C -C Check the stability of the closed-loop system. -C - NS = 0 -C - DO 140 I = 0, N2 - 1 - IF( DLAPY2( DWORK( I8+I ), DWORK( I9+I ) ).GT.ONE ) - $ NS = NS + 1 - 140 CONTINUE -C - IF( NS.GT.0 ) THEN - INFO = 10 - RETURN - END IF -C - DWORK( 1 ) = DBLE( LWAMAX ) - RETURN -C *** Last line of SB10ZD *** - END diff --git a/mex/sources/libslicot/SB10ZP.f b/mex/sources/libslicot/SB10ZP.f deleted file mode 100644 index efaa9ac14..000000000 --- a/mex/sources/libslicot/SB10ZP.f +++ /dev/null @@ -1,339 +0,0 @@ - SUBROUTINE SB10ZP( DISCFL, N, A, LDA, B, C, D, IWORK, DWORK, - $ LDWORK, INFO ) -C -C SLICOT RELEASE 5.0. -C -C Copyright (c) 2002-2009 NICONET e.V. -C -C This program is free software: you can redistribute it and/or -C modify it under the terms of the GNU General Public License as -C published by the Free Software Foundation, either version 2 of -C the License, or (at your option) any later version. -C -C This program is distributed in the hope that it will be useful, -C but WITHOUT ANY WARRANTY; without even the implied warranty of -C MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the -C GNU General Public License for more details. -C -C You should have received a copy of the GNU General Public License -C along with this program. If not, see -C . -C -C PURPOSE -C -C To transform a SISO (single-input single-output) system [A,B;C,D] -C by mirroring its unstable poles and zeros in the boundary of the -C stability domain, thus preserving the frequency response of the -C system, but making it stable and minimum phase. Specifically, for -C a continuous-time system, the positive real parts of its poles -C and zeros are exchanged with their negatives. Discrete-time -C systems are first converted to continuous-time systems using a -C bilinear transformation, and finally converted back. -C -C ARGUMENTS -C -C Input/Output parameters -C -C DISCFL (input) INTEGER -C Indicates the type of the system, as follows: -C = 0: continuous-time system; -C = 1: discrete-time system. -C -C N (input/output) INTEGER -C On entry, the order of the original system. N >= 0. -C On exit, the order of the transformed, minimal system. -C -C A (input/output) DOUBLE PRECISION array, dimension (LDA,N) -C On entry, the leading N-by-N part of this array must -C contain the original system matrix A. -C On exit, the leading N-by-N part of this array contains -C the transformed matrix A, in an upper Hessenberg form. -C -C LDA INTEGER -C The leading dimension of the array A. LDA >= MAX(1,N). -C -C B (input/output) DOUBLE PRECISION array, dimension (N) -C On entry, this array must contain the original system -C vector B. -C On exit, this array contains the transformed vector B. -C -C C (input/output) DOUBLE PRECISION array, dimension (N) -C On entry, this array must contain the original system -C vector C. -C On exit, this array contains the transformed vector C. -C The first N-1 elements are zero (for the exit value of N). -C -C D (input/output) DOUBLE PRECISION array, dimension (1) -C On entry, this array must contain the original system -C scalar D. -C On exit, this array contains the transformed scalar D. -C -C Workspace -C -C IWORK INTEGER array, dimension max(2,N+1) -C -C DWORK DOUBLE PRECISION array, dimension (LDWORK) -C On exit, if INFO = 0, DWORK(1) returns the optimal value -C of LDWORK. -C -C LDWORK INTEGER -C The length of the array DWORK. -C LDWORK >= max(N*N + 5*N, 6*N + 1 + min(1,N)). -C For optimum performance LDWORK should be larger. -C -C Error indicator -C -C INFO INTEGER -C = 0: successful exit; -C < 0: if INFO = -i, the i-th argument had an illegal -C value; -C = 1: if the discrete --> continuous transformation cannot -C be made; -C = 2: if the system poles cannot be found; -C = 3: if the inverse system cannot be found, i.e., D is -C (close to) zero; -C = 4: if the system zeros cannot be found; -C = 5: if the state-space representation of the new -C transfer function T(s) cannot be found; -C = 6: if the continuous --> discrete transformation cannot -C be made. -C -C METHOD -C -C First, if the system is discrete-time, it is transformed to -C continuous-time using alpha = beta = 1 in the bilinear -C transformation implemented in the SLICOT routine AB04MD. -C Then the eigenvalues of A, i.e., the system poles, are found. -C Then, the inverse of the original system is found and its poles, -C i.e., the system zeros, are evaluated. -C The obtained system poles Pi and zeros Zi are checked and if a -C positive real part is detected, it is exchanged by -Pi or -Zi. -C Then the polynomial coefficients of the transfer function -C T(s) = Q(s)/P(s) are found. -C The state-space representation of T(s) is then obtained. -C The system matrices B, C, D are scaled so that the transformed -C system has the same system gain as the original system. -C If the original system is discrete-time, then the result (which is -C continuous-time) is converted back to discrete-time. -C -C CONTRIBUTORS -C -C Asparuh Markovski, Technical University of Sofia, July 2003. -C -C REVISIONS -C -C V. Sima, Research Institute for Informatics, Bucharest, Aug. 2003. -C -C KEYWORDS -C -C Bilinear transformation, stability, state-space representation. -C -C ****************************************************************** -C -C .. Parameters .. - DOUBLE PRECISION ZERO, ONE - PARAMETER ( ZERO = 0.0D+0, ONE = 1.0D+0 ) -C .. -C .. Scalar Arguments .. - INTEGER DISCFL, INFO, LDA, LDWORK, N -C .. -C .. Array Arguments .. - INTEGER IWORK( * ) - DOUBLE PRECISION A( LDA, * ), B( * ), C( * ), D( * ), DWORK( * ) -C .. -C .. Local Scalars .. - INTEGER I, IDW1, IDW2, IDW3, IMP, IMZ, INFO2, IWA, IWP, - $ IWPS, IWQ, IWQS, LDW1, MAXWRK, REP, REZ - DOUBLE PRECISION RCOND, SCALB, SCALC, SCALD -C .. -C .. Local Arrays .. - INTEGER INDEX(1) -C .. -C .. External Subroutines .. - EXTERNAL AB04MD, AB07ND, DCOPY, DGEEV, DLACPY, DSCAL, - $ MC01PD, TD04AD, XERBLA -C .. -C .. Intrinsic Functions .. - INTRINSIC ABS, INT, MAX, MIN, SIGN, SQRT -C -C Test input parameters and workspace. -C - INFO = 0 - IF ( DISCFL.NE.0 .AND. DISCFL.NE.1 ) THEN - INFO = -1 - ELSE IF ( N.LT.0 ) THEN - INFO = -2 - ELSE IF( LDA.LT.MAX( 1, N ) ) THEN - INFO = -4 - ELSE IF ( LDWORK.LT.MAX( N*N + 5*N, 6*N + 1 + MIN( 1, N ) ) ) THEN - INFO = -10 - END IF -C - IF ( INFO.NE.0 ) THEN -C -C Error return. -C - CALL XERBLA( 'SB10ZP', -INFO ) - RETURN - END IF -C -C Quick return if possible. -C - IF( N.EQ.0 ) THEN - DWORK(1) = ONE - RETURN - END IF -C -C Workspace usage 1. -C - REP = 1 - IMP = REP + N - REZ = IMP + N - IMZ = REZ + N - IWA = REZ - IDW1 = IWA + N*N - LDW1 = LDWORK - IDW1 + 1 -C -C 1. Discrete --> continuous transformation if needed. -C - IF ( DISCFL.EQ.1 ) THEN -C -C Workspace: need max(1,N); -C prefer larger. -C - CALL AB04MD( 'D', N, 1, 1, ONE, ONE, A, LDA, B, LDA, C, 1, - $ D, 1, IWORK, DWORK, LDWORK, INFO2 ) - IF ( INFO2.NE.0 ) THEN - INFO = 1 - RETURN - END IF - MAXWRK = INT( DWORK(1) ) - ELSE - MAXWRK = 0 - END IF -C -C 2. Determine the factors for restoring system gain. -C - SCALD = D(1) - SCALC = SQRT( ABS( SCALD ) ) - SCALB = SIGN( SCALC, SCALD ) -C -C 3. Find the system poles, i.e., the eigenvalues of A. -C Workspace: need N*N + 2*N + 3*N; -C prefer larger. -C - CALL DLACPY( 'Full', N, N, A, LDA, DWORK(IWA), N ) -C - CALL DGEEV( 'N', 'N', N, DWORK(IWA), N, DWORK(REP), DWORK(IMP), - $ DWORK(IDW1), 1, DWORK(IDW1), 1, DWORK(IDW1), LDW1, - $ INFO2 ) - IF ( INFO2.NE.0 ) THEN - INFO = 2 - RETURN - END IF - MAXWRK = MAX( MAXWRK, INT( DWORK(IDW1) + IDW1 - 1 ) ) -C -C 4. Compute the inverse system [Ai, Bi; Ci, Di]. -C Workspace: need N*N + 2*N + 4; -C prefer larger. -C - CALL AB07ND( N, 1, A, LDA, B, LDA, C, 1, D, 1, RCOND, IWORK, - $ DWORK(IDW1), LDW1, INFO2 ) - IF ( INFO2.NE.0 ) THEN - INFO = 3 - RETURN - END IF - MAXWRK = MAX( MAXWRK, INT( DWORK(IDW1) + IDW1 - 1 ) ) -C -C 5. Find the system zeros, i.e., the eigenvalues of Ai. -C Workspace: need 4*N + 3*N; -C prefer larger. -C - IDW1 = IMZ + N - LDW1 = LDWORK - IDW1 + 1 -C - CALL DGEEV( 'N', 'N', N, A, LDA, DWORK(REZ), DWORK(IMZ), - $ DWORK(IDW1), 1, DWORK(IDW1), 1, DWORK(IDW1), LDW1, - $ INFO2 ) - IF ( INFO2.NE.0 ) THEN - INFO = 4 - RETURN - END IF - MAXWRK = MAX( MAXWRK, INT( DWORK(IDW1) + IDW1 - 1 ) ) -C -C 6. Exchange the zeros and the poles with positive real parts with -C their negatives. -C - DO 10 I = 0, N - 1 - IF ( DWORK(REP+I).GT.ZERO ) - $ DWORK(REP+I) = -DWORK(REP+I) - IF ( DWORK(REZ+I).GT.ZERO ) - $ DWORK(REZ+I) = -DWORK(REZ+I) - 10 CONTINUE -C -C Workspace usage 2. -C - IWP = IDW1 - IDW2 = IWP + N + 1 - IWPS = 1 -C -C 7. Construct the nominator and the denominator -C of the system transfer function T( s ) = Q( s )/P( s ). -C 8. Rearrange the coefficients in Q(s) and P(s) because -C MC01PD subroutine produces them in increasing powers of s. -C Workspace: need 6*N + 2. -C - CALL MC01PD( N, DWORK(REP), DWORK(IMP), DWORK(IWP), DWORK(IDW2), - $ INFO2 ) - CALL DCOPY( N+1, DWORK(IWP), -1, DWORK(IWPS), 1 ) -C -C Workspace usage 3. -C - IWQ = IDW1 - IWQS = IWPS + N + 1 - IDW3 = IWQS + N + 1 -C - CALL MC01PD( N, DWORK(REZ), DWORK(IMZ), DWORK(IWQ), DWORK(IDW2), - $ INFO2 ) - CALL DCOPY( N+1, DWORK(IWQ), -1, DWORK(IWQS), 1 ) -C -C 9. Make the conversion T(s) --> [A, B; C, D]. -C Workspace: need 2*N + 2 + N + max(N,3); -C prefer larger. -C - INDEX(1) = N - CALL TD04AD( 'R', 1, 1, INDEX, DWORK(IWPS), 1, DWORK(IWQS), 1, 1, - $ N, A, LDA, B, LDA, C, 1, D, 1, -ONE, IWORK, - $ DWORK(IDW3), LDWORK-IDW3+1, INFO2 ) - IF ( INFO2.NE.0 ) THEN - INFO = 5 - RETURN - END IF - MAXWRK = MAX( MAXWRK, INT( DWORK(IDW3) + IDW3 - 1 ) ) -C -C 10. Scale the transformed system to the previous gain. -C - IF ( N.GT.0 ) THEN - CALL DSCAL( N, SCALB, B, 1 ) - C(N) = SCALC*C(N) - END IF -C - D(1) = SCALD -C -C 11. Continuous --> discrete transformation if needed. -C - IF ( DISCFL.EQ.1 ) THEN - CALL AB04MD( 'C', N, 1, 1, ONE, ONE, A, LDA, B, LDA, C, 1, - $ D, 1, IWORK, DWORK, LDWORK, INFO2 ) - - IF ( INFO2.NE.0 ) THEN - INFO = 6 - RETURN - END IF - END IF -C - DWORK(1) = MAXWRK - RETURN -C -C *** Last line of SB10ZP *** - END diff --git a/mex/sources/libslicot/SB16AD.f b/mex/sources/libslicot/SB16AD.f deleted file mode 100644 index 565147c9f..000000000 --- a/mex/sources/libslicot/SB16AD.f +++ /dev/null @@ -1,719 +0,0 @@ - SUBROUTINE SB16AD( DICO, JOBC, JOBO, JOBMR, WEIGHT, EQUIL, ORDSEL, - $ N, M, P, NC, NCR, ALPHA, A, LDA, B, LDB, - $ C, LDC, D, LDD, AC, LDAC, BC, LDBC, CC, LDCC, - $ DC, LDDC, NCS, HSVC, TOL1, TOL2, IWORK, DWORK, - $ LDWORK, IWARN, INFO ) -C -C SLICOT RELEASE 5.0. -C -C Copyright (c) 2002-2009 NICONET e.V. -C -C This program is free software: you can redistribute it and/or -C modify it under the terms of the GNU General Public License as -C published by the Free Software Foundation, either version 2 of -C the License, or (at your option) any later version. -C -C This program is distributed in the hope that it will be useful, -C but WITHOUT ANY WARRANTY; without even the implied warranty of -C MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the -C GNU General Public License for more details. -C -C You should have received a copy of the GNU General Public License -C along with this program. If not, see -C . -C -C PURPOSE -C -C To compute a reduced order controller (Acr,Bcr,Ccr,Dcr) for an -C original state-space controller representation (Ac,Bc,Cc,Dc) by -C using the frequency-weighted square-root or balancing-free -C square-root Balance & Truncate (B&T) or Singular Perturbation -C Approximation (SPA) model reduction methods. The algorithm tries -C to minimize the norm of the frequency-weighted error -C -C ||V*(K-Kr)*W|| -C -C where K and Kr are the transfer-function matrices of the original -C and reduced order controllers, respectively. V and W are special -C frequency-weighting transfer-function matrices constructed -C to enforce closed-loop stability and/or closed-loop performance. -C If G is the transfer-function matrix of the open-loop system, then -C the following weightings V and W can be used: -C -1 -C (a) V = (I-G*K) *G, W = I - to enforce closed-loop stability; -C -1 -C (b) V = I, W = (I-G*K) *G - to enforce closed-loop stability; -C -1 -1 -C (c) V = (I-G*K) *G, W = (I-G*K) - to enforce closed-loop -C stability and performance. -C -C G has the state space representation (A,B,C,D). -C If K is unstable, only the ALPHA-stable part of K is reduced. -C -C ARGUMENTS -C -C Mode Parameters -C -C DICO CHARACTER*1 -C Specifies the type of the original controller as follows: -C = 'C': continuous-time controller; -C = 'D': discrete-time controller. -C -C JOBC CHARACTER*1 -C Specifies the choice of frequency-weighted controllability -C Grammian as follows: -C = 'S': choice corresponding to standard Enns' method [1]; -C = 'E': choice corresponding to the stability enhanced -C modified Enns' method of [2]. -C -C JOBO CHARACTER*1 -C Specifies the choice of frequency-weighted observability -C Grammian as follows: -C = 'S': choice corresponding to standard Enns' method [1]; -C = 'E': choice corresponding to the stability enhanced -C modified combination method of [2]. -C -C JOBMR CHARACTER*1 -C Specifies the model reduction approach to be used -C as follows: -C = 'B': use the square-root B&T method; -C = 'F': use the balancing-free square-root B&T method; -C = 'S': use the square-root SPA method; -C = 'P': use the balancing-free square-root SPA method. -C -C WEIGHT CHARACTER*1 -C Specifies the type of frequency-weighting, as follows: -C = 'N': no weightings are used (V = I, W = I); -C = 'O': stability enforcing left (output) weighting -C -1 -C V = (I-G*K) *G is used (W = I); -C = 'I': stability enforcing right (input) weighting -C -1 -C W = (I-G*K) *G is used (V = I); -C = 'P': stability and performance enforcing weightings -C -1 -1 -C V = (I-G*K) *G , W = (I-G*K) are used. -C -C EQUIL CHARACTER*1 -C Specifies whether the user wishes to preliminarily -C equilibrate the triplets (A,B,C) and (Ac,Bc,Cc) as -C follows: -C = 'S': perform equilibration (scaling); -C = 'N': do not perform equilibration. -C -C ORDSEL CHARACTER*1 -C Specifies the order selection method as follows: -C = 'F': the resulting order NCR is fixed; -C = 'A': the resulting order NCR is automatically -C determined on basis of the given tolerance TOL1. -C -C Input/Output Parameters -C -C N (input) INTEGER -C The order of the open-loop system state-space -C representation, i.e., the order of the matrix A. N >= 0. -C -C M (input) INTEGER -C The number of system inputs. M >= 0. -C -C P (input) INTEGER -C The number of system outputs. P >= 0. -C -C NC (input) INTEGER -C The order of the controller state-space representation, -C i.e., the order of the matrix AC. NC >= 0. -C -C NCR (input/output) INTEGER -C On entry with ORDSEL = 'F', NCR is the desired order of -C the resulting reduced order controller. 0 <= NCR <= NC. -C On exit, if INFO = 0, NCR is the order of the resulting -C reduced order controller. For a controller with NCU -C ALPHA-unstable eigenvalues and NCS ALPHA-stable -C eigenvalues (NCU+NCS = NC), NCR is set as follows: -C if ORDSEL = 'F', NCR is equal to -C NCU+MIN(MAX(0,NCR-NCU),NCMIN), where NCR is the desired -C order on entry, NCMIN is the number of frequency-weighted -C Hankel singular values greater than NCS*EPS*S1, EPS is the -C machine precision (see LAPACK Library Routine DLAMCH) and -C S1 is the largest Hankel singular value (computed in -C HSVC(1)); NCR can be further reduced to ensure -C HSVC(NCR-NCU) > HSVC(NCR+1-NCU); -C if ORDSEL = 'A', NCR is the sum of NCU and the number of -C Hankel singular values greater than MAX(TOL1,NCS*EPS*S1). -C -C ALPHA (input) DOUBLE PRECISION -C Specifies the ALPHA-stability boundary for the eigenvalues -C of the state dynamics matrix AC. For a continuous-time -C controller (DICO = 'C'), ALPHA <= 0 is the boundary value -C for the real parts of eigenvalues; for a discrete-time -C controller (DICO = 'D'), 0 <= ALPHA <= 1 represents the -C boundary value for the moduli of eigenvalues. -C The ALPHA-stability domain does not include the boundary. -C -C A (input/output) DOUBLE PRECISION array, dimension (LDA,N) -C On entry, the leading N-by-N part of this array must -C contain the state dynamics matrix A of the open-loop -C system. -C On exit, if INFO = 0 and EQUIL = 'S', the leading N-by-N -C part of this array contains the scaled state dynamics -C matrix of the open-loop system. -C If EQUIL = 'N', this array is unchanged on exit. -C -C LDA INTEGER -C The leading dimension of array A. LDA >= MAX(1,N). -C -C B (input/output) DOUBLE PRECISION array, dimension (LDB,M) -C On entry, the leading N-by-M part of this array must -C contain the input/state matrix B of the open-loop system. -C On exit, if INFO = 0 and EQUIL = 'S', the leading N-by-M -C part of this array contains the scaled input/state matrix -C of the open-loop system. -C If EQUIL = 'N', this array is unchanged on exit. -C -C LDB INTEGER -C The leading dimension of array B. LDB >= MAX(1,N). -C -C C (input/output) DOUBLE PRECISION array, dimension (LDC,N) -C On entry, the leading P-by-N part of this array must -C contain the state/output matrix C of the open-loop system. -C On exit, if INFO = 0 and EQUIL = 'S', the leading P-by-N -C part of this array contains the scaled state/output matrix -C of the open-loop system. -C If EQUIL = 'N', this array is unchanged on exit. -C -C LDC INTEGER -C The leading dimension of array C. LDC >= MAX(1,P). -C -C D (input) DOUBLE PRECISION array, dimension (LDD,M) -C The leading P-by-M part of this array must contain the -C input/output matrix D of the open-loop system. -C -C LDD INTEGER -C The leading dimension of array D. LDD >= MAX(1,P). -C -C AC (input/output) DOUBLE PRECISION array, dimension (LDAC,NC) -C On entry, the leading NC-by-NC part of this array must -C contain the state dynamics matrix Ac of the original -C controller. -C On exit, if INFO = 0, the leading NCR-by-NCR part of this -C array contains the state dynamics matrix Acr of the -C reduced controller. The resulting Ac has a -C block-diagonal form with two blocks. -C For a system with NCU ALPHA-unstable eigenvalues and -C NCS ALPHA-stable eigenvalues (NCU+NCS = NC), the leading -C NCU-by-NCU block contains the unreduced part of Ac -C corresponding to the ALPHA-unstable eigenvalues. -C The trailing (NCR+NCS-NC)-by-(NCR+NCS-NC) block contains -C the reduced part of Ac corresponding to ALPHA-stable -C eigenvalues. -C -C LDAC INTEGER -C The leading dimension of array AC. LDAC >= MAX(1,NC). -C -C BC (input/output) DOUBLE PRECISION array, dimension (LDBC,P) -C On entry, the leading NC-by-P part of this array must -C contain the input/state matrix Bc of the original -C controller. -C On exit, if INFO = 0, the leading NCR-by-P part of this -C array contains the input/state matrix Bcr of the reduced -C controller. -C -C LDBC INTEGER -C The leading dimension of array BC. LDBC >= MAX(1,NC). -C -C CC (input/output) DOUBLE PRECISION array, dimension (LDCC,NC) -C On entry, the leading M-by-NC part of this array must -C contain the state/output matrix Cc of the original -C controller. -C On exit, if INFO = 0, the leading M-by-NCR part of this -C array contains the state/output matrix Ccr of the reduced -C controller. -C -C LDCC INTEGER -C The leading dimension of array CC. LDCC >= MAX(1,M). -C -C DC (input/output) DOUBLE PRECISION array, dimension (LDDC,P) -C On entry, the leading M-by-P part of this array must -C contain the input/output matrix Dc of the original -C controller. -C On exit, if INFO = 0, the leading M-by-P part of this -C array contains the input/output matrix Dcr of the reduced -C controller. -C -C LDDC INTEGER -C The leading dimension of array DC. LDDC >= MAX(1,M). -C -C NCS (output) INTEGER -C The dimension of the ALPHA-stable part of the controller. -C -C HSVC (output) DOUBLE PRECISION array, dimension (NC) -C If INFO = 0, the leading NCS elements of this array -C contain the frequency-weighted Hankel singular values, -C ordered decreasingly, of the ALPHA-stable part of the -C controller. -C -C Tolerances -C -C TOL1 DOUBLE PRECISION -C If ORDSEL = 'A', TOL1 contains the tolerance for -C determining the order of the reduced controller. -C For model reduction, the recommended value is -C TOL1 = c*S1, where c is a constant in the -C interval [0.00001,0.001], and S1 is the largest -C frequency-weighted Hankel singular value of the -C ALPHA-stable part of the original controller -C (computed in HSVC(1)). -C If TOL1 <= 0 on entry, the used default value is -C TOL1 = NCS*EPS*S1, where NCS is the number of -C ALPHA-stable eigenvalues of Ac and EPS is the machine -C precision (see LAPACK Library Routine DLAMCH). -C If ORDSEL = 'F', the value of TOL1 is ignored. -C -C TOL2 DOUBLE PRECISION -C The tolerance for determining the order of a minimal -C realization of the ALPHA-stable part of the given -C controller. The recommended value is TOL2 = NCS*EPS*S1. -C This value is used by default if TOL2 <= 0 on entry. -C If TOL2 > 0 and ORDSEL = 'A', then TOL2 <= TOL1. -C -C Workspace -C -C IWORK INTEGER array, dimension MAX(1,LIWRK1,LIWRK2) -C LIWRK1 = 0, if JOBMR = 'B'; -C LIWRK1 = NC, if JOBMR = 'F'; -C LIWRK1 = 2*NC, if JOBMR = 'S' or 'P'; -C LIWRK2 = 0, if WEIGHT = 'N'; -C LIWRK2 = 2*(M+P), if WEIGHT = 'O', 'I', or 'P'. -C On exit, if INFO = 0, IWORK(1) contains NCMIN, the order -C of the computed minimal realization of the stable part of -C the controller. -C -C DWORK DOUBLE PRECISION array, dimension (LDWORK) -C On exit, if INFO = 0, DWORK(1) returns the optimal value -C of LDWORK. -C -C LDWORK INTEGER -C The length of the array DWORK. -C LDWORK >= 2*NC*NC + MAX( 1, LFREQ, LSQRED ), -C where -C LFREQ = (N+NC)*(N+NC+2*M+2*P)+ -C MAX((N+NC)*(N+NC+MAX(N+NC,M,P)+7), (M+P)*(M+P+4)) -C if WEIGHT = 'I' or 'O' or 'P'; -C LFREQ = NC*(MAX(M,P)+5) if WEIGHT = 'N' and EQUIL = 'N'; -C LFREQ = MAX(N,NC*(MAX(M,P)+5)) if WEIGHT = 'N' and -C EQUIL = 'S'; -C LSQRED = MAX( 1, 2*NC*NC+5*NC ); -C For optimum performance LDWORK should be larger. -C -C Warning Indicator -C -C IWARN INTEGER -C = 0: no warning; -C = 1: with ORDSEL = 'F', the selected order NCR is greater -C than NSMIN, the sum of the order of the -C ALPHA-unstable part and the order of a minimal -C realization of the ALPHA-stable part of the given -C controller; in this case, the resulting NCR is set -C equal to NSMIN; -C = 2: with ORDSEL = 'F', the selected order NCR -C corresponds to repeated singular values for the -C ALPHA-stable part of the controller, which are -C neither all included nor all excluded from the -C reduced model; in this case, the resulting NCR is -C automatically decreased to exclude all repeated -C singular values; -C = 3: with ORDSEL = 'F', the selected order NCR is less -C than the order of the ALPHA-unstable part of the -C given controller. In this case NCR is set equal to -C the order of the ALPHA-unstable part. -C -C Error Indicator -C -C INFO INTEGER -C = 0: successful exit; -C < 0: if INFO = -i, the i-th argument had an illegal -C value; -C = 1: the closed-loop system is not well-posed; -C its feedthrough matrix is (numerically) singular; -C = 2: the computation of the real Schur form of the -C closed-loop state matrix failed; -C = 3: the closed-loop state matrix is not stable; -C = 4: the solution of a symmetric eigenproblem failed; -C = 5: the computation of the ordered real Schur form of Ac -C failed; -C = 6: the separation of the ALPHA-stable/unstable -C diagonal blocks failed because of very close -C eigenvalues; -C = 7: the computation of Hankel singular values failed. -C -C METHOD -C -C Let K be the transfer-function matrix of the original linear -C controller -C -C d[xc(t)] = Ac*xc(t) + Bc*y(t) -C u(t) = Cc*xc(t) + Dc*y(t), (1) -C -C where d[xc(t)] is dxc(t)/dt for a continuous-time system and -C xc(t+1) for a discrete-time system. The subroutine SB16AD -C determines the matrices of a reduced order controller -C -C d[z(t)] = Acr*z(t) + Bcr*y(t) -C u(t) = Ccr*z(t) + Dcr*y(t), (2) -C -C such that the corresponding transfer-function matrix Kr minimizes -C the norm of the frequency-weighted error -C -C V*(K-Kr)*W, (3) -C -C where V and W are special stable transfer-function matrices -C chosen to enforce stability and/or performance of the closed-loop -C system [3] (see description of the parameter WEIGHT). -C -C The following procedure is used to reduce K in conjunction -C with the frequency-weighted balancing approach of [2] -C (see also [3]): -C -C 1) Decompose additively K, of order NC, as -C -C K = K1 + K2, -C -C such that K1 has only ALPHA-stable poles and K2, of order NCU, -C has only ALPHA-unstable poles. -C -C 2) Compute for K1 a B&T or SPA frequency-weighted approximation -C K1r of order NCR-NCU using the frequency-weighted balancing -C approach of [1] in conjunction with accuracy enhancing -C techniques specified by the parameter JOBMR. -C -C 3) Assemble the reduced model Kr as -C -C Kr = K1r + K2. -C -C For the reduction of the ALPHA-stable part, several accuracy -C enhancing techniques can be employed (see [2] for details). -C -C If JOBMR = 'B', the square-root B&T method of [1] is used. -C -C If JOBMR = 'F', the balancing-free square-root version of the -C B&T method [1] is used. -C -C If JOBMR = 'S', the square-root version of the SPA method [2,3] -C is used. -C -C If JOBMR = 'P', the balancing-free square-root version of the -C SPA method [2,3] is used. -C -C For each of these methods, two left and right truncation matrices -C are determined using the Cholesky factors of an input -C frequency-weighted controllability Grammian P and an output -C frequency-weighted observability Grammian Q. -C P and Q are determined as the leading NC-by-NC diagonal blocks -C of the controllability Grammian of K*W and of the -C observability Grammian of V*K. Special techniques developed in [2] -C are used to compute the Cholesky factors of P and Q directly -C (see also SLICOT Library routine SB16AY). -C The frequency-weighted Hankel singular values HSVC(1), ...., -C HSVC(NC) are computed as the square roots of the eigenvalues -C of the product P*Q. -C -C REFERENCES -C -C [1] Enns, D. -C Model reduction with balanced realizations: An error bound -C and a frequency weighted generalization. -C Proc. 23-th CDC, Las Vegas, pp. 127-132, 1984. -C -C [2] Varga, A. and Anderson, B.D.O. -C Square-root balancing-free methods for frequency-weighted -C balancing related model reduction. -C (report in preparation) -C -C [3] Anderson, B.D.O and Liu, Y. -C Controller reduction: concepts and approaches. -C IEEE Trans. Autom. Control, Vol. 34, pp. 802-812, 1989. -C -C NUMERICAL ASPECTS -C -C The implemented methods rely on accuracy enhancing square-root -C techniques. -C -C CONTRIBUTORS -C -C A. Varga, German Aerospace Center, Oberpfaffenhofen, Sept. 2000. -C D. Sima, University of Bucharest, Sept. 2000. -C V. Sima, Research Institute for Informatics, Bucharest, Sept.2000. -C -C REVISIONS -C -C A. Varga, Australian National University, Canberra, November 2000. -C V. Sima, Research Institute for Informatics, Bucharest, Dec. 2000, -C Sep. 2001. -C -C KEYWORDS -C -C Controller reduction, frequency weighting, multivariable system, -C state-space model, state-space representation. -C -C ****************************************************************** -C -C .. Parameters .. - DOUBLE PRECISION C100, ONE, ZERO - PARAMETER ( C100 = 100.0D0, ONE = 1.0D0, ZERO = 0.0D0 ) -C .. Scalar Arguments .. - CHARACTER DICO, EQUIL, JOBC, JOBO, JOBMR, ORDSEL, WEIGHT - INTEGER INFO, IWARN, LDA, LDAC, LDB, LDBC, LDC, LDCC, - $ LDD, LDDC, LDWORK, M, N, NC, NCR, NCS, P - DOUBLE PRECISION ALPHA, TOL1, TOL2 -C .. Array Arguments .. - INTEGER IWORK(*) - DOUBLE PRECISION A(LDA,*), AC(LDAC,*), B(LDB,*), BC(LDBC,*), - $ C(LDC,*), CC(LDCC,*), D(LDD,*), DC(LDDC,*), - $ DWORK(*), HSVC(*) -C .. Local Scalars .. - LOGICAL BAL, BTA, DISCR, FIXORD, FRWGHT, ISTAB, LEFTW, - $ OSTAB, PERF, RIGHTW, SPA - INTEGER IERR, IWARNL, KI, KR, KT, KTI, KU, KW, LW, MP, - $ NCU, NCU1, NMR, NNC, NRA, WRKOPT - DOUBLE PRECISION ALPWRK, MAXRED, SCALEC, SCALEO -C .. External Functions .. - LOGICAL LSAME - DOUBLE PRECISION DLAMCH - EXTERNAL DLAMCH, LSAME -C .. External Subroutines .. - EXTERNAL AB09IX, SB16AY, TB01ID, TB01KD, XERBLA -C .. Intrinsic Functions .. - INTRINSIC INT, MAX, MIN, SQRT -C .. Executable Statements .. -C - INFO = 0 - IWARN = 0 - DISCR = LSAME( DICO, 'D' ) - BTA = LSAME( JOBMR, 'B' ) .OR. LSAME( JOBMR, 'F' ) - SPA = LSAME( JOBMR, 'S' ) .OR. LSAME( JOBMR, 'P' ) - BAL = LSAME( JOBMR, 'B' ) .OR. LSAME( JOBMR, 'S' ) - FIXORD = LSAME( ORDSEL, 'F' ) - ISTAB = LSAME( WEIGHT, 'I' ) - OSTAB = LSAME( WEIGHT, 'O' ) - PERF = LSAME( WEIGHT, 'P' ) - LEFTW = OSTAB .OR. PERF - RIGHTW = ISTAB .OR. PERF - FRWGHT = LEFTW .OR. RIGHTW -C - LW = 1 - NNC = N + NC - MP = M + P - IF( FRWGHT ) THEN - LW = NNC*( NNC + 2*MP ) + - $ MAX( NNC*( NNC + MAX( NNC, M, P ) + 7 ), MP*( MP + 4 ) ) - ELSE - LW = NC*( MAX( M, P ) + 5 ) - IF ( LSAME( EQUIL, 'S' ) ) - $ LW = MAX( N, LW ) - END IF - LW = 2*NC*NC + MAX( 1, LW, NC*( 2*NC + 5 ) ) -C -C Check the input scalar arguments. -C - IF( .NOT. ( LSAME( DICO, 'C' ) .OR. DISCR ) ) THEN - INFO = -1 - ELSE IF( .NOT.( LSAME( JOBC, 'S' ) .OR. LSAME( JOBC, 'E' ) ) ) - $ THEN - INFO = -2 - ELSE IF( .NOT.( LSAME( JOBO, 'S' ) .OR. LSAME( JOBO, 'E' ) ) ) - $ THEN - INFO = -3 - ELSE IF( .NOT. ( BTA .OR. SPA ) ) THEN - INFO = -4 - ELSE IF( .NOT.( FRWGHT .OR. LSAME( WEIGHT, 'N' ) ) ) THEN - INFO = -5 - ELSE IF( .NOT. ( LSAME( EQUIL, 'S' ) .OR. - $ LSAME( EQUIL, 'N' ) ) ) THEN - INFO = -6 - ELSE IF( .NOT. ( FIXORD .OR. LSAME( ORDSEL, 'A' ) ) ) THEN - INFO = -7 - ELSE IF( N.LT.0 ) THEN - INFO = -8 - ELSE IF( M.LT.0 ) THEN - INFO = -9 - ELSE IF( P.LT.0 ) THEN - INFO = -10 - ELSE IF( NC.LT.0 ) THEN - INFO = -11 - ELSE IF( FIXORD .AND. ( NCR.LT.0 .OR. NCR.GT.NC ) ) THEN - INFO = -12 - ELSE IF( ( DISCR .AND. ( ALPHA.LT.ZERO .OR. ALPHA.GT.ONE ) ) .OR. - $ ( .NOT.DISCR .AND. ALPHA.GT.ZERO ) ) THEN - INFO = -13 - ELSE IF( LDA.LT.MAX( 1, N ) ) THEN - INFO = -15 - ELSE IF( LDB.LT.MAX( 1, N ) ) THEN - INFO = -17 - ELSE IF( LDC.LT.MAX( 1, P ) ) THEN - INFO = -19 - ELSE IF( LDD.LT.MAX( 1, P ) ) THEN - INFO = -21 - ELSE IF( LDAC.LT.MAX( 1, NC ) ) THEN - INFO = -23 - ELSE IF( LDBC.LT.MAX( 1, NC ) ) THEN - INFO = -25 - ELSE IF( LDCC.LT.MAX( 1, M ) ) THEN - INFO = -27 - ELSE IF( LDDC.LT.MAX( 1, M ) ) THEN - INFO = -29 - ELSE IF( TOL2.GT.ZERO .AND. .NOT.FIXORD .AND. TOL2.GT.TOL1 ) THEN - INFO = -33 - ELSE IF( LDWORK.LT.LW ) THEN - INFO = -36 - END IF -C - IF( INFO.NE.0 ) THEN -C -C Error return. -C - CALL XERBLA( 'SB16AD', -INFO ) - RETURN - END IF -C -C Quick return if possible. -C - IF( MIN( NC, M, P ).EQ.0 ) THEN - NCR = 0 - NCS = 0 - IWORK(1) = 0 - DWORK(1) = ONE - RETURN - END IF -C - IF( LSAME( EQUIL, 'S' ) ) THEN -C -C Scale simultaneously the matrices A, B and C and AC, BC and CC; -C A <- inv(T1)*A*T1, B <- inv(T1)*B and C <- C*T1, where T1 is a -C diagonal matrix; -C AC <- inv(T2)*AC*T2, BC <- inv(T2)*BC and CC <- CC*T2, where T2 -C is a diagonal matrix. -C -C Real workspace: need MAX(N,NC). -C - MAXRED = C100 - CALL TB01ID( 'All', N, M, P, MAXRED, A, LDA, B, LDB, C, LDC, - $ DWORK, INFO ) - MAXRED = C100 - CALL TB01ID( 'All', NC, P, M, MAXRED, AC, LDAC, BC, LDBC, - $ CC, LDCC, DWORK, INFO ) - END IF -C -C Correct the value of ALPHA to ensure stability. -C - ALPWRK = ALPHA - IF( DISCR ) THEN - IF( ALPHA.EQ.ONE ) ALPWRK = ONE - SQRT( DLAMCH( 'E' ) ) - ELSE - IF( ALPHA.EQ.ZERO ) ALPWRK = -SQRT( DLAMCH( 'E' ) ) - END IF -C -C Reduce Ac to a block-diagonal real Schur form, with the -C ALPHA-unstable part in the leading diagonal position, using a -C non-orthogonal similarity transformation, AC <- inv(T)*AC*T, and -C apply the transformation to BC and CC: -C BC <- inv(T)*BC and CC <- CC*T. -C -C Workspace: need NC*(NC+5); -C prefer larger. -C - WRKOPT = 1 - KU = 1 - KR = KU + NC*NC - KI = KR + NC - KW = KI + NC -C - CALL TB01KD( DICO, 'Unstable', 'General', NC, P, M, ALPWRK, - $ AC, LDAC, BC, LDBC, CC, LDCC, NCU, DWORK(KU), NC, - $ DWORK(KR), DWORK(KI), DWORK(KW), LDWORK-KW+1, IERR ) -C - IF( IERR.NE.0 ) THEN - IF( IERR.NE.3 ) THEN - INFO = 5 - ELSE - INFO = 6 - END IF - RETURN - END IF - WRKOPT = MAX( WRKOPT, INT( DWORK(KW) ) + KW - 1 ) -C - IWARNL = 0 - NCS = NC - NCU - IF( FIXORD ) THEN - NRA = MAX( 0, NCR-NCU ) - IF( NCR.LT.NCU ) - $ IWARNL = 3 - ELSE - NRA = 0 - END IF -C -C Finish if only unstable part is present. -C - IF( NCS.EQ.0 ) THEN - NCR = NCU - IWORK(1) = 0 - DWORK(1) = WRKOPT - RETURN - END IF -C -C Allocate working storage. -C - KT = 1 - KTI = KT + NC*NC - KW = KTI + NC*NC -C -C Compute in DWORK(KTI) and DWORK(KT) the Cholesky factors S and R -C of the frequency-weighted controllability and observability -C Grammians, respectively. -C -C Real workspace: need 2*NC*NC + MAX( 1, LFREQ ), -C where -C LFREQ = (N+NC)*(N+NC+2*M+2*P)+ -C MAX((N+NC)*(N+NC+MAX(N+NC,M,P)+7), -C (M+P)*(M+P+4)) -C if WEIGHT = 'I' or 'O' or 'P'; -C LFREQ = NCS*(MAX(M,P)+5) if WEIGHT = 'N'; -C prefer larger. -C Integer workspace: 2*(M+P) if WEIGHT = 'I' or 'O' or 'P'; -C 0, if WEIGHT = 'N'. -C - CALL SB16AY( DICO, JOBC, JOBO, WEIGHT, N, M, P, NC, NCS, - $ A, LDA, B, LDB, C, LDC, D, LDD, - $ AC, LDAC, BC, LDBC, CC, LDCC, DC, LDDC, - $ SCALEC, SCALEO, DWORK(KTI), NC, DWORK(KT), NC, - $ IWORK, DWORK(KW), LDWORK-KW+1, INFO ) - IF( INFO.NE.0 ) - $ RETURN - WRKOPT = MAX( WRKOPT, INT( DWORK(KW) ) + KW - 1 ) -C -C Compute a BTA or SPA of the stable part. -C Real workspace: need 2*NC*NC + MAX( 1, 2*NC*NC+5*NC, -C NC*MAX(M,P) ); -C prefer larger. -C Integer workspace: 0, if JOBMR = 'B'; -C NC, if JOBMR = 'F'; -C 2*NC, if JOBMR = 'S' or 'P'. -C - NCU1 = NCU + 1 - CALL AB09IX( DICO, JOBMR, 'Schur', ORDSEL, NCS, P, M, NRA, SCALEC, - $ SCALEO, AC(NCU1,NCU1), LDAC, BC(NCU1,1), LDBC, - $ CC(1,NCU1), LDCC, DC, LDDC, DWORK(KTI), NC, - $ DWORK(KT), NC, NMR, HSVC, TOL1, TOL2, IWORK, - $ DWORK(KW), LDWORK-KW+1, IWARN, IERR ) - IWARN = MAX( IWARN, IWARNL ) - IF( IERR.NE.0 ) THEN - INFO = 7 - RETURN - END IF - NCR = NRA + NCU - IWORK(1) = NMR -C - DWORK(1) = MAX( WRKOPT, INT( DWORK(KW) ) + KW - 1 ) -C - RETURN -C *** Last line of SB16AD *** - END diff --git a/mex/sources/libslicot/SB16AY.f b/mex/sources/libslicot/SB16AY.f deleted file mode 100644 index 51438021e..000000000 --- a/mex/sources/libslicot/SB16AY.f +++ /dev/null @@ -1,909 +0,0 @@ - SUBROUTINE SB16AY( DICO, JOBC, JOBO, WEIGHT, N, M, P, NC, NCS, - $ A, LDA, B, LDB, C, LDC, D, LDD, - $ AC, LDAC, BC, LDBC, CC, LDCC, DC, LDDC, - $ SCALEC, SCALEO, S, LDS, R, LDR, - $ IWORK, DWORK, LDWORK, INFO ) -C -C SLICOT RELEASE 5.0. -C -C Copyright (c) 2002-2009 NICONET e.V. -C -C This program is free software: you can redistribute it and/or -C modify it under the terms of the GNU General Public License as -C published by the Free Software Foundation, either version 2 of -C the License, or (at your option) any later version. -C -C This program is distributed in the hope that it will be useful, -C but WITHOUT ANY WARRANTY; without even the implied warranty of -C MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the -C GNU General Public License for more details. -C -C You should have received a copy of the GNU General Public License -C along with this program. If not, see -C . -C -C PURPOSE -C -C To compute for given state-space representations (A,B,C,D) and -C (Ac,Bc,Cc,Dc) of the transfer-function matrices of the -C open-loop system G and feedback controller K, respectively, -C the Cholesky factors of the frequency-weighted -C controllability and observability Grammians corresponding -C to a frequency-weighted model reduction problem. -C The controller must stabilize the closed-loop system. -C The state matrix Ac must be in a block-diagonal real Schur form -C Ac = diag(Ac1,Ac2), where Ac1 contains the unstable eigenvalues -C of Ac and Ac2 contains the stable eigenvalues of Ac. -C -C ARGUMENTS -C -C Mode Parameters -C -C DICO CHARACTER*1 -C Specifies the type of the systems as follows: -C = 'C': G and K are continuous-time systems; -C = 'D': G and K are discrete-time systems. -C -C JOBC CHARACTER*1 -C Specifies the choice of frequency-weighted controllability -C Grammian as follows: -C = 'S': choice corresponding to standard Enns' method [1]; -C = 'E': choice corresponding to the stability enhanced -C modified Enns' method of [2]. -C -C JOBO CHARACTER*1 -C Specifies the choice of frequency-weighted observability -C Grammian as follows: -C = 'S': choice corresponding to standard Enns' method [1]; -C = 'E': choice corresponding to the stability enhanced -C modified combination method of [2]. -C -C WEIGHT CHARACTER*1 -C Specifies the type of frequency-weighting, as follows: -C = 'N': no weightings are used (V = I, W = I); -C = 'O': stability enforcing left (output) weighting -C -1 -C V = (I-G*K) *G is used (W = I); -C = 'I': stability enforcing right (input) weighting -C -1 -C W = (I-G*K) *G is used (V = I); -C = 'P': stability and performance enforcing weightings -C -1 -1 -C V = (I-G*K) *G , W = (I-G*K) are used. -C -C Input/Output Parameters -C -C N (input) INTEGER -C The order of the open-loop system state-space -C representation, i.e., the order of the matrix A. N >= 0. -C -C M (input) INTEGER -C The number of system inputs. M >= 0. -C -C P (input) INTEGER -C The number of system outputs. P >= 0. -C -C NC (input) INTEGER -C The order of the controller state-space representation, -C i.e., the order of the matrix AC. NC >= 0. -C -C NCS (input) INTEGER -C The dimension of the stable part of the controller, i.e., -C the order of matrix Ac2. NC >= NCS >= 0. -C -C A (input) DOUBLE PRECISION array, dimension (LDA,N) -C The leading N-by-N part of this array must contain the -C state matrix A of the system with the transfer-function -C matrix G. -C -C LDA INTEGER -C The leading dimension of array A. LDA >= MAX(1,N). -C -C B (input) DOUBLE PRECISION array, dimension (LDB,M) -C The leading N-by-M part of this array must contain the -C input/state matrix B. -C -C LDB INTEGER -C The leading dimension of array B. LDB >= MAX(1,N). -C -C C (input) DOUBLE PRECISION array, dimension (LDC,N) -C The leading P-by-N part of this array must contain the -C state/output matrix C. -C -C LDC INTEGER -C The leading dimension of array C. LDC >= MAX(1,P). -C -C D (input) DOUBLE PRECISION array, dimension (LDD,M) -C The leading P-by-M part of this array must contain the -C input/output matrix D of the open-loop system. -C -C LDD INTEGER -C The leading dimension of array D. LDD >= MAX(1,P). -C -C AC (input) DOUBLE PRECISION array, dimension (LDAC,NC) -C The leading NC-by-NC part of this array must contain -C the state dynamics matrix Ac of the controller in a -C block diagonal real Schur form Ac = diag(Ac1,Ac2), where -C Ac1 is (NC-NCS)-by-(NC-NCS) and contains the unstable -C eigenvalues of Ac, and Ac2 is NCS-by-NCS and contains -C the stable eigenvalues of Ac. -C -C LDAC INTEGER -C The leading dimension of array AC. LDAC >= MAX(1,NC). -C -C BC (input) DOUBLE PRECISION array, dimension (LDBC,P) -C The leading NC-by-P part of this array must contain -C the input/state matrix Bc of the controller. -C -C LDBC INTEGER -C The leading dimension of array BC. LDBC >= MAX(1,NC). -C -C CC (input) DOUBLE PRECISION array, dimension (LDCC,NC) -C The leading M-by-NC part of this array must contain -C the state/output matrix Cc of the controller. -C -C LDCC INTEGER -C The leading dimension of array CC. LDCC >= MAX(1,M). -C -C DC (input) DOUBLE PRECISION array, dimension (LDDC,P) -C The leading M-by-P part of this array must contain -C the input/output matrix Dc of the controller. -C -C LDDC INTEGER -C The leading dimension of array DC. LDDC >= MAX(1,M). -C -C SCALEC (output) DOUBLE PRECISION -C Scaling factor for the controllability Grammian. -C See METHOD. -C -C SCALEO (output) DOUBLE PRECISION -C Scaling factor for the observability Grammian. See METHOD. -C -C S (output) DOUBLE PRECISION array, dimension (LDS,NCS) -C The leading NCS-by-NCS upper triangular part of this array -C contains the Cholesky factor S of the frequency-weighted -C controllability Grammian P = S*S'. See METHOD. -C -C LDS INTEGER -C The leading dimension of array S. LDS >= MAX(1,NCS). -C -C R (output) DOUBLE PRECISION array, dimension (LDR,NCS) -C The leading NCS-by-NCS upper triangular part of this array -C contains the Cholesky factor R of the frequency-weighted -C observability Grammian Q = R'*R. See METHOD. -C -C LDR INTEGER -C The leading dimension of array R. LDR >= MAX(1,NCS). -C -C Workspace -C -C IWORK INTEGER array, dimension MAX(LIWRK) -C LIWRK = 0, if WEIGHT = 'N'; -C LIWRK = 2(M+P), if WEIGHT = 'O', 'I', or 'P'. -C -C DWORK DOUBLE PRECISION array, dimension (LDWORK) -C On exit, if INFO = 0, DWORK(1) returns the optimal value -C of LDWORK. -C -C LDWORK INTEGER -C The length of the array DWORK. -C LDWORK >= MAX( 1, LFREQ ), -C where -C LFREQ = (N+NC)*(N+NC+2*M+2*P)+ -C MAX((N+NC)*(N+NC+MAX(N+NC,M,P)+7), (M+P)*(M+P+4)) -C if WEIGHT = 'I' or 'O' or 'P'; -C LFREQ = NCS*(MAX(M,P)+5) if WEIGHT = 'N'. -C For optimum performance LDWORK should be larger. -C -C Error Indicator -C -C INFO INTEGER -C = 0: successful exit; -C < 0: if INFO = -i, the i-th argument had an illegal -C value; -C = 1: the closed-loop system is not well-posed; -C its feedthrough matrix is (numerically) singular; -C = 2: the computation of the real Schur form of the -C closed-loop state matrix failed; -C = 3: the closed-loop state matrix is not stable; -C = 4: the solution of a symmetric eigenproblem failed; -C = 5: the NCS-by-NCS trailing part Ac2 of the state -C matrix Ac is not stable or not in a real Schur form. -C -C METHOD -C -C If JOBC = 'S', the controllability Grammian P is determined as -C follows: -C -C - if WEIGHT = 'O' or 'N', P satisfies for a continuous-time -C controller the Lyapunov equation -C -C Ac2*P + P*Ac2' + scalec^2*Bc*Bc' = 0 -C -C and for a discrete-time controller -C -C Ac2*P*Ac2' - P + scalec^2*Bc*Bc' = 0; -C -C - if WEIGHT = 'I' or 'P', let Pi be the solution of the -C continuous-time Lyapunov equation -C -C Ai*Pi + Pi*Ai' + scalec^2*Bi*Bi' = 0 -C -C or of the discrete-time Lyapunov equation -C -C Ai*Pi*Ai' - Pi + scalec^2*Bi*Bi' = 0, -C -C where Ai and Bi are the state and input matrices of a special -C state-space realization of the input frequency weight (see [2]); -C P results as the trailing NCS-by-NCS part of Pi partitioned as -C -C Pi = ( * * ). -C ( * P ) -C -C If JOBC = 'E', a modified controllability Grammian P1 >= P is -C determined to guarantee stability for a modified Enns' method [2]. -C -C If JOBO = 'S', the observability Grammian Q is determined as -C follows: -C -C - if WEIGHT = 'I' or 'N', Q satisfies for a continuous-time -C controller the Lyapunov equation -C -C Ac2'*Q + Q*Ac2 + scaleo^2*Cc'*Cc = 0 -C -C and for a discrete-time controller -C -C Ac2'*Q*Ac2 - Q + scaleo^2*Cc'*Cc = 0; -C -C - if WEIGHT = 'O' or 'P', let Qo be the solution of the -C continuous-time Lyapunov equation -C -C Ao'*Qo + Qo*Ao + scaleo^2*Co'*Co = 0 -C -C or of the discrete-time Lyapunov equation -C -C Ao'*Qo*Ao - Qo + scaleo^2*Co'*Co = 0, -C -C where Ao and Co are the state and output matrices of a -C special state-space realization of the output frequency weight -C (see [2]); if WEIGHT = 'O', Q results as the leading NCS-by-NCS -C part of Qo partitioned as -C -C Qo = ( Q * ) -C ( * * ) -C -C while if WEIGHT = 'P', Q results as the trailing NCS-by-NCS -C part of Qo partitioned as -C -C Qo = ( * * ). -C ( * Q ) -C -C If JOBO = 'E', a modified observability Grammian Q1 >= Q is -C determined to guarantee stability for a modified Enns' method [2]. -C -C The routine computes directly the Cholesky factors S and R -C such that P = S*S' and Q = R'*R according to formulas -C developed in [2]. -C -C REFERENCES -C -C [1] Enns, D. -C Model reduction with balanced realizations: An error bound -C and a frequency weighted generalization. -C Proc. CDC, Las Vegas, pp. 127-132, 1984. -C -C [2] Varga, A. and Anderson, B.D.O. -C Frequency-weighted balancing related controller reduction. -C Proceedings of the 15th IFAC World Congress, July 21-26, 2002, -C Barcelona, Spain, Vol.15, Part 1, 2002-07-21. -C -C CONTRIBUTORS -C -C A. Varga, Australian National University, Canberra, November 2000. -C -C REVISIONS -C -C V. Sima, Research Institute for Informatics, Bucharest, Dec. 2000, -C May 2009. -C A. Varga, DLR Oberpfafenhofen, June 2001. -C -C -C KEYWORDS -C -C Controller reduction, frequency weighting, multivariable system, -C state-space model, state-space representation. -C -C ****************************************************************** -C -C .. Parameters .. - DOUBLE PRECISION ZERO, ONE - PARAMETER ( ZERO = 0.0D0, ONE = 1.0D0 ) -C .. Scalar Arguments .. - CHARACTER DICO, JOBC, JOBO, WEIGHT - INTEGER INFO, LDA, LDAC, LDB, LDBC, LDC, LDCC, LDD, LDDC, - $ LDR, LDS, LDWORK, M, N, NC, NCS, P - DOUBLE PRECISION SCALEC, SCALEO -C .. Array Arguments .. - INTEGER IWORK(*) - DOUBLE PRECISION A(LDA,*), AC(LDAC,*), B(LDB,*), BC(LDBC,*), - $ C(LDC,*), CC(LDCC,*), D(LDD,*), DC(LDDC,*), - $ DWORK(*), R(LDR,*), S(LDS,*) -C .. Local Scalars .. - CHARACTER JOBFAC - LOGICAL DISCR, FRWGHT, LEFTW, PERF, RIGHTW - INTEGER I, IERR, J, JJ, KI, KL, KQ, KR, KTAU, KU, KW, - $ KWA, KWB, KWC, KWD, LDU, LW, MBBAR, ME, MP, - $ NCU, NCU1, NE, NNC, NNCU, PCBAR, PE, WRKOPT - DOUBLE PRECISION RCOND, T, TOL -C .. Local Arrays .. - DOUBLE PRECISION DUM(1) -C .. External Functions .. - LOGICAL LSAME - DOUBLE PRECISION DLAMCH - EXTERNAL DLAMCH, LSAME -C .. External Subroutines .. - EXTERNAL AB05PD, AB05QD, AB07ND, DCOPY, DLACPY, DLASET, - $ DSCAL, DSYEV, MB01WD, MB04OD, SB03OD, SB03OU, - $ XERBLA -C .. Intrinsic Functions .. - INTRINSIC ABS, INT, MAX, MIN, SQRT -C .. Executable Statements .. -C - DISCR = LSAME( DICO, 'D' ) - LEFTW = LSAME( WEIGHT, 'O' ) - RIGHTW = LSAME( WEIGHT, 'I' ) - PERF = LSAME( WEIGHT, 'P' ) - FRWGHT = LEFTW .OR. RIGHTW .OR. PERF -C - INFO = 0 - NNC = N + NC - MP = M + P - IF( FRWGHT ) THEN - LW = NNC*( NNC + 2*MP ) + - $ MAX( NNC*( NNC + MAX( NNC, M, P ) + 7 ), MP*( MP + 4 ) ) - ELSE - LW = NCS*( MAX( M, P ) + 5 ) - END IF - LW = MAX( 1, LW ) -C - IF( .NOT. ( LSAME( DICO, 'C' ) .OR. DISCR ) ) THEN - INFO = -1 - ELSE IF( .NOT.( LSAME( JOBC, 'S' ) .OR. LSAME( JOBC, 'E' ) ) ) - $ THEN - INFO = -2 - ELSE IF( .NOT.( LSAME( JOBO, 'S' ) .OR. LSAME( JOBO, 'E' ) ) ) - $ THEN - INFO = -3 - ELSE IF( .NOT.( FRWGHT .OR. LSAME( WEIGHT, 'N' ) ) ) THEN - INFO = -4 - ELSE IF( N.LT.0 ) THEN - INFO = -5 - ELSE IF( M.LT.0 ) THEN - INFO = -6 - ELSE IF( P.LT.0 ) THEN - INFO = -7 - ELSE IF( NC.LT.0 ) THEN - INFO = -8 - ELSE IF( NCS.LT.0 .OR. NCS.GT.NC ) THEN - INFO = -9 - ELSE IF( LDA.LT.MAX( 1, N ) ) THEN - INFO = -11 - ELSE IF( LDB.LT.MAX( 1, N ) ) THEN - INFO = -13 - ELSE IF( LDC.LT.MAX( 1, P ) ) THEN - INFO = -15 - ELSE IF( LDD.LT.MAX( 1, P ) ) THEN - INFO = -17 - ELSE IF( LDAC.LT.MAX( 1, NC ) ) THEN - INFO = -19 - ELSE IF( LDBC.LT.MAX( 1, NC ) ) THEN - INFO = -21 - ELSE IF( LDCC.LT.MAX( 1, M ) ) THEN - INFO = -23 - ELSE IF( LDDC.LT.MAX( 1, M ) ) THEN - INFO = -25 - ELSE IF( LDS.LT.MAX( 1, NCS ) ) THEN - INFO = -29 - ELSE IF( LDR.LT.MAX( 1, NCS ) ) THEN - INFO = -31 - ELSE IF( LDWORK.LT.LW ) THEN - INFO = -34 - END IF -C - IF( INFO.NE.0 ) THEN -C -C Error return. -C - CALL XERBLA( 'SB16AY', -INFO ) - RETURN - END IF -C -C Quick return if possible. -C - SCALEC = ONE - SCALEO = ONE - IF( MIN( NCS, M, P ).EQ.0 ) THEN - DWORK(1) = ONE - RETURN - END IF -C - WRKOPT = 1 - NCU = NC - NCS - NCU1 = NCU + 1 -C - IF( .NOT.PERF ) THEN -C -C Compute the Grammians in the case of no weighting or -C one-sided weighting. -C - IF( LEFTW .OR. LSAME( WEIGHT, 'N' ) ) THEN -C -C Compute the standard controllability Grammian. -C -C Solve for the Cholesky factor S of P, P = S*S', -C the continuous-time Lyapunov equation (if DICO = 'C') -C -C Ac2*P + P*Ac2' + scalec^2*Bc2*Bc2' = 0, -C -C or the discrete-time Lyapunov equation (if DICO = 'D') -C -C Ac2*P*Ac2' - P + scalec^2*Bc2*Bc2' = 0, -C -C where Bc2 is the matrix formed from the last NCS rows of Bc. -C -C Workspace: need NCS*(P+5); -C prefer larger. - KU = 1 - KTAU = KU + NCS*P - KW = KTAU + NCS -C - CALL DLACPY( 'Full', NCS, P, BC(NCU1,1), LDBC, - $ DWORK(KU), NCS ) - CALL SB03OU( DISCR, .TRUE., NCS, P, AC(NCU1,NCU1), LDAC, - $ DWORK(KU), NCS, DWORK(KTAU), S, LDS, SCALEC, - $ DWORK(KW), LDWORK-KW+1, IERR ) - IF( IERR.NE.0 ) THEN - INFO = 5 - RETURN - END IF - WRKOPT = MAX( WRKOPT, INT( DWORK(KW) ) + KW - 1 ) - END IF -C - IF( RIGHTW .OR. LSAME( WEIGHT, 'N' ) ) THEN -C -C Compute the standard observability Grammian. -C -C Solve for the Cholesky factor R of Q, Q = R'*R, -C the continuous-time Lyapunov equation (if DICO = 'C') -C -C Ac2'*Q + Q*Ac2 + scaleo^2*Cc2'*Cc2 = 0, -C -C or the discrete-time Lyapunov equation (if DICO = 'D') -C -C Ac2'*Q*Ac2 - Q + scaleo^2*Cc2'*Cc2 = 0, -C -C where Cc2 is the matrix formed from the last NCS columns -C of Cc. -C -C Workspace: need NCS*(M + 5); -C prefer larger. - KU = 1 - KTAU = KU + M*NCS - KW = KTAU + NCS -C - CALL DLACPY( 'Full', M, NCS, CC(1,NCU1), LDCC, - $ DWORK(KU), M ) - CALL SB03OU( DISCR, .FALSE., NCS, M, AC(NCU1,NCU1), LDAC, - $ DWORK(KU), M, DWORK(KTAU), R, LDR, SCALEO, - $ DWORK(KW), LDWORK-KW+1, IERR ) - IF( IERR.NE.0 ) THEN - INFO = 5 - RETURN - END IF - WRKOPT = MAX( WRKOPT, INT( DWORK(KW) ) + KW - 1 ) - END IF -C -C Finish if there are no weights. -C - IF( LSAME( WEIGHT, 'N' ) ) THEN - DWORK(1) = WRKOPT - RETURN - END IF - END IF -C - IF( FRWGHT ) THEN -C -C Allocate working storage for computing the weights. -C -C Real workspace: need MAX(1,NNC*NNC+2*NNC*MP+MP*(MP+4)); -C Integer workspace: need 2*MP. -C - KWA = 1 - KWB = KWA + NNC*NNC - KWC = KWB + NNC*MP - KWD = KWC + NNC*MP - KW = KWD + MP*MP - KL = KWD -C - IF( LEFTW ) THEN -C -C Build the extended matrices -C -C Ao = ( Ac+Bc*inv(R)*D*Cc Bc*inv(R)*C ), -C ( B*inv(Rt)*Cc A+B*Dc*inv(R)*C ) -C -C Co = ( -inv(R)*D*Cc -inv(R)*C ) , -C -C where R = I-D*Dc and Rt = I-Dc*D. -C -1 -C Method: Compute Ge = ( Ge11 Ge12 ), where Ge = ( K -Im ). -C ( Ge21 Ge22 ) ( -Ip G ) -C -C -1 -C Then Ge11 = -(I-G*K) *G . -C -C Construct first Ge = ( K -Im ) such that the stable part -C ( -Ip G ) -C of K is in the leading position (to avoid updating of -C QR factorization). -C - CALL DLASET( 'Full', M, P, ZERO, ZERO, DWORK(KWD), MP ) - CALL AB05PD( 'N', NCS, P, M, NCU, ONE, - $ AC(NCU1,NCU1), LDAC, BC(NCU1,1), LDBC, - $ CC(1,NCU1), LDCC, DWORK(KWD), MP, - $ AC, LDAC, BC, LDBC, CC, LDCC, DC, LDDC, - $ NE, DWORK(KWA), NNC, DWORK(KWB), NNC, - $ DWORK(KWC), MP, DWORK(KWD), MP, IERR ) - CALL AB05QD( 'Over', NC, P, M, N, M, P, DWORK(KWA), NNC, - $ DWORK(KWB), NNC, DWORK(KWC), MP, DWORK(KWD), - $ MP, A, LDA, B, LDB, C, LDC, D, LDD, - $ NE, ME, PE, DWORK(KWA), NNC, DWORK(KWB), NNC, - $ DWORK(KWC), MP, DWORK(KWD), MP, IERR ) - CALL DLASET( 'Full', M, M, ZERO, -ONE, DWORK(KWD+MP*P), MP ) - CALL DLASET( 'Full', P, P, ZERO, -ONE, DWORK(KWD+M), MP ) -C - ELSE -C -C Build the extended matrices -C -C Ai = ( A+B*Dc*inv(R)*C B*inv(Rt)*Cc ) , -C ( Bc*inv(R)*C Ac+Bc*inv(R)*D*Cc ) -C -C Bi = ( B*Dc*inv(R) B*inv(Rt) ) , -C ( Bc*inv(R) Bc*D*inv(Rt) ) -C -C Ci = ( -inv(R)*C -inv(R)*D*Cc ) , where -C -C R = I-D*Dc and Rt = I-Dc*D. -C -C -1 -C Method: Compute Ge = ( Ge11 Ge12 ), where Ge = ( G -Ip ). -C ( Ge21 Ge22 ) ( -Im K ) -C -C -1 -1 -C Then Ge22 = -(I-G*K) *G and Ge21 = -(I-G*K) . -C -C Construct first Ge = ( G -Ip ). -C ( -Im K ) -C - CALL AB05QD( 'N', N, M, P, NC, P, M, A, LDA, B, LDB, C, LDC, - $ D, LDD, AC, LDAC, BC, LDBC, CC, LDCC, DC, LDDC, - $ NE, ME, PE, DWORK(KWA), NNC, DWORK(KWB), NNC, - $ DWORK(KWC), MP, DWORK(KWD), MP, IERR ) - CALL DLASET( 'Full', P, P, ZERO, -ONE, DWORK(KWD+MP*M), MP ) - CALL DLASET( 'Full', M, M, ZERO, -ONE, DWORK(KWD+P), MP ) - END IF -C -1 -C Compute Ge = ( Ge11 Ge12 ). -C ( Ge21 Ge22 ) -C -C Additional real workspace: need 4*MP; -C Integer workspace: need 2*MP. -C - CALL AB07ND( NNC, MP, DWORK(KWA), NNC, DWORK(KWB), NNC, - $ DWORK(KWC), MP, DWORK(KWD), MP, RCOND, - $ IWORK, DWORK(KW), LDWORK-KW+1, IERR ) - IF( IERR.NE.0 ) THEN - INFO = 1 - RETURN - END IF - WRKOPT = MAX( WRKOPT, INT( DWORK(KW) ) + KW - 1 ) -C -C -1 ( A1 | B1 B2 ) -C Partition Ge = (--------------) and select appropriate -C ( C1 | D11 D12 ) -C ( C2 | D21 D22 ) -C -C pointers to matrices and column dimensions to define weights. -C - IF( RIGHTW ) THEN -C -C Define B2 for Ge22. -C - ME = M - KWB = KWB + NNC*P - ELSE IF( PERF ) THEN -C -C Define B1 and C2 for Ge21. -C - ME = P - KWC = KWC + M - END IF - END IF -C - IF( LEFTW .OR. PERF ) THEN -C -C Compute the frequency-weighted observability Grammian. -C -C Solve for the Cholesky factor Ro of Qo, Qo = Ro'*Ro, -C the continuous-time Lyapunov equation (if DICO = 'C') -C -C Ao'*Qo + Qo*Ao + scaleo^2*Co'*Co = 0, -C -C or the discrete-time Lyapunov equation (if DICO = 'D') -C -C Ao'*Qo*Ao - Qo + scaleo^2*Co'*Co = 0. -C -C Additional workspace: need NNC*(NNC+MAX(NNC,P)+7); -C prefer larger. -C - LDU = MAX( NNC, P ) - KU = KL - KQ = KU + NNC*LDU - KR = KQ + NNC*NNC - KI = KR + NNC - KW = KI + NNC -C - JOBFAC = 'N' - CALL DLACPY( 'Full', P, NNC, DWORK(KWC), MP, DWORK(KU), LDU ) - CALL SB03OD( DICO, JOBFAC, 'No-transpose', NNC, P, - $ DWORK(KWA), NNC, DWORK(KQ), NNC, DWORK(KU), LDU, - $ SCALEO, DWORK(KR), DWORK(KI), DWORK(KW), - $ LDWORK-KW+1, IERR ) - IF( IERR.NE.0 ) THEN - IF( IERR.EQ.6 ) THEN - INFO = 2 - ELSE - INFO = 3 - END IF - RETURN - END IF - WRKOPT = MAX( WRKOPT, INT( DWORK(KW) ) + KW - 1 ) -C -C Partition Ro as Ro = ( R11 R12 ). -C ( 0 R22 ) -C - IF( LEFTW ) THEN -C -C R = R11 (NCS-by-NCS). -C - CALL DLACPY( 'Upper', NCS, NCS, DWORK(KU), LDU, R, LDR ) - ELSE -C -C Compute R such that R'*R = R22'*R22 + R12'*R12, where -C R22 is NCS-by-NCS and R12 is (N+NCU)-by-NCS. -C R22 corresponds to the stable part of the controller. -C - NNCU = N + NCU - CALL DLACPY( 'Upper', NCS, NCS, DWORK(KU+(LDU+1)*NNCU), LDU, - $ R, LDR ) - KTAU = KU - CALL MB04OD( 'Full', NCS, 0, NNCU, R, LDR, - $ DWORK(KU+LDU*NNCU), LDU, DUM, 1, DUM, 1, - $ DWORK(KTAU), DWORK(KW) ) -C - DO 10 J = 1, NCS - IF( R(J,J).LT.ZERO ) - $ CALL DSCAL( NCS-J+1, -ONE, R(J,J), LDR ) - 10 CONTINUE - END IF - END IF -C - IF( RIGHTW .OR. PERF ) THEN -C -C Compute the frequency-weighted controllability Grammian. -C -C Solve for the Cholesky factor Si of Pi, Pi = Si*Si', -C the continuous-time Lyapunov equation (if DICO = 'C') -C -C Ai*Pi + Pi*Ai' + scalec^2*Bi*Bi' = 0, -C -C or the discrete-time Lyapunov equation (if DICO = 'D') -C -C Ai*Pi*Ai' - Pi + scalec^2*Bi*Bi' = 0. -C -C Additional workspace: need NNC*(NNC+MAX(NNC,P,M)+7); -C prefer larger. -C - KU = KL - KQ = KU + NNC*MAX( NNC, ME ) - KR = KQ + NNC*NNC - KI = KR + NNC - KW = KI + NNC -C - CALL DLACPY( 'Full', NNC, ME, DWORK(KWB), NNC, DWORK(KU), NNC ) - JOBFAC = 'F' - IF( RIGHTW ) JOBFAC = 'N' - CALL SB03OD( DICO, JOBFAC, 'Transpose', NNC, ME, - $ DWORK(KWA), NNC, DWORK(KQ), NNC, DWORK(KU), NNC, - $ SCALEC, DWORK(KR), DWORK(KI), DWORK(KW), - $ LDWORK-KW+1, IERR ) - IF( IERR.NE.0 ) THEN - IF( IERR.EQ.6 ) THEN - INFO = 2 - ELSE - INFO = 3 - END IF - RETURN - END IF - WRKOPT = MAX( WRKOPT, INT( DWORK(KW) ) + KW - 1 ) -C -C Partition Si as Si = ( S11 S12 ) with S22 NCS-by-NCS and -C ( 0 S22 ) -C set S = S22. -C - NNCU = N + NCU - CALL DLACPY( 'Upper', NCS, NCS, DWORK(KU+(NNC+1)*NNCU), NNC, - $ S, LDS ) - END IF -C - KU = 1 - IF( LEFTW .OR. PERF ) THEN - IF( LSAME( JOBO, 'E' ) ) THEN -C -C Form Y = -Ac2'*(R'*R)-(R'*R)*Ac2 if DICO = 'C', or -C Y = -Ac2'*(R'*R)*Ac2+(R'*R) if DICO = 'D'. -C -C Workspace: need 2*NCS*NCS. -C - CALL DLACPY( 'Upper', NCS, NCS, R, LDR, DWORK(KU), NCS ) - CALL DLACPY( 'Full', NCS, NCS, AC(NCU1,NCU1), LDAC, - $ DWORK(KU+NCS*NCS), NCS ) - CALL MB01WD( DICO, 'Upper', 'No-transpose', 'Hessenberg', - $ NCS, -ONE, ZERO, R, LDR, DWORK(KU+NCS*NCS), - $ NCS, DWORK(KU), NCS, IERR ) -C -C Compute the eigendecomposition of Y as Y = Z*Sigma*Z'. -C - KW = KU + NCS - CALL DSYEV( 'Vectors', 'Upper', NCS, R, LDR, DWORK(KU), - $ DWORK(KW), LDWORK-KW+1, IERR ) - IF( IERR.GT.0 ) THEN - INFO = 4 - RETURN - END IF - WRKOPT = MAX( WRKOPT, INT( DWORK(KW) ) + KW - 1 ) -C -C Partition Sigma = (Sigma1,Sigma2), such that -C Sigma1 <= 0, Sigma2 > 0. -C Partition correspondingly Z = [Z1 Z2]. -C - TOL = MAX( ABS( DWORK(KU) ), ABS( DWORK(KU+NCS-1) ) ) - $ * DLAMCH( 'Epsilon') -C _ -C Form Cc = [ sqrt(Sigma2)*Z2' ] -C - PCBAR = 0 - JJ = KU - DO 20 J = 1, NCS - IF( DWORK(JJ).GT.TOL ) THEN - CALL DSCAL( NCS, SQRT( DWORK(JJ) ), R(1,J), 1 ) - CALL DCOPY( NCS, R(1,J), 1, DWORK(KW+PCBAR), NCS ) - PCBAR = PCBAR + 1 - END IF - JJ = JJ + 1 - 20 CONTINUE -C -C Solve for the Cholesky factor R of Q, Q = R'*R, -C the continuous-time Lyapunov equation (if DICO = 'C') -C _ _ -C Ac2'*Q + Q*Ac2 + scaleo^2*Cc'*Cc = 0, -C -C or the discrete-time Lyapunov equation (if DICO = 'D') -C _ _ -C Ac2'*Q*Ac2 - Q + scaleo^2*Cc'*Cc = 0. -C -C Workspace: need NCS*(NCS + 6); -C prefer larger. -C - KU = KW - KTAU = KU + NCS*NCS - KW = KTAU + NCS -C - CALL SB03OU( DISCR, .FALSE., NCS, PCBAR, AC(NCU1,NCU1), - $ LDAC, DWORK(KU), NCS, DWORK(KTAU), R, LDR, T, - $ DWORK(KW), LDWORK-KW+1, IERR ) - IF( IERR.NE.0 ) THEN - INFO = 5 - RETURN - END IF - SCALEO = SCALEO*T - WRKOPT = MAX( WRKOPT, INT( DWORK(KW) ) + KW - 1 ) - END IF -C - END IF -C - IF( RIGHTW .OR. PERF ) THEN - IF( LSAME( JOBC, 'E' ) ) THEN -C -C Form X = -A2c*(S*S')-(S*S')*Ac2' if DICO = 'C', or -C X = -Ac2*(S*S')*Ac2'+(S*S') if DICO = 'D'. -C -C Workspace: need 2*NCS*NCS. -C - CALL DLACPY( 'Upper', NCS, NCS, S, LDS, DWORK(KU), NCS ) - CALL DLACPY( 'Full', NCS, NCS, AC(NCU1,NCU1), LDAC, - $ DWORK(KU+NCS*NCS), NCS ) - CALL MB01WD( DICO, 'Upper', 'Transpose', 'Hessenberg', NCS, - $ -ONE, ZERO, S, LDS, DWORK(KU+NCS*NCS), NCS, - $ DWORK(KU), NCS, IERR ) -C -C Compute the eigendecomposition of X as X = Z*Sigma*Z'. -C - KW = KU + NCS - CALL DSYEV( 'Vectors', 'Upper', NCS, S, LDS, DWORK(KU), - $ DWORK(KW), LDWORK-KW+1, IERR ) - IF( IERR.GT.0 ) THEN - INFO = 4 - RETURN - END IF - WRKOPT = MAX( WRKOPT, INT( DWORK(KW) ) + KW - 1 ) -C -C Partition Sigma = (Sigma1,Sigma2), such that -C Sigma1 =< 0, Sigma2 > 0. -C Partition correspondingly Z = [Z1 Z2]. -C - TOL = MAX( ABS( DWORK(KU) ), ABS( DWORK(KU+NCS-1) ) ) - $ * DLAMCH( 'Epsilon') -C _ -C Form Bc = [ Z2*sqrt(Sigma2) ] -C - MBBAR = 0 - I = KW - JJ = KU - DO 30 J = 1, NCS - IF( DWORK(JJ).GT.TOL ) THEN - MBBAR = MBBAR + 1 - CALL DSCAL( NCS, SQRT( DWORK(JJ) ), S(1,J), 1 ) - CALL DCOPY( NCS, S(1,J), 1, DWORK(I), 1 ) - I = I + NCS - END IF - JJ = JJ + 1 - 30 CONTINUE -C -C Solve for the Cholesky factor S of P, P = S*S', -C the continuous-time Lyapunov equation (if DICO = 'C') -C _ _ -C Ac2*P + P*Ac2' + scalec^2*Bc*Bc' = 0, -C -C or the discrete-time Lyapunov equation (if DICO = 'D') -C _ _ -C Ac2*P*Ac2' - P + scalec^2*Bc*Bc' = 0. -C -C Workspace: need maximum NCS*(NCS + 6); -C prefer larger. -C - KU = KW - KTAU = KU + MBBAR*NCS - KW = KTAU + NCS -C - CALL SB03OU( DISCR, .TRUE., NCS, MBBAR, AC(NCU1,NCU1), LDAC, - $ DWORK(KU), NCS, DWORK(KTAU), S, LDS, T, - $ DWORK(KW), LDWORK-KW+1, IERR ) - IF( IERR.NE.0 ) THEN - INFO = 5 - RETURN - END IF - SCALEC = SCALEC*T - WRKOPT = MAX( WRKOPT, INT( DWORK(KW) ) + KW - 1 ) - END IF -C - END IF -C -C Save optimal workspace. -C - DWORK(1) = WRKOPT -C - RETURN -C *** Last line of SB16AY *** - END diff --git a/mex/sources/libslicot/SB16BD.f b/mex/sources/libslicot/SB16BD.f deleted file mode 100644 index 0141f1d0c..000000000 --- a/mex/sources/libslicot/SB16BD.f +++ /dev/null @@ -1,652 +0,0 @@ - SUBROUTINE SB16BD( DICO, JOBD, JOBMR, JOBCF, EQUIL, ORDSEL, - $ N, M, P, NCR, A, LDA, B, LDB, C, LDC, D, LDD, - $ F, LDF, G, LDG, DC, LDDC, HSV, TOL1, TOL2, - $ IWORK, DWORK, LDWORK, IWARN, INFO ) -C -C SLICOT RELEASE 5.0. -C -C Copyright (c) 2002-2009 NICONET e.V. -C -C This program is free software: you can redistribute it and/or -C modify it under the terms of the GNU General Public License as -C published by the Free Software Foundation, either version 2 of -C the License, or (at your option) any later version. -C -C This program is distributed in the hope that it will be useful, -C but WITHOUT ANY WARRANTY; without even the implied warranty of -C MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the -C GNU General Public License for more details. -C -C You should have received a copy of the GNU General Public License -C along with this program. If not, see -C . -C -C PURPOSE -C -C To compute, for a given open-loop model (A,B,C,D), and for -C given state feedback gain F and full observer gain G, -C such that A+B*F and A+G*C are stable, a reduced order -C controller model (Ac,Bc,Cc,Dc) using a coprime factorization -C based controller reduction approach. For reduction, -C either the square-root or the balancing-free square-root -C versions of the Balance & Truncate (B&T) or Singular Perturbation -C Approximation (SPA) model reduction methods are used in -C conjunction with stable coprime factorization techniques. -C -C ARGUMENTS -C -C Mode Parameters -C -C DICO CHARACTER*1 -C Specifies the type of the open-loop system as follows: -C = 'C': continuous-time system; -C = 'D': discrete-time system. -C -C JOBD CHARACTER*1 -C Specifies whether or not a non-zero matrix D appears -C in the given state space model: -C = 'D': D is present; -C = 'Z': D is assumed a zero matrix. -C -C JOBMR CHARACTER*1 -C Specifies the model reduction approach to be used -C as follows: -C = 'B': use the square-root B&T method; -C = 'F': use the balancing-free square-root B&T method; -C = 'S': use the square-root SPA method; -C = 'P': use the balancing-free square-root SPA method. -C -C JOBCF CHARACTER*1 -C Specifies whether left or right coprime factorization is -C to be used as follows: -C = 'L': use left coprime factorization; -C = 'R': use right coprime factorization. -C -C EQUIL CHARACTER*1 -C Specifies whether the user wishes to perform a -C preliminary equilibration before performing -C order reduction as follows: -C = 'S': perform equilibration (scaling); -C = 'N': do not perform equilibration. -C -C ORDSEL CHARACTER*1 -C Specifies the order selection method as follows: -C = 'F': the resulting controller order NCR is fixed; -C = 'A': the resulting controller order NCR is -C automatically determined on basis of the given -C tolerance TOL1. -C -C Input/Output Parameters -C -C N (input) INTEGER -C The order of the open-loop state-space representation, -C i.e., the order of the matrix A. N >= 0. -C N also represents the order of the original state-feedback -C controller. -C -C M (input) INTEGER -C The number of system inputs. M >= 0. -C -C P (input) INTEGER -C The number of system outputs. P >= 0. -C -C NCR (input/output) INTEGER -C On entry with ORDSEL = 'F', NCR is the desired order of -C the resulting reduced order controller. 0 <= NCR <= N. -C On exit, if INFO = 0, NCR is the order of the resulting -C reduced order controller. NCR is set as follows: -C if ORDSEL = 'F', NCR is equal to MIN(NCR,NMIN), where NCR -C is the desired order on entry, and NMIN is the order of a -C minimal realization of an extended system Ge (see METHOD); -C NMIN is determined as the number of -C Hankel singular values greater than N*EPS*HNORM(Ge), -C where EPS is the machine precision (see LAPACK Library -C Routine DLAMCH) and HNORM(Ge) is the Hankel norm of the -C extended system (computed in HSV(1)); -C if ORDSEL = 'A', NCR is equal to the number of Hankel -C singular values greater than MAX(TOL1,N*EPS*HNORM(Ge)). -C -C A (input/output) DOUBLE PRECISION array, dimension (LDA,N) -C On entry, the leading N-by-N part of this array must -C contain the original state dynamics matrix A. -C On exit, if INFO = 0, the leading NCR-by-NCR part of this -C array contains the state dynamics matrix Ac of the reduced -C controller. -C -C LDA INTEGER -C The leading dimension of array A. LDA >= MAX(1,N). -C -C B (input) DOUBLE PRECISION array, dimension (LDB,M) -C The leading N-by-M part of this array must -C contain the original input/state matrix B. -C -C LDB INTEGER -C The leading dimension of array B. LDB >= MAX(1,N). -C -C C (input) DOUBLE PRECISION array, dimension (LDC,N) -C The leading P-by-N part of this array must -C contain the original state/output matrix C. -C -C LDC INTEGER -C The leading dimension of array C. LDC >= MAX(1,P). -C -C D (input) DOUBLE PRECISION array, dimension (LDD,M) -C If JOBD = 'D', the leading P-by-M part of this -C array must contain the system direct input/output -C transmission matrix D. -C The array D is not referenced if JOBD = 'Z'. -C -C LDD INTEGER -C The leading dimension of array D. -C LDD >= MAX(1,P), if JOBD = 'D'; -C LDD >= 1, if JOBD = 'Z'. -C -C F (input/output) DOUBLE PRECISION array, dimension (LDF,N) -C On entry, the leading M-by-N part of this array must -C contain a stabilizing state feedback matrix. -C On exit, if INFO = 0, the leading M-by-NCR part of this -C array contains the state/output matrix Cc of the reduced -C controller. -C -C LDF INTEGER -C The leading dimension of array F. LDF >= MAX(1,M). -C -C G (input/output) DOUBLE PRECISION array, dimension (LDG,P) -C On entry, the leading N-by-P part of this array must -C contain a stabilizing observer gain matrix. -C On exit, if INFO = 0, the leading NCR-by-P part of this -C array contains the input/state matrix Bc of the reduced -C controller. -C -C LDG INTEGER -C The leading dimension of array G. LDG >= MAX(1,N). -C -C DC (output) DOUBLE PRECISION array, dimension (LDDC,P) -C If INFO = 0, the leading M-by-P part of this array -C contains the input/output matrix Dc of the reduced -C controller. -C -C LDDC INTEGER -C The leading dimension of array DC. LDDC >= MAX(1,M). -C -C HSV (output) DOUBLE PRECISION array, dimension (N) -C If INFO = 0, it contains the N Hankel singular values -C of the extended system ordered decreasingly (see METHOD). -C -C Tolerances -C -C TOL1 DOUBLE PRECISION -C If ORDSEL = 'A', TOL1 contains the tolerance for -C determining the order of the reduced extended system. -C For model reduction, the recommended value is -C TOL1 = c*HNORM(Ge), where c is a constant in the -C interval [0.00001,0.001], and HNORM(Ge) is the -C Hankel norm of the extended system (computed in HSV(1)). -C The value TOL1 = N*EPS*HNORM(Ge) is used by default if -C TOL1 <= 0 on entry, where EPS is the machine precision -C (see LAPACK Library Routine DLAMCH). -C If ORDSEL = 'F', the value of TOL1 is ignored. -C -C TOL2 DOUBLE PRECISION -C The tolerance for determining the order of a minimal -C realization of the coprime factorization controller -C (see METHOD). The recommended value is -C TOL2 = N*EPS*HNORM(Ge) (see METHOD). -C This value is used by default if TOL2 <= 0 on entry. -C If TOL2 > 0 and ORDSEL = 'A', then TOL2 <= TOL1. -C -C Workspace -C -C IWORK INTEGER array, dimension (LIWORK) -C LIWORK = 0, if ORDSEL = 'F' and NCR = N. -C Otherwise, -C LIWORK = MAX(PM,M), if JOBCF = 'L', -C LIWORK = MAX(PM,P), if JOBCF = 'R', where -C PM = 0, if JOBMR = 'B', -C PM = N, if JOBMR = 'F', -C PM = MAX(1,2*N), if JOBMR = 'S' or 'P'. -C -C DWORK DOUBLE PRECISION array, dimension (LDWORK) -C On exit, if INFO = 0, DWORK(1) returns the optimal value -C of LDWORK. -C -C LDWORK INTEGER -C The length of the array DWORK. -C LDWORK >= P*N, if ORDSEL = 'F' and NCR = N. Otherwise, -C LDWORK >= (N+M)*(M+P) + MAX(LWR,4*M), if JOBCF = 'L', -C LDWORK >= (N+P)*(M+P) + MAX(LWR,4*P), if JOBCF = 'R', -C where LWR = MAX(1,N*(2*N+MAX(N,M+P)+5)+N*(N+1)/2). -C For optimum performance LDWORK should be larger. -C -C Warning Indicator -C -C IWARN INTEGER -C = 0: no warning; -C = 1: with ORDSEL = 'F', the selected order NCR is -C greater than the order of a minimal -C realization of the controller. -C -C Error Indicator -C -C INFO INTEGER -C = 0: successful exit; -C < 0: if INFO = -i, the i-th argument had an illegal -C value; -C = 1: the reduction of A+G*C to a real Schur form -C failed; -C = 2: the matrix A+G*C is not stable (if DICO = 'C'), -C or not convergent (if DICO = 'D'); -C = 3: the computation of Hankel singular values failed; -C = 4: the reduction of A+B*F to a real Schur form -C failed; -C = 5: the matrix A+B*F is not stable (if DICO = 'C'), -C or not convergent (if DICO = 'D'). -C -C METHOD -C -C Let be the linear system -C -C d[x(t)] = Ax(t) + Bu(t) -C y(t) = Cx(t) + Du(t), (1) -C -C where d[x(t)] is dx(t)/dt for a continuous-time system and x(t+1) -C for a discrete-time system, and let Go(d) be the open-loop -C transfer-function matrix -C -1 -C Go(d) = C*(d*I-A) *B + D . -C -C Let F and G be the state feedback and observer gain matrices, -C respectively, chosen so that A+B*F and A+G*C are stable matrices. -C The controller has a transfer-function matrix K(d) given by -C -1 -C K(d) = F*(d*I-A-B*F-G*C-G*D*F) *G . -C -C The closed-loop transfer-function matrix is given by -C -1 -C Gcl(d) = Go(d)(I+K(d)Go(d)) . -C -C K(d) can be expressed as a left coprime factorization (LCF), -C -1 -C K(d) = M_left(d) *N_left(d) , -C -C or as a right coprime factorization (RCF), -C -1 -C K(d) = N_right(d)*M_right(d) , -C -C where M_left(d), N_left(d), N_right(d), and M_right(d) are -C stable transfer-function matrices. -C -C The subroutine SB16BD determines the matrices of a reduced -C controller -C -C d[z(t)] = Ac*z(t) + Bc*y(t) -C u(t) = Cc*z(t) + Dc*y(t), (2) -C -C with the transfer-function matrix Kr as follows: -C -C (1) If JOBCF = 'L', the extended system -C Ge(d) = [ N_left(d) M_left(d) ] is reduced to -C Ger(d) = [ N_leftr(d) M_leftr(d) ] by using either the -C B&T or SPA methods. The reduced order controller Kr(d) -C is computed as -C -1 -C Kr(d) = M_leftr(d) *N_leftr(d) ; -C -C (2) If JOBCF = 'R', the extended system -C Ge(d) = [ N_right(d) ] is reduced to -C [ M_right(d) ] -C Ger(d) = [ N_rightr(d) ] by using either the -C [ M_rightr(d) ] -C B&T or SPA methods. The reduced order controller Kr(d) -C is computed as -C -1 -C Kr(d) = N_rightr(d)* M_rightr(d) . -C -C If ORDSEL = 'A', the order of the controller is determined by -C computing the number of Hankel singular values greater than -C the given tolerance TOL1. The Hankel singular values are -C the square roots of the eigenvalues of the product of -C the controllability and observability Grammians of the -C extended system Ge. -C -C If JOBMR = 'B', the square-root B&T method of [1] is used. -C -C If JOBMR = 'F', the balancing-free square-root version of the -C B&T method [1] is used. -C -C If JOBMR = 'S', the square-root version of the SPA method [2,3] -C is used. -C -C If JOBMR = 'P', the balancing-free square-root version of the -C SPA method [2,3] is used. -C -C REFERENCES -C -C [1] Tombs, M.S. and Postlethwaite, I. -C Truncated balanced realization of stable, non-minimal -C state-space systems. -C Int. J. Control, Vol. 46, pp. 1319-1330, 1987. -C -C [2] Varga, A. -C Efficient minimal realization procedure based on balancing. -C Proc. of IMACS/IFAC Symp. MCTS, Lille, France, May 1991, -C A. El Moudui, P. Borne, S. G. Tzafestas (Eds.), Vol. 2, -C pp. 42-46, 1991. -C -C [3] Varga, A. -C Coprime factors model reduction method based on square-root -C balancing-free techniques. -C System Analysis, Modelling and Simulation, Vol. 11, -C pp. 303-311, 1993. -C -C [4] Liu, Y., Anderson, B.D.O. and Ly, O.L. -C Coprime factorization controller reduction with Bezout -C identity induced frequency weighting. -C Automatica, vol. 26, pp. 233-249, 1990. -C -C NUMERICAL ASPECTS -C -C The implemented methods rely on accuracy enhancing square-root or -C balancing-free square-root techniques. -C 3 -C The algorithms require less than 30N floating point operations. -C -C CONTRIBUTOR -C -C A. Varga, German Aerospace Center, Oberpfaffenhofen, August 2000. -C D. Sima, University of Bucharest, August 2000. -C V. Sima, Research Institute for Informatics, Bucharest, Aug. 2000. -C -C REVISIONS -C -C A. Varga, Australian National University, Canberra, November 2000. -C V. Sima, Research Institute for Informatics, Bucharest, Dec. 2000, -C Aug. 2001. -C -C KEYWORDS -C -C Balancing, controller reduction, coprime factorization, -C minimal realization, multivariable system, state-space model. -C -C ****************************************************************** -C -C .. Parameters .. - DOUBLE PRECISION ONE, ZERO - PARAMETER ( ONE = 1.0D0, ZERO = 0.0D0 ) -C .. Scalar Arguments .. - CHARACTER DICO, EQUIL, JOBCF, JOBD, JOBMR, ORDSEL - INTEGER INFO, IWARN, LDA, LDB, LDC, LDD, LDDC, - $ LDF, LDG, LDWORK, M, N, NCR, P - DOUBLE PRECISION TOL1, TOL2 -C .. Array Arguments .. - INTEGER IWORK(*) - DOUBLE PRECISION A(LDA,*), B(LDB,*), C(LDC,*), D(LDD,*), - $ DC(LDDC,*), DWORK(*), F(LDF,*), G(LDG,*), HSV(*) -C .. Local Scalars .. - CHARACTER JOB - LOGICAL BAL, BTA, DISCR, FIXORD, LEFT, LEQUIL, SPA, - $ WITHD - INTEGER KBE, KCE, KDE, KW, LDBE, LDCE, LDDE, LW1, LW2, - $ LWR, MAXMP, WRKOPT -C .. External Functions .. - LOGICAL LSAME - EXTERNAL LSAME -C .. External Subroutines .. - EXTERNAL AB09AD, AB09BD, DGEMM, DLACPY, DLASET, SB08GD, - $ SB08HD, XERBLA -C .. Intrinsic Functions .. - INTRINSIC INT, MAX, MIN -C .. Executable Statements .. -C - INFO = 0 - IWARN = 0 - DISCR = LSAME( DICO, 'D' ) - WITHD = LSAME( JOBD, 'D' ) - BTA = LSAME( JOBMR, 'B' ) .OR. LSAME( JOBMR, 'F' ) - SPA = LSAME( JOBMR, 'S' ) .OR. LSAME( JOBMR, 'P' ) - BAL = LSAME( JOBMR, 'B' ) .OR. LSAME( JOBMR, 'S' ) - LEFT = LSAME( JOBCF, 'L' ) - LEQUIL = LSAME( EQUIL, 'S' ) - FIXORD = LSAME( ORDSEL, 'F' ) - MAXMP = MAX( M, P ) -C - LWR = MAX( 1, N*( 2*N + MAX( N, M+P ) + 5 ) + ( N*(N+1) )/2 ) - LW1 = (N+M)*(M+P) + MAX( LWR, 4*M ) - LW2 = (N+P)*(M+P) + MAX( LWR, 4*P ) -C -C Test the input scalar arguments. -C - IF( .NOT. ( LSAME( DICO, 'C' ) .OR. DISCR ) ) THEN - INFO = -1 - ELSE IF( .NOT. ( WITHD .OR. LSAME( JOBD, 'Z' ) ) ) THEN - INFO = -2 - ELSE IF( .NOT. ( BTA .OR. SPA ) ) THEN - INFO = -3 - ELSE IF( .NOT. ( LEFT .OR. LSAME( JOBCF, 'R' ) ) ) THEN - INFO = -4 - ELSE IF( .NOT. ( LEQUIL .OR. LSAME( EQUIL, 'N' ) ) ) THEN - INFO = -5 - ELSE IF( .NOT. ( FIXORD .OR. LSAME( ORDSEL, 'A' ) ) ) THEN - INFO = -6 - ELSE IF( N.LT.0 ) THEN - INFO = -7 - ELSE IF( M.LT.0 ) THEN - INFO = -8 - ELSE IF( P.LT.0 ) THEN - INFO = -9 - ELSE IF( FIXORD .AND. ( NCR.LT.0 .OR. NCR.GT.N ) ) THEN - INFO = -10 - ELSE IF( LDA.LT.MAX( 1, N ) ) THEN - INFO = -12 - ELSE IF( LDB.LT.MAX( 1, N ) ) THEN - INFO = -14 - ELSE IF( LDC.LT.MAX( 1, P ) ) THEN - INFO = -16 - ELSE IF( LDD.LT.1 .OR. ( WITHD .AND. LDD.LT.P ) ) THEN - INFO = -18 - ELSE IF( LDF.LT.MAX( 1, M ) ) THEN - INFO = -20 - ELSE IF( LDG.LT.MAX( 1, N ) ) THEN - INFO = -22 - ELSE IF( LDDC.LT.MAX( 1, M ) ) THEN - INFO = -24 - ELSE IF( .NOT.FIXORD .AND. TOL2.GT.ZERO .AND. TOL2.GT.TOL1 ) THEN - INFO = -27 - ELSE IF( ( ( .NOT.FIXORD .OR. NCR.LT.N ) .AND. - $ ( ( LEFT .AND. LDWORK.LT.LW1 ) ) .OR. - $ ( .NOT.LEFT .AND. LDWORK.LT.LW2 ) ) .OR. - $ ( FIXORD .AND. NCR.EQ.N .AND. LDWORK.LT.P*N ) ) THEN - INFO = -30 - END IF -C - IF( INFO.NE.0 ) THEN -C -C Error return. -C - CALL XERBLA( 'SB16BD', -INFO ) - RETURN - END IF -C -C Quick return if possible. -C - IF( MIN( N, M, P ).EQ.0 .OR. - $ ( FIXORD .AND. BTA .AND. NCR.EQ.0 ) ) THEN - NCR = 0 - DWORK(1) = ONE - RETURN - END IF -C - IF( NCR.EQ.N ) THEN -C -C Form the controller state matrix, -C Ac = A + B*F + G*C + G*D*F = A + B*F + G*(C+D*F) . -C Real workspace: need P*N. -C Integer workspace: need 0. -C - CALL DLACPY( 'Full', P, N, C, LDC, DWORK, P ) - IF( WITHD ) CALL DGEMM( 'NoTranspose', 'NoTranspose', P, N, M, - $ ONE, D, LDD, F, LDF, ONE, - $ DWORK, P ) - CALL DGEMM( 'NoTranspose', 'NoTranspose', N, N, P, ONE, G, - $ LDG, DWORK, P, ONE, A, LDA ) - CALL DGEMM( 'NoTranspose', 'NoTranspose', N, N, M, ONE, B, - $ LDB, F, LDF, ONE, A, LDA ) -C - DWORK(1) = P*N - RETURN - END IF -C - IF( BAL ) THEN - JOB = 'B' - ELSE - JOB = 'N' - END IF -C -C Reduce the coprime factors. -C - IF( LEFT ) THEN -C -C Form Ge(d) = [ N_left(d) M_left(d) ] as -C -C ( A+G*C | G B+GD ) -C (------------------) -C ( F | 0 I ) -C -C Real workspace: need (N+M)*(M+P). -C Integer workspace: need 0. -C - CALL DGEMM( 'NoTranspose', 'NoTranspose', N, N, P, ONE, G, - $ LDG, C, LDC, ONE, A, LDA ) - KBE = 1 - KDE = KBE + N*(P+M) - LDBE = MAX( 1, N ) - LDDE = M - CALL DLACPY( 'Full', N, P, G, LDG, DWORK(KBE), LDBE ) - CALL DLACPY( 'Full', N, M, B, LDB, DWORK(KBE+N*P), LDBE ) - IF( WITHD ) CALL DGEMM( 'NoTranspose', 'NoTranspose', N, M, P, - $ ONE, G, LDG, D, LDD, ONE, - $ DWORK(KBE+N*P), LDBE ) - CALL DLASET( 'Full', M, P, ZERO, ZERO, DWORK(KDE), LDDE ) - CALL DLASET( 'Full', M, M, ZERO, ONE, DWORK(KDE+M*P), LDDE ) -C -C Compute the reduced coprime factors, -C Ger(d) = [ N_leftr(d) M_leftr(d) ] , -C by using either the B&T or SPA methods. -C -C Real workspace: need (N+M)*(M+P) + -C MAX(1,N*(2*N+MAX(N,M+P)+5)+N*(N+1)/2). -C Integer workspace: need 0, if JOBMR = 'B', -C N, if JOBMR = 'F', and -C MAX(1,2*N) if JOBMR = 'S' or 'P'. -C - KW = KDE + M*(P+M) - IF( BTA ) THEN - CALL AB09AD( DICO, JOB, EQUIL, ORDSEL, N, M+P, M, NCR, A, - $ LDA, DWORK(KBE), LDBE, F, LDF, HSV, TOL1, - $ IWORK, DWORK(KW), LDWORK-KW+1, IWARN, INFO ) - ELSE - CALL AB09BD( DICO, JOB, EQUIL, ORDSEL, N, M+P, M, NCR, A, - $ LDA, DWORK(KBE), LDBE, F, LDF, DWORK(KDE), - $ LDDE, HSV, TOL1, TOL2, IWORK, DWORK(KW), - $ LDWORK-KW+1, IWARN, INFO ) - END IF - IF( INFO.NE.0 ) - $ RETURN -C - WRKOPT = INT( DWORK(KW) ) + KW - 1 -C -C Compute the reduced order controller, -C -1 -C Kr(d) = M_leftr(d) *N_leftr(d). -C -C Real workspace: need (N+M)*(M+P) + MAX(1,4*M). -C Integer workspace: need M. -C - CALL SB08GD( NCR, P, M, A, LDA, DWORK(KBE), LDBE, F, LDF, - $ DWORK(KDE), LDDE, DWORK(KBE+N*P), LDBE, - $ DWORK(KDE+M*P), LDDE, IWORK, DWORK(KW), INFO ) -C -C Copy the reduced system matrices Bc and Dc. -C - CALL DLACPY( 'Full', NCR, P, DWORK(KBE), LDBE, G, LDG ) - CALL DLACPY( 'Full', M, P, DWORK(KDE), LDDE, DC, LDDC ) -C - ELSE -C -C Form Ge(d) = [ N_right(d) ] -C [ M_right(d) ] as -C -C ( A+B*F | G ) -C (-----------) -C ( F | 0 ) -C ( C+D*F | I ) -C -C Real workspace: need (N+P)*(M+P). -C Integer workspace: need 0. -C - CALL DGEMM( 'NoTranspose', 'NoTranspose', N, N, M, ONE, B, - $ LDB, F, LDF, ONE, A, LDA ) - KCE = 1 - KDE = KCE + N*(P+M) - LDCE = M+P - LDDE = LDCE - CALL DLACPY( 'Full', M, N, F, LDF, DWORK(KCE), LDCE ) - CALL DLACPY( 'Full', P, N, C, LDC, DWORK(KCE+M), LDCE ) - IF( WITHD ) CALL DGEMM( 'NoTranspose', 'NoTranspose', P, N, M, - $ ONE, D, LDD, F, LDF, ONE, - $ DWORK(KCE+M), LDCE ) - CALL DLASET( 'Full', M, P, ZERO, ZERO, DWORK(KDE), LDDE ) - CALL DLASET( 'Full', P, P, ZERO, ONE, DWORK(KDE+M), LDDE ) -C -C Compute the reduced coprime factors, -C Ger(d) = [ N_rightr(d) ] -C [ M_rightr(d) ], -C by using either the B&T or SPA methods. -C -C Real workspace: need (N+P)*(M+P) + -C MAX(1,N*(2*N+MAX(N,M+P)+5)+N*(N+1)/2). -C Integer workspace: need 0, if JOBMR = 'B', -C N, if JOBMR = 'F', and -C MAX(1,2*N) if JOBMR = 'S' or 'P'. -C - KW = KDE + P*(P+M) - IF( BTA ) THEN - CALL AB09AD( DICO, JOB, EQUIL, ORDSEL, N, P, M+P, NCR, A, - $ LDA, G, LDG, DWORK(KCE), LDCE, HSV, TOL1, - $ IWORK, DWORK(KW), LDWORK-KW+1, IWARN, INFO ) - ELSE - CALL AB09BD( DICO, JOB, EQUIL, ORDSEL, N, P, M+P, NCR, A, - $ LDA, G, LDG, DWORK(KCE), LDCE, DWORK(KDE), - $ LDDE, HSV, TOL1, TOL2, IWORK, DWORK(KW), - $ LDWORK-KW+1, IWARN, INFO ) - END IF - IF( INFO.NE.0 ) THEN - IF( INFO.NE.3 ) INFO = INFO + 3 - RETURN - END IF -C - WRKOPT = INT( DWORK(KW) ) + KW - 1 -C -C Compute the reduced order controller, -C -1 -C Kr(d) = N_rightr(d)*M_rightr(d) . -C -C Real workspace: need (N+P)*(M+P) + MAX(1,4*P). -C Integer workspace: need P. -C - CALL SB08HD( NCR, P, M, A, LDA, G, LDG, DWORK(KCE), LDCE, - $ DWORK(KDE), LDDE, DWORK(KCE+M), LDCE, - $ DWORK(KDE+M), LDDE, IWORK, DWORK(KW), INFO ) -C -C Copy the reduced system matrices Cc and Dc. -C - CALL DLACPY( 'Full', M, NCR, DWORK(KCE), LDCE, F, LDF ) - CALL DLACPY( 'Full', M, P, DWORK(KDE), LDDE, DC, LDDC ) -C - END IF -C - DWORK(1) = WRKOPT -C - RETURN -C *** Last line of SB16BD *** - END diff --git a/mex/sources/libslicot/SB16CD.f b/mex/sources/libslicot/SB16CD.f deleted file mode 100644 index 677a916d7..000000000 --- a/mex/sources/libslicot/SB16CD.f +++ /dev/null @@ -1,526 +0,0 @@ - SUBROUTINE SB16CD( DICO, JOBD, JOBMR, JOBCF, ORDSEL, N, M, P, NCR, - $ A, LDA, B, LDB, C, LDC, D, LDD, F, LDF, G, LDG, - $ HSV, TOL, IWORK, DWORK, LDWORK, IWARN, INFO ) -C -C SLICOT RELEASE 5.0. -C -C Copyright (c) 2002-2009 NICONET e.V. -C -C This program is free software: you can redistribute it and/or -C modify it under the terms of the GNU General Public License as -C published by the Free Software Foundation, either version 2 of -C the License, or (at your option) any later version. -C -C This program is distributed in the hope that it will be useful, -C but WITHOUT ANY WARRANTY; without even the implied warranty of -C MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the -C GNU General Public License for more details. -C -C You should have received a copy of the GNU General Public License -C along with this program. If not, see -C . -C -C PURPOSE -C -C To compute, for a given open-loop model (A,B,C,D), and for -C given state feedback gain F and full observer gain G, -C such that A+B*F and A+G*C are stable, a reduced order -C controller model (Ac,Bc,Cc) using a coprime factorization -C based controller reduction approach. For reduction of -C coprime factors, a stability enforcing frequency-weighted -C model reduction is performed using either the square-root or -C the balancing-free square-root versions of the Balance & Truncate -C (B&T) model reduction method. -C -C ARGUMENTS -C -C Mode Parameters -C -C DICO CHARACTER*1 -C Specifies the type of the open-loop system as follows: -C = 'C': continuous-time system; -C = 'D': discrete-time system. -C -C JOBD CHARACTER*1 -C Specifies whether or not a non-zero matrix D appears -C in the given state space model, as follows: -C = 'D': D is present; -C = 'Z': D is assumed a zero matrix. -C -C JOBMR CHARACTER*1 -C Specifies the model reduction approach to be used -C as follows: -C = 'B': use the square-root B&T method; -C = 'F': use the balancing-free square-root B&T method. -C -C JOBCF CHARACTER*1 -C Specifies whether left or right coprime factorization -C of the controller is to be used as follows: -C = 'L': use left coprime factorization; -C = 'R': use right coprime factorization. -C -C ORDSEL CHARACTER*1 -C Specifies the order selection method as follows: -C = 'F': the resulting controller order NCR is fixed; -C = 'A': the resulting controller order NCR is -C automatically determined on basis of the given -C tolerance TOL. -C -C Input/Output Parameters -C -C N (input) INTEGER -C The order of the original state-space representation, i.e. -C the order of the matrix A. N >= 0. -C N also represents the order of the original state-feedback -C controller. -C -C M (input) INTEGER -C The number of system inputs. M >= 0. -C -C P (input) INTEGER -C The number of system outputs. P >= 0. -C -C NCR (input/output) INTEGER -C On entry with ORDSEL = 'F', NCR is the desired order of -C the resulting reduced order controller. 0 <= NCR <= N. -C On exit, if INFO = 0, NCR is the order of the resulting -C reduced order controller. NCR is set as follows: -C if ORDSEL = 'F', NCR is equal to MIN(NCR,NCRMIN), where -C NCR is the desired order on entry, and NCRMIN is the -C number of Hankel-singular values greater than N*EPS*S1, -C where EPS is the machine precision (see LAPACK Library -C Routine DLAMCH) and S1 is the largest Hankel singular -C value (computed in HSV(1)); NCR can be further reduced -C to ensure HSV(NCR) > HSV(NCR+1); -C if ORDSEL = 'A', NCR is equal to the number of Hankel -C singular values greater than MAX(TOL,N*EPS*S1). -C -C A (input/output) DOUBLE PRECISION array, dimension (LDA,N) -C On entry, the leading N-by-N part of this array must -C contain the original state dynamics matrix A. -C On exit, if INFO = 0, the leading NCR-by-NCR part of this -C array contains the state dynamics matrix Ac of the reduced -C controller. -C -C LDA INTEGER -C The leading dimension of array A. LDA >= MAX(1,N). -C -C B (input/output) DOUBLE PRECISION array, dimension (LDB,M) -C On entry, the leading N-by-M part of this array must -C contain the open-loop system input/state matrix B. -C On exit, this array is overwritten with a NCR-by-M -C B&T approximation of the matrix B. -C -C LDB INTEGER -C The leading dimension of array B. LDB >= MAX(1,N). -C -C C (input/output) DOUBLE PRECISION array, dimension (LDC,N) -C On entry, the leading P-by-N part of this array must -C contain the open-loop system state/output matrix C. -C On exit, this array is overwritten with a P-by-NCR -C B&T approximation of the matrix C. -C -C LDC INTEGER -C The leading dimension of array C. LDC >= MAX(1,P). -C -C D (input) DOUBLE PRECISION array, dimension (LDD,M) -C On entry, if JOBD = 'D', the leading P-by-M part of this -C array must contain the system direct input/output -C transmission matrix D. -C The array D is not referenced if JOBD = 'Z'. -C -C LDD INTEGER -C The leading dimension of array D. -C LDD >= MAX(1,P), if JOBD = 'D'; -C LDD >= 1, if JOBD = 'Z'. -C -C F (input/output) DOUBLE PRECISION array, dimension (LDF,N) -C On entry, the leading M-by-N part of this array must -C contain a stabilizing state feedback matrix. -C On exit, if INFO = 0, the leading M-by-NCR part of this -C array contains the output/state matrix Cc of the reduced -C controller. -C -C LDF INTEGER -C The leading dimension of array F. LDF >= MAX(1,M). -C -C G (input/output) DOUBLE PRECISION array, dimension (LDG,P) -C On entry, the leading N-by-P part of this array must -C contain a stabilizing observer gain matrix. -C On exit, if INFO = 0, the leading NCR-by-P part of this -C array contains the input/state matrix Bc of the reduced -C controller. -C -C LDG INTEGER -C The leading dimension of array G. LDG >= MAX(1,N). -C -C HSV (output) DOUBLE PRECISION array, dimension (N) -C If INFO = 0, HSV contains the N frequency-weighted -C Hankel singular values ordered decreasingly (see METHOD). -C -C Tolerances -C -C TOL DOUBLE PRECISION -C If ORDSEL = 'A', TOL contains the tolerance for -C determining the order of reduced controller. -C The recommended value is TOL = c*S1, where c is a constant -C in the interval [0.00001,0.001], and S1 is the largest -C Hankel singular value (computed in HSV(1)). -C The value TOL = N*EPS*S1 is used by default if -C TOL <= 0 on entry, where EPS is the machine precision -C (see LAPACK Library Routine DLAMCH). -C If ORDSEL = 'F', the value of TOL is ignored. -C -C Workspace -C -C IWORK INTEGER array, dimension LIWORK, where -C LIWORK = 0, if JOBMR = 'B'; -C LIWORK = N, if JOBMR = 'F'. -C -C DWORK DOUBLE PRECISION array, dimension (LDWORK) -C On exit, if INFO = 0, DWORK(1) returns the optimal value -C of LDWORK. -C -C LDWORK INTEGER -C The length of the array DWORK. -C LDWORK >= 2*N*N + MAX( 1, 2*N*N + 5*N, N*MAX(M,P), -C N*(N + MAX(N,MP) + MIN(N,MP) + 6)), -C where MP = M, if JOBCF = 'L'; -C MP = P, if JOBCF = 'R'. -C For optimum performance LDWORK should be larger. -C -C Warning Indicator -C -C IWARN INTEGER -C = 0: no warning; -C = 1: with ORDSEL = 'F', the selected order NCR is -C greater than the order of a minimal realization -C of the controller; -C = 2: with ORDSEL = 'F', the selected order NCR -C corresponds to repeated singular values, which are -C neither all included nor all excluded from the -C reduced controller. In this case, the resulting NCR -C is set automatically to the largest value such that -C HSV(NCR) > HSV(NCR+1). -C -C Error Indicator -C -C INFO INTEGER -C = 0: successful exit; -C < 0: if INFO = -i, the i-th argument had an illegal -C value; -C = 1: eigenvalue computation failure; -C = 2: the matrix A+G*C is not stable; -C = 3: the matrix A+B*F is not stable; -C = 4: the Lyapunov equation for computing the -C observability Grammian is (nearly) singular; -C = 5: the Lyapunov equation for computing the -C controllability Grammian is (nearly) singular; -C = 6: the computation of Hankel singular values failed. -C -C METHOD -C -C Let be the linear system -C -C d[x(t)] = Ax(t) + Bu(t) -C y(t) = Cx(t) + Du(t), (1) -C -C where d[x(t)] is dx(t)/dt for a continuous-time system and x(t+1) -C for a discrete-time system, and let Go(d) be the open-loop -C transfer-function matrix -C -1 -C Go(d) = C*(d*I-A) *B + D . -C -C Let F and G be the state feedback and observer gain matrices, -C respectively, chosen such that A+BF and A+GC are stable matrices. -C The controller has a transfer-function matrix K(d) given by -C -1 -C K(d) = F*(d*I-A-B*F-G*C-G*D*F) *G . -C -C The closed-loop transfer function matrix is given by -C -1 -C Gcl(d) = Go(d)(I+K(d)Go(d)) . -C -C K(d) can be expressed as a left coprime factorization (LCF) -C -1 -C K(d) = M_left(d) *N_left(d), -C -C or as a right coprime factorization (RCF) -C -1 -C K(d) = N_right(d)*M_right(d) , -C -C where M_left(d), N_left(d), N_right(d), and M_right(d) are -C stable transfer-function matrices. -C -C The subroutine SB16CD determines the matrices of a reduced -C controller -C -C d[z(t)] = Ac*z(t) + Bc*y(t) -C u(t) = Cc*z(t), (2) -C -C with the transfer-function matrix Kr, using the following -C stability enforcing approach proposed in [1]: -C -C (1) If JOBCF = 'L', the frequency-weighted approximation problem -C is solved -C -C min||[M_left(d)-M_leftr(d) N_left(d)-N_leftr(d)][-Y(d)]|| , -C [ X(d)] -C where -C -1 -C G(d) = Y(d)*X(d) -C -C is a RCF of the open-loop system transfer-function matrix. -C The B&T model reduction technique is used in conjunction -C with the method proposed in [1]. -C -C (2) If JOBCF = 'R', the frequency-weighted approximation problem -C is solved -C -C min || [ -U(d) V(d) ] [ N_right(d)-N_rightr(d) ] || , -C [ M_right(d)-M_rightr(d) ] -C where -C -1 -C G(d) = V(d) *U(d) -C -C is a LCF of the open-loop system transfer-function matrix. -C The B&T model reduction technique is used in conjunction -C with the method proposed in [1]. -C -C If ORDSEL = 'A', the order of the controller is determined by -C computing the number of Hankel singular values greater than -C the given tolerance TOL. The Hankel singular values are -C the square roots of the eigenvalues of the product of -C two frequency-weighted Grammians P and Q, defined as follows. -C -C If JOBCF = 'L', then P is the controllability Grammian of a system -C of the form (A+BF,B,*,*), and Q is the observability Grammian of a -C system of the form (A+GC,*,F,*). This choice corresponds to an -C input frequency-weighted order reduction of left coprime -C factors [1]. -C -C If JOBCF = 'R', then P is the controllability Grammian of a system -C of the form (A+BF,G,*,*), and Q is the observability Grammian of a -C system of the form (A+GC,*,C,*). This choice corresponds to an -C output frequency-weighted order reduction of right coprime -C factors [1]. -C -C For the computation of truncation matrices, the B&T approach -C is used in conjunction with accuracy enhancing techniques. -C If JOBMR = 'B', the square-root B&T method of [2,4] is used. -C If JOBMR = 'F', the balancing-free square-root version of the -C B&T method [3,4] is used. -C -C REFERENCES -C -C [1] Liu, Y., Anderson, B.D.O. and Ly, O.L. -C Coprime factorization controller reduction with Bezout -C identity induced frequency weighting. -C Automatica, vol. 26, pp. 233-249, 1990. -C -C [2] Tombs, M.S. and Postlethwaite I. -C Truncated balanced realization of stable, non-minimal -C state-space systems. -C Int. J. Control, Vol. 46, pp. 1319-1330, 1987. -C -C [3] Varga, A. -C Efficient minimal realization procedure based on balancing. -C Proc. of IMACS/IFAC Symp. MCTS, Lille, France, May 1991, -C A. El Moudui, P. Borne, S. G. Tzafestas (Eds.), Vol. 2, -C pp. 42-46, 1991. -C -C [4] Varga, A. -C Coprime factors model reduction method based on square-root -C balancing-free techniques. -C System Analysis, Modelling and Simulation, Vol. 11, -C pp. 303-311, 1993. -C -C NUMERICAL ASPECTS -C -C The implemented methods rely on accuracy enhancing square-root or -C balancing-free square-root techniques. -C 3 -C The algorithms require less than 30N floating point operations. -C -C CONTRIBUTOR -C -C A. Varga, German Aerospace Center, Oberpfaffenhofen, October 2000. -C D. Sima, University of Bucharest, October 2000. -C V. Sima, Research Institute for Informatics, Bucharest, Oct. 2000. -C -C REVISIONS -C -C A. Varga, Australian National University, Canberra, November 2000. -C V. Sima, Research Institute for Informatics, Bucharest, Aug. 2001. -C -C KEYWORDS -C -C Controller reduction, coprime factorization, frequency weighting, -C multivariable system, state-space model. -C -C ****************************************************************** -C -C .. Parameters .. - DOUBLE PRECISION ONE, ZERO - PARAMETER ( ONE = 1.0D0, ZERO = 0.0D0 ) -C .. Scalar Arguments .. - CHARACTER DICO, JOBCF, JOBD, JOBMR, ORDSEL - INTEGER INFO, IWARN, LDA, LDB, LDC, LDD, - $ LDF, LDG, LDWORK, M, N, NCR, P - DOUBLE PRECISION TOL -C .. Array Arguments .. - INTEGER IWORK(*) - DOUBLE PRECISION A(LDA,*), B(LDB,*), C(LDC,*), D(LDD,*), - $ DWORK(*), F(LDF,*), G(LDG,*), HSV(*) -C .. Local Scalars .. - LOGICAL BAL, DISCR, FIXORD, LEFT, WITHD - INTEGER IERR, KT, KTI, KW, LW, MP, NMR, WRKOPT - DOUBLE PRECISION SCALEC, SCALEO -C .. External Functions .. - LOGICAL LSAME - EXTERNAL LSAME -C .. External Subroutines .. - EXTERNAL AB09IX, DGEMM, DLACPY, SB16CY, XERBLA -C .. Intrinsic Functions .. - INTRINSIC INT, MAX, MIN -C .. Executable Statements .. -C - INFO = 0 - IWARN = 0 - DISCR = LSAME( DICO, 'D' ) - WITHD = LSAME( JOBD, 'D' ) - BAL = LSAME( JOBMR, 'B' ) - LEFT = LSAME( JOBCF, 'L' ) - FIXORD = LSAME( ORDSEL, 'F' ) - IF( LEFT ) THEN - MP = M - ELSE - MP = P - END IF - LW = 2*N*N + MAX( 1, 2*N*N + 5*N, N*MAX( M, P ), - $ N*( N + MAX( N, MP ) + MIN( N, MP ) + 6 ) ) -C -C Test the input scalar arguments. -C - IF( .NOT. ( LSAME( DICO, 'C' ) .OR. DISCR ) ) THEN - INFO = -1 - ELSE IF( .NOT. ( WITHD .OR. LSAME( JOBD, 'Z' ) ) ) THEN - INFO = -2 - ELSE IF( .NOT. ( BAL .OR. LSAME( JOBMR, 'F' ) ) ) THEN - INFO = -3 - ELSE IF( .NOT. ( LEFT .OR. LSAME( JOBCF, 'R' ) ) ) THEN - INFO = -4 - ELSE IF( .NOT. ( FIXORD .OR. LSAME( ORDSEL, 'A' ) ) ) THEN - INFO = -5 - ELSE IF( N.LT.0 ) THEN - INFO = -6 - ELSE IF( M.LT.0 ) THEN - INFO = -7 - ELSE IF( P.LT.0 ) THEN - INFO = -8 - ELSE IF( FIXORD .AND. ( NCR.LT.0 .OR. NCR.GT.N ) ) THEN - INFO = -9 - ELSE IF( LDA.LT.MAX( 1, N ) ) THEN - INFO = -11 - ELSE IF( LDB.LT.MAX( 1, N ) ) THEN - INFO = -13 - ELSE IF( LDC.LT.MAX( 1, P ) ) THEN - INFO = -15 - ELSE IF( LDD.LT.1 .OR. ( WITHD .AND. LDD.LT.P ) ) THEN - INFO = -17 - ELSE IF( LDF.LT.MAX( 1, M ) ) THEN - INFO = -19 - ELSE IF( LDG.LT.MAX( 1, N ) ) THEN - INFO = -21 - ELSE IF( LDWORK.LT.LW ) THEN - INFO = -26 - END IF -C - IF( INFO.NE.0 ) THEN -C -C Error return. -C - CALL XERBLA( 'SB16CD', -INFO ) - RETURN - END IF -C -C Quick return if possible. -C - IF( MIN( N, M, P ).EQ.0 .OR. - $ ( FIXORD .AND. NCR.EQ.0 ) ) THEN - NCR = 0 - DWORK(1) = ONE - RETURN - END IF -C -C Allocate working storage. -C - KT = 1 - KTI = KT + N*N - KW = KTI + N*N -C -C Compute in DWORK(KTI) and DWORK(KT) the Cholesky factors Su and Ru -C of the frequency-weighted controllability and observability -C Grammians, respectively. -C -C Workspace: need 2*N*N + MAX(1, N*(N + MAX(N,M) + MIN(N,M) + 6)), -C if JOBCF = 'L'; -C 2*N*N + MAX(1, N*(N + MAX(N,P) + MIN(N,P) + 6)), -C if JOBCF = 'R'. -C prefer larger. -C - CALL SB16CY( DICO, JOBCF, N, M, P, A, LDA, B, LDB, C, LDC, - $ F, LDF, G, LDG, SCALEC, SCALEO, DWORK(KTI), N, - $ DWORK(KT), N, DWORK(KW), LDWORK-KW+1, INFO ) -C - IF( INFO.NE.0 ) - $ RETURN - WRKOPT = INT( DWORK(KW) ) + KW - 1 -C -C Compute a B&T approximation (Ar,Br,Cr) of (A,B,C) and -C the corresponding truncation matrices TI and T. -C -C Real workspace: need 2*N*N + MAX( 1, 2*N*N+5*N, N*MAX(M,P) ); -C prefer larger. -C Integer workspace: 0, if JOBMR = 'B'; -C N, if JOBMR = 'F'. -C - CALL AB09IX( DICO, JOBMR, 'NotSchur', ORDSEL, N, M, P, NCR, - $ SCALEC, SCALEO, A, LDA, B, LDB, C, LDC, D, LDD, - $ DWORK(KTI), N, DWORK(KT), N, NMR, HSV, TOL, TOL, - $ IWORK, DWORK(KW), LDWORK-KW+1, IWARN, IERR ) - IF( IERR.NE.0 ) THEN - INFO = 6 - RETURN - END IF - WRKOPT = MAX( WRKOPT, INT( DWORK(KW) ) + KW - 1 ) -C -C Compute reduced gains Bc = Gr = TI*G and Cc = Fr = F*T. -C Workspace: need N*(2*N+MAX(M,P)). -C - CALL DLACPY( 'Full', N, P, G, LDG, DWORK(KW), N ) - CALL DGEMM( 'NoTranspose', 'NoTranspose', NCR, P, N, ONE, - $ DWORK(KTI), N, DWORK(KW), N, ZERO, G, LDG ) -C - CALL DLACPY( 'Full', M, N, F, LDF, DWORK(KW), M ) - CALL DGEMM( 'NoTranspose', 'NoTranspose', M, NCR, N, ONE, - $ DWORK(KW), M, DWORK(KT), N, ZERO, F, LDF ) -C -C Form the reduced controller state matrix, -C Ac = Ar + Br*Fr + Gr*Cr + Gr*D*Fr = Ar + Br*Fr + Gr*(Cr+D*Fr) . -C -C Workspace: need P*N. -C - CALL DLACPY( 'Full', P, NCR, C, LDC, DWORK, P ) - IF( WITHD) CALL DGEMM( 'NoTranspose', 'NoTranspose', P, NCR, M, - $ ONE, D, LDD, F, LDF, ONE, DWORK, P ) - CALL DGEMM( 'NoTranspose', 'NoTranspose', NCR, NCR, P, ONE, G, - $ LDG, DWORK, P, ONE, A, LDA ) - CALL DGEMM( 'NoTranspose', 'NoTranspose', NCR, NCR, M, ONE, B, - $ LDB, F, LDF, ONE, A, LDA ) -C - DWORK(1) = WRKOPT -C - RETURN -C *** Last line of SB16CD *** - END diff --git a/mex/sources/libslicot/SB16CY.f b/mex/sources/libslicot/SB16CY.f deleted file mode 100644 index 34ebaae79..000000000 --- a/mex/sources/libslicot/SB16CY.f +++ /dev/null @@ -1,409 +0,0 @@ - SUBROUTINE SB16CY( DICO, JOBCF, N, M, P, A, LDA, B, LDB, C, LDC, - $ F, LDF, G, LDG, SCALEC, SCALEO, S, LDS, R, LDR, - $ DWORK, LDWORK, INFO ) -C -C SLICOT RELEASE 5.0. -C -C Copyright (c) 2002-2009 NICONET e.V. -C -C This program is free software: you can redistribute it and/or -C modify it under the terms of the GNU General Public License as -C published by the Free Software Foundation, either version 2 of -C the License, or (at your option) any later version. -C -C This program is distributed in the hope that it will be useful, -C but WITHOUT ANY WARRANTY; without even the implied warranty of -C MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the -C GNU General Public License for more details. -C -C You should have received a copy of the GNU General Public License -C along with this program. If not, see -C . -C -C PURPOSE -C -C To compute, for a given open-loop model (A,B,C,0), and for -C given state feedback gain F and full observer gain G, -C such that A+B*F and A+G*C are stable, the Cholesky factors -C Su and Ru of a controllability Grammian P = Su*Su' and of -C an observability Grammian Q = Ru'*Ru corresponding to a -C frequency-weighted model reduction of the left or right coprime -C factors of the state-feedback controller. -C -C ARGUMENTS -C -C Mode Parameters -C -C DICO CHARACTER*1 -C Specifies the type of the open-loop system as follows: -C = 'C': continuous-time system; -C = 'D': discrete-time system. -C -C JOBCF CHARACTER*1 -C Specifies whether a left or right coprime factorization -C of the state-feedback controller is to be used as follows: -C = 'L': use a left coprime factorization; -C = 'R': use a right coprime factorization. -C -C Input/Output Parameters -C -C N (input) INTEGER -C The order of the open-loop state-space representation, -C i.e., the order of the matrix A. N >= 0. -C -C M (input) INTEGER -C The number of system inputs. M >= 0. -C -C P (input) INTEGER -C The number of system outputs. P >= 0. -C -C A (input) DOUBLE PRECISION array, dimension (LDA,N) -C The leading N-by-N part of this array must contain the -C state matrix A of the open-loop system. -C -C LDA INTEGER -C The leading dimension of array A. LDA >= MAX(1,N). -C -C B (input) DOUBLE PRECISION array, dimension (LDB,M) -C The leading N-by-M part of this array must contain the -C input/state matrix B of the open-loop system. -C -C LDB INTEGER -C The leading dimension of array B. LDB >= MAX(1,N). -C -C C (input) DOUBLE PRECISION array, dimension (LDC,N) -C The leading P-by-N part of this array must contain the -C state/output matrix C of the open-loop system. -C -C LDC INTEGER -C The leading dimension of array C. LDC >= MAX(1,P). -C -C F (input) DOUBLE PRECISION array, dimension (LDF,N) -C The leading M-by-N part of this array must contain a -C stabilizing state feedback matrix. -C -C LDF INTEGER -C The leading dimension of array F. LDF >= MAX(1,M). -C -C G (input) DOUBLE PRECISION array, dimension (LDG,P) -C The leading N-by-P part of this array must contain a -C stabilizing observer gain matrix. -C -C LDG INTEGER -C The leading dimension of array G. LDG >= MAX(1,N). -C -C SCALEC (output) DOUBLE PRECISION -C Scaling factor for the controllability Grammian. -C See METHOD. -C -C SCALEO (output) DOUBLE PRECISION -C Scaling factor for the observability Grammian. -C See METHOD. -C -C S (output) DOUBLE PRECISION array, dimension (LDS,N) -C The leading N-by-N upper triangular part of this array -C contains the Cholesky factor Su of frequency-weighted -C cotrollability Grammian P = Su*Su'. See METHOD. -C -C LDS INTEGER -C The leading dimension of the array S. LDS >= MAX(1,N). -C -C R (output) DOUBLE PRECISION array, dimension (LDR,N) -C The leading N-by-N upper triangular part of this array -C contains the Cholesky factor Ru of the frequency-weighted -C observability Grammian Q = Ru'*Ru. See METHOD. -C -C LDR INTEGER -C The leading dimension of the array R. LDR >= MAX(1,N). -C -C Workspace -C -C DWORK DOUBLE PRECISION array, dimension (LDWORK) -C On exit, if INFO = 0, DWORK(1) returns the optimal value -C of LDWORK. -C -C LDWORK INTEGER -C The length of the array DWORK. -C LDWORK >= MAX(1, N*(N + MAX(N,M) + MIN(N,M) + 6)), -C if JOBCF = 'L'; -C LDWORK >= MAX(1, N*(N + MAX(N,P) + MIN(N,P) + 6)), -C if JOBCF = 'R'. -C For optimum performance LDWORK should be larger. -C An upper bound for both cases is -C LDWORK >= MAX(1, N*(N + MAX(N,M,P) + 7)). -C -C Error Indicator -C -C INFO INTEGER -C = 0: successful exit; -C < 0: if INFO = -i, the i-th argument had an illegal -C value; -C = 1: eigenvalue computation failure; -C = 2: the matrix A+G*C is not stable; -C = 3: the matrix A+B*F is not stable; -C = 4: the Lyapunov equation for computing the -C observability Grammian is (nearly) singular; -C = 5: the Lyapunov equation for computing the -C controllability Grammian is (nearly) singular. -C -C METHOD -C -C In accordance with the type of the coprime factorization -C of the controller (left or right), the Cholesky factors Su and Ru -C of the frequency-weighted controllability Grammian P = Su*Su' and -C of the frequency-weighted observability Grammian Q = Ru'*Ru are -C computed by solving appropriate Lyapunov or Stein equations [1]. -C -C If JOBCF = 'L' and DICO = 'C', P and Q are computed as the -C solutions of the following Lyapunov equations: -C -C (A+B*F)*P + P*(A+B*F)' + scalec^2*B*B' = 0, (1) -C -C (A+G*C)'*Q + Q*(A+G*C) + scaleo^2*F'*F = 0. (2) -C -C If JOBCF = 'L' and DICO = 'D', P and Q are computed as the -C solutions of the following Stein equations: -C -C (A+B*F)*P*(A+B*F)' - P + scalec^2*B*B' = 0, (3) -C -C (A+G*C)'*Q*(A+G*C) - Q + scaleo^2*F'*F = 0. (4) -C -C If JOBCF = 'R' and DICO = 'C', P and Q are computed as the -C solutions of the following Lyapunov equations: -C -C (A+B*F)*P + P*(A+B*F)' + scalec^2*G*G' = 0, (5) -C -C (A+G*C)'*Q + Q*(A+G*C) + scaleo^2*C'*C = 0. (6) -C -C If JOBCF = 'R' and DICO = 'D', P and Q are computed as the -C solutions of the following Stein equations: -C -C (A+B*F)*P*(A+B*F)' - P + scalec^2*G*G' = 0, (7) -C -C (A+G*C)'*Q*(A+G*C) - Q + scaleo^2*C'*C = 0. (8) -C -C REFERENCES -C -C [1] Liu, Y., Anderson, B.D.O. and Ly, O.L. -C Coprime factorization controller reduction with Bezout -C identity induced frequency weighting. -C Automatica, vol. 26, pp. 233-249, 1990. -C -C CONTRIBUTORS -C -C A. Varga, German Aerospace Center, Oberpfaffenhofen, October 2000. -C D. Sima, University of Bucharest, October 2000. -C V. Sima, Research Institute for Informatics, Bucharest, Oct. 2000. -C -C REVISIONS -C -C A. Varga, Australian National University, Canberra, November 2000. -C -C KEYWORDS -C -C Controller reduction, frequency weighting, multivariable system, -C state-space model, state-space representation. -C -C ****************************************************************** -C -C .. Parameters .. - DOUBLE PRECISION ZERO, ONE - PARAMETER ( ZERO = 0.0D0, ONE = 1.0D0 ) -C .. Scalar Arguments .. - CHARACTER DICO, JOBCF - INTEGER INFO, LDA, LDB, LDC, LDF, LDG, LDR, LDS, LDWORK, - $ M, N, P - DOUBLE PRECISION SCALEC, SCALEO -C .. Array Arguments .. - DOUBLE PRECISION A(LDA,*), B(LDB,*), C(LDC,*), DWORK(*), - $ F(LDF,*), G(LDG,*), R(LDR,*), S(LDS,*) -C .. Local Scalars .. - LOGICAL DISCR, LEFTW - INTEGER IERR, KAW, KU, KW, KWI, KWR, LDU, LW, ME, MP, - $ WRKOPT -C .. External Functions .. - LOGICAL LSAME - EXTERNAL LSAME -C .. External Subroutines .. - EXTERNAL DGEMM, DLACPY, SB03OD, XERBLA -C .. Intrinsic Functions .. - INTRINSIC INT, MAX, MIN -C .. Executable Statements .. -C - DISCR = LSAME( DICO, 'D' ) - LEFTW = LSAME( JOBCF, 'L' ) -C - INFO = 0 - IF( LEFTW ) THEN - MP = M - ELSE - MP = P - END IF - LW = N*( N + MAX( N, MP ) + MIN( N, MP ) + 6 ) -C - IF( .NOT. ( LSAME( DICO, 'C' ) .OR. DISCR ) ) THEN - INFO = -1 - ELSE IF( .NOT.( LEFTW .OR. LSAME( JOBCF, 'R' ) ) ) THEN - INFO = -2 - ELSE IF( N.LT.0 ) THEN - INFO = -3 - ELSE IF( M.LT.0 ) THEN - INFO = -4 - ELSE IF( P.LT.0 ) THEN - INFO = -5 - ELSE IF( LDA.LT.MAX( 1, N ) ) THEN - INFO = -7 - ELSE IF( LDB.LT.MAX( 1, N ) ) THEN - INFO = -9 - ELSE IF( LDC.LT.MAX( 1, P ) ) THEN - INFO = -11 - ELSE IF( LDF.LT.MAX( 1, M ) ) THEN - INFO = -13 - ELSE IF( LDG.LT.MAX( 1, N ) ) THEN - INFO = -15 - ELSE IF( LDS.LT.MAX( 1, N ) ) THEN - INFO = -19 - ELSE IF( LDR.LT.MAX( 1, N ) ) THEN - INFO = -21 - ELSE IF( LDWORK.LT.MAX( 1, LW ) ) THEN - INFO = -23 - END IF -C - IF( INFO.NE.0 ) THEN -C -C Error return. -C - CALL XERBLA( 'SB16CY', -INFO ) - RETURN - END IF -C -C Quick return if possible. -C - IF( MIN( N, M, P ).EQ.0 ) THEN - SCALEC = ONE - SCALEO = ONE - DWORK(1) = ONE - RETURN - END IF -C -C Allocate storage for work arrays. -C - KAW = 1 - KU = KAW + N*N - KWR = KU + N*MAX( N, MP ) - KWI = KWR + N - KW = KWI + N -C -C Form A+G*C. -C - CALL DLACPY( 'Full', N, N, A, LDA, DWORK(KAW), N ) - CALL DGEMM( 'No-transpose', 'No-transpose', N, N, P, ONE, - $ G, LDG, C, LDC, ONE, DWORK(KAW), N ) -C -C Form the factor H of the free term. -C - IF( LEFTW ) THEN -C -C H = F. -C - LDU = MAX( N, M ) - ME = M - CALL DLACPY( 'Full', M, N, F, LDF, DWORK(KU), LDU ) - ELSE -C -C H = C. -C - LDU = MAX( N, P ) - ME = P - CALL DLACPY( 'Full', P, N, C, LDC, DWORK(KU), LDU ) - END IF -C -C Solve for the Cholesky factor Ru of Q, Q = Ru'*Ru, -C the continuous-time Lyapunov equation (if DICO = 'C') -C -C (A+G*C)'*Q + Q*(A+G*C) + scaleo^2*H'*H = 0, -C -C or the discrete-time Lyapunov equation (if DICO = 'D') -C -C (A+G*C)'*Q*(A+G*C) - Q + scaleo^2*H'*H = 0. -C -C Workspace: need N*(N + MAX(N,M) + MIN(N,M) + 6) if JOBCF = 'L'; -C N*(N + MAX(N,P) + MIN(N,P) + 6) if JOBCF = 'R'. -C prefer larger. -C - CALL SB03OD( DICO, 'NoFact', 'NoTransp', N, ME, DWORK(KAW), N, - $ R, LDR, DWORK(KU), LDU, SCALEO, DWORK(KWR), - $ DWORK(KWI), DWORK(KW), LDWORK-KW+1, IERR ) - IF( IERR.NE.0 ) THEN - IF( IERR.EQ.2 ) THEN - INFO = 2 - ELSE IF( IERR.EQ.1 ) THEN - INFO = 4 - ELSE IF( IERR.EQ.6 ) THEN - INFO = 1 - END IF - RETURN - END IF -C - WRKOPT = INT( DWORK(KW) ) + KW - 1 - CALL DLACPY( 'Upper', N, N, DWORK(KU), LDU, R, LDR ) -C -C Form A+B*F. -C - CALL DLACPY( 'Full', N, N, A, LDA, DWORK(KAW), N ) - CALL DGEMM( 'No-transpose', 'No-transpose', N, N, M, ONE, - $ B, LDB, F, LDF, ONE, DWORK(KAW), N ) -C -C Form the factor K of the free term. -C - LDU = N - IF( LEFTW ) THEN -C -C K = B. -C - ME = M - CALL DLACPY( 'Full', N, M, B, LDB, DWORK(KU), LDU ) - ELSE -C -C K = G. -C - ME = P - CALL DLACPY( 'Full', N, P, G, LDG, DWORK(KU), LDU ) - END IF -C -C Solve for the Cholesky factor Su of P, P = Su*Su', -C the continuous-time Lyapunov equation (if DICO = 'C') -C -C (A+B*F)*P + P*(A+B*F)' + scalec^2*K*K' = 0, -C -C or the discrete-time Lyapunov equation (if DICO = 'D') -C -C (A+B*F)*P*(A+B*F)' - P + scalec^2*K*K' = 0. -C -C Workspace: need N*(N + MAX(N,M) + MIN(N,M) + 6) if JOBCF = 'L'; -C N*(N + MAX(N,P) + MIN(N,P) + 6) if JOBCF = 'R'. -C prefer larger. -C - CALL SB03OD( DICO, 'NoFact', 'Transp', N, ME, DWORK(KAW), N, - $ S, LDS, DWORK(KU), LDU, SCALEC, DWORK(KWR), - $ DWORK(KWI), DWORK(KW), LDWORK-KW+1, IERR ) - IF( IERR.NE.0 ) THEN - IF( IERR.EQ.2 ) THEN - INFO = 3 - ELSE IF( IERR.EQ.1 ) THEN - INFO = 5 - ELSE IF( IERR.EQ.6 ) THEN - INFO = 1 - END IF - RETURN - END IF - WRKOPT = MAX( WRKOPT, INT( DWORK(KW) ) + KW - 1 ) - CALL DLACPY( 'Upper', N, N, DWORK(KU), LDU, S, LDS ) -C -C Save the optimal workspace. -C - DWORK(1) = WRKOPT -C - RETURN -C *** Last line of SB16CY *** - END diff --git a/mex/sources/libslicot/SG02AD.f b/mex/sources/libslicot/SG02AD.f deleted file mode 100644 index e7a9d9782..000000000 --- a/mex/sources/libslicot/SG02AD.f +++ /dev/null @@ -1,939 +0,0 @@ - SUBROUTINE SG02AD( DICO, JOBB, FACT, UPLO, JOBL, SCAL, SORT, ACC, - $ N, M, P, A, LDA, E, LDE, B, LDB, Q, LDQ, R, - $ LDR, L, LDL, RCONDU, X, LDX, ALFAR, ALFAI, - $ BETA, S, LDS, T, LDT, U, LDU, TOL, IWORK, - $ DWORK, LDWORK, BWORK, IWARN, INFO ) -C -C SLICOT RELEASE 5.0. -C -C Copyright (c) 2002-2009 NICONET e.V. -C -C This program is free software: you can redistribute it and/or -C modify it under the terms of the GNU General Public License as -C published by the Free Software Foundation, either version 2 of -C the License, or (at your option) any later version. -C -C This program is distributed in the hope that it will be useful, -C but WITHOUT ANY WARRANTY; without even the implied warranty of -C MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the -C GNU General Public License for more details. -C -C You should have received a copy of the GNU General Public License -C along with this program. If not, see -C . -C -C PURPOSE -C -C To solve for X either the continuous-time algebraic Riccati -C equation -C -1 -C Q + A'XE + E'XA - (L+E'XB)R (L+E'XB)' = 0 , (1) -C -C or the discrete-time algebraic Riccati equation -C -1 -C E'XE = A'XA - (L+A'XB)(R + B'XB) (L+A'XB)' + Q , (2) -C -C where A, E, B, Q, R, and L are N-by-N, N-by-N, N-by-M, N-by-N, -C M-by-M and N-by-M matrices, respectively, such that Q = C'C, -C R = D'D and L = C'D; X is an N-by-N symmetric matrix. -C The routine also returns the computed values of the closed-loop -C spectrum of the system, i.e., the stable eigenvalues -C lambda(1),...,lambda(N) of the pencil (A - BF,E), where F is -C the optimal gain matrix, -C -1 -C F = R (L+E'XB)' , for (1), -C -C and -C -1 -C F = (R+B'XB) (L+A'XB)' , for (2). -C -1 -C Optionally, matrix G = BR B' may be given instead of B and R. -C Other options include the case with Q and/or R given in a -C factored form, Q = C'C, R = D'D, and with L a zero matrix. -C -C The routine uses the method of deflating subspaces, based on -C reordering the eigenvalues in a generalized Schur matrix pair. -C -C It is assumed that E is nonsingular, but this condition is not -C checked. Note that the definition (1) of the continuous-time -C algebraic Riccati equation, and the formula for the corresponding -C optimal gain matrix, require R to be nonsingular, but the -C associated linear quadratic optimal problem could have a unique -C solution even when matrix R is singular, under mild assumptions -C (see METHOD). The routine SG02AD works accordingly in this case. -C -C ARGUMENTS -C -C Mode Parameters -C -C DICO CHARACTER*1 -C Specifies the type of Riccati equation to be solved as -C follows: -C = 'C': Equation (1), continuous-time case; -C = 'D': Equation (2), discrete-time case. -C -C JOBB CHARACTER*1 -C Specifies whether or not the matrix G is given, instead -C of the matrices B and R, as follows: -C = 'B': B and R are given; -C = 'G': G is given. -C -C FACT CHARACTER*1 -C Specifies whether or not the matrices Q and/or R (if -C JOBB = 'B') are factored, as follows: -C = 'N': Not factored, Q and R are given; -C = 'C': C is given, and Q = C'C; -C = 'D': D is given, and R = D'D; -C = 'B': Both factors C and D are given, Q = C'C, R = D'D. -C -C UPLO CHARACTER*1 -C If JOBB = 'G', or FACT = 'N', specifies which triangle of -C the matrices G, or Q and R, is stored, as follows: -C = 'U': Upper triangle is stored; -C = 'L': Lower triangle is stored. -C -C JOBL CHARACTER*1 -C Specifies whether or not the matrix L is zero, as follows: -C = 'Z': L is zero; -C = 'N': L is nonzero. -C JOBL is not used if JOBB = 'G' and JOBL = 'Z' is assumed. -C SLICOT Library routine SB02MT should be called just before -C SG02AD, for obtaining the results when JOBB = 'G' and -C JOBL = 'N'. -C -C SCAL CHARACTER*1 -C If JOBB = 'B', specifies whether or not a scaling strategy -C should be used to scale Q, R, and L, as follows: -C = 'G': General scaling should be used; -C = 'N': No scaling should be used. -C SCAL is not used if JOBB = 'G'. -C -C SORT CHARACTER*1 -C Specifies which eigenvalues should be obtained in the top -C of the generalized Schur form, as follows: -C = 'S': Stable eigenvalues come first; -C = 'U': Unstable eigenvalues come first. -C -C ACC CHARACTER*1 -C Specifies whether or not iterative refinement should be -C used to solve the system of algebraic equations giving -C the solution matrix X, as follows: -C = 'R': Use iterative refinement; -C = 'N': Do not use iterative refinement. -C -C Input/Output Parameters -C -C N (input) INTEGER -C The actual state dimension, i.e., the order of the -C matrices A, E, Q, and X, and the number of rows of the -C matrices B and L. N >= 0. -C -C M (input) INTEGER -C The number of system inputs. If JOBB = 'B', M is the -C order of the matrix R, and the number of columns of the -C matrix B. M >= 0. -C M is not used if JOBB = 'G'. -C -C P (input) INTEGER -C The number of system outputs. If FACT = 'C' or 'D' or 'B', -C P is the number of rows of the matrices C and/or D. -C P >= 0. -C Otherwise, P is not used. -C -C A (input) DOUBLE PRECISION array, dimension (LDA,N) -C The leading N-by-N part of this array must contain the -C state matrix A of the descriptor system. -C -C LDA INTEGER -C The leading dimension of array A. LDA >= MAX(1,N). -C -C E (input) DOUBLE PRECISION array, dimension (LDE,N) -C The leading N-by-N part of this array must contain the -C matrix E of the descriptor system. -C -C LDE INTEGER -C The leading dimension of array E. LDE >= MAX(1,N). -C -C B (input) DOUBLE PRECISION array, dimension (LDB,*) -C If JOBB = 'B', the leading N-by-M part of this array must -C contain the input matrix B of the system. -C If JOBB = 'G', the leading N-by-N upper triangular part -C (if UPLO = 'U') or lower triangular part (if UPLO = 'L') -C of this array must contain the upper triangular part or -C lower triangular part, respectively, of the matrix -C -1 -C G = BR B'. The stricly lower triangular part (if -C UPLO = 'U') or stricly upper triangular part (if -C UPLO = 'L') is not referenced. -C -C LDB INTEGER -C The leading dimension of array B. LDB >= MAX(1,N). -C -C Q (input) DOUBLE PRECISION array, dimension (LDQ,N) -C If FACT = 'N' or 'D', the leading N-by-N upper triangular -C part (if UPLO = 'U') or lower triangular part (if UPLO = -C 'L') of this array must contain the upper triangular part -C or lower triangular part, respectively, of the symmetric -C state weighting matrix Q. The stricly lower triangular -C part (if UPLO = 'U') or stricly upper triangular part (if -C UPLO = 'L') is not referenced. -C If FACT = 'C' or 'B', the leading P-by-N part of this -C array must contain the output matrix C of the system. -C If JOBB = 'B' and SCAL = 'G', then Q is modified -C internally, but is restored on exit. -C -C LDQ INTEGER -C The leading dimension of array Q. -C LDQ >= MAX(1,N) if FACT = 'N' or 'D'; -C LDQ >= MAX(1,P) if FACT = 'C' or 'B'. -C -C R (input) DOUBLE PRECISION array, dimension (LDR,*) -C If FACT = 'N' or 'C', the leading M-by-M upper triangular -C part (if UPLO = 'U') or lower triangular part (if UPLO = -C 'L') of this array must contain the upper triangular part -C or lower triangular part, respectively, of the symmetric -C input weighting matrix R. The stricly lower triangular -C part (if UPLO = 'U') or stricly upper triangular part (if -C UPLO = 'L') is not referenced. -C If FACT = 'D' or 'B', the leading P-by-M part of this -C array must contain the direct transmission matrix D of the -C system. -C If JOBB = 'B' and SCAL = 'G', then R is modified -C internally, but is restored on exit. -C If JOBB = 'G', this array is not referenced. -C -C LDR INTEGER -C The leading dimension of array R. -C LDR >= MAX(1,M) if JOBB = 'B' and FACT = 'N' or 'C'; -C LDR >= MAX(1,P) if JOBB = 'B' and FACT = 'D' or 'B'; -C LDR >= 1 if JOBB = 'G'. -C -C L (input) DOUBLE PRECISION array, dimension (LDL,*) -C If JOBL = 'N' and JOBB = 'B', the leading N-by-M part of -C this array must contain the cross weighting matrix L. -C If JOBB = 'B' and SCAL = 'G', then L is modified -C internally, but is restored on exit. -C If JOBL = 'Z' or JOBB = 'G', this array is not referenced. -C -C LDL INTEGER -C The leading dimension of array L. -C LDL >= MAX(1,N) if JOBL = 'N' and JOBB = 'B'; -C LDL >= 1 if JOBL = 'Z' or JOBB = 'G'. -C -C RCONDU (output) DOUBLE PRECISION -C If N > 0 and INFO = 0 or INFO = 7, an estimate of the -C reciprocal of the condition number (in the 1-norm) of -C the N-th order system of algebraic equations from which -C the solution matrix X is obtained. -C -C X (output) DOUBLE PRECISION array, dimension (LDX,N) -C If INFO = 0, the leading N-by-N part of this array -C contains the solution matrix X of the problem. -C -C LDX INTEGER -C The leading dimension of array X. LDX >= MAX(1,N). -C -C ALFAR (output) DOUBLE PRECISION array, dimension (2*N) -C ALFAI (output) DOUBLE PRECISION array, dimension (2*N) -C BETA (output) DOUBLE PRECISION array, dimension (2*N) -C The generalized eigenvalues of the 2N-by-2N matrix pair, -C ordered as specified by SORT (if INFO = 0, or INFO >= 5). -C For instance, if SORT = 'S', the leading N elements of -C these arrays contain the closed-loop spectrum of the -C system. Specifically, -C lambda(k) = [ALFAR(k)+j*ALFAI(k)]/BETA(k) for -C k = 1,2,...,N. -C -C S (output) DOUBLE PRECISION array, dimension (LDS,*) -C The leading 2N-by-2N part of this array contains the -C ordered real Schur form S of the first matrix in the -C reduced matrix pencil associated to the optimal problem, -C corresponding to the scaled Q, R, and L, if JOBB = 'B' -C and SCAL = 'G'. That is, -C -C (S S ) -C ( 11 12) -C S = ( ), -C (0 S ) -C ( 22) -C -C where S , S and S are N-by-N matrices. -C 11 12 22 -C Array S must have 2*N+M columns if JOBB = 'B', and 2*N -C columns, otherwise. -C -C LDS INTEGER -C The leading dimension of array S. -C LDS >= MAX(1,2*N+M) if JOBB = 'B'; -C LDS >= MAX(1,2*N) if JOBB = 'G'. -C -C T (output) DOUBLE PRECISION array, dimension (LDT,2*N) -C The leading 2N-by-2N part of this array contains the -C ordered upper triangular form T of the second matrix in -C the reduced matrix pencil associated to the optimal -C problem, corresponding to the scaled Q, R, and L, if -C JOBB = 'B' and SCAL = 'G'. That is, -C -C (T T ) -C ( 11 12) -C T = ( ), -C (0 T ) -C ( 22) -C -C where T , T and T are N-by-N matrices. -C 11 12 22 -C -C LDT INTEGER -C The leading dimension of array T. -C LDT >= MAX(1,2*N+M) if JOBB = 'B'; -C LDT >= MAX(1,2*N) if JOBB = 'G'. -C -C U (output) DOUBLE PRECISION array, dimension (LDU,2*N) -C The leading 2N-by-2N part of this array contains the right -C transformation matrix U which reduces the 2N-by-2N matrix -C pencil to the ordered generalized real Schur form (S,T). -C That is, -C -C (U U ) -C ( 11 12) -C U = ( ), -C (U U ) -C ( 21 22) -C -C where U , U , U and U are N-by-N matrices. -C 11 12 21 22 -C If JOBB = 'B' and SCAL = 'G', then U corresponds to the -C scaled pencil. If a basis for the stable deflating -C subspace of the original problem is needed, then the -C submatrix U must be multiplied by the scaling factor -C 21 -C contained in DWORK(4). -C -C LDU INTEGER -C The leading dimension of array U. LDU >= MAX(1,2*N). -C -C Tolerances -C -C TOL DOUBLE PRECISION -C The tolerance to be used to test for near singularity of -C the original matrix pencil, specifically of the triangular -C M-by-M factor obtained during the reduction process. If -C the user sets TOL > 0, then the given value of TOL is used -C as a lower bound for the reciprocal condition number of -C that matrix; a matrix whose estimated condition number is -C less than 1/TOL is considered to be nonsingular. If the -C user sets TOL <= 0, then a default tolerance, defined by -C TOLDEF = EPS, is used instead, where EPS is the machine -C precision (see LAPACK Library routine DLAMCH). -C This parameter is not referenced if JOBB = 'G'. -C -C Workspace -C -C IWORK INTEGER array, dimension (LIWORK) -C LIWORK >= MAX(1,M,2*N) if JOBB = 'B'; -C LIWORK >= MAX(1,2*N) if JOBB = 'G'. -C -C DWORK DOUBLE PRECISION array, dimension (LDWORK) -C On exit, if INFO = 0, DWORK(1) returns the optimal value -C of LDWORK. If JOBB = 'B' and N > 0, DWORK(2) returns the -C reciprocal of the condition number of the M-by-M bottom -C right lower triangular matrix obtained while compressing -C the matrix pencil of order 2N+M to obtain a pencil of -C order 2N. If ACC = 'R', and INFO = 0 or INFO = 7, DWORK(3) -C returns the reciprocal pivot growth factor (see SLICOT -C Library routine MB02PD) for the LU factorization of the -C coefficient matrix of the system of algebraic equations -C giving the solution matrix X; if DWORK(3) is much -C less than 1, then the computed X and RCONDU could be -C unreliable. If INFO = 0 or INFO = 7, DWORK(4) returns the -C scaling factor used to scale Q, R, and L. DWORK(4) is set -C to 1 if JOBB = 'G' or SCAL = 'N'. -C -C LDWORK INTEGER -C The length of the array DWORK. -C LDWORK >= MAX(7*(2*N+1)+16,16*N), if JOBB = 'G'; -C LDWORK >= MAX(7*(2*N+1)+16,16*N,2*N+M,3*M), if JOBB = 'B'. -C For optimum performance LDWORK should be larger. -C -C BWORK LOGICAL array, dimension (2*N) -C -C Warning Indicator -C -C IWARN INTEGER -C = 0: no warning; -C = 1: the computed solution may be inaccurate due to poor -C scaling or eigenvalues too close to the boundary of -C the stability domain (the imaginary axis, if -C DICO = 'C', or the unit circle, if DICO = 'D'). -C -C Error Indicator -C -C INFO INTEGER -C = 0: successful exit; -C < 0: if INFO = -i, the i-th argument had an illegal -C value; -C = 1: if the computed extended matrix pencil is singular, -C possibly due to rounding errors; -C = 2: if the QZ algorithm failed; -C = 3: if reordering of the generalized eigenvalues failed; -C = 4: if after reordering, roundoff changed values of -C some complex eigenvalues so that leading eigenvalues -C in the generalized Schur form no longer satisfy the -C stability condition; this could also be caused due -C to scaling; -C = 5: if the computed dimension of the solution does not -C equal N; -C = 6: if the spectrum is too close to the boundary of -C the stability domain; -C = 7: if a singular matrix was encountered during the -C computation of the solution matrix X. -C -C METHOD -C -C The routine uses a variant of the method of deflating subspaces -C proposed by van Dooren [1]. See also [2], [3], [4]. -C It is assumed that E is nonsingular, the triple (E,A,B) is -C strongly stabilizable and detectable (see [3]); if, in addition, -C -C - [ Q L ] -C R := [ ] >= 0 , -C [ L' R ] -C -C then the pencils -C -C discrete-time continuous-time -C -C |A 0 B| |E 0 0| |A 0 B| |E 0 0| -C |Q -E' L| - z |0 -A' 0| , |Q A' L| - s |0 -E' 0| , (3) -C |L' 0 R| |0 -B' 0| |L' B' R| |0 0 0| -C -C are dichotomic, i.e., they have no eigenvalues on the boundary of -C the stability domain. The above conditions are sufficient for -C regularity of these pencils. A necessary condition is that -C rank([ B' L' R']') = m. -C -C Under these assumptions the algebraic Riccati equation is known to -C have a unique non-negative definite solution. -C The first step in the method of deflating subspaces is to form the -C extended matrices in (3), of order 2N + M. Next, these pencils are -C compressed to a form of order 2N (see [1]) -C -C lambda x A - B . -C f f -C -C This generalized eigenvalue problem is then solved using the QZ -C algorithm and the stable deflating subspace Ys is determined. -C If [Y1'|Y2']' is a basis for Ys, then the required solution is -C -1 -C X = Y2 x Y1 . -C -C REFERENCES -C -C [1] Van Dooren, P. -C A Generalized Eigenvalue Approach for Solving Riccati -C Equations. -C SIAM J. Sci. Stat. Comp., 2, pp. 121-135, 1981. -C -C [2] Arnold, III, W.F. and Laub, A.J. -C Generalized Eigenproblem Algorithms and Software for -C Algebraic Riccati Equations. -C Proc. IEEE, 72, 1746-1754, 1984. -C -C [3] Mehrmann, V. -C The Autonomous Linear Quadratic Control Problem. Theory and -C Numerical Solution. -C Lect. Notes in Control and Information Sciences, vol. 163, -C Springer-Verlag, Berlin, 1991. -C -C [4] Sima, V. -C Algorithms for Linear-Quadratic Optimization. -C Pure and Applied Mathematics: A Series of Monographs and -C Textbooks, vol. 200, Marcel Dekker, Inc., New York, 1996. -C -C NUMERICAL ASPECTS -C -C This routine is particularly suited for systems where the matrix R -C is ill-conditioned, or even singular. -C -C FURTHER COMMENTS -C -C To obtain a stabilizing solution of the algebraic Riccati -C equations set SORT = 'S'. -C -C The routine can also compute the anti-stabilizing solutions of -C the algebraic Riccati equations, by specifying SORT = 'U'. -C -C CONTRIBUTOR -C -C V. Sima, Katholieke Univ. Leuven, Belgium, June 2002. -C -C REVISIONS -C -C V. Sima, Katholieke Univ. Leuven, Belgium, September 2002, -C December 2002. -C -C KEYWORDS -C -C Algebraic Riccati equation, closed loop system, continuous-time -C system, discrete-time system, optimal regulator, Schur form. -C -C ****************************************************************** -C -C .. Parameters .. - DOUBLE PRECISION ZERO, HALF, ONE, P1, FOUR - PARAMETER ( ZERO = 0.0D0, HALF = 0.5D0, ONE = 1.0D0, - $ P1 = 0.1D0, FOUR = 4.0D0 ) -C .. Scalar Arguments .. - CHARACTER ACC, DICO, FACT, JOBB, JOBL, SCAL, SORT, UPLO - INTEGER INFO, IWARN, LDA, LDB, LDE, LDL, LDQ, LDR, LDS, - $ LDT, LDU, LDWORK, LDX, M, N, P - DOUBLE PRECISION RCONDU, TOL -C .. Array Arguments .. - LOGICAL BWORK(*) - INTEGER IWORK(*) - DOUBLE PRECISION A(LDA,*), ALFAI(*), ALFAR(*), B(LDB,*), BETA(*), - $ DWORK(*), E(LDE,*), L(LDL,*), Q(LDQ,*), - $ R(LDR,*), S(LDS,*), T(LDT,*), U(LDU,*), X(LDX,*) -C .. Local Scalars .. - CHARACTER EQUED, QTYPE, RTYPE - LOGICAL COLEQU, DISCR, LFACB, LFACN, LFACQ, LFACR, - $ LJOBB, LJOBL, LJOBLN, LSCAL, LSORT, LUPLO, - $ REFINE, ROWEQU - INTEGER I, INFO1, IW, IWB, IWC, IWF, IWR, J, LDW, MP, - $ NDIM, NN, NNM, NP, NP1, WRKOPT - DOUBLE PRECISION ASYM, EPS, PIVOTU, RCONDL, RNORM, SCALE, SEPS, - $ U12M, UNORM -C .. External Functions .. - LOGICAL LSAME, SB02OU, SB02OV, SB02OW - DOUBLE PRECISION DLAMCH, DLANGE, DLANSY - EXTERNAL DLAMCH, DLANGE, DLANSY, LSAME, SB02OU, SB02OV, - $ SB02OW -C .. External Subroutines .. - EXTERNAL DAXPY, DCOPY, DGECON, DGEMM, DGEQRF, DGGES, - $ DLACPY, DLASCL, DLASET, DORGQR, DSCAL, DSWAP, - $ MB01SD, MB02PD, MB02VD, SB02OY, XERBLA -C .. Intrinsic Functions .. - INTRINSIC ABS, INT, MAX, SQRT -C .. Executable Statements .. -C - IWARN = 0 - INFO = 0 - DISCR = LSAME( DICO, 'D' ) - LJOBB = LSAME( JOBB, 'B' ) - LFACN = LSAME( FACT, 'N' ) - LFACQ = LSAME( FACT, 'C' ) - LFACR = LSAME( FACT, 'D' ) - LFACB = LSAME( FACT, 'B' ) - LUPLO = LSAME( UPLO, 'U' ) - LSORT = LSAME( SORT, 'S' ) - REFINE = LSAME( ACC, 'R' ) - NN = 2*N - IF ( LJOBB ) THEN - LJOBL = LSAME( JOBL, 'Z' ) - LJOBLN = LSAME( JOBL, 'N' ) - LSCAL = LSAME( SCAL, 'G' ) - NNM = NN + M - LDW = MAX( NNM, 3*M ) - ELSE - LSCAL = .FALSE. - NNM = NN - LDW = 1 - END IF - NP1 = N + 1 -C -C Test the input scalar arguments. -C - IF( .NOT.DISCR .AND. .NOT.LSAME( DICO, 'C' ) ) THEN - INFO = -1 - ELSE IF( .NOT.LJOBB .AND. .NOT.LSAME( JOBB, 'G' ) ) THEN - INFO = -2 - ELSE IF( .NOT.LFACQ .AND. .NOT.LFACR .AND. .NOT.LFACB - $ .AND. .NOT.LFACN ) THEN - INFO = -3 - ELSE IF( .NOT.LJOBB .OR. LFACN ) THEN - IF( .NOT.LUPLO .AND. .NOT.LSAME( UPLO, 'L' ) ) - $ INFO = -4 - END IF - IF( INFO.EQ.0 .AND. LJOBB ) THEN - IF( .NOT.LJOBL .AND. .NOT.LJOBLN ) THEN - INFO = -5 - ELSE IF( .NOT.LSCAL .AND. .NOT. LSAME( SCAL, 'N' ) ) THEN - INFO = -6 - END IF - END IF - IF( INFO.EQ.0 ) THEN - IF( .NOT.LSORT .AND. .NOT.LSAME( SORT, 'U' ) ) THEN - INFO = -7 - ELSE IF( .NOT.REFINE .AND. .NOT.LSAME( ACC, 'N' ) ) THEN - INFO = -8 - ELSE IF( N.LT.0 ) THEN - INFO = -9 - ELSE IF( LJOBB ) THEN - IF( M.LT.0 ) - $ INFO = -10 - END IF - END IF - IF( INFO.EQ.0 .AND. .NOT.LFACN ) THEN - IF( P.LT.0 ) - $ INFO = -11 - END IF - IF( INFO.EQ.0 ) THEN - IF( LDA.LT.MAX( 1, N ) ) THEN - INFO = -13 - ELSE IF( LDE.LT.MAX( 1, N ) ) THEN - INFO = -15 - ELSE IF( LDB.LT.MAX( 1, N ) ) THEN - INFO = -17 - ELSE IF( ( ( LFACN.OR.LFACR ) .AND. LDQ.LT.MAX( 1, N ) ) .OR. - $ ( ( LFACQ.OR.LFACB ) .AND. LDQ.LT.MAX( 1, P ) ) ) THEN - INFO = -19 - ELSE IF( LJOBB ) THEN - IF ( ( LFACN.OR.LFACQ ) .AND. LDR.LT.MAX( 1, M ) .OR. - $ ( LFACR.OR.LFACB ) .AND. LDR.LT.MAX( 1, P ) ) THEN - INFO = -21 - ELSE IF( ( LJOBLN .AND. LDL.LT.MAX( 1, N ) ) .OR. - $ ( LJOBL .AND. LDL.LT.1 ) ) THEN - INFO = -23 - END IF - ELSE - IF( LDR.LT.1 ) THEN - INFO = -21 - ELSE IF( LDL.LT.1 ) THEN - INFO = -23 - END IF - END IF - END IF - IF( INFO.EQ.0 ) THEN - IF( LDX.LT.MAX( 1, N ) ) THEN - INFO = -26 - ELSE IF( LDS.LT.MAX( 1, NNM ) ) THEN - INFO = -31 - ELSE IF( LDT.LT.MAX( 1, NNM ) ) THEN - INFO = -33 - ELSE IF( LDU.LT.MAX( 1, NN ) ) THEN - INFO = -35 - ELSE IF( LDWORK.LT.MAX( 14*N + 23, 16*N, LDW ) ) THEN - INFO = -39 - END IF - END IF -C - IF ( INFO.NE.0 ) THEN -C -C Error return. -C - CALL XERBLA( 'SG02AD', -INFO ) - RETURN - END IF -C -C Quick return if possible. -C - IF ( N.EQ.0 ) THEN - DWORK(1) = FOUR - DWORK(4) = ONE - RETURN - END IF -C -C Start computations. -C -C (Note: Comments in the code beginning "Workspace:" describe the -C minimal amount of real workspace needed at that point in the -C code, as well as the preferred amount for good performance. -C NB refers to the optimal block size for the immediately -C following subroutine, as returned by ILAENV.) -C - LSCAL = LSCAL .AND. LJOBB - IF ( LSCAL ) THEN -C -C Scale the matrices Q, R (or G), and L so that -C norm(Q) + norm(R) + norm(L) = 1, -C using the 1-norm. If Q and/or R are factored, the norms of -C the factors are used. -C Workspace: need max(N,M), if FACT = 'N'; -C N, if FACT = 'D'; -C M, if FACT = 'C'. -C - IF ( LFACN .OR. LFACR ) THEN - SCALE = DLANSY( '1-norm', UPLO, N, Q, LDQ, DWORK ) - QTYPE = UPLO - NP = N - ELSE - SCALE = DLANGE( '1-norm', P, N, Q, LDQ, DWORK ) - QTYPE = 'G' - NP = P - END IF -C - IF ( LFACN .OR. LFACQ ) THEN - RNORM = DLANSY( '1-norm', UPLO, M, R, LDR, DWORK ) - RTYPE = UPLO - MP = M - ELSE - RNORM = DLANGE( '1-norm', P, M, R, LDR, DWORK ) - RTYPE = 'G' - MP = P - END IF - SCALE = SCALE + RNORM -C - IF ( LJOBLN ) - $ SCALE = SCALE + DLANGE( '1-norm', N, M, L, LDL, DWORK ) - IF ( SCALE.EQ.ZERO ) - $ SCALE = ONE -C - CALL DLASCL( QTYPE, 0, 0, SCALE, ONE, NP, N, Q, LDQ, INFO1 ) - CALL DLASCL( RTYPE, 0, 0, SCALE, ONE, MP, M, R, LDR, INFO1 ) - IF ( LJOBLN ) - $ CALL DLASCL( 'G', 0, 0, SCALE, ONE, N, M, L, LDL, INFO1 ) - ELSE - SCALE = ONE - END IF -C -C Construct the extended matrix pair. -C Workspace: need 1, if JOBB = 'G', -C max(1,2*N+M,3*M), if JOBB = 'B'; -C prefer larger. -C - CALL SB02OY( 'Optimal control', DICO, JOBB, FACT, UPLO, JOBL, - $ 'Not identity E', N, M, P, A, LDA, B, LDB, Q, LDQ, R, - $ LDR, L, LDL, E, LDE, S, LDS, T, LDT, TOL, IWORK, - $ DWORK, LDWORK, INFO ) -C - IF ( LSCAL ) THEN -C -C Undo scaling of the data arrays. -C - CALL DLASCL( QTYPE, 0, 0, ONE, SCALE, NP, N, Q, LDQ, INFO1 ) - CALL DLASCL( RTYPE, 0, 0, ONE, SCALE, MP, M, R, LDR, INFO1 ) - IF ( LJOBLN ) - $ CALL DLASCL( 'G', 0, 0, ONE, SCALE, N, M, L, LDL, INFO1 ) - END IF -C - IF ( INFO.NE.0 ) - $ RETURN - WRKOPT = DWORK(1) - IF ( LJOBB ) - $ RCONDL = DWORK(2) -C -C Workspace: need max(7*(2*N+1)+16,16*N); -C prefer larger. -C - IF ( DISCR ) THEN - IF ( LSORT ) THEN -C -C The natural tendency of the QZ algorithm to get the largest -C eigenvalues in the leading part of the matrix pair is -C exploited, by computing the unstable eigenvalues of the -C permuted matrix pair. -C - CALL DGGES( 'No vectors', 'Vectors', 'Sort', SB02OV, NN, T, - $ LDT, S, LDS, NDIM, ALFAR, ALFAI, BETA, U, LDU, - $ U, LDU, DWORK, LDWORK, BWORK, INFO1 ) - CALL DSWAP( N, ALFAR(NP1), 1, ALFAR, 1 ) - CALL DSWAP( N, ALFAI(NP1), 1, ALFAI, 1 ) - CALL DSWAP( N, BETA (NP1), 1, BETA , 1 ) - ELSE - CALL DGGES( 'No vectors', 'Vectors', 'Sort', SB02OV, NN, S, - $ LDS, T, LDT, NDIM, ALFAR, ALFAI, BETA, U, LDU, - $ U, LDU, DWORK, LDWORK, BWORK, INFO1 ) - END IF - ELSE - IF ( LSORT ) THEN - CALL DGGES( 'No vectors', 'Vectors', 'Sort', SB02OW, NN, S, - $ LDS, T, LDT, NDIM, ALFAR, ALFAI, BETA, U, LDU, - $ U, LDU, DWORK, LDWORK, BWORK, INFO1 ) - ELSE - CALL DGGES( 'No vectors', 'Vectors', 'Sort', SB02OU, NN, S, - $ LDS, T, LDT, NDIM, ALFAR, ALFAI, BETA, U, LDU, - $ U, LDU, DWORK, LDWORK, BWORK, INFO1 ) - END IF - END IF - IF ( INFO1.GT.0 .AND. INFO1.LE.NN+1 ) THEN - INFO = 2 - ELSE IF ( INFO1.EQ.NN+2 ) THEN - INFO = 4 - ELSE IF ( INFO1.EQ.NN+3 ) THEN - INFO = 3 - ELSE IF ( NDIM.NE.N ) THEN - INFO = 5 - END IF - IF ( INFO.NE.0 ) - $ RETURN - WRKOPT = MAX( WRKOPT, INT( DWORK(1) ) ) -C -C Take the non-identity matrix E into account and orthogonalize the -C basis. Use the array X as workspace. -C Workspace: need N; -C prefer N*NB. -C - CALL DGEMM( 'No transpose', 'No transpose', N, N, N, ONE, E, LDE, - $ U, LDU, ZERO, X, LDX ) - CALL DLACPY( 'Full', N, N, X, LDX, U, LDU ) - CALL DGEQRF( NN, N, U, LDU, X, DWORK, LDWORK, INFO1 ) - WRKOPT = MAX( WRKOPT, INT( DWORK(1) ) ) - CALL DORGQR( NN, N, N, U, LDU, X, DWORK, LDWORK, INFO1 ) - WRKOPT = MAX( WRKOPT, INT( DWORK(1) ) ) -C -C Check for the symmetry of the solution. The array X is again used -C as workspace. -C - CALL DGEMM( 'Transpose', 'No transpose', N, N, N, ONE, U, LDU, - $ U(NP1,1), LDU, ZERO, X, LDX ) - U12M = ZERO - ASYM = ZERO -C - DO 20 J = 1, N -C - DO 10 I = 1, N - U12M = MAX( U12M, ABS( X(I,J) ) ) - ASYM = MAX( ASYM, ABS( X(I,J) - X(J,I) ) ) - 10 CONTINUE -C - 20 CONTINUE -C - EPS = DLAMCH( 'Epsilon' ) - SEPS = SQRT( EPS ) - ASYM = ASYM - SEPS - IF ( ASYM.GT.P1*U12M ) THEN - INFO = 6 - RETURN - ELSE IF ( ASYM.GT.SEPS ) THEN - IWARN = 1 - END IF -C -C Compute the solution of X*U(1,1) = U(2,1). Use the (2,1) block -C of S as a workspace for factoring U(1,1). -C - IF ( REFINE ) THEN -C -C Use LU factorization and iterative refinement for finding X. -C Workspace: need 8*N. -C -C First transpose U(2,1) in-situ. -C - DO 30 I = 1, N - 1 - CALL DSWAP( N-I, U(N+I,I+1), LDU, U(N+I+1,I), 1 ) - 30 CONTINUE -C - IWR = 1 - IWC = IWR + N - IWF = IWC + N - IWB = IWF + N - IW = IWB + N -C - CALL MB02PD( 'Equilibrate', 'Transpose', N, N, U, LDU, - $ S(NP1,1), LDS, IWORK, EQUED, DWORK(IWR), - $ DWORK(IWC), U(NP1,1), LDU, X, LDX, RCONDU, - $ DWORK(IWF), DWORK(IWB), IWORK(NP1), DWORK(IW), - $ INFO1 ) -C -C Transpose U(2,1) back in-situ. -C - DO 40 I = 1, N - 1 - CALL DSWAP( N-I, U(N+I,I+1), LDU, U(N+I+1,I), 1 ) - 40 CONTINUE -C - IF( .NOT.LSAME( EQUED, 'N' ) ) THEN -C -C Undo the equilibration of U(1,1) and U(2,1). -C - ROWEQU = LSAME( EQUED, 'R' ) .OR. LSAME( EQUED, 'B' ) - COLEQU = LSAME( EQUED, 'C' ) .OR. LSAME( EQUED, 'B' ) -C - IF( ROWEQU ) THEN -C - DO 50 I = 0, N - 1 - DWORK(IWR+I) = ONE / DWORK(IWR+I) - 50 CONTINUE -C - CALL MB01SD( 'Row scaling', N, N, U, LDU, DWORK(IWR), - $ DWORK(IWC) ) - END IF -C - IF( COLEQU ) THEN -C - DO 60 I = 0, N - 1 - DWORK(IWC+I) = ONE / DWORK(IWC+I) - 60 CONTINUE -C - CALL MB01SD( 'Column scaling', NN, N, U, LDU, DWORK(IWR), - $ DWORK(IWC) ) - END IF - END IF -C - PIVOTU = DWORK(IW) -C - IF ( INFO1.GT.0 ) THEN -C -C Singular matrix. Set INFO and DWORK for error return. -C - INFO = 7 - GO TO 80 - END IF -C - ELSE -C -C Use LU factorization and a standard solution algorithm. -C - CALL DLACPY( 'Full', N, N, U, LDU, S(NP1,1), LDS ) - CALL DLACPY( 'Full', N, N, U(NP1,1), LDU, X, LDX ) -C -C Solve the system X*U(1,1) = U(2,1). -C - CALL MB02VD( 'No Transpose', N, N, S(NP1,1), LDS, IWORK, X, - $ LDX, INFO1 ) -C - IF ( INFO1.NE.0 ) THEN - INFO = 7 - RCONDU = ZERO - GO TO 80 - ELSE -C -C Compute the norm of U(1,1). -C - UNORM = DLANGE( '1-norm', N, N, U, LDU, DWORK ) -C -C Estimate the reciprocal condition of U(1,1). -C Workspace: need 4*N. -C - CALL DGECON( '1-norm', N, S(NP1,1), LDS, UNORM, RCONDU, - $ DWORK, IWORK(NP1), INFO ) -C - IF ( RCONDU.LT.EPS ) THEN -C -C Nearly singular matrix. Set IWARN for warning indication. -C - IWARN = 1 - END IF - WRKOPT = MAX( WRKOPT, 4*N ) - END IF - END IF -C -C Set S(2,1) to zero. -C - CALL DLASET( 'Full', N, N, ZERO, ZERO, S(NP1,1), LDS ) -C -C Make sure the solution matrix X is symmetric. -C - DO 70 I = 1, N - 1 - CALL DAXPY( N-I, ONE, X(I,I+1), LDX, X(I+1,I), 1 ) - CALL DSCAL( N-I, HALF, X(I+1,I), 1 ) - CALL DCOPY( N-I, X(I+1,I), 1, X(I,I+1), LDX ) - 70 CONTINUE -C - IF ( LSCAL ) THEN -C -C Undo scaling for the solution X. -C - CALL DLASCL( 'G', 0, 0, ONE, SCALE, N, N, X, LDX, INFO1 ) - END IF -C - DWORK(1) = WRKOPT -C - 80 CONTINUE - IF ( LJOBB ) - $ DWORK(2) = RCONDL - IF ( REFINE ) - $ DWORK(3) = PIVOTU - DWORK(4) = SCALE -C - RETURN -C *** Last line of SG02AD *** - END diff --git a/mex/sources/libslicot/SG03AD.f b/mex/sources/libslicot/SG03AD.f deleted file mode 100644 index a08e218ca..000000000 --- a/mex/sources/libslicot/SG03AD.f +++ /dev/null @@ -1,639 +0,0 @@ - SUBROUTINE SG03AD( DICO, JOB, FACT, TRANS, UPLO, N, A, LDA, E, - $ LDE, Q, LDQ, Z, LDZ, X, LDX, SCALE, SEP, FERR, - $ ALPHAR, ALPHAI, BETA, IWORK, DWORK, LDWORK, - $ INFO ) -C -C SLICOT RELEASE 5.0. -C -C Copyright (c) 2002-2009 NICONET e.V. -C -C This program is free software: you can redistribute it and/or -C modify it under the terms of the GNU General Public License as -C published by the Free Software Foundation, either version 2 of -C the License, or (at your option) any later version. -C -C This program is distributed in the hope that it will be useful, -C but WITHOUT ANY WARRANTY; without even the implied warranty of -C MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the -C GNU General Public License for more details. -C -C You should have received a copy of the GNU General Public License -C along with this program. If not, see -C . -C -C PURPOSE -C -C To solve for X either the generalized continuous-time Lyapunov -C equation -C -C T T -C op(A) X op(E) + op(E) X op(A) = SCALE * Y, (1) -C -C or the generalized discrete-time Lyapunov equation -C -C T T -C op(A) X op(A) - op(E) X op(E) = SCALE * Y, (2) -C -C where op(M) is either M or M**T for M = A, E and the right hand -C side Y is symmetric. A, E, Y, and the solution X are N-by-N -C matrices. SCALE is an output scale factor, set to avoid overflow -C in X. -C -C Estimates of the separation and the relative forward error norm -C are provided. -C -C ARGUMENTS -C -C Mode Parameters -C -C DICO CHARACTER*1 -C Specifies which type of the equation is considered: -C = 'C': Continuous-time equation (1); -C = 'D': Discrete-time equation (2). -C -C JOB CHARACTER*1 -C Specifies if the solution is to be computed and if the -C separation is to be estimated: -C = 'X': Compute the solution only; -C = 'S': Estimate the separation only; -C = 'B': Compute the solution and estimate the separation. -C -C FACT CHARACTER*1 -C Specifies whether the generalized real Schur -C factorization of the pencil A - lambda * E is supplied -C on entry or not: -C = 'N': Factorization is not supplied; -C = 'F': Factorization is supplied. -C -C TRANS CHARACTER*1 -C Specifies whether the transposed equation is to be solved -C or not: -C = 'N': op(A) = A, op(E) = E; -C = 'T': op(A) = A**T, op(E) = E**T. -C -C UPLO CHARACTER*1 -C Specifies whether the lower or the upper triangle of the -C array X is needed on input: -C = 'L': Only the lower triangle is needed on input; -C = 'U': Only the upper triangle is needed on input. -C -C Input/Output Parameters -C -C N (input) INTEGER -C The order of the matrix A. N >= 0. -C -C A (input/output) DOUBLE PRECISION array, dimension (LDA,N) -C On entry, if FACT = 'F', then the leading N-by-N upper -C Hessenberg part of this array must contain the -C generalized Schur factor A_s of the matrix A (see -C definition (3) in section METHOD). A_s must be an upper -C quasitriangular matrix. The elements below the upper -C Hessenberg part of the array A are not referenced. -C If FACT = 'N', then the leading N-by-N part of this -C array must contain the matrix A. -C On exit, the leading N-by-N part of this array contains -C the generalized Schur factor A_s of the matrix A. (A_s is -C an upper quasitriangular matrix.) -C -C LDA INTEGER -C The leading dimension of the array A. LDA >= MAX(1,N). -C -C E (input/output) DOUBLE PRECISION array, dimension (LDE,N) -C On entry, if FACT = 'F', then the leading N-by-N upper -C triangular part of this array must contain the -C generalized Schur factor E_s of the matrix E (see -C definition (4) in section METHOD). The elements below the -C upper triangular part of the array E are not referenced. -C If FACT = 'N', then the leading N-by-N part of this -C array must contain the coefficient matrix E of the -C equation. -C On exit, the leading N-by-N part of this array contains -C the generalized Schur factor E_s of the matrix E. (E_s is -C an upper triangular matrix.) -C -C LDE INTEGER -C The leading dimension of the array E. LDE >= MAX(1,N). -C -C Q (input/output) DOUBLE PRECISION array, dimension (LDQ,N) -C On entry, if FACT = 'F', then the leading N-by-N part of -C this array must contain the orthogonal matrix Q from -C the generalized Schur factorization (see definitions (3) -C and (4) in section METHOD). -C If FACT = 'N', Q need not be set on entry. -C On exit, the leading N-by-N part of this array contains -C the orthogonal matrix Q from the generalized Schur -C factorization. -C -C LDQ INTEGER -C The leading dimension of the array Q. LDQ >= MAX(1,N). -C -C Z (input/output) DOUBLE PRECISION array, dimension (LDZ,N) -C On entry, if FACT = 'F', then the leading N-by-N part of -C this array must contain the orthogonal matrix Z from -C the generalized Schur factorization (see definitions (3) -C and (4) in section METHOD). -C If FACT = 'N', Z need not be set on entry. -C On exit, the leading N-by-N part of this array contains -C the orthogonal matrix Z from the generalized Schur -C factorization. -C -C LDZ INTEGER -C The leading dimension of the array Z. LDZ >= MAX(1,N). -C -C X (input/output) DOUBLE PRECISION array, dimension (LDX,N) -C On entry, if JOB = 'B' or 'X', then the leading N-by-N -C part of this array must contain the right hand side matrix -C Y of the equation. Either the lower or the upper -C triangular part of this array is needed (see mode -C parameter UPLO). -C If JOB = 'S', X is not referenced. -C On exit, if JOB = 'B' or 'X', and INFO = 0, 3, or 4, then -C the leading N-by-N part of this array contains the -C solution matrix X of the equation. -C If JOB = 'S', X is not referenced. -C -C LDX INTEGER -C The leading dimension of the array X. LDX >= MAX(1,N). -C -C SCALE (output) DOUBLE PRECISION -C The scale factor set to avoid overflow in X. -C (0 < SCALE <= 1) -C -C SEP (output) DOUBLE PRECISION -C If JOB = 'S' or JOB = 'B', and INFO = 0, 3, or 4, then -C SEP contains an estimate of the separation of the -C Lyapunov operator. -C -C FERR (output) DOUBLE PRECISION -C If JOB = 'B', and INFO = 0, 3, or 4, then FERR contains an -C estimated forward error bound for the solution X. If XTRUE -C is the true solution, FERR estimates the relative error -C in the computed solution, measured in the Frobenius norm: -C norm(X - XTRUE) / norm(XTRUE) -C -C ALPHAR (output) DOUBLE PRECISION array, dimension (N) -C ALPHAI (output) DOUBLE PRECISION array, dimension (N) -C BETA (output) DOUBLE PRECISION array, dimension (N) -C If FACT = 'N' and INFO = 0, 3, or 4, then -C (ALPHAR(j) + ALPHAI(j)*i)/BETA(j), j=1,...,N, are the -C eigenvalues of the matrix pencil A - lambda * E. -C If FACT = 'F', ALPHAR, ALPHAI, and BETA are not -C referenced. -C -C Workspace -C -C IWORK INTEGER array, dimension (N**2) -C IWORK is not referenced if JOB = 'X'. -C -C DWORK DOUBLE PRECISION array, dimension (LDWORK) -C On exit, if INFO = 0, DWORK(1) returns the optimal value -C of LDWORK. -C -C LDWORK INTEGER -C The length of the array DWORK. The following table -C contains the minimal work space requirements depending -C on the choice of JOB and FACT. -C -C JOB FACT | LDWORK -C -------------------+------------------- -C 'X' 'F' | MAX(1,N) -C 'X' 'N' | MAX(1,4*N) -C 'B', 'S' 'F' | MAX(1,2*N**2) -C 'B', 'S' 'N' | MAX(1,2*N**2,4*N) -C -C For optimum performance, LDWORK should be larger. -C -C Error indicator -C -C INFO INTEGER -C = 0: successful exit; -C < 0: if INFO = -i, the i-th argument had an illegal -C value; -C = 1: FACT = 'F' and the matrix contained in the upper -C Hessenberg part of the array A is not in upper -C quasitriangular form; -C = 2: FACT = 'N' and the pencil A - lambda * E cannot be -C reduced to generalized Schur form: LAPACK routine -C DGEGS has failed to converge; -C = 3: DICO = 'D' and the pencil A - lambda * E has a -C pair of reciprocal eigenvalues. That is, lambda_i = -C 1/lambda_j for some i and j, where lambda_i and -C lambda_j are eigenvalues of A - lambda * E. Hence, -C equation (2) is singular; perturbed values were -C used to solve the equation (but the matrices A and -C E are unchanged); -C = 4: DICO = 'C' and the pencil A - lambda * E has a -C degenerate pair of eigenvalues. That is, lambda_i = -C -lambda_j for some i and j, where lambda_i and -C lambda_j are eigenvalues of A - lambda * E. Hence, -C equation (1) is singular; perturbed values were -C used to solve the equation (but the matrices A and -C E are unchanged). -C -C METHOD -C -C A straightforward generalization [3] of the method proposed by -C Bartels and Stewart [1] is utilized to solve (1) or (2). -C -C First the pencil A - lambda * E is reduced to real generalized -C Schur form A_s - lambda * E_s by means of orthogonal -C transformations (QZ-algorithm): -C -C A_s = Q**T * A * Z (upper quasitriangular) (3) -C -C E_s = Q**T * E * Z (upper triangular). (4) -C -C If FACT = 'F', this step is omitted. Assuming SCALE = 1 and -C defining -C -C ( Z**T * Y * Z : TRANS = 'N' -C Y_s = < -C ( Q**T * Y * Q : TRANS = 'T' -C -C -C ( Q**T * X * Q if TRANS = 'N' -C X_s = < (5) -C ( Z**T * X * Z if TRANS = 'T' -C -C leads to the reduced Lyapunov equation -C -C T T -C op(A_s) X_s op(E_s) + op(E_s) X_s op(A_s) = Y_s, (6) -C -C or -C T T -C op(A_s) X_s op(A_s) - op(E_s) X_s op(E_s) = Y_s, (7) -C -C which are equivalent to (1) or (2), respectively. The solution X_s -C of (6) or (7) is computed via block back substitution (if TRANS = -C 'N') or block forward substitution (if TRANS = 'T'), where the -C block order is at most 2. (See [1] and [3] for details.) -C Equation (5) yields the solution matrix X. -C -C For fast computation the estimates of the separation and the -C forward error are gained from (6) or (7) rather than (1) or -C (2), respectively. We consider (6) and (7) as special cases of the -C generalized Sylvester equation -C -C R * X * S + U * X * V = Y, (8) -C -C whose separation is defined as follows -C -C sep = sep(R,S,U,V) = min || R * X * S + U * X * V || . -C ||X|| = 1 F -C F -C -C Equation (8) is equivalent to the system of linear equations -C -C K * vec(X) = (kron(S**T,R) + kron(V**T,U)) * vec(X) = vec(Y), -C -C where kron is the Kronecker product of two matrices and vec -C is the mapping that stacks the columns of a matrix. If K is -C nonsingular then -C -C sep = 1 / ||K**(-1)|| . -C 2 -C -C We estimate ||K**(-1)|| by a method devised by Higham [2]. Note -C that this method yields an estimation for the 1-norm but we use it -C as an approximation for the 2-norm. Estimates for the forward -C error norm are provided by -C -C FERR = 2 * EPS * ||A_s|| * ||E_s|| / sep -C F F -C -C in the continuous-time case (1) and -C -C FERR = EPS * ( ||A_s|| **2 + ||E_s|| **2 ) / sep -C F F -C -C in the discrete-time case (2). -C The reciprocal condition number, RCOND, of the Lyapunov equation -C can be estimated by FERR/EPS. -C -C REFERENCES -C -C [1] Bartels, R.H., Stewart, G.W. -C Solution of the equation A X + X B = C. -C Comm. A.C.M., 15, pp. 820-826, 1972. -C -C [2] Higham, N.J. -C FORTRAN codes for estimating the one-norm of a real or complex -C matrix, with applications to condition estimation. -C A.C.M. Trans. Math. Soft., vol. 14, no. 4, pp. 381-396, 1988. -C -C [3] Penzl, T. -C Numerical solution of generalized Lyapunov equations. -C Advances in Comp. Math., vol. 8, pp. 33-48, 1998. -C -C NUMERICAL ASPECTS -C -C The number of flops required by the routine is given by the -C following table. Note that we count a single floating point -C arithmetic operation as one flop. c is an integer number of modest -C size (say 4 or 5). -C -C | FACT = 'F' FACT = 'N' -C -----------+------------------------------------------ -C JOB = 'B' | (26+8*c)/3 * N**3 (224+8*c)/3 * N**3 -C JOB = 'S' | 8*c/3 * N**3 (198+8*c)/3 * N**3 -C JOB = 'X' | 26/3 * N**3 224/3 * N**3 -C -C The algorithm is backward stable if the eigenvalues of the pencil -C A - lambda * E are real. Otherwise, linear systems of order at -C most 4 are involved into the computation. These systems are solved -C by Gauss elimination with complete pivoting. The loss of stability -C of the Gauss elimination with complete pivoting is rarely -C encountered in practice. -C -C The Lyapunov equation may be very ill-conditioned. In particular, -C if DICO = 'D' and the pencil A - lambda * E has a pair of almost -C reciprocal eigenvalues, or DICO = 'C' and the pencil has an almost -C degenerate pair of eigenvalues, then the Lyapunov equation will be -C ill-conditioned. Perturbed values were used to solve the equation. -C Ill-conditioning can be detected by a very small value of the -C reciprocal condition number RCOND. -C -C CONTRIBUTOR -C -C T. Penzl, Technical University Chemnitz, Germany, Aug. 1998. -C -C REVISIONS -C -C Sep. 1998 (V. Sima). -C Dec. 1998 (V. Sima). -C -C KEYWORDS -C -C Lyapunov equation -C -C ****************************************************************** -C -C .. Parameters .. - DOUBLE PRECISION ONE, TWO, ZERO - PARAMETER ( ONE = 1.0D+0, TWO = 2.0D+0, ZERO = 0.0D+0 ) -C .. Scalar Arguments .. - CHARACTER DICO, FACT, JOB, TRANS, UPLO - DOUBLE PRECISION FERR, SCALE, SEP - INTEGER INFO, LDA, LDE, LDQ, LDWORK, LDX, LDZ, N -C .. Array Arguments .. - DOUBLE PRECISION A(LDA,*), ALPHAI(*), ALPHAR(*), BETA(*), - $ DWORK(*), E(LDE,*), Q(LDQ,*), X(LDX,*), - $ Z(LDZ,*) - INTEGER IWORK(*) -C .. Local Scalars .. - CHARACTER ETRANS - DOUBLE PRECISION EST, EPS, NORMA, NORME, SCALE1 - INTEGER I, INFO1, KASE, MINWRK, OPTWRK - LOGICAL ISDISC, ISFACT, ISTRAN, ISUPPR, WANTBH, WANTSP, - $ WANTX -C .. External Functions .. - DOUBLE PRECISION DLAMCH, DNRM2 - LOGICAL LSAME - EXTERNAL DLAMCH, DNRM2, LSAME -C .. External Subroutines .. - EXTERNAL DCOPY, DGEGS, DLACON, MB01RD, MB01RW, SG03AX, - $ SG03AY, XERBLA -C .. Intrinsic Functions .. - INTRINSIC DBLE, INT, MAX, MIN -C .. Executable Statements .. -C -C Decode input parameters. -C - ISDISC = LSAME( DICO, 'D' ) - WANTX = LSAME( JOB, 'X' ) - WANTSP = LSAME( JOB, 'S' ) - WANTBH = LSAME( JOB, 'B' ) - ISFACT = LSAME( FACT, 'F' ) - ISTRAN = LSAME( TRANS, 'T' ) - ISUPPR = LSAME( UPLO, 'U' ) -C -C Check the scalar input parameters. -C - IF ( .NOT.( ISDISC .OR. LSAME( DICO, 'C' ) ) ) THEN - INFO = -1 - ELSEIF ( .NOT.( WANTX .OR. WANTSP .OR. WANTBH ) ) THEN - INFO = -2 - ELSEIF ( .NOT.( ISFACT .OR. LSAME( FACT, 'N' ) ) ) THEN - INFO = -3 - ELSEIF ( .NOT.( ISTRAN .OR. LSAME( TRANS, 'N' ) ) ) THEN - INFO = -4 - ELSEIF ( .NOT.( ISUPPR .OR. LSAME( UPLO, 'L' ) ) ) THEN - INFO = -5 - ELSEIF ( N .LT. 0 ) THEN - INFO = -6 - ELSEIF ( LDA .LT. MAX( 1, N ) ) THEN - INFO = -8 - ELSEIF ( LDE .LT. MAX( 1, N ) ) THEN - INFO = -10 - ELSEIF ( LDQ .LT. MAX( 1, N ) ) THEN - INFO = -12 - ELSEIF ( LDZ .LT. MAX( 1, N ) ) THEN - INFO = -14 - ELSEIF ( LDX .LT. MAX( 1, N ) ) THEN - INFO = -16 - ELSE - INFO = 0 - END IF - IF ( INFO .EQ. 0 ) THEN -C -C Compute minimal workspace. -C - IF ( WANTX ) THEN - IF ( ISFACT ) THEN - MINWRK = MAX( N, 1 ) - ELSE - MINWRK = MAX( 4*N, 1 ) - END IF - ELSE - IF ( ISFACT ) THEN - MINWRK = MAX( 2*N*N, 1 ) - ELSE - MINWRK = MAX( 2*N*N, 4*N, 1 ) - END IF - END IF - IF ( MINWRK .GT. LDWORK ) THEN - INFO = -25 - END IF - END IF - IF ( INFO .NE. 0 ) THEN - CALL XERBLA( 'SG03AD', -INFO ) - RETURN - END IF -C -C Quick return if possible. -C - IF ( N .EQ. 0 ) THEN - SCALE = ONE - IF ( .NOT.WANTX ) SEP = ZERO - IF ( WANTBH ) FERR = ZERO - DWORK(1) = ONE - RETURN - END IF -C - IF ( ISFACT ) THEN -C -C Make sure the upper Hessenberg part of A is quasitriangular. -C - DO 20 I = 1, N-2 - IF ( A(I+1,I).NE.ZERO .AND. A(I+2,I+1).NE.ZERO ) THEN - INFO = 1 - RETURN - END IF - 20 CONTINUE - END IF -C - IF ( .NOT.ISFACT ) THEN -C -C Reduce A - lambda * E to generalized Schur form. -C -C A := Q**T * A * Z (upper quasitriangular) -C E := Q**T * E * Z (upper triangular) -C -C ( Workspace: >= MAX(1,4*N) ) -C - CALL DGEGS( 'Vectors', 'Vectors', N, A, LDA, E, LDE, ALPHAR, - $ ALPHAI, BETA, Q, LDQ, Z, LDZ, DWORK, LDWORK, - $ INFO1 ) - IF ( INFO1 .NE. 0 ) THEN - INFO = 2 - RETURN - END IF - OPTWRK = INT( DWORK(1) ) - ELSE - OPTWRK = MINWRK - END IF -C - IF ( WANTBH .OR. WANTX ) THEN -C -C Transform right hand side. -C -C X := Z**T * X * Z or X := Q**T * X * Q -C -C Use BLAS 3 if there is enough workspace. Otherwise, use BLAS 2. -C -C ( Workspace: >= N ) -C - IF ( LDWORK .LT. N*N ) THEN - IF ( ISTRAN ) THEN - CALL MB01RW( UPLO, 'Transpose', N, N, X, LDX, Q, LDQ, - $ DWORK, INFO1 ) - ELSE - CALL MB01RW( UPLO, 'Transpose', N, N, X, LDX, Z, LDZ, - $ DWORK, INFO1 ) - END IF - ELSE - IF ( ISTRAN ) THEN - CALL MB01RD( UPLO, 'Transpose', N, N, ZERO, ONE, X, LDX, - $ Q, LDQ, X, LDX, DWORK, LDWORK, INFO ) - ELSE - CALL MB01RD( UPLO, 'Transpose', N, N, ZERO, ONE, X, LDX, - $ Z, LDZ, X, LDX, DWORK, LDWORK, INFO ) - END IF - END IF - IF ( .NOT.ISUPPR ) THEN - DO 40 I = 1, N-1 - CALL DCOPY( N-I, X(I+1,I), 1, X(I,I+1), LDX ) - 40 CONTINUE - END IF - OPTWRK = MAX( OPTWRK, N*N ) -C -C Solve reduced generalized Lyapunov equation. -C - IF ( ISDISC ) THEN - CALL SG03AX( TRANS, N, A, LDA, E, LDE, X, LDX, SCALE, INFO1) - IF ( INFO1 .NE. 0 ) - $ INFO = 3 - ELSE - CALL SG03AY( TRANS, N, A, LDA, E, LDE, X, LDX, SCALE, INFO1) - IF ( INFO1 .NE. 0 ) - $ INFO = 4 - END IF -C -C Transform the solution matrix back. -C -C X := Q * X * Q**T or X := Z * X * Z**T. -C -C Use BLAS 3 if there is enough workspace. Otherwise, use BLAS 2. -C -C ( Workspace: >= N ) -C - IF ( LDWORK .LT. N*N ) THEN - IF ( ISTRAN ) THEN - CALL MB01RW( 'Upper', 'NoTranspose', N, N, X, LDX, Z, - $ LDZ, DWORK, INFO1 ) - ELSE - CALL MB01RW( 'Upper', 'NoTranspose', N, N, X, LDX, Q, - $ LDQ, DWORK, INFO1 ) - END IF - ELSE - IF ( ISTRAN ) THEN - CALL MB01RD( 'Upper', 'NoTranspose', N, N, ZERO, ONE, X, - $ LDX, Z, LDZ, X, LDX, DWORK, LDWORK, INFO ) - ELSE - CALL MB01RD( 'Upper', 'NoTranspose', N, N, ZERO, ONE, X, - $ LDX, Q, LDQ, X, LDX, DWORK, LDWORK, INFO ) - END IF - END IF - DO 60 I = 1, N-1 - CALL DCOPY( N-I, X(I,I+1), LDX, X(I+1,I), 1 ) - 60 CONTINUE - END IF -C - IF ( WANTBH .OR. WANTSP ) THEN -C -C Estimate the 1-norm of the inverse Kronecker product matrix -C belonging to the reduced generalized Lyapunov equation. -C -C ( Workspace: 2*N*N ) -C - EST = ZERO - KASE = 0 - 80 CONTINUE - CALL DLACON( N*N, DWORK(N*N+1), DWORK, IWORK, EST, KASE ) - IF ( KASE .NE. 0 ) THEN - IF ( ( KASE.EQ.1 .AND. .NOT.ISTRAN ) .OR. - $ ( KASE.NE.1 .AND. ISTRAN ) ) THEN - ETRANS = 'N' - ELSE - ETRANS = 'T' - END IF - IF ( ISDISC ) THEN - CALL SG03AX( ETRANS, N, A, LDA, E, LDE, DWORK, N, SCALE1, - $ INFO1 ) - IF ( INFO1 .NE. 0 ) - $ INFO = 3 - ELSE - CALL SG03AY( ETRANS, N, A, LDA, E, LDE, DWORK, N, SCALE1, - $ INFO1 ) - IF ( INFO1 .NE. 0 ) - $ INFO = 4 - END IF - GOTO 80 - END IF - SEP = SCALE1/EST - END IF -C -C Estimate the relative forward error. -C -C ( Workspace: 2*N ) -C - IF ( WANTBH ) THEN - EPS = DLAMCH( 'Precision' ) - DO 100 I = 1, N - DWORK(I) = DNRM2( MIN( I+1, N ), A(1,I), 1 ) - DWORK(N+I) = DNRM2( I, E(1,I), 1 ) - 100 CONTINUE - NORMA = DNRM2( N, DWORK, 1 ) - NORME = DNRM2( N, DWORK(N+1), 1 ) - IF ( ISDISC ) THEN - FERR = ( NORMA**2 + NORME**2 )*EPS/SEP - ELSE - FERR = TWO*NORMA*NORME*EPS/SEP - END IF - END IF -C - DWORK(1) = DBLE( MAX( OPTWRK, MINWRK ) ) - RETURN -C *** Last line of SG03AD *** - END diff --git a/mex/sources/libslicot/SG03AX.f b/mex/sources/libslicot/SG03AX.f deleted file mode 100644 index 872ed0282..000000000 --- a/mex/sources/libslicot/SG03AX.f +++ /dev/null @@ -1,687 +0,0 @@ - SUBROUTINE SG03AX( TRANS, N, A, LDA, E, LDE, X, LDX, SCALE, INFO ) -C -C SLICOT RELEASE 5.0. -C -C Copyright (c) 2002-2009 NICONET e.V. -C -C This program is free software: you can redistribute it and/or -C modify it under the terms of the GNU General Public License as -C published by the Free Software Foundation, either version 2 of -C the License, or (at your option) any later version. -C -C This program is distributed in the hope that it will be useful, -C but WITHOUT ANY WARRANTY; without even the implied warranty of -C MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the -C GNU General Public License for more details. -C -C You should have received a copy of the GNU General Public License -C along with this program. If not, see -C . -C -C PURPOSE -C -C To solve for X either the reduced generalized discrete-time -C Lyapunov equation -C -C T T -C A * X * A - E * X * E = SCALE * Y (1) -C -C or -C -C T T -C A * X * A - E * X * E = SCALE * Y (2) -C -C where the right hand side Y is symmetric. A, E, Y, and the -C solution X are N-by-N matrices. The pencil A - lambda * E must be -C in generalized Schur form (A upper quasitriangular, E upper -C triangular). SCALE is an output scale factor, set to avoid -C overflow in X. -C -C ARGUMENTS -C -C Mode Parameters -C -C TRANS CHARACTER*1 -C Specifies whether the transposed equation is to be solved -C or not: -C = 'N': Solve equation (1); -C = 'T': Solve equation (2). -C -C Input/Output Parameters -C -C N (input) INTEGER -C The order of the matrix A. N >= 0. -C -C A (input) DOUBLE PRECISION array, dimension (LDA,N) -C The leading N-by-N upper Hessenberg part of this array -C must contain the quasitriangular matrix A. -C -C LDA INTEGER -C The leading dimension of the array A. LDA >= MAX(1,N). -C -C E (input) DOUBLE PRECISION array, dimension (LDE,N) -C The leading N-by-N upper triangular part of this array -C must contain the matrix E. -C -C LDE INTEGER -C The leading dimension of the array E. LDE >= MAX(1,N). -C -C X (input/output) DOUBLE PRECISION array, dimension (LDX,N) -C On entry, the leading N-by-N part of this array must -C contain the right hand side matrix Y of the equation. Only -C the upper triangular part of this matrix need be given. -C On exit, the leading N-by-N part of this array contains -C the solution matrix X of the equation. -C -C LDX INTEGER -C The leading dimension of the array X. LDX >= MAX(1,N). -C -C SCALE (output) DOUBLE PRECISION -C The scale factor set to avoid overflow in X. -C (0 < SCALE <= 1) -C -C Error indicator -C -C INFO INTEGER -C = 0: successful exit; -C < 0: if INFO = -i, the i-th argument had an illegal -C value; -C = 1: equation is (almost) singular to working precision; -C perturbed values were used to solve the equation -C (but the matrices A and E are unchanged). -C -C METHOD -C -C The solution X of (1) or (2) is computed via block back -C substitution or block forward substitution, respectively. (See -C [1] and [2] for details.) -C -C REFERENCES -C -C [1] Bartels, R.H., Stewart, G.W. -C Solution of the equation A X + X B = C. -C Comm. A.C.M., 15, pp. 820-826, 1972. -C -C [2] Penzl, T. -C Numerical solution of generalized Lyapunov equations. -C Advances in Comp. Math., vol. 8, pp. 33-48, 1998. -C -C NUMERICAL ASPECTS -C -C 8/3 * N**3 flops are required by the routine. Note that we count a -C single floating point arithmetic operation as one flop. -C -C The algorithm is backward stable if the eigenvalues of the pencil -C A - lambda * E are real. Otherwise, linear systems of order at -C most 4 are involved into the computation. These systems are solved -C by Gauss elimination with complete pivoting. The loss of stability -C of the Gauss elimination with complete pivoting is rarely -C encountered in practice. -C -C CONTRIBUTOR -C -C T. Penzl, Technical University Chemnitz, Germany, Aug. 1998. -C -C REVISIONS -C -C Sep. 1998 (V. Sima). -C Dec. 1998 (V. Sima). -C -C KEYWORDS -C -C Lyapunov equation -C -C ****************************************************************** -C -C .. Parameters .. - DOUBLE PRECISION MONE, ONE, ZERO - PARAMETER ( MONE = -1.0D+0, ONE = 1.0D+0, ZERO = 0.0D+0 ) -C .. Scalar Arguments .. - CHARACTER TRANS - DOUBLE PRECISION SCALE - INTEGER INFO, LDA, LDE, LDX, N -C .. Array Arguments .. - DOUBLE PRECISION A(LDA,*), E(LDE,*), X(LDX,*) -C .. Local Scalars .. - DOUBLE PRECISION AK11, AK12, AK21, AK22, AL11, AL12, AL21, AL22, - $ EK11, EK12, EK22, EL11, EL12, EL22, SCALE1 - INTEGER DIMMAT, I, INFO1, KB, KH, KL, LB, LH, LL - LOGICAL NOTRNS -C .. Local Arrays .. - DOUBLE PRECISION MAT(4,4), RHS(4), TM(2,2) - INTEGER PIV1(4), PIV2(4) -C .. External Functions .. - LOGICAL LSAME - EXTERNAL LSAME -C .. External Subroutines .. - EXTERNAL DAXPY, DCOPY, DGEMM, DGEMV, DSCAL, MB02UU, - $ MB02UV, XERBLA -C .. Intrinsic Functions .. - INTRINSIC MAX -C .. Executable Statements .. -C -C Decode input parameter. -C - NOTRNS = LSAME( TRANS, 'N' ) -C -C Check the scalar input parameters. -C - IF ( .NOT.( NOTRNS .OR. LSAME( TRANS, 'T' ) ) ) THEN - INFO = -1 - ELSEIF ( N .LT. 0 ) THEN - INFO = -2 - ELSEIF ( LDA .LT. MAX( 1, N ) ) THEN - INFO = -4 - ELSEIF ( LDE .LT. MAX( 1, N ) ) THEN - INFO = -6 - ELSEIF ( LDX .LT. MAX( 1, N ) ) THEN - INFO = -8 - ELSE - INFO = 0 - END IF - IF ( INFO .NE. 0 ) THEN - CALL XERBLA( 'SG03AX', -INFO ) - RETURN - END IF -C - SCALE = ONE -C -C Quick return if possible. -C - IF ( N .EQ. 0 ) RETURN -C - IF ( NOTRNS ) THEN -C -C Solve equation (1). -C -C Outer Loop. Compute block row X(KL:KH,:). KB denotes the number -C of rows in this block row. -C - KL = 0 - KB = 1 -C WHILE ( KL+KB .LE. N ) DO - 20 IF ( KL+KB .LE. N ) THEN - KL = KL + KB - IF ( KL .EQ. N ) THEN - KB = 1 - ELSE - IF ( A(KL+1,KL) .NE. ZERO ) THEN - KB = 2 - ELSE - KB = 1 - END IF - END IF - KH = KL + KB - 1 -C -C Copy elements of solution already known by symmetry. -C -C X(KL:KH,1:KL-1) = X(1:KL-1,KL:KH)' -C - IF ( KL .GT. 1 ) THEN - DO 40 I = KL, KH - CALL DCOPY( KL-1, X(1,I), 1, X(I,1), LDX ) - 40 CONTINUE - END IF -C -C Inner Loop. Compute block X(KL:KH,LL:LH). LB denotes the -C number of columns in this block. -C - LL = KL - 1 - LB = 1 -C WHILE ( LL+LB .LE. N ) DO - 60 IF ( LL+LB .LE. N ) THEN - LL = LL + LB - IF ( LL .EQ. N ) THEN - LB = 1 - ELSE - IF ( A(LL+1,LL) .NE. ZERO ) THEN - LB = 2 - ELSE - LB = 1 - END IF - END IF - LH = LL + LB - 1 -C -C Update right hand sides (I). -C -C X(KL:LH,LL:LH) = X(KL:LH,LL:LH) - -C A(KL:KH,KL:LH)'*(X(KL:KH,1:LL-1)*A(1:LL-1,LL:LH)) -C -C X(KL:LH,LL:LH) = X(KL:LH,LL:LH) + -C E(KL:KH,KL:LH)'*(X(KL:KH,1:LL-1)*E(1:LL-1,LL:LH)) -C - IF ( LL .GT. 1 ) THEN - CALL DGEMM( 'N', 'N', KB, LB, LL-1, ONE, X(KL,1), LDX, - $ A(1,LL), LDA, ZERO, TM, 2 ) - CALL DGEMM( 'T', 'N', LH-KL+1, LB, KB, MONE, A(KL,KL), - $ LDA, TM, 2, ONE, X(KL,LL), LDX ) - CALL DGEMM( 'N', 'N', KB, LB, LL-1, ONE, X(KL,1), - $ LDX, E(1,LL), LDE, ZERO, TM, 2 ) - CALL DGEMM( 'T', 'N', LH-KH+1, LB, KB, ONE, E(KL,KH), - $ LDE, TM, 2, ONE, X(KH,LL), LDX ) - IF ( KB .EQ. 2 ) CALL DAXPY( LB, E(KL,KL), TM, 2, - $ X(KL,LL), LDX ) - END IF -C -C Solve small Sylvester equations of order at most (2,2). -C - IF ( KB.EQ.1 .AND. LB.EQ.1 ) THEN -C - DIMMAT = 1 -C - MAT(1,1) = A(LL,LL)*A(KL,KL) - E(LL,LL)*E(KL,KL) -C - RHS(1) = X(KL,LL) -C - ELSEIF ( KB.EQ.2 .AND. LB.EQ.1 ) THEN -C - DIMMAT = 2 -C - AK11 = A(KL,KL) - AK12 = A(KL,KH) - AK21 = A(KH,KL) - AK22 = A(KH,KH) -C - AL11 = A(LL,LL) -C - EK11 = E(KL,KL) - EK12 = E(KL,KH) - EK22 = E(KH,KH) -C - EL11 = E(LL,LL) -C - MAT(1,1) = AL11*AK11 - EL11*EK11 - MAT(1,2) = AL11*AK21 - MAT(2,1) = AL11*AK12 - EL11*EK12 - MAT(2,2) = AL11*AK22 - EL11*EK22 -C - RHS(1) = X(KL,LL) - RHS(2) = X(KH,LL) -C - ELSEIF ( KB.EQ.1 .AND. LB.EQ.2 ) THEN -C - DIMMAT = 2 -C - AK11 = A(KL,KL) -C - AL11 = A(LL,LL) - AL12 = A(LL,LH) - AL21 = A(LH,LL) - AL22 = A(LH,LH) -C - EK11 = E(KL,KL) -C - EL11 = E(LL,LL) - EL12 = E(LL,LH) - EL22 = E(LH,LH) -C - MAT(1,1) = AL11*AK11 - EL11*EK11 - MAT(1,2) = AL21*AK11 - MAT(2,1) = AL12*AK11 - EL12*EK11 - MAT(2,2) = AL22*AK11 - EL22*EK11 -C - RHS(1) = X(KL,LL) - RHS(2) = X(KL,LH) -C - ELSE -C - DIMMAT = 4 -C - AK11 = A(KL,KL) - AK12 = A(KL,KH) - AK21 = A(KH,KL) - AK22 = A(KH,KH) -C - AL11 = A(LL,LL) - AL12 = A(LL,LH) - AL21 = A(LH,LL) - AL22 = A(LH,LH) -C - EK11 = E(KL,KL) - EK12 = E(KL,KH) - EK22 = E(KH,KH) -C - EL11 = E(LL,LL) - EL12 = E(LL,LH) - EL22 = E(LH,LH) -C - MAT(1,1) = AL11*AK11 - EL11*EK11 - MAT(1,2) = AL11*AK21 - MAT(1,3) = AL21*AK11 - MAT(1,4) = AL21*AK21 -C - MAT(2,1) = AL11*AK12 - EL11*EK12 - MAT(2,2) = AL11*AK22 - EL11*EK22 - MAT(2,3) = AL21*AK12 - MAT(2,4) = AL21*AK22 -C - MAT(3,1) = AL12*AK11 - EL12*EK11 - MAT(3,2) = AL12*AK21 - MAT(3,3) = AL22*AK11 - EL22*EK11 - MAT(3,4) = AL22*AK21 -C - MAT(4,1) = AL12*AK12 - EL12*EK12 - MAT(4,2) = AL12*AK22 - EL12*EK22 - MAT(4,3) = AL22*AK12 - EL22*EK12 - MAT(4,4) = AL22*AK22 - EL22*EK22 -C - RHS(1) = X(KL,LL) - IF ( KL .EQ. LL ) THEN - RHS(2) = X(KL,KH) - ELSE - RHS(2) = X(KH,LL) - END IF - RHS(3) = X(KL,LH) - RHS(4) = X(KH,LH) -C - END IF -C - CALL MB02UV( DIMMAT, MAT, 4, PIV1, PIV2, INFO1 ) - IF ( INFO1 .NE. 0 ) - $ INFO = 1 - CALL MB02UU( DIMMAT, MAT, 4, RHS, PIV1, PIV2, SCALE1 ) -C -C Scaling. -C - IF ( SCALE1 .NE. ONE ) THEN - DO 80 I = 1, N - CALL DSCAL( N, SCALE1, X(1,I), 1 ) - 80 CONTINUE - SCALE = SCALE*SCALE1 - END IF -C - IF ( LB.EQ.1 .AND. KB.EQ.1 ) THEN - X(KL,LL) = RHS(1) - ELSEIF ( LB.EQ.1 .AND. KB.EQ.2 ) THEN - X(KL,LL) = RHS(1) - X(KH,LL) = RHS(2) - ELSEIF ( LB.EQ.2 .AND. KB.EQ.1 ) THEN - X(KL,LL) = RHS(1) - X(KL,LH) = RHS(2) - ELSE - X(KL,LL) = RHS(1) - X(KH,LL) = RHS(2) - X(KL,LH) = RHS(3) - X(KH,LH) = RHS(4) - END IF -C -C Update right hand sides (II). -C -C X(KH+1:LH,LL:LH) = X(KH+1:LH,LL:LH) - -C A(KL:KH,KH+1:LH)'*(X(KL:KH,LL:LH)*A(LL:LH,LL:LH)) -C -C X(KH+1:LH,LL:LH) = X(KH+1:LH,LL:LH) + -C E(KL:KH,KH+1:LH)'*(X(KL:KH,LL:LH)*E(LL:LH,LL:LH)) -C - IF ( KL .LT. LL ) THEN - CALL DGEMM( 'N', 'N', KB, LB, LB, ONE, X(KL,LL), LDX, - $ A(LL,LL), LDA, ZERO, TM, 2 ) - CALL DGEMM( 'T', 'N', LH-KH, LB, KB, MONE, A(KL,KH+1), - $ LDA, TM, 2, ONE, X(KH+1,LL), LDX ) - IF ( LB .EQ. 2 ) THEN - CALL DCOPY( KB, X(KL,LL), 1, TM, 1 ) - CALL DSCAL( KB, E(LL,LL), TM, 1 ) - END IF - CALL DGEMV( 'N', KB, LB, ONE, X(KL,LL), LDX, E(LL,LH), - $ 1, ZERO, TM(1,LB), 1 ) - CALL DGEMM( 'T', 'N', LH-KH, LB, KB, ONE, E(KL,KH+1), - $ LDE, TM, 2, ONE, X(KH+1,LL), LDX ) - END IF -C - GOTO 60 - END IF -C END WHILE 60 -C - GOTO 20 - END IF -C END WHILE 20 -C - ELSE -C -C Solve equation (2). -C -C Outer Loop. Compute block column X(:,LL:LH). LB denotes the -C number of columns in this block column. -C - LL = N + 1 -C WHILE ( LL .GT. 1 ) DO - 100 IF ( LL .GT. 1 ) THEN - LH = LL - 1 - IF ( LH .EQ. 1 ) THEN - LB = 1 - ELSE - IF ( A(LL-1,LL-2) .NE. ZERO ) THEN - LB = 2 - ELSE - LB = 1 - END IF - END IF - LL = LL - LB -C -C Copy elements of solution already known by symmetry. -C -C X(LH+1:N,LL:LH) = X(LL:LH,LH+1:N)' -C - IF ( LH .LT. N ) THEN - DO 120 I = LL, LH - CALL DCOPY( N-LH, X(I,LH+1), LDX, X(LH+1,I), 1 ) - 120 CONTINUE - END IF -C -C Inner Loop. Compute block X(KL:KH,LL:LH). KB denotes the -C number of rows in this block. -C - KL = LH + 1 -C WHILE ( KL .GT. 1 ) DO - 140 IF ( KL .GT. 1 ) THEN - KH = KL - 1 - IF ( KH .EQ. 1 ) THEN - KB = 1 - ELSE - IF ( A(KL-1,KL-2) .NE. ZERO ) THEN - KB =2 - ELSE - KB = 1 - END IF - END IF - KL = KL - KB -C -C Update right hand sides (I). -C -C X(KL:KH,KL:LH) = X(KL:KH,KL:LH) - -C (A(KL:KH,KH+1:N)*X(KH+1:N,LL:LH))*A(KL:LH,LL:LH)' -C -C X(KL:KH,KL:LH) = X(KL:KH,KL:LH) + -C (E(KL:KH,KH+1:N)*X(KH+1:N,LL:LH))*E(KL:LH,LL:LH)' -C - IF ( KH .LT. N ) THEN - CALL DGEMM( 'N', 'N', KB, LB, N-KH, ONE, A(KL,KH+1), - $ LDA, X(KH+1,LL), LDX, ZERO, TM, 2 ) - CALL DGEMM( 'N', 'T', KB, LH-KL+1, LB, MONE, TM, 2, - $ A(KL,LL), LDA, ONE, X(KL,KL), LDX ) - CALL DGEMM( 'N', 'N', KB, LB, N-KH, ONE, E(KL,KH+1), - $ LDE, X(KH+1,LL), LDX, ZERO, TM, 2 ) - CALL DGEMM( 'N', 'T', KB, LL-KL+1, LB, ONE, TM, 2, - $ E(KL,LL), LDE, ONE, X(KL,KL), LDX ) - IF ( LB .EQ. 2 ) CALL DAXPY( KB, E(LH,LH), TM(1,2), 1, - $ X(KL,LH), 1 ) - END IF -C -C Solve small Sylvester equations of order at most (2,2). -C - IF ( KB.EQ.1 .AND. LB.EQ.1 ) THEN -C - DIMMAT = 1 -C - MAT(1,1) = A(LL,LL)*A(KL,KL) - E(LL,LL)*E(KL,KL) -C - RHS(1) = X(KL,LL) -C - ELSEIF ( KB.EQ.2 .AND. LB.EQ.1 ) THEN -C - DIMMAT = 2 -C - AK11 = A(KL,KL) - AK12 = A(KL,KH) - AK21 = A(KH,KL) - AK22 = A(KH,KH) -C - AL11 = A(LL,LL) -C - EK11 = E(KL,KL) - EK12 = E(KL,KH) - EK22 = E(KH,KH) -C - EL11 = E(LL,LL) -C - MAT(1,1) = AL11*AK11 - EL11*EK11 - MAT(1,2) = AL11*AK12 - EL11*EK12 - MAT(2,1) = AL11*AK21 - MAT(2,2) = AL11*AK22 - EL11*EK22 -C - RHS(1) = X(KL,LL) - RHS(2) = X(KH,LL) -C - ELSEIF ( KB.EQ.1 .AND. LB.EQ.2 ) THEN -C - DIMMAT = 2 -C - AK11 = A(KL,KL) -C - AL11 = A(LL,LL) - AL12 = A(LL,LH) - AL21 = A(LH,LL) - AL22 = A(LH,LH) -C - EK11 = E(KL,KL) -C - EL11 = E(LL,LL) - EL12 = E(LL,LH) - EL22 = E(LH,LH) -C - MAT(1,1) = AL11*AK11 - EL11*EK11 - MAT(1,2) = AL12*AK11 - EL12*EK11 - MAT(2,1) = AL21*AK11 - MAT(2,2) = AL22*AK11 - EL22*EK11 -C - RHS(1) = X(KL,LL) - RHS(2) = X(KL,LH) -C - ELSE -C - DIMMAT = 4 -C - AK11 = A(KL,KL) - AK12 = A(KL,KH) - AK21 = A(KH,KL) - AK22 = A(KH,KH) -C - AL11 = A(LL,LL) - AL12 = A(LL,LH) - AL21 = A(LH,LL) - AL22 = A(LH,LH) -C - EK11 = E(KL,KL) - EK12 = E(KL,KH) - EK22 = E(KH,KH) -C - EL11 = E(LL,LL) - EL12 = E(LL,LH) - EL22 = E(LH,LH) -C - MAT(1,1) = AL11*AK11 - EL11*EK11 - MAT(1,2) = AL11*AK12 - EL11*EK12 - MAT(1,3) = AL12*AK11 - EL12*EK11 - MAT(1,4) = AL12*AK12 - EL12*EK12 -C - MAT(2,1) = AL11*AK21 - MAT(2,2) = AL11*AK22 - EL11*EK22 - MAT(2,3) = AL12*AK21 - MAT(2,4) = AL12*AK22 - EL12*EK22 -C - MAT(3,1) = AL21*AK11 - MAT(3,2) = AL21*AK12 - MAT(3,3) = AL22*AK11 - EL22*EK11 - MAT(3,4) = AL22*AK12 - EL22*EK12 -C - MAT(4,1) = AL21*AK21 - MAT(4,2) = AL21*AK22 - MAT(4,3) = AL22*AK21 - MAT(4,4) = AL22*AK22 - EL22*EK22 -C - RHS(1) = X(KL,LL) - IF ( KL .EQ. LL ) THEN - RHS(2) = X(KL,KH) - ELSE - RHS(2) = X(KH,LL) - END IF - RHS(3) = X(KL,LH) - RHS(4) = X(KH,LH) -C - END IF -C - CALL MB02UV( DIMMAT, MAT, 4, PIV1, PIV2, INFO1 ) - IF ( INFO1 .NE. 0 ) - $ INFO = 1 - CALL MB02UU( DIMMAT, MAT, 4, RHS, PIV1, PIV2, SCALE1 ) -C -C Scaling. -C - IF ( SCALE1 .NE. ONE ) THEN - DO 160 I = 1, N - CALL DSCAL( N, SCALE1, X(1,I), 1 ) - 160 CONTINUE - SCALE = SCALE*SCALE1 - END IF -C - IF ( LB.EQ.1 .AND. KB.EQ.1 ) THEN - X(KL,LL) = RHS(1) - ELSEIF ( LB.EQ.1 .AND. KB.EQ.2 ) THEN - X(KL,LL) = RHS(1) - X(KH,LL) = RHS(2) - ELSEIF ( LB.EQ.2 .AND. KB.EQ.1 ) THEN - X(KL,LL) = RHS(1) - X(KL,LH) = RHS(2) - ELSE - X(KL,LL) = RHS(1) - X(KH,LL) = RHS(2) - X(KL,LH) = RHS(3) - X(KH,LH) = RHS(4) - END IF -C -C Update right hand sides (II). -C -C X(KL:KH,KL:LL-1) = X(KL:KH,KL:LL-1) - -C (A(KL:KH,KL:KH)*X(KL:KH,LL:LH))*A(KL:LL-1,LL:LH)' -C -C X(KL:KH,KL:LL-1) = X(KL:KH,KL:LL-1) + -C (E(KL:KH,KL:KH)*X(KL:KH,LL:LH))*E(KL:LL-1,LL:LH)' -C - IF ( KL .LT. LL ) THEN - CALL DGEMM( 'N', 'N', KB, LB, KB, ONE, A(KL,KL), LDA, - $ X(KL,LL), LDX, ZERO, TM, 2 ) - CALL DGEMM( 'N', 'T', KB, LL-KL, LB, MONE, TM, 2, - $ A(KL,LL), LDA, ONE, X(KL,KL), LDX ) - CALL DGEMV( 'T', KB, LB, ONE, X(KL,LL), LDX, E(KL,KL), - $ LDE, ZERO, TM, 2 ) - IF ( KB .EQ. 2 ) THEN - CALL DCOPY( LB, X(KH,LL), LDX, TM(2,1), 2 ) - CALL DSCAL( LB, E(KH,KH), TM(2,1), 2 ) - END IF - CALL DGEMM( 'N', 'T', KB, LL-KL, LB, ONE, TM, 2, - $ E(KL,LL), LDE, ONE, X(KL,KL), LDX ) - END IF -C - GOTO 140 - END IF -C END WHILE 140 -C - GOTO 100 - END IF -C END WHILE 100 -C - END IF -C - RETURN -C *** Last line of SG03AX *** - END diff --git a/mex/sources/libslicot/SG03AY.f b/mex/sources/libslicot/SG03AY.f deleted file mode 100644 index 4f2dfe5ab..000000000 --- a/mex/sources/libslicot/SG03AY.f +++ /dev/null @@ -1,686 +0,0 @@ - SUBROUTINE SG03AY( TRANS, N, A, LDA, E, LDE, X, LDX, SCALE, INFO ) -C -C SLICOT RELEASE 5.0. -C -C Copyright (c) 2002-2009 NICONET e.V. -C -C This program is free software: you can redistribute it and/or -C modify it under the terms of the GNU General Public License as -C published by the Free Software Foundation, either version 2 of -C the License, or (at your option) any later version. -C -C This program is distributed in the hope that it will be useful, -C but WITHOUT ANY WARRANTY; without even the implied warranty of -C MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the -C GNU General Public License for more details. -C -C You should have received a copy of the GNU General Public License -C along with this program. If not, see -C . -C -C PURPOSE -C -C To solve for X either the reduced generalized continuous-time -C Lyapunov equation -C -C T T -C A * X * E + E * X * A = SCALE * Y (1) -C -C or -C -C T T -C A * X * E + E * X * A = SCALE * Y (2) -C -C where the right hand side Y is symmetric. A, E, Y, and the -C solution X are N-by-N matrices. The pencil A - lambda * E must be -C in generalized Schur form (A upper quasitriangular, E upper -C triangular). SCALE is an output scale factor, set to avoid -C overflow in X. -C -C ARGUMENTS -C -C Mode Parameters -C -C TRANS CHARACTER*1 -C Specifies whether the transposed equation is to be solved -C or not: -C = 'N': Solve equation (1); -C = 'T': Solve equation (2). -C -C Input/Output Parameters -C -C N (input) INTEGER -C The order of the matrix A. N >= 0. -C -C A (input) DOUBLE PRECISION array, dimension (LDA,N) -C The leading N-by-N upper Hessenberg part of this array -C must contain the quasitriangular matrix A. -C -C LDA INTEGER -C The leading dimension of the array A. LDA >= MAX(1,N). -C -C E (input) DOUBLE PRECISION array, dimension (LDE,N) -C The leading N-by-N upper triangular part of this array -C must contain the matrix E. -C -C LDE INTEGER -C The leading dimension of the array E. LDE >= MAX(1,N). -C -C X (input/output) DOUBLE PRECISION array, dimension (LDX,N) -C On entry, the leading N-by-N part of this array must -C contain the right hand side matrix Y of the equation. Only -C the upper triangular part of this matrix need be given. -C On exit, the leading N-by-N part of this array contains -C the solution matrix X of the equation. -C -C LDX INTEGER -C The leading dimension of the array X. LDX >= MAX(1,N). -C -C SCALE (output) DOUBLE PRECISION -C The scale factor set to avoid overflow in X. -C (0 < SCALE <= 1) -C -C Error indicator -C -C INFO INTEGER -C = 0: successful exit; -C < 0: if INFO = -i, the i-th argument had an illegal -C value; -C = 1: equation is (almost) singular to working precision; -C perturbed values were used to solve the equation -C (but the matrices A and E are unchanged). -C -C METHOD -C -C The solution X of (1) or (2) is computed via block back -C substitution or block forward substitution, respectively. (See -C [1] and [2] for details.) -C -C REFERENCES -C -C [1] Bartels, R.H., Stewart, G.W. -C Solution of the equation A X + X B = C. -C Comm. A.C.M., 15, pp. 820-826, 1972. -C -C [2] Penzl, T. -C Numerical solution of generalized Lyapunov equations. -C Advances in Comp. Math., vol. 8, pp. 33-48, 1998. -C -C NUMERICAL ASPECTS -C -C 8/3 * N**3 flops are required by the routine. Note that we count a -C single floating point arithmetic operation as one flop. -C -C The algorithm is backward stable if the eigenvalues of the pencil -C A - lambda * E are real. Otherwise, linear systems of order at -C most 4 are involved into the computation. These systems are solved -C by Gauss elimination with complete pivoting. The loss of stability -C of the Gauss elimination with complete pivoting is rarely -C encountered in practice. -C -C CONTRIBUTOR -C -C T. Penzl, Technical University Chemnitz, Germany, Aug. 1998. -C -C REVISIONS -C -C Sep. 1998 (V. Sima). -C Dec. 1998 (V. Sima). -C -C KEYWORDS -C -C Lyapunov equation -C -C ****************************************************************** -C -C .. Parameters .. - DOUBLE PRECISION MONE, ONE, ZERO - PARAMETER ( MONE = -1.0D+0, ONE = 1.0D+0, ZERO = 0.0D+0 ) -C .. Scalar Arguments .. - CHARACTER TRANS - DOUBLE PRECISION SCALE - INTEGER INFO, LDA, LDE, LDX, N -C .. Array Arguments .. - DOUBLE PRECISION A(LDA,*), E(LDE,*), X(LDX,*) -C .. Local Scalars .. - INTEGER DIMMAT, I, INFO1, KB, KH, KL, LB, LH, LL - DOUBLE PRECISION AK11, AK12, AK21, AK22, AL11, AL12, AL21, AL22, - $ EK11, EK12, EK22, EL11, EL12, EL22, SCALE1 - LOGICAL NOTRNS -C .. Local Arrays .. - DOUBLE PRECISION MAT(4,4), RHS(4), TM(2,2) - INTEGER PIV1(4), PIV2(4) -C .. External Functions .. - LOGICAL LSAME - EXTERNAL LSAME -C .. External Subroutines .. - EXTERNAL DAXPY, DCOPY, DGEMM, DGEMV, DSCAL, MB02UU, - $ MB02UV, XERBLA -C .. Intrinsic Functions .. - INTRINSIC MAX -C .. Executable Statements .. -C -C Decode input parameters. -C - NOTRNS = LSAME( TRANS, 'N' ) -C -C Check the scalar input parameters. -C - IF ( .NOT.( NOTRNS .OR. LSAME( TRANS, 'T' ) ) ) THEN - INFO = -1 - ELSEIF ( N .LT. 0 ) THEN - INFO = -2 - ELSEIF ( LDA .LT. MAX( 1, N ) ) THEN - INFO = -4 - ELSEIF ( LDE .LT. MAX( 1, N ) ) THEN - INFO = -6 - ELSEIF ( LDX .LT. MAX( 1, N ) ) THEN - INFO = -8 - ELSE - INFO = 0 - END IF - IF ( INFO .NE. 0 ) THEN - CALL XERBLA( 'SG03AY', -INFO ) - RETURN - END IF -C - SCALE = ONE -C -C Quick return if possible. -C - IF ( N .EQ. 0 ) RETURN -C - IF ( NOTRNS ) THEN -C -C Solve equation (1). -C -C Outer Loop. Compute block row X(KL:KH,:). KB denotes the number -C of rows in this block row. -C - KL = 0 - KB = 1 -C WHILE ( KL+KB .LE. N ) DO - 20 IF ( KL+KB .LE. N ) THEN - KL = KL + KB - IF ( KL .EQ. N ) THEN - KB = 1 - ELSE - IF ( A(KL+1,KL) .NE. ZERO ) THEN - KB = 2 - ELSE - KB = 1 - END IF - END IF - KH = KL + KB - 1 -C -C Copy elements of solution already known by symmetry. -C -C X(KL:KH,1:KL-1) = X(1:KL-1,KL:KH)' -C - IF ( KL .GT. 1 ) THEN - DO 40 I = KL, KH - CALL DCOPY( KL-1, X(1,I), 1, X(I,1), LDX ) - 40 CONTINUE - END IF -C -C Inner Loop. Compute block X(KL:KH,LL:LH). LB denotes the -C number of columns in this block. -C - LL = KL - 1 - LB = 1 -C WHILE ( LL+LB .LE. N ) DO - 60 IF ( LL+LB .LE. N ) THEN - LL = LL + LB - IF ( LL .EQ. N ) THEN - LB = 1 - ELSE - IF ( A(LL+1,LL) .NE. ZERO ) THEN - LB = 2 - ELSE - LB = 1 - END IF - END IF - LH = LL + LB - 1 -C -C Update right hand sides (I). -C -C X(KL:LH,LL:LH) = X(KL:LH,LL:LH) - -C A(KL:KH,KL:LH)'*(X(KL:KH,1:LL-1)*E(1:LL-1,LL:LH)) -C -C X(KL:LH,LL:LH) = X(KL:LH,LL:LH) - -C E(KL:KH,KL:LH)'*(X(KL:KH,1:LL-1)*A(1:LL-1,LL:LH)) -C - IF ( LL .GT. 1 ) THEN - CALL DGEMM( 'N', 'N', KB, LB, LL-1, ONE, X(KL,1), LDX, - $ E(1,LL), LDE, ZERO, TM, 2 ) - CALL DGEMM( 'T', 'N', LH-KL+1, LB, KB, MONE, A(KL,KL), - $ LDA, TM, 2, ONE, X(KL,LL), LDX ) - CALL DGEMM( 'N', 'N', KB, LB, LL-1, ONE, X(KL,1), LDX, - $ A(1,LL), LDA, ZERO, TM, 2 ) - CALL DGEMM( 'T', 'N', LH-KH+1, LB, KB, MONE, E(KL,KH), - $ LDE, TM, 2, ONE, X(KH,LL), LDX ) - IF ( KB .EQ. 2 ) CALL DAXPY( LB, -E(KL,KL), TM, 2, - $ X(KL,LL), LDX ) - END IF -C -C Solve small Sylvester equations of order at most (2,2). -C - IF ( KB.EQ.1 .AND. LB.EQ.1 ) THEN -C - DIMMAT = 1 -C - MAT(1,1) = E(LL,LL)*A(KL,KL) + A(LL,LL)*E(KL,KL) -C - RHS(1) = X(KL,LL) -C - ELSEIF ( KB.EQ.2 .AND. LB.EQ.1 ) THEN -C - DIMMAT = 2 -C - AK11 = A(KL,KL) - AK12 = A(KL,KH) - AK21 = A(KH,KL) - AK22 = A(KH,KH) -C - AL11 = A(LL,LL) -C - EK11 = E(KL,KL) - EK12 = E(KL,KH) - EK22 = E(KH,KH) -C - EL11 = E(LL,LL) -C - MAT(1,1) = EL11*AK11 + AL11*EK11 - MAT(1,2) = EL11*AK21 - MAT(2,1) = EL11*AK12 + AL11*EK12 - MAT(2,2) = EL11*AK22 + AL11*EK22 -C - RHS(1) = X(KL,LL) - RHS(2) = X(KH,LL) -C - ELSEIF ( KB.EQ.1 .AND. LB.EQ.2 ) THEN -C - DIMMAT = 2 -C - AK11 = A(KL,KL) -C - AL11 = A(LL,LL) - AL12 = A(LL,LH) - AL21 = A(LH,LL) - AL22 = A(LH,LH) -C - EK11 = E(KL,KL) -C - EL11 = E(LL,LL) - EL12 = E(LL,LH) - EL22 = E(LH,LH) -C - MAT(1,1) = EL11*AK11 + AL11*EK11 - MAT(1,2) = AL21*EK11 - MAT(2,1) = EL12*AK11 + AL12*EK11 - MAT(2,2) = EL22*AK11 + AL22*EK11 -C - RHS(1) = X(KL,LL) - RHS(2) = X(KL,LH) -C - ELSE -C - DIMMAT = 4 -C - AK11 = A(KL,KL) - AK12 = A(KL,KH) - AK21 = A(KH,KL) - AK22 = A(KH,KH) -C - AL11 = A(LL,LL) - AL12 = A(LL,LH) - AL21 = A(LH,LL) - AL22 = A(LH,LH) -C - EK11 = E(KL,KL) - EK12 = E(KL,KH) - EK22 = E(KH,KH) -C - EL11 = E(LL,LL) - EL12 = E(LL,LH) - EL22 = E(LH,LH) -C - MAT(1,1) = EL11*AK11 + AL11*EK11 - MAT(1,2) = EL11*AK21 - MAT(1,3) = AL21*EK11 - MAT(1,4) = ZERO -C - MAT(2,1) = EL11*AK12 + AL11*EK12 - MAT(2,2) = EL11*AK22 + AL11*EK22 - MAT(2,3) = AL21*EK12 - MAT(2,4) = AL21*EK22 -C - MAT(3,1) = EL12*AK11 + AL12*EK11 - MAT(3,2) = EL12*AK21 - MAT(3,3) = EL22*AK11 + AL22*EK11 - MAT(3,4) = EL22*AK21 -C - MAT(4,1) = EL12*AK12 + AL12*EK12 - MAT(4,2) = EL12*AK22 + AL12*EK22 - MAT(4,3) = EL22*AK12 + AL22*EK12 - MAT(4,4) = EL22*AK22 + AL22*EK22 -C - RHS(1) = X(KL,LL) - IF ( KL .EQ. LL ) THEN - RHS(2) = X(KL,KH) - ELSE - RHS(2) = X(KH,LL) - END IF - RHS(3) = X(KL,LH) - RHS(4) = X(KH,LH) -C - END IF -C - CALL MB02UV( DIMMAT, MAT, 4, PIV1, PIV2, INFO1 ) - IF ( INFO1 .NE. 0 ) - $ INFO = 1 - CALL MB02UU( DIMMAT, MAT, 4, RHS, PIV1, PIV2, SCALE1 ) -C -C Scaling. -C - IF ( SCALE1 .NE. ONE ) THEN - DO 80 I = 1, N - CALL DSCAL( N, SCALE1, X(1,I), 1 ) - 80 CONTINUE - SCALE = SCALE*SCALE1 - END IF -C - IF ( LB.EQ.1 .AND. KB.EQ.1 ) THEN - X(KL,LL) = RHS(1) - ELSEIF ( LB.EQ.1 .AND. KB.EQ.2 ) THEN - X(KL,LL) = RHS(1) - X(KH,LL) = RHS(2) - ELSEIF ( LB.EQ.2 .AND. KB.EQ.1 ) THEN - X(KL,LL) = RHS(1) - X(KL,LH) = RHS(2) - ELSE - X(KL,LL) = RHS(1) - X(KH,LL) = RHS(2) - X(KL,LH) = RHS(3) - X(KH,LH) = RHS(4) - END IF -C -C Update right hand sides (II). -C -C X(KH+1:LH,LL:LH) = X(KH+1:LH,LL:LH) - -C A(KL:KH,KH+1:LH)'*(X(KL:KH,LL:LH)*E(LL:LH,LL:LH)) -C -C X(KH+1:LH,LL:LH) = X(KH+1:LH,LL:LH) - -C E(KL:KH,KH+1:LH)'*(X(KL:KH,LL:LH)*A(LL:LH,LL:LH)) -C - IF ( KL .LT. LL ) THEN - IF ( LB .EQ. 2 ) - $ CALL DGEMV( 'N', KB, 2, ONE, X(KL,LL), LDX, - $ E(LL,LH), 1, ZERO, TM(1,2), 1 ) - CALL DCOPY( KB, X(KL,LL), 1, TM, 1 ) - CALL DSCAL( KB, E(LL,LL), TM, 1 ) - CALL DGEMM( 'T', 'N', LH-KH, LB, KB, MONE, A(KL,KH+1), - $ LDA, TM, 2, ONE, X(KH+1,LL), LDX ) - CALL DGEMM( 'N', 'N', KB, LB, LB, ONE, X(KL,LL), LDX, - $ A(LL,LL), LDA, ZERO, TM, 2 ) - CALL DGEMM( 'T', 'N', LH-KH, LB, KB, MONE, E(KL,KH+1), - $ LDE, TM, 2, ONE, X(KH+1,LL), LDX ) - END IF -C - GOTO 60 - END IF -C END WHILE 60 -C - GOTO 20 - END IF -C END WHILE 20 -C - ELSE -C -C Solve equation (2). -C -C Outer Loop. Compute block column X(:,LL:LH). LB denotes the -C number of columns in this block column. -C - LL = N + 1 -C WHILE ( LL .GT. 1 ) DO - 100 IF ( LL .GT. 1 ) THEN - LH = LL - 1 - IF ( LH .EQ. 1 ) THEN - LB = 1 - ELSE - IF ( A(LL-1,LL-2) .NE. ZERO ) THEN - LB = 2 - ELSE - LB = 1 - END IF - END IF - LL = LL - LB -C -C Copy elements of solution already known by symmetry. -C -C X(LH+1:N,LL:LH) = X(LL:LH,LH+1:N)' -C - IF ( LH .LT. N ) THEN - DO 120 I = LL, LH - CALL DCOPY( N-LH, X(I,LH+1), LDX, X(LH+1,I), 1 ) - 120 CONTINUE - END IF -C -C Inner Loop. Compute block X(KL:KH,LL:LH). KB denotes the -C number of rows in this block. -C - KL = LH + 1 -C WHILE ( KL .GT. 1 ) DO - 140 IF ( KL .GT. 1 ) THEN - KH = KL - 1 - IF ( KH .EQ. 1 ) THEN - KB = 1 - ELSE - IF ( A(KL-1,KL-2) .NE. ZERO ) THEN - KB = 2 - ELSE - KB = 1 - END IF - END IF - KL = KL - KB -C -C Update right hand sides (I). -C -C X(KL:KH,KL:LH) = X(KL:KH,KL:LH) - -C (A(KL:KH,KH+1:N)*X(KH+1:N,LL:LH))*E(KL:LH,LL:LH)' -C -C X(KL:KH,KL:LH) = X(KL:KH,KL:LH) - -C (E(KL:KH,KH+1:N)*X(KH+1:N,LL:LH))*A(KL:LH,LL:LH)' -C - IF ( KH .LT. N ) THEN - CALL DGEMM( 'N', 'N', KB, LB, N-KH, ONE, A(KL,KH+1), - $ LDA, X(KH+1,LL), LDX, ZERO, TM, 2 ) - CALL DGEMM( 'N', 'T', KB, LL-KL+1, LB, MONE, TM, 2, - $ E(KL,LL), LDE, ONE, X(KL,KL), LDX ) - IF ( LB .EQ. 2 ) CALL DAXPY( KB, -E(LH,LH), TM(1,2), - $ 1, X(KL,LH), 1 ) - CALL DGEMM( 'N', 'N', KB, LB, N-KH, ONE, E(KL,KH+1), - $ LDE, X(KH+1,LL), LDX, ZERO, TM, 2 ) - CALL DGEMM( 'N', 'T', KB, LH-KL+1, LB, MONE, TM, 2, - $ A(KL,LL), LDA, ONE, X(KL,KL), LDX ) - END IF -C -C Solve small Sylvester equations of order at most (2,2). -C - IF ( KB.EQ.1 .AND. LB.EQ.1 ) THEN -C - DIMMAT = 1 -C - MAT(1,1) = E(LL,LL)*A(KL,KL) + A(LL,LL)*E(KL,KL) -C - RHS(1) = X(KL,LL) -C - ELSEIF ( KB.EQ.2 .AND. LB.EQ.1 ) THEN -C - DIMMAT = 2 -C - AK11 = A(KL,KL) - AK12 = A(KL,KH) - AK21 = A(KH,KL) - AK22 = A(KH,KH) -C - AL11 = A(LL,LL) -C - EK11 = E(KL,KL) - EK12 = E(KL,KH) - EK22 = E(KH,KH) -C - EL11 = E(LL,LL) -C - MAT(1,1) = EL11*AK11 + AL11*EK11 - MAT(1,2) = EL11*AK12 + AL11*EK12 - MAT(2,1) = EL11*AK21 - MAT(2,2) = EL11*AK22 + AL11*EK22 -C - RHS(1) = X(KL,LL) - RHS(2) = X(KH,LL) -C - ELSEIF ( KB.EQ.1 .AND. LB.EQ.2 ) THEN -C - DIMMAT = 2 -C - AK11 = A(KL,KL) -C - AL11 = A(LL,LL) - AL12 = A(LL,LH) - AL21 = A(LH,LL) - AL22 = A(LH,LH) -C - EK11 = E(KL,KL) -C - EL11 = E(LL,LL) - EL12 = E(LL,LH) - EL22 = E(LH,LH) -C - MAT(1,1) = EL11*AK11 + AL11*EK11 - MAT(1,2) = EL12*AK11 + AL12*EK11 - MAT(2,1) = AL21*EK11 - MAT(2,2) = EL22*AK11 + AL22*EK11 -C - RHS(1) = X(KL,LL) - RHS(2) = X(KL,LH) -C - ELSE -C - DIMMAT = 4 -C - AK11 = A(KL,KL) - AK12 = A(KL,KH) - AK21 = A(KH,KL) - AK22 = A(KH,KH) -C - AL11 = A(LL,LL) - AL12 = A(LL,LH) - AL21 = A(LH,LL) - AL22 = A(LH,LH) -C - EK11 = E(KL,KL) - EK12 = E(KL,KH) - EK22 = E(KH,KH) -C - EL11 = E(LL,LL) - EL12 = E(LL,LH) - EL22 = E(LH,LH) -C - MAT(1,1) = EL11*AK11 + AL11*EK11 - MAT(1,2) = EL11*AK12 + AL11*EK12 - MAT(1,3) = EL12*AK11 + AL12*EK11 - MAT(1,4) = EL12*AK12 + AL12*EK12 -C - MAT(2,1) = EL11*AK21 - MAT(2,2) = EL11*AK22 + AL11*EK22 - MAT(2,3) = EL12*AK21 - MAT(2,4) = EL12*AK22 + AL12*EK22 -C - MAT(3,1) = AL21*EK11 - MAT(3,2) = AL21*EK12 - MAT(3,3) = EL22*AK11 + AL22*EK11 - MAT(3,4) = EL22*AK12 + AL22*EK12 -C - MAT(4,1) = ZERO - MAT(4,2) = AL21*EK22 - MAT(4,3) = EL22*AK21 - MAT(4,4) = EL22*AK22 + AL22*EK22 -C - RHS(1) = X(KL,LL) - IF ( KL .EQ. LL ) THEN - RHS(2) = X(KL,KH) - ELSE - RHS(2) = X(KH,LL) - END IF - RHS(3) = X(KL,LH) - RHS(4) = X(KH,LH) -C - END IF -C - CALL MB02UV( DIMMAT, MAT, 4, PIV1, PIV2, INFO1 ) - IF ( INFO1 .NE. 0 ) - $ INFO = 1 - CALL MB02UU( DIMMAT, MAT, 4, RHS, PIV1, PIV2, SCALE1 ) -C -C Scaling. -C - IF ( SCALE1 .NE. ONE ) THEN - DO 160 I = 1, N - CALL DSCAL( N, SCALE1, X(1,I), 1 ) - 160 CONTINUE - SCALE = SCALE*SCALE1 - END IF -C - IF ( LB.EQ.1 .AND. KB.EQ.1 ) THEN - X(KL,LL) = RHS(1) - ELSEIF ( LB.EQ.1 .AND. KB.EQ.2 ) THEN - X(KL,LL) = RHS(1) - X(KH,LL) = RHS(2) - ELSEIF ( LB.EQ.2 .AND. KB.EQ.1 ) THEN - X(KL,LL) = RHS(1) - X(KL,LH) = RHS(2) - ELSE - X(KL,LL) = RHS(1) - X(KH,LL) = RHS(2) - X(KL,LH) = RHS(3) - X(KH,LH) = RHS(4) - END IF -C -C Update right hand sides (II). -C -C X(KL:KH,KL:LL-1) = X(KL:KH,KL:LL-1) - -C (A(KL:KH,KL:KH)*X(KL:KH,LL:LH))*E(KL:LL-1,LL:LH)' -C -C X(KL:KH,KL:LL-1) = X(KL:KH,KL:LL-1) - -C (E(KL:KH,KL:KH)*X(KL:KH,LL:LH))*A(KL:LL-1,LL:LH)' -C - IF ( KL .LT. LL ) THEN - CALL DGEMM( 'N', 'N', KB, LB, KB, ONE, A(KL,KL), LDA, - $ X(KL,LL), LDX, ZERO, TM, 2 ) - CALL DGEMM( 'N', 'T', KB, LL-KL, LB, MONE, TM, 2, - $ E(KL,LL), LDE, ONE, X(KL,KL), LDX ) - CALL DGEMV( 'T', KB, LB, ONE, X(KL,LL), LDX, E(KL,KL), - $ LDE, ZERO, TM, 2 ) - IF ( KB .EQ. 2 ) THEN - CALL DCOPY( LB, X(KH,LL), LDX, TM(2,1), 2 ) - CALL DSCAL( LB, E(KH,KH), TM(2,1), 2 ) - END IF - CALL DGEMM( 'N', 'T', KB, LL-KL, LB, MONE, TM, 2, - $ A(KL,LL), LDA, ONE, X(KL,KL), LDX ) - END IF -C - GOTO 140 - END IF -C END WHILE 140 -C - GOTO 100 - END IF -C END WHILE 100 -C - END IF -C - RETURN -C *** Last line of SG03AY *** - END diff --git a/mex/sources/libslicot/SG03BD.f b/mex/sources/libslicot/SG03BD.f deleted file mode 100644 index 6bcd7400b..000000000 --- a/mex/sources/libslicot/SG03BD.f +++ /dev/null @@ -1,814 +0,0 @@ - SUBROUTINE SG03BD( DICO, FACT, TRANS, N, M, A, LDA, E, LDE, Q, - $ LDQ, Z, LDZ, B, LDB, SCALE, ALPHAR, ALPHAI, - $ BETA, DWORK, LDWORK, INFO ) -C -C SLICOT RELEASE 5.0. -C -C Copyright (c) 2002-2009 NICONET e.V. -C -C This program is free software: you can redistribute it and/or -C modify it under the terms of the GNU General Public License as -C published by the Free Software Foundation, either version 2 of -C the License, or (at your option) any later version. -C -C This program is distributed in the hope that it will be useful, -C but WITHOUT ANY WARRANTY; without even the implied warranty of -C MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the -C GNU General Public License for more details. -C -C You should have received a copy of the GNU General Public License -C along with this program. If not, see -C . -C -C PURPOSE -C -C To compute the Cholesky factor U of the matrix X, -C -C T -C X = op(U) * op(U), -C -C which is the solution of either the generalized -C c-stable continuous-time Lyapunov equation -C -C T T -C op(A) * X * op(E) + op(E) * X * op(A) -C -C 2 T -C = - SCALE * op(B) * op(B), (1) -C -C or the generalized d-stable discrete-time Lyapunov equation -C -C T T -C op(A) * X * op(A) - op(E) * X * op(E) -C -C 2 T -C = - SCALE * op(B) * op(B), (2) -C -C without first finding X and without the need to form the matrix -C op(B)**T * op(B). -C -C op(K) is either K or K**T for K = A, B, E, U. A and E are N-by-N -C matrices, op(B) is an M-by-N matrix. The resulting matrix U is an -C N-by-N upper triangular matrix with non-negative entries on its -C main diagonal. SCALE is an output scale factor set to avoid -C overflow in U. -C -C In the continuous-time case (1) the pencil A - lambda * E must be -C c-stable (that is, all eigenvalues must have negative real parts). -C In the discrete-time case (2) the pencil A - lambda * E must be -C d-stable (that is, the moduli of all eigenvalues must be smaller -C than one). -C -C ARGUMENTS -C -C Mode Parameters -C -C DICO CHARACTER*1 -C Specifies which type of the equation is considered: -C = 'C': Continuous-time equation (1); -C = 'D': Discrete-time equation (2). -C -C FACT CHARACTER*1 -C Specifies whether the generalized real Schur -C factorization of the pencil A - lambda * E is supplied -C on entry or not: -C = 'N': Factorization is not supplied; -C = 'F': Factorization is supplied. -C -C TRANS CHARACTER*1 -C Specifies whether the transposed equation is to be solved -C or not: -C = 'N': op(A) = A, op(E) = E; -C = 'T': op(A) = A**T, op(E) = E**T. -C -C Input/Output Parameters -C -C N (input) INTEGER -C The order of the matrix A. N >= 0. -C -C M (input) INTEGER -C The number of rows in the matrix op(B). M >= 0. -C -C A (input/output) DOUBLE PRECISION array, dimension (LDA,N) -C On entry, if FACT = 'F', then the leading N-by-N upper -C Hessenberg part of this array must contain the -C generalized Schur factor A_s of the matrix A (see -C definition (3) in section METHOD). A_s must be an upper -C quasitriangular matrix. The elements below the upper -C Hessenberg part of the array A are not referenced. -C If FACT = 'N', then the leading N-by-N part of this -C array must contain the matrix A. -C On exit, the leading N-by-N part of this array contains -C the generalized Schur factor A_s of the matrix A. (A_s is -C an upper quasitriangular matrix.) -C -C LDA INTEGER -C The leading dimension of the array A. LDA >= MAX(1,N). -C -C E (input/output) DOUBLE PRECISION array, dimension (LDE,N) -C On entry, if FACT = 'F', then the leading N-by-N upper -C triangular part of this array must contain the -C generalized Schur factor E_s of the matrix E (see -C definition (4) in section METHOD). The elements below the -C upper triangular part of the array E are not referenced. -C If FACT = 'N', then the leading N-by-N part of this -C array must contain the coefficient matrix E of the -C equation. -C On exit, the leading N-by-N part of this array contains -C the generalized Schur factor E_s of the matrix E. (E_s is -C an upper triangular matrix.) -C -C LDE INTEGER -C The leading dimension of the array E. LDE >= MAX(1,N). -C -C Q (input/output) DOUBLE PRECISION array, dimension (LDQ,N) -C On entry, if FACT = 'F', then the leading N-by-N part of -C this array must contain the orthogonal matrix Q from -C the generalized Schur factorization (see definitions (3) -C and (4) in section METHOD). -C If FACT = 'N', Q need not be set on entry. -C On exit, the leading N-by-N part of this array contains -C the orthogonal matrix Q from the generalized Schur -C factorization. -C -C LDQ INTEGER -C The leading dimension of the array Q. LDQ >= MAX(1,N). -C -C Z (input/output) DOUBLE PRECISION array, dimension (LDZ,N) -C On entry, if FACT = 'F', then the leading N-by-N part of -C this array must contain the orthogonal matrix Z from -C the generalized Schur factorization (see definitions (3) -C and (4) in section METHOD). -C If FACT = 'N', Z need not be set on entry. -C On exit, the leading N-by-N part of this array contains -C the orthogonal matrix Z from the generalized Schur -C factorization. -C -C LDZ INTEGER -C The leading dimension of the array Z. LDZ >= MAX(1,N). -C -C B (input/output) DOUBLE PRECISION array, dimension (LDB,N1) -C On entry, if TRANS = 'T', the leading N-by-M part of this -C array must contain the matrix B and N1 >= MAX(M,N). -C If TRANS = 'N', the leading M-by-N part of this array -C must contain the matrix B and N1 >= N. -C On exit, the leading N-by-N part of this array contains -C the Cholesky factor U of the solution matrix X of the -C problem, X = op(U)**T * op(U). -C If M = 0 and N > 0, then U is set to zero. -C -C LDB INTEGER -C The leading dimension of the array B. -C If TRANS = 'T', LDB >= MAX(1,N). -C If TRANS = 'N', LDB >= MAX(1,M,N). -C -C SCALE (output) DOUBLE PRECISION -C The scale factor set to avoid overflow in U. -C 0 < SCALE <= 1. -C -C ALPHAR (output) DOUBLE PRECISION array, dimension (N) -C ALPHAI (output) DOUBLE PRECISION array, dimension (N) -C BETA (output) DOUBLE PRECISION array, dimension (N) -C If INFO = 0, 3, 5, 6, or 7, then -C (ALPHAR(j) + ALPHAI(j)*i)/BETA(j), j=1,...,N, are the -C eigenvalues of the matrix pencil A - lambda * E. -C -C Workspace -C -C DWORK DOUBLE PRECISION array, dimension (LDWORK) -C On exit, if INFO = 0, DWORK(1) returns the optimal value -C of LDWORK. -C -C LDWORK INTEGER -C The dimension of the array DWORK. -C LDWORK >= MAX(1,4*N,6*N-6), if FACT = 'N'; -C LDWORK >= MAX(1,2*N,6*N-6), if FACT = 'F'. -C For good performance, LDWORK should be larger. -C -C Error indicator -C -C INFO INTEGER -C = 0: successful exit; -C < 0: if INFO = -i, the i-th argument had an illegal -C value; -C = 1: the pencil A - lambda * E is (nearly) singular; -C perturbed values were used to solve the equation -C (but the reduced (quasi)triangular matrices A and E -C are unchanged); -C = 2: FACT = 'F' and the matrix contained in the upper -C Hessenberg part of the array A is not in upper -C quasitriangular form; -C = 3: FACT = 'F' and there is a 2-by-2 block on the main -C diagonal of the pencil A_s - lambda * E_s whose -C eigenvalues are not conjugate complex; -C = 4: FACT = 'N' and the pencil A - lambda * E cannot be -C reduced to generalized Schur form: LAPACK routine -C DGEGS has failed to converge; -C = 5: DICO = 'C' and the pencil A - lambda * E is not -C c-stable; -C = 6: DICO = 'D' and the pencil A - lambda * E is not -C d-stable; -C = 7: the LAPACK routine DSYEVX utilized to factorize M3 -C failed to converge in the discrete-time case (see -C section METHOD for SLICOT Library routine SG03BU). -C This error is unlikely to occur. -C -C METHOD -C -C An extension [2] of Hammarling's method [1] to generalized -C Lyapunov equations is utilized to solve (1) or (2). -C -C First the pencil A - lambda * E is reduced to real generalized -C Schur form A_s - lambda * E_s by means of orthogonal -C transformations (QZ-algorithm): -C -C A_s = Q**T * A * Z (upper quasitriangular) (3) -C -C E_s = Q**T * E * Z (upper triangular). (4) -C -C If the pencil A - lambda * E has already been factorized prior to -C calling the routine however, then the factors A_s, E_s, Q and Z -C may be supplied and the initial factorization omitted. -C -C Depending on the parameters TRANS and M the N-by-N upper -C triangular matrix B_s is defined as follows. In any case Q_B is -C an M-by-M orthogonal matrix, which need not be accumulated. -C -C 1. If TRANS = 'N' and M < N, B_s is the upper triangular matrix -C from the QR-factorization -C -C ( Q_B O ) ( B * Z ) -C ( ) * B_s = ( ), -C ( O I ) ( O ) -C -C where the O's are zero matrices of proper size and I is the -C identity matrix of order N-M. -C -C 2. If TRANS = 'N' and M >= N, B_s is the upper triangular matrix -C from the (rectangular) QR-factorization -C -C ( B_s ) -C Q_B * ( ) = B * Z, -C ( O ) -C -C where O is the (M-N)-by-N zero matrix. -C -C 3. If TRANS = 'T' and M < N, B_s is the upper triangular matrix -C from the RQ-factorization -C -C ( Q_B O ) -C (B_s O ) * ( ) = ( Q**T * B O ). -C ( O I ) -C -C 4. If TRANS = 'T' and M >= N, B_s is the upper triangular matrix -C from the (rectangular) RQ-factorization -C -C ( B_s O ) * Q_B = Q**T * B, -C -C where O is the N-by-(M-N) zero matrix. -C -C Assuming SCALE = 1, the transformation of A, E and B described -C above leads to the reduced continuous-time equation -C -C T T -C op(A_s) op(U_s) op(U_s) op(E_s) -C -C T T -C + op(E_s) op(U_s) op(U_s) op(A_s) -C -C T -C = - op(B_s) op(B_s) (5) -C -C or to the reduced discrete-time equation -C -C T T -C op(A_s) op(U_s) op(U_s) op(A_s) -C -C T T -C - op(E_s) op(U_s) op(U_s) op(E_s) -C -C T -C = - op(B_s) op(B_s). (6) -C -C For brevity we restrict ourself to equation (5) and the case -C TRANS = 'N'. The other three cases can be treated in a similar -C fashion. -C -C We use the following partitioning for the matrices A_s, E_s, B_s -C and U_s -C -C ( A11 A12 ) ( E11 E12 ) -C A_s = ( ), E_s = ( ), -C ( 0 A22 ) ( 0 E22 ) -C -C ( B11 B12 ) ( U11 U12 ) -C B_s = ( ), U_s = ( ). (7) -C ( 0 B22 ) ( 0 U22 ) -C -C The size of the (1,1)-blocks is 1-by-1 (iff A_s(2,1) = 0.0) or -C 2-by-2. -C -C We compute U11 and U12**T in three steps. -C -C Step I: -C -C From (5) and (7) we get the 1-by-1 or 2-by-2 equation -C -C T T T T -C A11 * U11 * U11 * E11 + E11 * U11 * U11 * A11 -C -C T -C = - B11 * B11. -C -C For brevity, details are omitted here. See [2]. The technique -C for computing U11 is similar to those applied to standard -C Lyapunov equations in Hammarling's algorithm ([1], section 6). -C -C Furthermore, the auxiliary matrices M1 and M2 defined as -C follows -C -C -1 -1 -C M1 = U11 * A11 * E11 * U11 -C -C -1 -1 -C M2 = B11 * E11 * U11 -C -C are computed in a numerically reliable way. -C -C Step II: -C -C The generalized Sylvester equation -C -C T T T T -C A22 * U12 + E22 * U12 * M1 = -C -C T T T T T -C - B12 * M2 - A12 * U11 - E12 * U11 * M1 -C -C is solved for U12**T. -C -C Step III: -C -C It can be shown that -C -C T T T T -C A22 * U22 * U22 * E22 + E22 * U22 * U22 * A22 = -C -C T T -C - B22 * B22 - y * y (8) -C -C holds, where y is defined as -C -C T T T T T T -C y = B12 - ( E12 * U11 + E22 * U12 ) * M2 . -C -C If B22_tilde is the square triangular matrix arising from the -C (rectangular) QR-factorization -C -C ( B22_tilde ) ( B22 ) -C Q_B_tilde * ( ) = ( ), -C ( O ) ( y**T ) -C -C where Q_B_tilde is an orthogonal matrix of order N, then -C -C T T T -C - B22 * B22 - y * y = - B22_tilde * B22_tilde. -C -C Replacing the right hand side in (8) by the term -C - B22_tilde**T * B22_tilde leads to a reduced generalized -C Lyapunov equation of lower dimension compared to (5). -C -C The recursive application of the steps I to III yields the -C solution U_s of the equation (5). -C -C It remains to compute the solution matrix U of the original -C problem (1) or (2) from the matrix U_s. To this end we transform -C the solution back (with respect to the transformation that led -C from (1) to (5) (from (2) to (6)) and apply the QR-factorization -C (RQ-factorization). The upper triangular solution matrix U is -C obtained by -C -C Q_U * U = U_s * Q**T (if TRANS = 'N') -C -C or -C -C U * Q_U = Z * U_s (if TRANS = 'T') -C -C where Q_U is an N-by-N orthogonal matrix. Again, the orthogonal -C matrix Q_U need not be accumulated. -C -C REFERENCES -C -C [1] Hammarling, S.J. -C Numerical solution of the stable, non-negative definite -C Lyapunov equation. -C IMA J. Num. Anal., 2, pp. 303-323, 1982. -C -C [2] Penzl, T. -C Numerical solution of generalized Lyapunov equations. -C Advances in Comp. Math., vol. 8, pp. 33-48, 1998. -C -C NUMERICAL ASPECTS -C -C The number of flops required by the routine is given by the -C following table. Note that we count a single floating point -C arithmetic operation as one flop. -C -C | FACT = 'F' FACT = 'N' -C ---------+-------------------------------------------------- -C M <= N | (13*N**3+6*M*N**2 (211*N**3+6*M*N**2 -C | +6*M**2*N-2*M**3)/3 +6*M**2*N-2*M**3)/3 -C | -C M > N | (11*N**3+12*M*N**2)/3 (209*N**3+12*M*N**2)/3 -C -C FURTHER COMMENTS -C -C The Lyapunov equation may be very ill-conditioned. In particular, -C if DICO = 'D' and the pencil A - lambda * E has a pair of almost -C reciprocal eigenvalues, or DICO = 'C' and the pencil has an almost -C degenerate pair of eigenvalues, then the Lyapunov equation will be -C ill-conditioned. Perturbed values were used to solve the equation. -C A condition estimate can be obtained from the routine SG03AD. -C When setting the error indicator INFO, the routine does not test -C for near instability in the equation but only for exact -C instability. -C -C CONTRIBUTOR -C -C T. Penzl, Technical University Chemnitz, Germany, Aug. 1998. -C -C REVISIONS -C -C Sep. 1998 (V. Sima). -C May 1999 (V. Sima). -C March 2002 (A. Varga). -C Feb. 2004 (V. Sima). -C -C KEYWORDS -C -C Lyapunov equation -C -C ****************************************************************** -C -C .. Parameters .. - DOUBLE PRECISION MONE, ONE, TWO, ZERO - PARAMETER ( MONE = -1.0D+0, ONE = 1.0D+0, TWO = 2.0D+0, - $ ZERO = 0.0D+0 ) -C .. Scalar Arguments .. - DOUBLE PRECISION SCALE - INTEGER INFO, LDA, LDB, LDE, LDQ, LDWORK, LDZ, M, N - CHARACTER DICO, FACT, TRANS -C .. Array Arguments .. - DOUBLE PRECISION A(LDA,*), ALPHAI(*), ALPHAR(*), B(LDB,*), - $ BETA(*), DWORK(*), E(LDE,*), Q(LDQ,*), Z(LDZ,*) -C .. Local Scalars .. - DOUBLE PRECISION S1, S2, SAFMIN, WI, WR1, WR2 - INTEGER I, INFO1, MINMN, MINWRK, OPTWRK - LOGICAL ISDISC, ISFACT, ISTRAN -C .. Local Arrays .. - DOUBLE PRECISION E1(2,2) -C .. External Functions .. - DOUBLE PRECISION DLAMCH, DLAPY2 - LOGICAL LSAME - EXTERNAL DLAMCH, DLAPY2, LSAME -C .. External Subroutines .. - EXTERNAL DCOPY, DGEGS, DGEMM, DGEMV, DGEQRF, DGERQF, - $ DLACPY, DLAG2, DLASET, DSCAL, DTRMM, SG03BU, - $ SG03BV, XERBLA -C .. Intrinsic Functions .. - INTRINSIC ABS, DBLE, INT, MAX, MIN, SIGN -C .. Executable Statements .. -C -C Decode input parameters. -C - ISDISC = LSAME( DICO, 'D' ) - ISFACT = LSAME( FACT, 'F' ) - ISTRAN = LSAME( TRANS, 'T' ) -C -C Compute minimal workspace. -C - IF (ISFACT ) THEN - MINWRK = MAX( 1, 2*N, 6*N-6 ) - ELSE - MINWRK = MAX( 1, 4*N, 6*N-6 ) - END IF -C -C Check the scalar input parameters. -C - IF ( .NOT.( ISDISC .OR. LSAME( DICO, 'C' ) ) ) THEN - INFO = -1 - ELSEIF ( .NOT.( ISFACT .OR. LSAME( FACT, 'N' ) ) ) THEN - INFO = -2 - ELSEIF ( .NOT.( ISTRAN .OR. LSAME( TRANS, 'N' ) ) ) THEN - INFO = -3 - ELSEIF ( N .LT. 0 ) THEN - INFO = -4 - ELSEIF ( M .LT. 0 ) THEN - INFO = -5 - ELSEIF ( LDA .LT. MAX( 1, N ) ) THEN - INFO = -7 - ELSEIF ( LDE .LT. MAX( 1, N ) ) THEN - INFO = -9 - ELSEIF ( LDQ .LT. MAX( 1, N ) ) THEN - INFO = -11 - ELSEIF ( LDZ .LT. MAX( 1, N ) ) THEN - INFO = -13 - ELSEIF ( ( ISTRAN .AND. ( LDB .LT. MAX( 1, N ) ) ) .OR. - $ ( .NOT.ISTRAN .AND. ( LDB .LT. MAX( 1, M, N ) ) ) ) THEN - INFO = -15 - ELSEIF ( LDWORK .LT. MINWRK ) THEN - INFO = -21 - ELSE - INFO = 0 - END IF - IF ( INFO .NE. 0 ) THEN - CALL XERBLA( 'SG03BD', -INFO ) - RETURN - END IF -C - SCALE = ONE -C -C Quick return if possible. -C - MINMN = MIN( M, N ) - IF ( MINMN .EQ. 0 ) THEN - IF ( N.GT.0 ) - $ CALL DLASET( 'Full', N, N, ZERO, ZERO, B, LDB ) - DWORK(1) = ONE - RETURN - ENDIF -C - IF ( ISFACT ) THEN -C -C Make sure the upper Hessenberg part of A is quasitriangular. -C - DO 20 I = 1, N-2 - IF ( A(I+1,I).NE.ZERO .AND. A(I+2,I+1).NE.ZERO ) THEN - INFO = 2 - RETURN - END IF - 20 CONTINUE - END IF -C - IF ( .NOT.ISFACT ) THEN -C -C Reduce the pencil A - lambda * E to generalized Schur form. -C -C A := Q**T * A * Z (upper quasitriangular) -C E := Q**T * E * Z (upper triangular) -C -C ( Workspace: >= MAX(1,4*N) ) -C - CALL DGEGS( 'Vectors', 'Vectors', N, A, LDA, E, LDE, ALPHAR, - $ ALPHAI, BETA, Q, LDQ, Z, LDZ, DWORK, LDWORK, - $ INFO1 ) - IF ( INFO1 .NE. 0 ) THEN - INFO = 4 - RETURN - END IF - OPTWRK = INT( DWORK(1) ) - ELSE - OPTWRK = MINWRK - END IF -C - IF ( ISFACT ) THEN -C -C If the matrix pencil A - lambda * E has been in generalized -C Schur form on entry, compute its eigenvalues. -C - SAFMIN = DLAMCH( 'Safe minimum' ) - E1(2,1) = ZERO - I = 1 -C WHILE ( I .LE. N ) DO - 30 IF ( I .LE. N ) THEN - IF ( ( I.EQ.N ) .OR. ( A(MIN( I+1, N ),I).EQ.ZERO ) ) THEN - ALPHAR(I) = A(I,I) - ALPHAI(I) = ZERO - BETA(I) = E(I,I) - I = I+1 - ELSE - E1(1,1) = E(I,I) - E1(1,2) = E(I,I+1) - E1(2,2) = E(I+1,I+1) - CALL DLAG2( A(I,I), LDA, E1, 2, SAFMIN, S1, S2, WR1, WR2, - $ WI ) - IF ( WI .EQ. ZERO ) INFO = 3 - ALPHAR(I) = WR1 - ALPHAI(I) = WI - BETA(I) = S1 - ALPHAR(I+1) = WR2 - ALPHAI(I+1) = -WI - BETA(I+1) = S2 - I = I+2 - END IF - GOTO 30 - END IF -C END WHILE 30 - IF ( INFO.NE.0 ) RETURN - END IF -C -C Check on the stability of the matrix pencil A - lambda * E. -C - DO 40 I = 1, N - IF ( ISDISC ) THEN - IF ( DLAPY2( ALPHAR(I), ALPHAI(I) ) .GE. ABS( BETA(I) ) ) - $ THEN - INFO = 6 - RETURN - END IF - ELSE - IF ( ( ALPHAR(I).EQ.ZERO ) .OR. ( BETA(I).EQ.ZERO ) .OR. - $ ( SIGN( ONE,ALPHAR(I) )*SIGN( ONE, BETA(I) ) .GE. ZERO) ) - $ THEN - INFO = 5 - RETURN - END IF - END IF - 40 CONTINUE -C -C Transformation of the right hand side. -C -C B := B * Z or B := Q**T * B -C -C Use BLAS 3 if there is enough workspace. Otherwise, use BLAS 2. -C -C ( Workspace: max(1,N) ) -C - IF ( .NOT.ISTRAN ) THEN - IF ( LDWORK .GE. N*M ) THEN - CALL DGEMM( 'NoTranspose', 'NoTranspose', M, N, N, ONE, B, - $ LDB, Z, LDZ, ZERO, DWORK, M ) - CALL DLACPY( 'All', M, N, DWORK, M, B, LDB ) - ELSE - DO 60 I = 1, M - CALL DCOPY( N, B(I,1), LDB, DWORK, 1 ) - CALL DGEMV( 'Transpose', N, N, ONE, Z, LDZ, DWORK, 1, - $ ZERO, B(I,1), LDB ) - 60 CONTINUE - END IF - IF ( M .LT. N ) - $ CALL DLASET( 'All', N-M, N, ZERO, ZERO, B(M+1,1), LDB ) - ELSE - IF ( LDWORK .GE. N*M ) THEN - CALL DLACPY( 'All', N, M, B, LDB, DWORK, N ) - CALL DGEMM( 'Transpose', 'NoTranspose', N, M, N, ONE, Q, - $ LDQ, DWORK, N, ZERO, B, LDB ) - ELSE - DO 80 I = 1, M - CALL DCOPY( N, B(1,I), 1, DWORK, 1 ) - CALL DGEMV( 'Transpose', N, N, ONE, Q, LDQ, DWORK, 1, - $ ZERO, B(1,I), 1 ) - 80 CONTINUE - END IF - IF ( M .LT. N ) - $ CALL DLASET( 'All', N, N-M, ZERO, ZERO, B(1,M+1), LDB ) - END IF - OPTWRK = MAX( OPTWRK, N*M ) -C -C Overwrite B with the triangular matrix of its QR-factorization -C or its RQ-factorization. -C (The entries on the main diagonal are non-negative.) -C -C ( Workspace: >= max(1,2*N) ) -C - IF ( .NOT.ISTRAN ) THEN - IF ( M .GE. 2 ) THEN - CALL DGEQRF( M, N, B, LDB, DWORK, DWORK(N+1), LDWORK-N, - $ INFO1 ) - CALL DLASET( 'Lower', MAX( M, N )-1, MIN( M, N ), ZERO, - $ ZERO, B(2,1), LDB ) - END IF - DO 100 I = 1, MINMN - IF ( B(I,I) .LT. ZERO ) - $ CALL DSCAL( N+1-I, MONE, B(I,I), LDB ) - 100 CONTINUE - ELSE - IF ( M .GE. 2 ) THEN - CALL DGERQF( N, M, B, LDB, DWORK, DWORK(N+1), LDWORK-N, - $ INFO1 ) - IF ( N .GE. M ) THEN - CALL DLASET( 'Lower', M-1, M-1, ZERO, ZERO, B(N-M+2,1), - $ LDB ) - IF ( N .GT. M ) THEN - DO 120 I = M, 1, -1 - CALL DCOPY( N, B(1,I), 1, B(1,I+N-M), 1 ) - 120 CONTINUE - CALL DLASET( 'All', N, N-M, ZERO, ZERO, B(1,1), LDB ) - END IF - ELSE - IF ( N .GT. 1 ) - $ CALL DLASET( 'Lower', N-1, N-1, ZERO, ZERO, - $ B(2,M-N+1), LDB ) - DO 140 I = 1, N - CALL DCOPY( N, B(1,M-N+I), 1, B(1,I), 1 ) - 140 CONTINUE - CALL DLASET( 'All', N, M-N, ZERO, ZERO, B(1,N+1), LDB ) - END IF - ELSE - IF ( N .NE. 1 ) THEN - CALL DCOPY( N, B(1,1), 1, B(1,N), 1 ) - CALL DLASET( 'All', N, 1, ZERO, ZERO, B(1,1), LDB ) - END IF - END IF - DO 160 I = N - MINMN + 1, N - IF ( B(I,I) .LT. ZERO ) - $ CALL DSCAL( I, MONE, B(1,I), 1 ) - 160 CONTINUE - END IF - OPTWRK = MAX( OPTWRK, INT( DWORK(N+1) ) + N ) -C -C Solve the reduced generalized Lyapunov equation. -C -C ( Workspace: 6*N-6 ) -C - IF ( ISDISC ) THEN - CALL SG03BU( TRANS, N, A, LDA, E, LDE, B, LDB, SCALE, DWORK, - $ INFO1 ) - IF ( INFO1 .NE. 0 ) THEN - IF ( INFO1 .EQ. 1 ) INFO = 1 - IF ( INFO1 .EQ. 2 ) INFO = 3 - IF ( INFO1 .EQ. 3 ) INFO = 6 - IF ( INFO1 .EQ. 4 ) INFO = 7 - IF ( INFO .NE. 1 ) - $ RETURN - END IF - ELSE - CALL SG03BV( TRANS, N, A, LDA, E, LDE, B, LDB, SCALE, DWORK, - $ INFO1 ) - IF ( INFO1 .NE. 0 ) THEN - IF ( INFO1 .EQ. 1 ) INFO = 1 - IF ( INFO1 .GE. 2 ) INFO = 3 - IF ( INFO1 .EQ. 3 ) INFO = 5 - IF ( INFO .NE. 1 ) - $ RETURN - END IF - END IF -C -C Transform the solution matrix back. -C -C U := U * Q**T or U := Z * U -C -C Use BLAS 3 if there is enough workspace. Otherwise, use BLAS 2. -C -C ( Workspace: max(1,N) ) -C - IF ( .NOT.ISTRAN ) THEN - IF ( LDWORK .GE. N*N ) THEN - CALL DLACPY( 'All', N, N, Q, LDQ, DWORK, N ) - CALL DTRMM( 'Right', 'Upper', 'Transpose', 'NonUnit', N, N, - $ ONE, B, LDB, DWORK, N) - DO 170 I = 1, N - CALL DCOPY( N, DWORK(N*(I-1)+1), 1, B(I,1), LDB ) - 170 CONTINUE - ELSE - DO 180 I = 1, N - CALL DCOPY( N-I+1, B(I,I), LDB, DWORK, 1 ) - CALL DGEMV( 'NoTranspose', N, N-I+1, ONE, Q(1,I), LDQ, - $ DWORK, 1, ZERO, B(I,1), LDB ) - 180 CONTINUE - END IF - ELSE - IF ( LDWORK .GE. N*N ) THEN - CALL DLACPY( 'All', N, N, Z, LDZ, DWORK, N ) - CALL DTRMM( 'Right', 'Upper', 'NoTranspose', 'NonUnit', N, - $ N, ONE, B, LDB, DWORK, N ) - CALL DLACPY( 'All', N, N, DWORK, N, B, LDB ) - ELSE - DO 200 I = 1, N - CALL DCOPY( I, B(1,I), 1, DWORK, 1 ) - CALL DGEMV( 'NoTranspose', N, I, ONE, Z, LDZ, DWORK, 1, - $ ZERO, B(1,I), 1 ) - 200 CONTINUE - END IF - END IF - OPTWRK = MAX( OPTWRK, N*N ) -C -C Overwrite U with the triangular matrix of its QR-factorization -C or its RQ-factorization. -C (The entries on the main diagonal are non-negative.) -C -C ( Workspace: >= max(1,2*N) ) -C - IF ( .NOT.ISTRAN ) THEN - CALL DGEQRF( N, N, B, LDB, DWORK, DWORK(N+1), LDWORK-N, INFO1 ) - IF ( N .GT. 1 ) - $ CALL DLASET( 'Lower', N-1, N-1, ZERO, ZERO, B(2,1), LDB ) - DO 220 I = 1, N - IF ( B(I,I) .LT. ZERO ) - $ CALL DSCAL( N+1-I, MONE, B(I,I), LDB ) - 220 CONTINUE - ELSE - CALL DGERQF( N, N, B, LDB, DWORK, DWORK(N+1), LDWORK-N, INFO1 ) - IF ( N .GT. 1 ) - $ CALL DLASET( 'Lower', N-1, N-1, ZERO, ZERO, B(2,1), LDB ) - DO 240 I = 1, N - IF ( B(I,I) .LT. ZERO ) - $ CALL DSCAL( I, MONE, B(1,I), 1 ) - 240 CONTINUE - END IF - OPTWRK = MAX( OPTWRK, INT( DWORK(N+1) ) + N ) -C - DWORK(1) = DBLE( MAX( OPTWRK, MINWRK ) ) - RETURN -C *** Last line of SG03BD *** - END diff --git a/mex/sources/libslicot/SG03BU.f b/mex/sources/libslicot/SG03BU.f deleted file mode 100644 index 0e1084f96..000000000 --- a/mex/sources/libslicot/SG03BU.f +++ /dev/null @@ -1,696 +0,0 @@ - SUBROUTINE SG03BU( TRANS, N, A, LDA, E, LDE, B, LDB, SCALE, - $ DWORK, INFO ) -C -C SLICOT RELEASE 5.0. -C -C Copyright (c) 2002-2009 NICONET e.V. -C -C This program is free software: you can redistribute it and/or -C modify it under the terms of the GNU General Public License as -C published by the Free Software Foundation, either version 2 of -C the License, or (at your option) any later version. -C -C This program is distributed in the hope that it will be useful, -C but WITHOUT ANY WARRANTY; without even the implied warranty of -C MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the -C GNU General Public License for more details. -C -C You should have received a copy of the GNU General Public License -C along with this program. If not, see -C . -C -C PURPOSE -C -C To compute the Cholesky factor U of the matrix X, X = U**T * U or -C X = U * U**T, which is the solution of the generalized d-stable -C discrete-time Lyapunov equation -C -C T T 2 T -C A * X * A - E * X * E = - SCALE * B * B, (1) -C -C or the transposed equation -C -C T T 2 T -C A * X * A - E * X * E = - SCALE * B * B , (2) -C -C respectively, where A, E, B, and U are real N-by-N matrices. The -C Cholesky factor U of the solution is computed without first -C finding X. The pencil A - lambda * E must be in generalized Schur -C form ( A upper quasitriangular, E upper triangular ). Moreover, it -C must be d-stable, i.e. the moduli of its eigenvalues must be less -C than one. B must be an upper triangular matrix with non-negative -C entries on its main diagonal. -C -C The resulting matrix U is upper triangular. The entries on its -C main diagonal are non-negative. SCALE is an output scale factor -C set to avoid overflow in U. -C -C ARGUMENTS -C -C Mode Parameters -C -C TRANS CHARACTER*1 -C Specifies whether equation (1) or equation (2) is to be -C solved: -C = 'N': Solve equation (1); -C = 'T': Solve equation (2). -C -C Input/Output Parameters -C -C N (input) INTEGER -C The order of the matrix A. N >= 0. -C -C A (input) DOUBLE PRECISION array, dimension (LDA,N) -C The leading N-by-N upper Hessenberg part of this array -C must contain the quasitriangular matrix A. -C -C LDA INTEGER -C The leading dimension of the array A. LDA >= MAX(1,N). -C -C E (input) DOUBLE PRECISION array, dimension (LDE,N) -C The leading N-by-N upper triangular part of this array -C must contain the matrix E. -C -C LDE INTEGER -C The leading dimension of the array E. LDE >= MAX(1,N). -C -C B (input/output) DOUBLE PRECISION array, dimension (LDB,N) -C On entry, the leading N-by-N upper triangular part of this -C array must contain the matrix B. -C On exit, the leading N-by-N upper triangular part of this -C array contains the solution matrix U. -C -C LDB INTEGER -C The leading dimension of the array B. LDB >= MAX(1,N). -C -C SCALE (output) DOUBLE PRECISION -C The scale factor set to avoid overflow in U. -C 0 < SCALE <= 1. -C -C Workspace -C -C DWORK DOUBLE PRECISION array, dimension (6*N-6) -C -C Error indicator -C -C INFO INTEGER -C = 0: successful exit; -C < 0: if INFO = -i, the i-th argument had an illegal -C value; -C = 1: the generalized Sylvester equation to be solved in -C step II (see METHOD) is (nearly) singular to working -C precision; perturbed values were used to solve the -C equation (but the matrices A and E are unchanged); -C = 2: the generalized Schur form of the pencil -C A - lambda * E contains a 2-by-2 main diagonal block -C whose eigenvalues are not a pair of conjugate -C complex numbers; -C = 3: the pencil A - lambda * E is not d-stable, i.e. -C there are eigenvalues outside the open unit circle; -C = 4: the LAPACK routine DSYEVX utilized to factorize M3 -C failed to converge. This error is unlikely to occur. -C -C METHOD -C -C The method [2] used by the routine is an extension of Hammarling's -C algorithm [1] to generalized Lyapunov equations. -C -C We present the method for solving equation (1). Equation (2) can -C be treated in a similar fashion. For simplicity, assume SCALE = 1. -C -C The matrix A is an upper quasitriangular matrix, i.e. it is a -C block triangular matrix with square blocks on the main diagonal -C and the block order at most 2. We use the following partitioning -C for the matrices A, E, B and the solution matrix U -C -C ( A11 A12 ) ( E11 E12 ) -C A = ( ), E = ( ), -C ( 0 A22 ) ( 0 E22 ) -C -C ( B11 B12 ) ( U11 U12 ) -C B = ( ), U = ( ). (3) -C ( 0 B22 ) ( 0 U22 ) -C -C The size of the (1,1)-blocks is 1-by-1 (iff A(2,1) = 0.0) or -C 2-by-2. -C -C We compute U11 and U12**T in three steps. -C -C Step I: -C -C From (1) and (3) we get the 1-by-1 or 2-by-2 equation -C -C T T T T -C A11 * U11 * U11 * A11 - E11 * U11 * U11 * E11 -C -C T -C = - B11 * B11. -C -C For brevity, details are omitted here. The technique for -C computing U11 is similar to those applied to standard Lyapunov -C equations in Hammarling's algorithm ([1], section 6). -C -C Furthermore, the auxiliary matrices M1 and M2 defined as -C follows -C -C -1 -1 -C M1 = U11 * A11 * E11 * U11 -C -C -1 -1 -C M2 = B11 * E11 * U11 -C -C are computed in a numerically reliable way. -C -C Step II: -C -C We solve for U12**T the generalized Sylvester equation -C -C T T T T -C A22 * U12 * M1 - E22 * U12 -C -C T T T T T -C = - B12 * M2 + E12 * U11 - A12 * U11 * M1. -C -C Step III: -C -C One can show that -C -C T T T T -C A22 * U22 * U22 * A22 - E22 * U22 * U22 * E22 = -C -C T T -C - B22 * B22 - y * y (4) -C -C holds, where y is defined as follows -C -C T T T T -C w = A12 * U11 + A22 * U12 -C -C T -C y = ( B12 w ) * M3EV, -C -C where M3EV is a matrix which fulfils -C -C ( I-M2*M2**T -M2*M1**T ) T -C M3 = ( ) = M3EV * M3EV . -C ( -M1*M2**T I-M1*M1**T ) -C -C M3 is positive semidefinite and its rank is equal to the size -C of U11. Therefore, a matrix M3EV can be found by solving the -C symmetric eigenvalue problem for M3 such that y consists of -C either 1 or 2 rows. -C -C If B22_tilde is the square triangular matrix arising from the -C QR-factorization -C -C ( B22_tilde ) ( B22 ) -C Q * ( ) = ( ), -C ( 0 ) ( y**T ) -C -C then -C -C T T T -C - B22 * B22 - y * y = - B22_tilde * B22_tilde. -C -C Replacing the right hand side in (4) by the term -C - B22_tilde**T * B22_tilde leads to a generalized Lyapunov -C equation of lower dimension compared to (1). -C -C The solution U of the equation (1) can be obtained by recursive -C application of the steps I to III. -C -C REFERENCES -C -C [1] Hammarling, S.J. -C Numerical solution of the stable, non-negative definite -C Lyapunov equation. -C IMA J. Num. Anal., 2, pp. 303-323, 1982. -C -C [2] Penzl, T. -C Numerical solution of generalized Lyapunov equations. -C Advances in Comp. Math., vol. 8, pp. 33-48, 1998. -C -C NUMERICAL ASPECTS -C -C The routine requires 2*N**3 flops. Note that we count a single -C floating point arithmetic operation as one flop. -C -C FURTHER COMMENTS -C -C The Lyapunov equation may be very ill-conditioned. In particular, -C if the pencil A - lambda * E has a pair of almost reciprocal -C eigenvalues, then the Lyapunov equation will be ill-conditioned. -C Perturbed values were used to solve the equation. -C A condition estimate can be obtained from the routine SG03AD. -C When setting the error indicator INFO, the routine does not test -C for near instability in the equation but only for exact -C instability. -C -C CONTRIBUTOR -C -C T. Penzl, Technical University Chemnitz, Germany, Aug. 1998. -C -C REVISIONS -C -C Sep. 1998 (V. Sima). -C -C KEYWORDS -C -C Lyapunov equation -C -C ****************************************************************** -C -C .. Parameters .. - DOUBLE PRECISION HALF, MONE, ONE, TWO, ZERO - PARAMETER ( HALF = 0.5D+0, MONE = -1.0D0, ONE = 1.0D+0, - $ TWO = 2.0D+0, ZERO = 0.0D+0 ) -C .. Scalar Arguments .. - CHARACTER TRANS - DOUBLE PRECISION SCALE - INTEGER INFO, LDA, LDB, LDE, N -C .. Array Arguments .. - DOUBLE PRECISION A(LDA,*), B(LDB,*), DWORK(*), E(LDE,*) -C .. Local Scalars .. - DOUBLE PRECISION BIGNUM, C, DELTA1, EPS, S, SCALE1, SMLNUM, UFLT, - $ X, Z - INTEGER I, INFO1, J, KB, KH, KL, LDWS, M, UIIPT, WPT, - $ YPT - LOGICAL NOTRNS -C .. Local Arrays .. - DOUBLE PRECISION M1(2,2), M2(2,2), M3(4,4), M3C(4,4), M3EW(4), - $ RW(32), TM(2,2), UI(2,2) - INTEGER IW(24) -C .. External Functions .. - DOUBLE PRECISION DLAMCH - LOGICAL LSAME - EXTERNAL DLAMCH, LSAME -C .. External Subroutines .. - EXTERNAL DCOPY, DGEMM, DGEMV, DLABAD, DLACPY, DLASET, - $ DROT, DROTG, DSCAL, DSYEVX, DSYRK, SG03BW, - $ SG03BX, XERBLA -C .. Intrinsic Functions .. - INTRINSIC ABS, SQRT -C .. Executable Statements .. -C -C Decode input parameter. -C - NOTRNS = LSAME( TRANS, 'N' ) -C -C Check the scalar input parameters. -C - IF ( .NOT.( NOTRNS .OR. LSAME( TRANS, 'T' ) ) ) THEN - INFO = -1 - ELSEIF ( N .LT. 0 ) THEN - INFO = -2 - ELSEIF ( LDA .LT. MAX( 1, N ) ) THEN - INFO = -4 - ELSEIF ( LDE .LT. MAX( 1, N ) ) THEN - INFO = -6 - ELSEIF ( LDB .LT. MAX( 1, N ) ) THEN - INFO = -8 - ELSE - INFO = 0 - END IF - IF ( INFO .NE. 0 ) THEN - CALL XERBLA( 'SG03BU', -INFO ) - RETURN - END IF -C - SCALE = ONE -C -C Quick return if possible. -C - IF ( N .EQ. 0 ) - $ RETURN -C -C Set constants to control overflow. -C - EPS = DLAMCH( 'P' ) - UFLT = DLAMCH( 'S' ) - SMLNUM = UFLT/EPS - BIGNUM = ONE/SMLNUM - CALL DLABAD( SMLNUM, BIGNUM ) -C -C Set work space pointers and leading dimension of matrices in -C work space. -C - UIIPT = 1 - WPT = 2*N-1 - YPT = 4*N-3 - LDWS = N-1 -C - IF ( NOTRNS ) THEN -C -C Solve equation (1). -C -C Main Loop. Compute block row U(KL:KH,KL:N). KB denotes the -C number of rows in this block row. -C - KH = 0 -C WHILE ( KH .LT. N ) DO - 20 IF ( KH .LT. N ) THEN - KL = KH + 1 - IF ( KL .EQ. N ) THEN - KH = N - KB = 1 - ELSE - IF ( A(KL+1,KL) .EQ. ZERO ) THEN - KH = KL - KB = 1 - ELSE - KH = KL + 1 - KB = 2 - END IF - END IF -C -C STEP I: Compute block U(KL:KH,KL:KH) and the auxiliary -C matrices M1 and M2. (For the moment the result -C U(KL:KH,KL:KH) is stored in UI). -C - IF ( KB .EQ. 1 ) THEN - DELTA1 = E(KL,KL)**2 - A(KL,KL)**2 - IF ( DELTA1 .LE. ZERO ) THEN - INFO = 3 - RETURN - END IF - DELTA1 = SQRT( DELTA1 ) - Z = TWO*ABS( B(KL,KL) )*SMLNUM - IF ( Z .GT. DELTA1 ) THEN - SCALE1 = DELTA1/Z - SCALE = SCALE1*SCALE - DO 40 I = 1, N - CALL DSCAL( I, SCALE1, B(1,I), 1 ) - 40 CONTINUE - END IF - UI(1,1) = B(KL,KL)/DELTA1 - M1(1,1) = A(KL,KL)/E(KL,KL) - M2(1,1) = DELTA1/E(KL,KL) - ELSE -C -C If a pair of complex conjugate eigenvalues occurs, apply -C (complex) Hammarling algorithm for the 2-by-2 problem. -C - CALL SG03BX( 'D', 'N', A(KL,KL), LDA, E(KL,KL), LDE, - $ B(KL,KL), LDB, UI, 2, SCALE1, M1, 2, M2, 2, - $ INFO1 ) - IF ( INFO1 .NE. 0 ) THEN - INFO = INFO1 - RETURN - END IF - IF ( SCALE1 .NE. ONE ) THEN - SCALE = SCALE1*SCALE - DO 60 I = 1, N - CALL DSCAL( I, SCALE1, B(1,I), 1 ) - 60 CONTINUE - END IF - END IF -C - IF ( KH .LT. N ) THEN -C -C STEP II: Compute U(KL:KH,KH+1:N) by solving a generalized -C Sylvester equation. (For the moment the result -C U(KL:KH,KH+1:N) is stored in the workspace.) -C -C Form right hand side of the Sylvester equation. -C - CALL DGEMM( 'T', 'N', N-KH, KB, KB, MONE, B(KL,KH+1), - $ LDB, M2, 2, ZERO, DWORK(UIIPT), LDWS ) - CALL DGEMM( 'T', 'T', N-KH, KB, KB, ONE, E(KL,KH+1), - $ LDE, UI, 2, ONE, DWORK(UIIPT), LDWS ) - CALL DGEMM( 'T', 'N', KB, KB, KB, ONE, UI, 2, M1, 2, - $ ZERO, TM, 2 ) - CALL DGEMM( 'T', 'N', N-KH, KB, KB, MONE, A(KL,KH+1), - $ LDA, TM, 2, ONE, DWORK(UIIPT), LDWS ) -C -C Solve generalized Sylvester equation. -C - CALL DLASET( 'A', KB, KB, ZERO, MONE, TM, 2 ) - CALL SG03BW( 'N', N-KH, KB, A(KH+1,KH+1), LDA, M1, 2, - $ E(KH+1,KH+1), LDE, TM, 2, DWORK(UIIPT), - $ LDWS, SCALE1, INFO1 ) - IF ( INFO1 .NE. 0 ) - $ INFO = 1 - IF ( SCALE1 .NE. ONE ) THEN - SCALE = SCALE1*SCALE - DO 80 I = 1, N - CALL DSCAL( I, SCALE1, B(1,I), 1 ) - 80 CONTINUE - CALL DSCAL( 4, SCALE1, UI(1,1), 1 ) - END IF -C -C STEP III: Form the right hand side matrix -C B(KH+1:N,KH+1:N) of the (smaller) Lyapunov -C equation to be solved during the next pass of -C the main loop. -C -C Compute auxiliary matrices M3 and Y. The factorization -C M3 = M3C * M3C**T is found by solving the symmetric -C eigenvalue problem. -C - CALL DLASET( 'U', 2*KB, 2*KB, ZERO, ONE, M3, 4 ) - CALL DSYRK( 'U', 'N', KB, KB, MONE, M2, 2, ONE, M3, 4 ) - CALL DGEMM( 'N', 'T', KB, KB, KB, MONE, M2, 2, M1, 2, - $ ZERO, M3(1,KB+1), 4 ) - CALL DSYRK( 'U', 'N', KB, KB, MONE, M1, 2, ONE, - $ M3(KB+1,KB+1), 4 ) - CALL DSYEVX( 'V', 'V', 'U', 2*KB, M3, 4, HALF, TWO, 1, 4, - $ TWO*UFLT, M, M3EW, M3C, 4, RW, 32, IW(5), - $ IW, INFO1 ) - IF ( INFO1 .NE. 0 ) THEN - INFO = 4 - RETURN - END IF - CALL DGEMM( 'T', 'N', N-KH, KB, KB, ONE, B(KL,KH+1), LDB, - $ M3C, 4, ZERO, DWORK(YPT), LDWS ) - CALL DGEMM( 'T', 'T', N-KH, KB, KB, ONE, A(KL,KH+1), LDA, - $ UI, 2, ZERO, DWORK(WPT), LDWS ) - DO 100 I = 1, N-KH - CALL DGEMV( 'T', MIN( I+1, N-KH ), KB, ONE, - $ DWORK(UIIPT), LDWS, A(KH+1,KH+I), 1, ONE, - $ DWORK(WPT+I-1), LDWS ) - 100 CONTINUE - CALL DGEMM( 'N', 'N', N-KH, KB, KB, ONE, DWORK(WPT), - $ LDWS, M3C(KB+1,1), 4, ONE, DWORK(YPT), LDWS ) -C -C Overwrite B(KH+1:N,KH+1:N) with the triangular matrix -C from the QR-factorization of the (N-KH+KB)-by-(N-KH) -C matrix -C -C ( B(KH+1:N,KH+1:N) ) -C ( ) -C ( Y**T ) . -C - DO 140 J = 1, KB - DO 120 I = 1, N-KH - X = B(KH+I,KH+I) - Z = DWORK(YPT+I-1+(J-1)*LDWS) - CALL DROTG( X, Z, C, S ) - CALL DROT( N-KH-I+1, B(KH+I,KH+I), LDB, - $ DWORK(YPT+I-1+(J-1)*LDWS), 1, C, S ) - 120 CONTINUE - 140 CONTINUE -C -C Make main diagonal elements of B(KH+1:N,KH+1:N) positive. -C - DO 160 I = KH+1, N - IF ( B(I,I) .LT. ZERO ) - $ CALL DSCAL( N-I+1, MONE, B(I,I), LDB ) - 160 CONTINUE -C -C Overwrite right hand side with the part of the solution -C computed in step II. -C - DO 180 J = KL, KH - CALL DCOPY( N-KH, DWORK(UIIPT+(J-KL)*LDWS), 1, - $ B(J,KH+1), LDB ) - 180 CONTINUE - END IF -C -C Overwrite right hand side with the part of the solution -C computed in step I. -C - CALL DLACPY( 'U', KB, KB, UI, 2, B(KL,KL), LDB ) -C - GOTO 20 - END IF -C END WHILE 20 -C - ELSE -C -C Solve equation (2). -C -C Main Loop. Compute block column U(1:KH,KL:KH). KB denotes the -C number of columns in this block column. -C - KL = N + 1 -C WHILE ( KL .GT. 1 ) DO - 200 IF ( KL .GT. 1 ) THEN - KH = KL - 1 - IF ( KH .EQ. 1 ) THEN - KL = 1 - KB = 1 - ELSE - IF ( A(KH,KH-1) .EQ. ZERO ) THEN - KL = KH - KB = 1 - ELSE - KL = KH - 1 - KB = 2 - END IF - END IF -C -C STEP I: Compute block U(KL:KH,KL:KH) and the auxiliary -C matrices M1 and M2. (For the moment the result -C U(KL:KH,KL:KH) is stored in UI). -C - IF ( KB .EQ. 1 ) THEN - DELTA1 = E(KL,KL)**2 - A(KL,KL)**2 - IF ( DELTA1 .LE. ZERO ) THEN - INFO = 3 - RETURN - END IF - DELTA1 = SQRT( DELTA1 ) - Z = TWO*ABS( B(KL,KL) )*SMLNUM - IF ( Z .GT. DELTA1 ) THEN - SCALE1 = DELTA1/Z - SCALE = SCALE1*SCALE - DO 220 I = 1, N - CALL DSCAL( I, SCALE1, B(1,I), 1 ) - 220 CONTINUE - END IF - UI(1,1) = B(KL,KL)/DELTA1 - M1(1,1) = A(KL,KL)/E(KL,KL) - M2(1,1) = DELTA1/E(KL,KL) - ELSE -C -C If a pair of complex conjugate eigenvalues occurs, apply -C (complex) Hammarling algorithm for the 2-by-2 problem. -C - CALL SG03BX( 'D', 'T', A(KL,KL), LDA, E(KL,KL), LDE, - $ B(KL,KL), LDB, UI, 2, SCALE1, M1, 2, M2, 2, - $ INFO1 ) - IF ( INFO1 .NE. 0 ) THEN - INFO = INFO1 - RETURN - END IF - IF ( SCALE1 .NE. ONE ) THEN - SCALE = SCALE1*SCALE - DO 240 I = 1, N - CALL DSCAL( I, SCALE1, B(1,I), 1 ) - 240 CONTINUE - END IF - END IF -C - IF ( KL .GT. 1 ) THEN -C -C STEP II: Compute U(1:KL-1,KL:KH) by solving a generalized -C Sylvester equation. (For the moment the result -C U(1:KL-1,KL:KH) is stored in the workspace.) -C -C Form right hand side of the Sylvester equation. -C - CALL DGEMM( 'N', 'T', KL-1, KB, KB, MONE, B(1,KL), LDB, - $ M2, 2, ZERO, DWORK(UIIPT), LDWS ) - CALL DGEMM( 'N', 'N', KL-1, KB, KB, ONE, E(1,KL), LDE, - $ UI, 2, ONE, DWORK(UIIPT), LDWS ) - CALL DGEMM( 'N', 'T', KB, KB, KB, ONE, UI, 2, M1, 2, - $ ZERO, TM, 2 ) - CALL DGEMM( 'N', 'N', KL-1, KB, KB, MONE, A(1,KL), LDA, - $ TM, 2, ONE, DWORK(UIIPT), LDWS ) -C -C Solve generalized Sylvester equation. -C - CALL DLASET( 'A', KB, KB, ZERO, MONE, TM, 2 ) - CALL SG03BW( 'T', KL-1, KB, A, LDA, M1, 2, E, LDE, TM, 2, - $ DWORK(UIIPT), LDWS, SCALE1, INFO1 ) - IF ( INFO1 .NE. 0 ) - $ INFO = 1 - IF ( SCALE1 .NE. ONE ) THEN - SCALE = SCALE1*SCALE - DO 260 I = 1, N - CALL DSCAL( I, SCALE1, B(1,I), 1 ) - 260 CONTINUE - CALL DSCAL( 4, SCALE1, UI(1,1), 1 ) - END IF -C -C STEP III: Form the right hand side matrix -C B(1:KL-1,1:KL-1) of the (smaller) Lyapunov -C equation to be solved during the next pass of -C the main loop. -C -C Compute auxiliary matrices M3 and Y. The factorization -C M3 = M3C * M3C**T is found by solving the symmetric -C eigenvalue problem. -C - CALL DLASET( 'U', 2*KB, 2*KB, ZERO, ONE, M3, 4 ) - CALL DSYRK( 'U', 'T', KB, KB, MONE, M2, 2, ONE, M3, 4 ) - CALL DGEMM( 'T', 'N', KB, KB, KB, MONE, M2, 2, M1, 2, - $ ZERO, M3(1,KB+1), 4 ) - CALL DSYRK( 'U', 'T', KB, KB, MONE, M1, 2, ONE, - $ M3(KB+1,KB+1), 4 ) - CALL DSYEVX( 'V', 'V', 'U', 2*KB, M3, 4, HALF, TWO, 1, 4, - $ TWO*UFLT, M, M3EW, M3C, 4, RW, 32, IW(5), - $ IW, INFO1 ) - IF ( INFO1 .NE. 0 ) THEN - INFO = 4 - RETURN - END IF - CALL DGEMM( 'N', 'N', KL-1, KB, KB, ONE, B(1,KL), LDB, - $ M3C, 4, ZERO, DWORK(YPT), LDWS ) - CALL DGEMM( 'N', 'N', KL-1, KB, KB, ONE, A(1,KL), LDA, - $ UI, 2, ZERO, DWORK(WPT), LDWS ) - DO 280 I = 1, KL-1 - CALL DGEMV( 'T', MIN( KL-I+1, KL-1 ), KB, ONE, - $ DWORK(MAX( UIIPT, UIIPT+I-2 )), LDWS, - $ A(I,MAX( I-1, 1 )), LDA, ONE, - $ DWORK(WPT+I-1), LDWS ) - 280 CONTINUE - CALL DGEMM( 'N', 'N', KL-1, KB, KB, ONE, DWORK(WPT), - $ LDWS, M3C(KB+1,1), 4, ONE, DWORK(YPT), LDWS ) -C -C Overwrite B(1:KL-1,1:KL-1) with the triangular matrix -C from the RQ-factorization of the (KL-1)-by-KH matrix -C -C ( ) -C ( B(1:KL-1,1:KL-1) Y ) -C ( ). -C - DO 320 J = 1, KB - DO 300 I = KL-1, 1, -1 - X = B(I,I) - Z = DWORK(YPT+I-1+(J-1)*LDWS) - CALL DROTG( X, Z, C, S ) - CALL DROT( I, B(1,I), 1, DWORK(YPT+(J-1)*LDWS), 1, - $ C, S ) - 300 CONTINUE - 320 CONTINUE -C -C Make main diagonal elements of B(1:KL-1,1:KL-1) positive. -C - DO 340 I = 1, KL-1 - IF ( B(I,I) .LT. ZERO ) - $ CALL DSCAL( I, MONE, B(1,I), 1 ) - 340 CONTINUE -C -C Overwrite right hand side with the part of the solution -C computed in step II. -C - CALL DLACPY( 'A', KL-1, KB, DWORK(UIIPT), LDWS, B(1,KL), - $ LDB ) -C - END IF -C -C Overwrite right hand side with the part of the solution -C computed in step I. -C - CALL DLACPY( 'U', KB, KB, UI, 2, B(KL,KL), LDB ) -C - GOTO 200 - END IF -C END WHILE 200 -C - END IF -C - RETURN -C *** Last line of SG03BU *** - END diff --git a/mex/sources/libslicot/SG03BV.f b/mex/sources/libslicot/SG03BV.f deleted file mode 100644 index edce6f0dc..000000000 --- a/mex/sources/libslicot/SG03BV.f +++ /dev/null @@ -1,645 +0,0 @@ - SUBROUTINE SG03BV( TRANS, N, A, LDA, E, LDE, B, LDB, SCALE, - $ DWORK, INFO ) -C -C SLICOT RELEASE 5.0. -C -C Copyright (c) 2002-2009 NICONET e.V. -C -C This program is free software: you can redistribute it and/or -C modify it under the terms of the GNU General Public License as -C published by the Free Software Foundation, either version 2 of -C the License, or (at your option) any later version. -C -C This program is distributed in the hope that it will be useful, -C but WITHOUT ANY WARRANTY; without even the implied warranty of -C MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the -C GNU General Public License for more details. -C -C You should have received a copy of the GNU General Public License -C along with this program. If not, see -C . -C -C PURPOSE -C -C To compute the Cholesky factor U of the matrix X, X = U**T * U or -C X = U * U**T, which is the solution of the generalized c-stable -C continuous-time Lyapunov equation -C -C T T 2 T -C A * X * E + E * X * A = - SCALE * B * B, (1) -C -C or the transposed equation -C -C T T 2 T -C A * X * E + E * X * A = - SCALE * B * B , (2) -C -C respectively, where A, E, B, and U are real N-by-N matrices. The -C Cholesky factor U of the solution is computed without first -C finding X. The pencil A - lambda * E must be in generalized Schur -C form ( A upper quasitriangular, E upper triangular ). Moreover, it -C must be c-stable, i.e. its eigenvalues must have negative real -C parts. B must be an upper triangular matrix with non-negative -C entries on its main diagonal. -C -C The resulting matrix U is upper triangular. The entries on its -C main diagonal are non-negative. SCALE is an output scale factor -C set to avoid overflow in U. -C -C ARGUMENTS -C -C Mode Parameters -C -C TRANS CHARACTER*1 -C Specifies whether equation (1) or equation (2) is to be -C solved: -C = 'N': Solve equation (1); -C = 'T': Solve equation (2). -C -C Input/Output Parameters -C -C N (input) INTEGER -C The order of the matrix A. N >= 0. -C -C A (input) DOUBLE PRECISION array, dimension (LDA,N) -C The leading N-by-N upper Hessenberg part of this array -C must contain the quasitriangular matrix A. -C -C LDA INTEGER -C The leading dimension of the array A. LDA >= MAX(1,N). -C -C E (input) DOUBLE PRECISION array, dimension (LDE,N) -C The leading N-by-N upper triangular part of this array -C must contain the matrix E. -C -C LDE INTEGER -C The leading dimension of the array E. LDE >= MAX(1,N). -C -C B (input/output) DOUBLE PRECISION array, dimension (LDB,N) -C On entry, the leading N-by-N upper triangular part of this -C array must contain the matrix B. -C On exit, the leading N-by-N upper triangular part of this -C array contains the solution matrix U. -C -C LDB INTEGER -C The leading dimension of the array B. LDB >= MAX(1,N). -C -C SCALE (output) DOUBLE PRECISION -C The scale factor set to avoid overflow in U. -C 0 < SCALE <= 1. -C -C Workspace -C -C DWORK DOUBLE PRECISION array, dimension (6*N-6) -C -C Error indicator -C -C INFO INTEGER -C = 0: successful exit; -C < 0: if INFO = -i, the i-th argument had an illegal -C value; -C = 1: the generalized Sylvester equation to be solved in -C step II (see METHOD) is (nearly) singular to working -C precision; perturbed values were used to solve the -C equation (but the matrices A and E are unchanged); -C = 2: the generalized Schur form of the pencil -C A - lambda * E contains a 2-by-2 main diagonal block -C whose eigenvalues are not a pair of conjugate -C complex numbers; -C = 3: the pencil A - lambda * E is not stable, i.e. there -C is an eigenvalue without a negative real part. -C -C METHOD -C -C The method [2] used by the routine is an extension of Hammarling's -C algorithm [1] to generalized Lyapunov equations. -C -C We present the method for solving equation (1). Equation (2) can -C be treated in a similar fashion. For simplicity, assume SCALE = 1. -C -C The matrix A is an upper quasitriangular matrix, i.e. it is a -C block triangular matrix with square blocks on the main diagonal -C and the block order at most 2. We use the following partitioning -C for the matrices A, E, B and the solution matrix U -C -C ( A11 A12 ) ( E11 E12 ) -C A = ( ), E = ( ), -C ( 0 A22 ) ( 0 E22 ) -C -C ( B11 B12 ) ( U11 U12 ) -C B = ( ), U = ( ). (3) -C ( 0 B22 ) ( 0 U22 ) -C -C The size of the (1,1)-blocks is 1-by-1 (iff A(2,1) = 0.0) or -C 2-by-2. -C -C We compute U11 and U12**T in three steps. -C -C Step I: -C -C From (1) and (3) we get the 1-by-1 or 2-by-2 equation -C -C T T T T -C A11 * U11 * U11 * E11 + E11 * U11 * U11 * A11 -C -C T -C = - B11 * B11. -C -C For brevity, details are omitted here. The technique for -C computing U11 is similar to those applied to standard Lyapunov -C equations in Hammarling's algorithm ([1], section 6). -C -C Furthermore, the auxiliary matrices M1 and M2 defined as -C follows -C -C -1 -1 -C M1 = U11 * A11 * E11 * U11 -C -C -1 -1 -C M2 = B11 * E11 * U11 -C -C are computed in a numerically reliable way. -C -C Step II: -C -C We solve for U12**T the generalized Sylvester equation -C -C T T T T -C A22 * U12 + E22 * U12 * M1 -C -C T T T T T -C = - B12 * M2 - A12 * U11 - E12 * U11 * M1. -C -C Step III: -C -C One can show that -C -C T T T T -C A22 * U22 * U22 * E22 + E22 * U22 * U22 * A22 = -C -C T T -C - B22 * B22 - y * y (4) -C -C holds, where y is defined as follows -C -C T T T T -C w = E12 * U11 + E22 * U12 -C T T -C y = B12 - w * M2 . -C -C If B22_tilde is the square triangular matrix arising from the -C QR-factorization -C -C ( B22_tilde ) ( B22 ) -C Q * ( ) = ( ), -C ( 0 ) ( y**T ) -C -C then -C -C T T T -C - B22 * B22 - y * y = - B22_tilde * B22_tilde. -C -C Replacing the right hand side in (4) by the term -C - B22_tilde**T * B22_tilde leads to a generalized Lyapunov -C equation of lower dimension compared to (1). -C -C The solution U of the equation (1) can be obtained by recursive -C application of the steps I to III. -C -C REFERENCES -C -C [1] Hammarling, S.J. -C Numerical solution of the stable, non-negative definite -C Lyapunov equation. -C IMA J. Num. Anal., 2, pp. 303-323, 1982. -C -C [2] Penzl, T. -C Numerical solution of generalized Lyapunov equations. -C Advances in Comp. Math., vol. 8, pp. 33-48, 1998. -C -C NUMERICAL ASPECTS -C -C The routine requires 2*N**3 flops. Note that we count a single -C floating point arithmetic operation as one flop. -C -C FURTHER COMMENTS -C -C The Lyapunov equation may be very ill-conditioned. In particular, -C if the pencil A - lambda * E has a pair of almost degenerate -C eigenvalues, then the Lyapunov equation will be ill-conditioned. -C Perturbed values were used to solve the equation. -C A condition estimate can be obtained from the routine SG03AD. -C When setting the error indicator INFO, the routine does not test -C for near instability in the equation but only for exact -C instability. -C -C CONTRIBUTOR -C -C T. Penzl, Technical University Chemnitz, Germany, Aug. 1998. -C -C REVISIONS -C -C Sep. 1998 (V. Sima). -C -C KEYWORDS -C -C Lyapunov equation -C -C ****************************************************************** -C -C .. Parameters .. - DOUBLE PRECISION MONE, ONE, TWO, ZERO - PARAMETER ( MONE = -1.0D0, ONE = 1.0D+0, TWO = 2.0D+0, - $ ZERO = 0.0D+0 ) -C .. Scalar Arguments .. - CHARACTER TRANS - DOUBLE PRECISION SCALE - INTEGER INFO, LDA, LDB, LDE, N -C .. Array Arguments .. - DOUBLE PRECISION A(LDA,*), B(LDB,*), DWORK(*), E(LDE,*) -C .. Local Scalars .. - DOUBLE PRECISION BIGNUM, C, DELTA1, EPS, S, SCALE1, SMLNUM, X, Z - INTEGER I, INFO1, J, KB, KH, KL, LDWS, UIIPT, WPT, YPT - LOGICAL NOTRNS -C .. Local Arrays .. - DOUBLE PRECISION M1(2,2), M2(2,2), TM(2,2), UI(2,2) -C .. External Functions .. - DOUBLE PRECISION DLAMCH - LOGICAL LSAME - EXTERNAL DLAMCH, LSAME -C .. External Subroutines .. - EXTERNAL DCOPY, DGEMM, DLABAD, DLACPY, DLASET, DROT, - $ DROTG, DSCAL, DTRMM, SG03BW, SG03BX, XERBLA -C .. Intrinsic Functions .. - INTRINSIC ABS, SQRT -C .. Executable Statements .. -C -C Decode input parameter. -C - NOTRNS = LSAME( TRANS, 'N' ) -C -C Check the scalar input parameters. -C - IF ( .NOT.( NOTRNS .OR. LSAME( TRANS, 'T' ) ) ) THEN - INFO = -1 - ELSEIF ( N .LT. 0 ) THEN - INFO = -2 - ELSEIF ( LDA .LT. MAX( 1, N ) ) THEN - INFO = -4 - ELSEIF ( LDE .LT. MAX( 1, N ) ) THEN - INFO = -6 - ELSEIF ( LDB .LT. MAX( 1, N ) ) THEN - INFO = -8 - ELSE - INFO = 0 - END IF - IF ( INFO .NE. 0 ) THEN - CALL XERBLA( 'SG03BV', -INFO ) - RETURN - END IF -C - SCALE = ONE -C -C Quick return if possible. -C - IF ( N .EQ. 0 ) - $ RETURN -C -C Set constants to control overflow. -C - EPS = DLAMCH( 'P' ) - SMLNUM = DLAMCH( 'S' )/EPS - BIGNUM = ONE/SMLNUM - CALL DLABAD( SMLNUM, BIGNUM ) -C -C Set work space pointers and leading dimension of matrices in -C work space. -C - UIIPT = 1 - WPT = 2*N-1 - YPT = 4*N-3 - LDWS = N-1 -C - IF ( NOTRNS ) THEN -C -C Solve equation (1). -C -C Main Loop. Compute block row U(KL:KH,KL:N). KB denotes the -C number of rows in this block row. -C - KH = 0 -C WHILE ( KH .LT. N ) DO - 20 IF ( KH .LT. N ) THEN - KL = KH + 1 - IF ( KL .EQ. N ) THEN - KH = N - KB = 1 - ELSE - IF ( A(KL+1,KL) .EQ. ZERO ) THEN - KH = KL - KB = 1 - ELSE - KH = KL + 1 - KB = 2 - END IF - END IF -C -C STEP I: Compute block U(KL:KH,KL:KH) and the auxiliary -C matrices M1 and M2. (For the moment the result -C U(KL:KH,KL:KH) is stored in UI). -C - IF ( KB .EQ. 1 ) THEN - DELTA1 = -TWO*A(KL,KL)*E(KL,KL) - IF ( DELTA1 .LE. ZERO ) THEN - INFO = 3 - RETURN - END IF - DELTA1 = SQRT( DELTA1 ) - Z = TWO*ABS( B(KL,KL) )*SMLNUM - IF ( Z .GT. DELTA1 ) THEN - SCALE1 = DELTA1/Z - SCALE = SCALE1*SCALE - DO 40 I = 1, N - CALL DSCAL( I, SCALE1, B(1,I), 1 ) - 40 CONTINUE - END IF - UI(1,1) = B(KL,KL)/DELTA1 - M1(1,1) = A(KL,KL)/E(KL,KL) - M2(1,1) = DELTA1/E(KL,KL) - ELSE -C -C If a pair of complex conjugate eigenvalues occurs, apply -C (complex) Hammarling algorithm for the 2-by-2 problem. -C - CALL SG03BX( 'C', 'N', A(KL,KL), LDA, E(KL,KL), LDE, - $ B(KL,KL), LDB, UI, 2, SCALE1, M1, 2, M2, 2, - $ INFO1 ) - IF ( INFO1 .NE. 0 ) THEN - INFO = INFO1 - RETURN - END IF - IF ( SCALE1 .NE. ONE ) THEN - SCALE = SCALE1*SCALE - DO 60 I = 1, N - CALL DSCAL( I, SCALE1, B(1,I), 1 ) - 60 CONTINUE - END IF - END IF -C - IF ( KH .LT. N ) THEN -C -C STEP II: Compute U(KL:KH,KH+1:N) by solving a generalized -C Sylvester equation. (For the moment the result -C U(KL:KH,KH+1:N) is stored in the workspace.) -C -C Form right hand side of the Sylvester equation. -C - CALL DGEMM( 'T', 'N', N-KH, KB, KB, MONE, B(KL,KH+1), - $ LDB, M2, 2, ZERO, DWORK(UIIPT), LDWS ) - CALL DGEMM( 'T', 'T', N-KH, KB, KB, MONE, A(KL,KH+1), - $ LDA, UI, 2, ONE, DWORK(UIIPT), LDWS ) - CALL DGEMM( 'T', 'N', KB, KB, KB, ONE, UI, 2, M1, 2, - $ ZERO, TM, 2 ) - CALL DGEMM( 'T', 'N', N-KH, KB, KB, MONE, E(KL,KH+1), - $ LDE, TM, 2, ONE, DWORK(UIIPT), LDWS ) -C -C Solve generalized Sylvester equation. -C - CALL DLASET( 'A', KB, KB, ZERO, ONE, TM, 2 ) - CALL SG03BW( 'N', N-KH, KB, A(KH+1,KH+1), LDA, TM, 2, - $ E(KH+1,KH+1), LDE, M1, 2, DWORK(UIIPT), - $ LDWS, SCALE1, INFO1 ) - IF ( INFO1 .NE. 0 ) - $ INFO = 1 - IF ( SCALE1 .NE. ONE ) THEN - SCALE = SCALE1*SCALE - DO 80 I = 1, N - CALL DSCAL( I, SCALE1, B(1,I), 1 ) - 80 CONTINUE - CALL DSCAL( 4, SCALE1, UI(1,1), 1 ) - END IF -C -C STEP III: Form the right hand side matrix -C B(KH+1:N,KH+1:N) of the (smaller) Lyapunov -C equation to be solved during the next pass of -C the main loop. -C -C Compute auxiliary vectors (or matrices) W and Y. -C - CALL DLACPY( 'A', N-KH, KB, DWORK(UIIPT), LDWS, - $ DWORK(WPT), LDWS ) - CALL DTRMM( 'L', 'U', 'T', 'N', N-KH, KB, ONE, - $ E(KH+1,KH+1), LDE, DWORK(WPT), LDWS ) - CALL DGEMM( 'T', 'T', N-KH, KB, KB, ONE, E(KL,KH+1), - $ LDE, UI, 2, ONE, DWORK(WPT), LDWS ) - DO 100 I = KL, KH - CALL DCOPY( N-KH, B(I,KH+1), LDB, - $ DWORK(YPT+LDWS*(I-KL)), 1 ) - 100 CONTINUE - CALL DGEMM( 'N', 'T', N-KH, KB, KB, MONE, DWORK(WPT), - $ LDWS, M2, 2, ONE, DWORK(YPT), LDWS ) -C -C Overwrite B(KH+1:N,KH+1:N) with the triangular matrix -C from the QR-factorization of the (N-KH+KB)-by-(N-KH) -C matrix -C -C ( B(KH+1:N,KH+1:N) ) -C ( ) -C ( Y**T ) . -C - DO 140 J = 1, KB - DO 120 I = 1, N-KH - X = B(KH+I,KH+I) - Z = DWORK(YPT+I-1+(J-1)*LDWS) - CALL DROTG( X, Z, C, S ) - CALL DROT( N-KH-I+1, B(KH+I,KH+I), LDB, - $ DWORK(YPT+I-1+(J-1)*LDWS), 1, C, S ) - 120 CONTINUE - 140 CONTINUE -C -C Make main diagonal elements of B(KH+1:N,KH+1:N) positive. -C - DO 160 I = KH+1, N - IF ( B(I,I) .LT. ZERO ) - $ CALL DSCAL( N-I+1, MONE, B(I,I), LDB ) - 160 CONTINUE -C -C Overwrite right hand side with the part of the solution -C computed in step II. -C - DO 180 J = KL, KH - CALL DCOPY( N-KH, DWORK(UIIPT+(J-KL)*LDWS), 1, - $ B(J,KH+1), LDB ) - 180 CONTINUE - END IF -C -C Overwrite right hand side with the part of the solution -C computed in step I. -C - CALL DLACPY( 'U', KB, KB, UI, 2, B(KL,KL), LDB ) -C - GOTO 20 - END IF -C END WHILE 20 -C - ELSE -C -C Solve equation (2). -C -C Main Loop. Compute block column U(1:KH,KL:KH). KB denotes the -C number of columns in this block column. -C - KL = N + 1 -C WHILE ( KL .GT. 1 ) DO - 200 IF ( KL .GT. 1 ) THEN - KH = KL - 1 - IF ( KH .EQ. 1 ) THEN - KL = 1 - KB = 1 - ELSE - IF ( A(KH,KH-1) .EQ. ZERO ) THEN - KL = KH - KB = 1 - ELSE - KL = KH - 1 - KB = 2 - END IF - END IF -C -C STEP I: Compute block U(KL:KH,KL:KH) and the auxiliary -C matrices M1 and M2. (For the moment the result -C U(KL:KH,KL:KH) is stored in UI). -C - IF ( KB .EQ. 1 ) THEN - DELTA1 = -TWO*A(KL,KL)*E(KL,KL) - IF ( DELTA1 .LE. ZERO ) THEN - INFO = 3 - RETURN - END IF - DELTA1 = SQRT( DELTA1 ) - Z = TWO*ABS( B(KL,KL) )*SMLNUM - IF ( Z .GT. DELTA1 ) THEN - SCALE1 = DELTA1/Z - SCALE = SCALE1*SCALE - DO 220 I = 1, N - CALL DSCAL( I, SCALE1, B(1,I), 1 ) - 220 CONTINUE - END IF - UI(1,1) = B(KL,KL)/DELTA1 - M1(1,1) = A(KL,KL)/E(KL,KL) - M2(1,1) = DELTA1/E(KL,KL) - ELSE -C -C If a pair of complex conjugate eigenvalues occurs, apply -C (complex) Hammarling algorithm for the 2-by-2 problem. -C - CALL SG03BX( 'C', 'T', A(KL,KL), LDA, E(KL,KL), LDE, - $ B(KL,KL), LDB, UI, 2, SCALE1, M1, 2, M2, 2, - $ INFO1 ) - IF ( INFO1 .NE. 0 ) THEN - INFO = INFO1 - RETURN - END IF - IF ( SCALE1 .NE. ONE ) THEN - SCALE = SCALE1*SCALE - DO 240 I = 1, N - CALL DSCAL( I, SCALE1, B(1,I), 1 ) - 240 CONTINUE - END IF - END IF -C - IF ( KL .GT. 1 ) THEN -C -C STEP II: Compute U(1:KL-1,KL:KH) by solving a generalized -C Sylvester equation. (For the moment the result -C U(1:KL-1,KL:KH) is stored in the workspace.) -C -C Form right hand side of the Sylvester equation. -C - CALL DGEMM( 'N', 'T', KL-1, KB, KB, MONE, B(1,KL), LDB, - $ M2, 2, ZERO, DWORK(UIIPT), LDWS ) - CALL DGEMM( 'N', 'N', KL-1, KB, KB, MONE, A(1,KL), LDA, - $ UI, 2, ONE, DWORK(UIIPT), LDWS ) - CALL DGEMM( 'N', 'T', KB, KB, KB, ONE, UI, 2, M1, 2, - $ ZERO, TM, 2 ) - CALL DGEMM( 'N', 'N', KL-1, KB, KB, MONE, E(1,KL), LDE, - $ TM, 2, ONE, DWORK(UIIPT), LDWS ) -C -C Solve generalized Sylvester equation. -C - CALL DLASET( 'A', KB, KB, ZERO, ONE, TM, 2 ) - CALL SG03BW( 'T', KL-1, KB, A, LDA, TM, 2, E, LDE, M1, 2, - $ DWORK(UIIPT), LDWS, SCALE1, INFO1 ) - IF ( INFO1 .NE. 0 ) - $ INFO = 1 - IF ( SCALE1 .NE. ONE ) THEN - SCALE = SCALE1*SCALE - DO 260 I = 1, N - CALL DSCAL( I, SCALE1, B(1,I), 1 ) - 260 CONTINUE - CALL DSCAL( 4, SCALE1, UI(1,1), 1 ) - END IF -C -C STEP III: Form the right hand side matrix -C B(1:KL-1,1:KL-1) of the (smaller) Lyapunov -C equation to be solved during the next pass of -C the main loop. -C -C Compute auxiliary vectors (or matrices) W and Y. -C - CALL DLACPY( 'A', KL-1, KB, DWORK(UIIPT), LDWS, - $ DWORK(WPT), LDWS ) - CALL DTRMM( 'L', 'U', 'N', 'N', KL-1, KB, ONE, E(1,1), - $ LDE, DWORK(WPT), LDWS ) - CALL DGEMM( 'N', 'N', KL-1, KB, KB, ONE, E(1,KL), LDE, - $ UI, 2, ONE, DWORK(WPT), LDWS ) - CALL DLACPY( 'A', KL-1, KB, B(1, KL), LDB, DWORK(YPT), - $ LDWS ) - CALL DGEMM( 'N', 'N', KL-1, KB, KB, MONE, DWORK(WPT), - $ LDWS, M2, 2, ONE, DWORK(YPT), LDWS ) -C -C Overwrite B(1:KL-1,1:KL-1) with the triangular matrix -C from the RQ-factorization of the (KL-1)-by-KH matrix -C -C ( ) -C ( B(1:KL-1,1:KL-1) Y ) -C ( ). -C - DO 300 J = 1, KB - DO 280 I = KL-1, 1, -1 - X = B(I,I) - Z = DWORK(YPT+I-1+(J-1)*LDWS) - CALL DROTG( X, Z, C, S ) - CALL DROT( I, B(1,I), 1, DWORK(YPT+(J-1)*LDWS), 1, - $ C, S ) - 280 CONTINUE - 300 CONTINUE -C -C Make main diagonal elements of B(1:KL-1,1:KL-1) positive. -C - DO 320 I = 1, KL-1 - IF ( B(I,I) .LT. ZERO ) - $ CALL DSCAL( I, MONE, B(1,I), 1 ) - 320 CONTINUE -C -C Overwrite right hand side with the part of the solution -C computed in step II. -C - CALL DLACPY( 'A', KL-1, KB, DWORK(UIIPT), LDWS, B(1,KL), - $ LDB ) -C - END IF -C -C Overwrite right hand side with the part of the solution -C computed in step I. -C - CALL DLACPY( 'U', KB, KB, UI, 2, B(KL,KL), LDB ) -C - GOTO 200 - END IF -C END WHILE 200 -C - END IF -C - RETURN -C *** Last line of SG03BV *** - END diff --git a/mex/sources/libslicot/SG03BW.f b/mex/sources/libslicot/SG03BW.f deleted file mode 100644 index aed45369f..000000000 --- a/mex/sources/libslicot/SG03BW.f +++ /dev/null @@ -1,459 +0,0 @@ - SUBROUTINE SG03BW( TRANS, M, N, A, LDA, C, LDC, E, LDE, D, LDD, X, - $ LDX, SCALE, INFO ) -C -C SLICOT RELEASE 5.0. -C -C Copyright (c) 2002-2009 NICONET e.V. -C -C This program is free software: you can redistribute it and/or -C modify it under the terms of the GNU General Public License as -C published by the Free Software Foundation, either version 2 of -C the License, or (at your option) any later version. -C -C This program is distributed in the hope that it will be useful, -C but WITHOUT ANY WARRANTY; without even the implied warranty of -C MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the -C GNU General Public License for more details. -C -C You should have received a copy of the GNU General Public License -C along with this program. If not, see -C . -C -C PURPOSE -C -C To solve for X the generalized Sylvester equation -C -C T T -C A * X * C + E * X * D = SCALE * Y, (1) -C -C or the transposed equation -C -C T T -C A * X * C + E * X * D = SCALE * Y, (2) -C -C where A and E are real M-by-M matrices, C and D are real N-by-N -C matrices, X and Y are real M-by-N matrices. N is either 1 or 2. -C The pencil A - lambda * E must be in generalized real Schur form -C (A upper quasitriangular, E upper triangular). SCALE is an output -C scale factor, set to avoid overflow in X. -C -C ARGUMENTS -C -C Mode Parameters -C -C TRANS CHARACTER*1 -C Specifies whether the transposed equation is to be solved -C or not: -C = 'N': Solve equation (1); -C = 'T': Solve equation (2). -C -C Input/Output Parameters -C -C M (input) INTEGER -C The order of the matrices A and E. M >= 0. -C -C N (input) INTEGER -C The order of the matrices C and D. N = 1 or N = 2. -C -C A (input) DOUBLE PRECISION array, dimension (LDA,M) -C The leading M-by-M part of this array must contain the -C upper quasitriangular matrix A. The elements below the -C upper Hessenberg part are not referenced. -C -C LDA INTEGER -C The leading dimension of the array A. LDA >= MAX(1,M). -C -C C (input) DOUBLE PRECISION array, dimension (LDC,N) -C The leading N-by-N part of this array must contain the -C matrix C. -C -C LDC INTEGER -C The leading dimension of the array C. LDC >= MAX(1,N). -C -C E (input) DOUBLE PRECISION array, dimension (LDE,M) -C The leading M-by-M part of this array must contain the -C upper triangular matrix E. The elements below the main -C diagonal are not referenced. -C -C LDE INTEGER -C The leading dimension of the array E. LDE >= MAX(1,M). -C -C D (input) DOUBLE PRECISION array, dimension (LDD,N) -C The leading N-by-N part of this array must contain the -C matrix D. -C -C LDD INTEGER -C The leading dimension of the array D. LDD >= MAX(1,N). -C -C X (input/output) DOUBLE PRECISION array, dimension (LDX,N) -C On entry, the leading M-by-N part of this array must -C contain the right hand side matrix Y. -C On exit, the leading M-by-N part of this array contains -C the solution matrix X. -C -C LDX INTEGER -C The leading dimension of the array X. LDX >= MAX(1,M). -C -C SCALE (output) DOUBLE PRECISION -C The scale factor set to avoid overflow in X. -C 0 < SCALE <= 1. -C -C Error indicator -C -C INFO INTEGER -C = 0: successful exit; -C < 0: if INFO = -i, the i-th argument had an illegal -C value; -C = 1: the generalized Sylvester equation is (nearly) -C singular to working precision; perturbed values -C were used to solve the equation (but the matrices -C A, C, D, and E are unchanged). -C -C METHOD -C -C The method used by the routine is based on a generalization of the -C algorithm due to Bartels and Stewart [1]. See also [2] and [3] for -C details. -C -C REFERENCES -C -C [1] Bartels, R.H., Stewart, G.W. -C Solution of the equation A X + X B = C. -C Comm. A.C.M., 15, pp. 820-826, 1972. -C -C [2] Gardiner, J.D., Laub, A.J., Amato, J.J., Moler, C.B. -C Solution of the Sylvester Matrix Equation -C A X B**T + C X D**T = E. -C A.C.M. Trans. Math. Soft., vol. 18, no. 2, pp. 223-231, 1992. -C -C [3] Penzl, T. -C Numerical solution of generalized Lyapunov equations. -C Advances in Comp. Math., vol. 8, pp. 33-48, 1998. -C -C NUMERICAL ASPECTS -C -C The routine requires about 2 * N * M**2 flops. Note that we count -C a single floating point arithmetic operation as one flop. -C -C The algorithm is backward stable if the eigenvalues of the pencil -C A - lambda * E are real. Otherwise, linear systems of order at -C most 4 are involved into the computation. These systems are solved -C by Gauss elimination with complete pivoting. The loss of stability -C of the Gauss elimination with complete pivoting is rarely -C encountered in practice. -C -C FURTHER COMMENTS -C -C When near singularity is detected, perturbed values are used -C to solve the equation (but the given matrices are unchanged). -C -C CONTRIBUTOR -C -C T. Penzl, Technical University Chemnitz, Germany, Aug. 1998. -C -C REVISIONS -C -C Sep. 1998 (V. Sima). -C -C KEYWORDS -C -C Lyapunov equation -C -C ****************************************************************** -C -C .. Parameters .. - DOUBLE PRECISION MONE, ONE, ZERO - PARAMETER ( MONE = -1.0D+0, ONE = 1.0D+0, ZERO = 0.0D+0 ) -C .. Scalar Arguments .. - CHARACTER TRANS - DOUBLE PRECISION SCALE - INTEGER INFO, LDA, LDC, LDD, LDE, LDX, M, N -C .. Array Arguments .. - DOUBLE PRECISION A(LDA,*), C(LDC,*), D(LDD,*), E(LDE,*), X(LDX,*) -C .. Local Scalars .. - DOUBLE PRECISION SCALE1 - INTEGER DIMMAT, I, INFO1, J, MA, MAI, MAJ, MB, ME - LOGICAL NOTRNS -C .. Local Arrays .. - DOUBLE PRECISION MAT(4,4), RHS(4), TM(2,2) - INTEGER PIV1(4), PIV2(4) -C .. External Functions .. - LOGICAL LSAME - EXTERNAL LSAME -C .. External Subroutines .. - EXTERNAL DGEMM, DSCAL, MB02UU, MB02UV, XERBLA -C .. Intrinsic Functions .. - INTRINSIC MAX -C -C Decode input parameters. -C - NOTRNS = LSAME( TRANS, 'N' ) -C -C Check the scalar input parameters. -C - IF ( .NOT.( NOTRNS .OR. LSAME( TRANS, 'T' ) ) ) THEN - INFO = -1 - ELSEIF ( M .LT. 0 ) THEN - INFO = -2 - ELSEIF ( N .NE. 1 .AND. N .NE. 2 ) THEN - INFO = -3 - ELSEIF ( LDA .LT. MAX( 1, M ) ) THEN - INFO = -5 - ELSEIF ( LDC .LT. MAX( 1, N ) ) THEN - INFO = -7 - ELSEIF ( LDE .LT. MAX( 1, M ) ) THEN - INFO = -9 - ELSEIF ( LDD .LT. MAX( 1, N ) ) THEN - INFO = -11 - ELSEIF ( LDX .LT. MAX( 1, M ) ) THEN - INFO = -13 - ELSE - INFO = 0 - END IF - IF ( INFO .NE. 0 ) THEN - CALL XERBLA( 'SG03BW', -INFO ) - RETURN - END IF -C - SCALE = ONE -C -C Quick return if possible. -C - IF ( M .EQ. 0 ) - $ RETURN -C - IF ( NOTRNS ) THEN -C -C Solve equation (1). -C -C Compute block row X(MA:ME,:). MB denotes the number of rows in -C this block row. -C - ME = 0 -C WHILE ( ME .NE. M ) DO - 20 IF ( ME .NE. M ) THEN - MA = ME + 1 - IF ( MA .EQ. M ) THEN - ME = M - MB = 1 - ELSE - IF ( A(MA+1,MA) .EQ. ZERO ) THEN - ME = MA - MB = 1 - ELSE - ME = MA + 1 - MB = 2 - END IF - END IF -C -C Assemble Kronecker product system of linear equations with -C matrix -C -C MAT = kron(C',A(MA:ME,MA:ME)') + kron(D',E(MA:ME,MA:ME)') -C -C and right hand side -C -C RHS = vec(X(MA:ME,:)). -C - IF ( N .EQ. 1 ) THEN - DIMMAT = MB - DO 60 I = 1, MB - MAI = MA + I - 1 - DO 40 J = 1, MB - MAJ = MA + J - 1 - MAT(I,J) = C(1,1)*A(MAJ,MAI) - IF ( MAJ .LE. MAI ) - $ MAT(I,J) = MAT(I,J) + D(1,1)*E(MAJ,MAI) - 40 CONTINUE - RHS(I) = X(MAI,1) - 60 CONTINUE - ELSE - DIMMAT = 2*MB - DO 100 I = 1, MB - MAI = MA + I - 1 - DO 80 J = 1, MB - MAJ = MA + J - 1 - MAT(I,J) = C(1,1)*A(MAJ,MAI) - MAT(MB+I,J) = C(1,2)*A(MAJ,MAI) - MAT(I,MB+J) = C(2,1)*A(MAJ,MAI) - MAT(MB+I,MB+J) = C(2,2)*A(MAJ,MAI) - IF ( MAJ .LE. MAI ) THEN - MAT(I,J) = MAT(I,J) + D(1,1)*E(MAJ,MAI) - MAT(MB+I,J) = MAT(MB+I,J) + D(1,2)*E(MAJ,MAI) - MAT(I,MB+J) = MAT(I,MB+J) + D(2,1)*E(MAJ,MAI) - MAT(MB+I,MB+J) = MAT(MB+I,MB+J) + - $ D(2,2)*E(MAJ,MAI) - END IF - 80 CONTINUE - RHS(I) = X(MAI,1) - RHS(MB+I) = X(MAI,2) - 100 CONTINUE - END IF -C -C Solve the system of linear equations. -C - CALL MB02UV( DIMMAT, MAT, 4, PIV1, PIV2, INFO1 ) - IF ( INFO1 .NE. 0 ) - $ INFO = 1 - CALL MB02UU( DIMMAT, MAT, 4, RHS, PIV1, PIV2, SCALE1 ) - IF ( SCALE1 .NE. ONE ) THEN - SCALE = SCALE1*SCALE - DO 120 I = 1, N - CALL DSCAL( M, SCALE1, X(1,I), 1 ) - 120 CONTINUE - END IF -C - IF ( N .EQ. 1 ) THEN - DO 140 I = 1, MB - MAI = MA + I - 1 - X(MAI,1) = RHS(I) - 140 CONTINUE - ELSE - DO 160 I = 1, MB - MAI = MA + I - 1 - X(MAI,1) = RHS(I) - X(MAI,2) = RHS(MB+I) - 160 CONTINUE - END IF -C -C Update right hand sides. -C -C X(ME+1:M,:) = X(ME+1:M,:) - A(MA:ME,ME+1:M)'*X(MA:ME,:)*C -C -C X(ME+1:M,:) = X(ME+1:M,:) - E(MA:ME,ME+1:M)'*X(MA:ME,:)*D -C - IF ( ME .LT. M ) THEN - CALL DGEMM( 'N', 'N', MB, N, N, ONE, X(MA,1), LDX, C, - $ LDC, ZERO, TM, 2 ) - CALL DGEMM( 'T', 'N', M-ME, N, MB, MONE, A(MA,ME+1), - $ LDA, TM, 2, ONE, X(ME+1,1), LDX ) - CALL DGEMM( 'N', 'N', MB, N, N, ONE, X(MA,1), LDX, D, - $ LDD, ZERO, TM, 2 ) - CALL DGEMM( 'T', 'N', M-ME, N, MB, MONE, E(MA,ME+1), LDE, - $ TM, 2, ONE, X(ME+1,1), LDX ) - END IF -C - GOTO 20 - END IF -C END WHILE 20 -C - ELSE -C -C Solve equation (2). -C -C Compute block row X(MA:ME,:). MB denotes the number of rows in -C this block row. -C - MA = M + 1 -C WHILE ( MA .NE. 1 ) DO - 180 IF ( MA .NE. 1 ) THEN - ME = MA - 1 - IF ( ME .EQ. 1 ) THEN - MA = 1 - MB = 1 - ELSE - IF ( A(ME,ME-1) .EQ. ZERO ) THEN - MA = ME - MB = 1 - ELSE - MA = ME - 1 - MB = 2 - END IF - END IF -C -C Assemble Kronecker product system of linear equations with -C matrix -C -C MAT = kron(C,A(MA:ME,MA:ME)) + kron(D,E(MA:ME,MA:ME)) -C -C and right hand side -C -C RHS = vec(X(MA:ME,:)). -C - IF ( N .EQ. 1 ) THEN - DIMMAT = MB - DO 220 I = 1, MB - MAI = MA + I - 1 - DO 200 J = 1, MB - MAJ = MA + J - 1 - MAT(I,J) = C(1,1)*A(MAI,MAJ) - IF ( MAJ .GE. MAI ) - $ MAT(I,J) = MAT(I,J) + D(1,1)*E(MAI,MAJ) - 200 CONTINUE - RHS(I) = X(MAI,1) - 220 CONTINUE - ELSE - DIMMAT = 2*MB - DO 260 I = 1, MB - MAI = MA + I - 1 - DO 240 J = 1, MB - MAJ = MA + J - 1 - MAT(I,J) = C(1,1)*A(MAI,MAJ) - MAT(MB+I,J) = C(2,1)*A(MAI,MAJ) - MAT(I,MB+J) = C(1,2)*A(MAI,MAJ) - MAT(MB+I,MB+J) = C(2,2)*A(MAI,MAJ) - IF ( MAJ .GE. MAI ) THEN - MAT(I,J) = MAT(I,J) + D(1,1)*E(MAI,MAJ) - MAT(MB+I,J) = MAT(MB+I,J) + D(2,1)*E(MAI,MAJ) - MAT(I,MB+J) = MAT(I,MB+J) + D(1,2)*E(MAI,MAJ) - MAT(MB+I,MB+J) = MAT(MB+I,MB+J) + - $ D(2,2)*E(MAI,MAJ) - END IF - 240 CONTINUE - RHS(I) = X(MAI,1) - RHS(MB+I) = X(MAI,2) - 260 CONTINUE - END IF -C -C Solve the system of linear equations. -C - CALL MB02UV( DIMMAT, MAT, 4, PIV1, PIV2, INFO1 ) - IF ( INFO1 .NE. 0 ) - $ INFO = 1 - CALL MB02UU( DIMMAT, MAT, 4, RHS, PIV1, PIV2, SCALE1 ) - IF ( SCALE1 .NE. ONE ) THEN - SCALE = SCALE1*SCALE - DO 280 I = 1, N - CALL DSCAL( M, SCALE1, X(1,I), 1 ) - 280 CONTINUE - END IF -C - IF ( N .EQ. 1 ) THEN - DO 300 I = 1, MB - MAI = MA + I - 1 - X(MAI,1) = RHS(I) - 300 CONTINUE - ELSE - DO 320 I = 1, MB - MAI = MA + I - 1 - X(MAI,1) = RHS(I) - X(MAI,2) = RHS(MB+I) - 320 CONTINUE - END IF -C -C Update right hand sides. -C -C X(1:MA-1,:) = X(1:MA-1,:) - A(1:MA-1,MA:ME)*X(MA:ME,:)*C' -C -C X(1:MA-1,:) = X(1:MA-1,:) - E(1:MA-1,MA:ME)*X(MA:ME,:)*D' -C - IF ( MA .GT. 1 ) THEN - CALL DGEMM( 'N', 'T', MB, N, N, ONE, X(MA,1), LDX, C, - $ LDC, ZERO, TM, 2 ) - CALL DGEMM( 'N', 'N', MA-1, N, MB, MONE, A(1,MA), LDA, - $ TM, 2, ONE, X, LDX ) - CALL DGEMM( 'N', 'T', MB, N, N, ONE, X(MA,1), LDX, D, - $ LDD, ZERO, TM, 2 ) - CALL DGEMM( 'N', 'N', MA-1, N, MB, MONE, E(1,MA), LDE, - $ TM, 2, ONE, X, LDX ) - END IF -C - GOTO 180 - END IF -C END WHILE 180 -C - END IF -C - RETURN -C *** Last line of SG03BW *** - END diff --git a/mex/sources/libslicot/SG03BX.f b/mex/sources/libslicot/SG03BX.f deleted file mode 100644 index 651716cd9..000000000 --- a/mex/sources/libslicot/SG03BX.f +++ /dev/null @@ -1,764 +0,0 @@ - SUBROUTINE SG03BX( DICO, TRANS, A, LDA, E, LDE, B, LDB, U, LDU, - $ SCALE, M1, LDM1, M2, LDM2, INFO ) -C -C SLICOT RELEASE 5.0. -C -C Copyright (c) 2002-2009 NICONET e.V. -C -C This program is free software: you can redistribute it and/or -C modify it under the terms of the GNU General Public License as -C published by the Free Software Foundation, either version 2 of -C the License, or (at your option) any later version. -C -C This program is distributed in the hope that it will be useful, -C but WITHOUT ANY WARRANTY; without even the implied warranty of -C MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the -C GNU General Public License for more details. -C -C You should have received a copy of the GNU General Public License -C along with this program. If not, see -C . -C -C PURPOSE -C -C To solve for X = op(U)**T * op(U) either the generalized c-stable -C continuous-time Lyapunov equation -C -C T T -C op(A) * X * op(E) + op(E) * X * op(A) -C -C 2 T -C = - SCALE * op(B) * op(B), (1) -C -C or the generalized d-stable discrete-time Lyapunov equation -C -C T T -C op(A) * X * op(A) - op(E) * X * op(E) -C -C 2 T -C = - SCALE * op(B) * op(B), (2) -C -C where op(K) is either K or K**T for K = A, B, E, U. The Cholesky -C factor U of the solution is computed without first finding X. -C -C Furthermore, the auxiliary matrices -C -C -1 -1 -C M1 := op(U) * op(A) * op(E) * op(U) -C -C -1 -1 -C M2 := op(B) * op(E) * op(U) -C -C are computed in a numerically reliable way. -C -C The matrices A, B, E, M1, M2, and U are real 2-by-2 matrices. The -C pencil A - lambda * E must have a pair of complex conjugate -C eigenvalues. The eigenvalues must be in the open right half plane -C (in the continuous-time case) or inside the unit circle (in the -C discrete-time case). -C -C The resulting matrix U is upper triangular. The entries on its -C main diagonal are non-negative. SCALE is an output scale factor -C set to avoid overflow in U. -C -C ARGUMENTS -C -C Mode Parameters -C -C DICO CHARACTER*1 -C Specifies whether the continuous-time or the discrete-time -C equation is to be solved: -C = 'C': Solve continuous-time equation (1); -C = 'D': Solve discrete-time equation (2). -C -C TRANS CHARACTER*1 -C Specifies whether the transposed equation is to be solved -C or not: -C = 'N': op(K) = K, K = A, B, E, U; -C = 'T': op(K) = K**T, K = A, B, E, U. -C -C Input/Output Parameters -C -C A (input) DOUBLE PRECISION array, dimension (LDA,2) -C The leading 2-by-2 part of this array must contain the -C matrix A. -C -C LDA INTEGER -C The leading dimension of the array A. LDA >= 2. -C -C E (input) DOUBLE PRECISION array, dimension (LDE,2) -C The leading 2-by-2 upper triangular part of this array -C must contain the matrix E. -C -C LDE INTEGER -C The leading dimension of the array E. LDE >= 2. -C -C B (input) DOUBLE PRECISION array, dimension (LDB,2) -C The leading 2-by-2 upper triangular part of this array -C must contain the matrix B. -C -C LDB INTEGER -C The leading dimension of the array B. LDB >= 2. -C -C U (output) DOUBLE PRECISION array, dimension (LDU,2) -C The leading 2-by-2 part of this array contains the upper -C triangular matrix U. -C -C LDU INTEGER -C The leading dimension of the array U. LDU >= 2. -C -C SCALE (output) DOUBLE PRECISION -C The scale factor set to avoid overflow in U. -C 0 < SCALE <= 1. -C -C M1 (output) DOUBLE PRECISION array, dimension (LDM1,2) -C The leading 2-by-2 part of this array contains the -C matrix M1. -C -C LDM1 INTEGER -C The leading dimension of the array M1. LDM1 >= 2. -C -C M2 (output) DOUBLE PRECISION array, dimension (LDM2,2) -C The leading 2-by-2 part of this array contains the -C matrix M2. -C -C LDM2 INTEGER -C The leading dimension of the array M2. LDM2 >= 2. -C -C Error indicator -C -C INFO INTEGER -C = 0: successful exit; -C = 2: the eigenvalues of the pencil A - lambda * E are not -C a pair of complex conjugate numbers; -C = 3: the eigenvalues of the pencil A - lambda * E are -C not in the open right half plane (in the continuous- -C time case) or inside the unit circle (in the -C discrete-time case). -C -C METHOD -C -C The method used by the routine is based on a generalization of the -C method due to Hammarling ([1], section 6) for Lyapunov equations -C of order 2. A more detailed description is given in [2]. -C -C REFERENCES -C -C [1] Hammarling, S.J. -C Numerical solution of the stable, non-negative definite -C Lyapunov equation. -C IMA J. Num. Anal., 2, pp. 303-323, 1982. -C -C [2] Penzl, T. -C Numerical solution of generalized Lyapunov equations. -C Advances in Comp. Math., vol. 8, pp. 33-48, 1998. -C -C FURTHER COMMENTS -C -C If the solution matrix U is singular, the matrices M1 and M2 are -C properly set (see [1], equation (6.21)). -C -C CONTRIBUTOR -C -C T. Penzl, Technical University Chemnitz, Germany, Aug. 1998. -C -C REVISIONS -C -C Sep. 1998 (V. Sima). -C Dec. 1998 (V. Sima). -C July 2003 (V. Sima; suggested by Klaus Schnepper). -C Oct. 2003 (A. Varga). -C -C ****************************************************************** -C -C .. Parameters .. - DOUBLE PRECISION MONE, ONE, TWO, ZERO - PARAMETER ( MONE = -1.0D+0, ONE = 1.0D+0, TWO = 2.0D+0, - $ ZERO = 0.0D+0) -C .. Scalar Arguments .. - CHARACTER DICO, TRANS - DOUBLE PRECISION SCALE - INTEGER INFO, LDA, LDB, LDE, LDM1, LDM2, LDU -C .. Array Arguments .. - DOUBLE PRECISION A(LDA,*), B(LDB,*), E(LDE,*), M1(LDM1,*), - $ M2(LDM2,*), U(LDU,*) -C .. Local Scalars .. - DOUBLE PRECISION ALPHA, B11, B12I, B12R, B22, BETAI, BETAR, - $ BIGNUM, CI, CR, EPS, L, LAMI, LAMR, SCALE1, - $ SCALE2, SI, SMLNUM, SR, T, V, W, XR, XI, YR, YI - LOGICAL ISCONT, ISTRNS -C .. Local Arrays .. - DOUBLE PRECISION AA(2,2), AI(2,2), AR(2,2), BB(2,2), BI(2,2), - $ BR(2,2), EE(2,2), EI(2,2), ER(2,2), M1I(2,2), - $ M1R(2,2), M2I(2,2), M2R(2,2), QBI(2,2), - $ QBR(2,2), QI(2,2), QR(2,2), QUI(2,2), QUR(2,2), - $ TI(2,2), TR(2,2), UI(2,2), UR(2,2), ZI(2,2), - $ ZR(2,2) -C .. External Functions .. - DOUBLE PRECISION DLAMCH, DLAPY2 - LOGICAL LSAME - EXTERNAL DLAMCH, DLAPY2, LSAME -C .. External Subroutines .. - EXTERNAL DCOPY, DGEMM, DGEMV, DLABAD, DLADIV, DLAG2, - $ SG03BY -C .. Intrinsic Functions .. - INTRINSIC ABS, MAX, MIN, SQRT -C -C Decode input parameters. -C - ISTRNS = LSAME( TRANS, 'T' ) - ISCONT = LSAME( DICO, 'C' ) -C -C Do not check input parameters for errors. -C -C Set constants to control overflow. -C - EPS = DLAMCH( 'P' ) - SMLNUM = DLAMCH( 'S' )/EPS - BIGNUM = ONE/SMLNUM - CALL DLABAD( SMLNUM, BIGNUM ) -C - INFO = 0 - SCALE = ONE -C -C Make copies of A, E, and B. -C - AA(1,1) = A(1,1) - AA(2,1) = A(2,1) - AA(1,2) = A(1,2) - AA(2,2) = A(2,2) - EE(1,1) = E(1,1) - EE(2,1) = ZERO - EE(1,2) = E(1,2) - EE(2,2) = E(2,2) - BB(1,1) = B(1,1) - BB(2,1) = ZERO - BB(1,2) = B(1,2) - BB(2,2) = B(2,2) -C -C If the transposed equation (op(K)=K**T, K=A,B,E,U) is to be -C solved, transpose the matrices A, E, B with respect to the -C anti-diagonal. This results in a non-transposed equation. -C - IF ( ISTRNS ) THEN - V = AA(1,1) - AA(1,1) = AA(2,2) - AA(2,2) = V - V = EE(1,1) - EE(1,1) = EE(2,2) - EE(2,2) = V - V = BB(1,1) - BB(1,1) = BB(2,2) - BB(2,2) = V - END IF -C -C Perform QZ-step to transform the pencil A - lambda * E to -C generalized Schur form. The main diagonal of the Schur factor of E -C is real and positive. -C -C Compute eigenvalues (LAMR + LAMI * I, LAMR - LAMI * I). -C - T = MAX( EPS*MAX( ABS( EE(1,1) ), ABS( EE(1,2) ), - $ ABS( EE(2,2) ) ), SMLNUM ) - IF ( MIN( ABS( EE(1,1) ), ABS( EE(2,2) ) ) .LT. T ) THEN - INFO = 3 - RETURN - END IF - CALL DLAG2( AA, 2, EE, 2, SMLNUM*EPS, SCALE1, SCALE2, LAMR, - $ W, LAMI ) - IF (LAMI .LE. ZERO) THEN - INFO = 2 - RETURN - END IF -C -C Compute right orthogonal transformation matrix Q. -C - CALL SG03BY( SCALE1*AA(1,1) - EE(1,1)*LAMR, -EE(1,1)*LAMI, - $ SCALE1*AA(2,1), ZERO, CR, CI, SR, SI, L ) - QR(1,1) = CR - QR(1,2) = SR - QR(2,1) = -SR - QR(2,2) = CR - QI(1,1) = -CI - QI(1,2) = -SI - QI(2,1) = -SI - QI(2,2) = CI -C -C A := Q * A -C - CALL DGEMM( 'N', 'N', 2, 2, 2, ONE, QR, 2, AA, 2, ZERO, AR, 2 ) - CALL DGEMM( 'N', 'N', 2, 2, 2, ONE, QI, 2, AA, 2, ZERO, AI, 2 ) -C -C E := Q * E -C - CALL DGEMM( 'N', 'N', 2, 2, 2, ONE, QR, 2, EE, 2, ZERO, ER, 2 ) - CALL DGEMM( 'N', 'N', 2, 2, 2, ONE, QI, 2, EE, 2, ZERO, EI, 2 ) -C -C Compute left orthogonal transformation matrix Z. -C - CALL SG03BY( ER(2,2), EI(2,2), ER(2,1), EI(2,1), CR, CI, SR, SI, - $ L ) - ZR(1,1) = CR - ZR(1,2) = SR - ZR(2,1) = -SR - ZR(2,2) = CR - ZI(1,1) = CI - ZI(1,2) = -SI - ZI(2,1) = -SI - ZI(2,2) = -CI -C -C E := E * Z -C - CALL DGEMV( 'T', 2, 2, ONE, ZR, 2, ER, 2, ZERO, TR, 2 ) - CALL DGEMV( 'T', 2, 2, MONE, ZI, 2, EI, 2, ONE, TR, 2 ) - CALL DGEMV( 'T', 2, 2, ONE, ZI, 2, ER, 2, ZERO, TI, 2 ) - CALL DGEMV( 'T', 2, 2, ONE, ZR, 2, EI, 2, ONE, TI, 2 ) - CALL DCOPY( 2, TR, 2, ER, 2 ) - CALL DCOPY( 2, TI, 2, EI, 2 ) - ER(2,1) = ZERO - ER(2,2) = L - EI(2,1) = ZERO - EI(2,2) = ZERO -C -C Make main diagonal entries of E real and positive. -C (Note: Z and E are altered.) -C - V = DLAPY2( ER(1,1), EI(1,1) ) - CALL DLADIV( V, ZERO, ER(1,1), EI(1,1), XR, XI ) - ER(1,1) = V - EI(1,1) = ZERO - YR = ZR(1,1) - YI = ZI(1,1) - ZR(1,1) = XR*YR - XI*YI - ZI(1,1) = XR*YI + XI*YR - YR = ZR(2,1) - YI = ZI(2,1) - ZR(2,1) = XR*YR - XI*YI - ZI(2,1) = XR*YI + XI*YR -C -C A := A * Z -C - CALL DGEMM( 'N', 'N', 2, 2, 2, ONE, AR, 2, ZR, 2, ZERO, TR, 2 ) - CALL DGEMM( 'N', 'N', 2, 2, 2, MONE, AI, 2, ZI, 2, ONE, TR, 2 ) - CALL DGEMM( 'N', 'N', 2, 2, 2, ONE, AR, 2, ZI, 2, ZERO, TI, 2 ) - CALL DGEMM( 'N', 'N', 2, 2, 2, ONE, AI, 2, ZR, 2, ONE, TI, 2 ) - CALL DCOPY( 4, TR, 1, AR, 1 ) - CALL DCOPY( 4, TI, 1, AI, 1 ) -C -C End of QZ-step. -C -C B := B * Z -C - CALL DGEMM( 'N', 'N', 2, 2, 2, ONE, BB, 2, ZR, 2, ZERO, BR, 2 ) - CALL DGEMM( 'N', 'N', 2, 2, 2, ONE, BB, 2, ZI, 2, ZERO, BI, 2 ) -C -C Overwrite B with the upper triangular matrix of its -C QR-factorization. The elements on the main diagonal are real -C and non-negative. -C - CALL SG03BY( BR(1,1), BI(1,1), BR(2,1), BI(2,1), CR, CI, SR, SI, - $ L ) - QBR(1,1) = CR - QBR(1,2) = SR - QBR(2,1) = -SR - QBR(2,2) = CR - QBI(1,1) = -CI - QBI(1,2) = -SI - QBI(2,1) = -SI - QBI(2,2) = CI - CALL DGEMV( 'N', 2, 2, ONE, QBR, 2, BR(1,2), 1, ZERO, TR, 1 ) - CALL DGEMV( 'N', 2, 2, MONE, QBI, 2, BI(1,2), 1, ONE, TR, 1 ) - CALL DGEMV( 'N', 2, 2, ONE, QBI, 2, BR(1,2), 1, ZERO, TI, 1 ) - CALL DGEMV( 'N', 2, 2, ONE, QBR, 2, BI(1,2), 1, ONE, TI, 1 ) - CALL DCOPY( 2, TR, 1, BR(1,2), 1 ) - CALL DCOPY( 2, TI, 1, BI(1,2), 1 ) - BR(1,1) = L - BR(2,1) = ZERO - BI(1,1) = ZERO - BI(2,1) = ZERO - V = DLAPY2( BR(2,2), BI(2,2) ) - IF ( V .GE. MAX( EPS*MAX( BR(1,1), DLAPY2( BR(1,2), BI(1,2) ) ), - $ SMLNUM ) ) THEN - CALL DLADIV( V, ZERO, BR(2,2), BI(2,2), XR, XI ) - BR(2,2) = V - YR = QBR(2,1) - YI = QBI(2,1) - QBR(2,1) = XR*YR - XI*YI - QBI(2,1) = XR*YI + XI*YR - YR = QBR(2,2) - YI = QBI(2,2) - QBR(2,2) = XR*YR - XI*YI - QBI(2,2) = XR*YI + XI*YR - ELSE - BR(2,2) = ZERO - END IF - BI(2,2) = ZERO -C -C Compute the Cholesky factor of the solution of the reduced -C equation. The solution may be scaled to avoid overflow. -C - IF ( ISCONT ) THEN -C -C Continuous-time equation. -C -C Step I: Compute U(1,1). Set U(2,1) = 0. -C - V = -TWO*( AR(1,1)*ER(1,1) + AI(1,1)*EI(1,1) ) - IF ( V .LE. ZERO ) THEN - INFO = 3 - RETURN - END IF - V = SQRT( V ) - T = TWO*ABS( BR(1,1) )*SMLNUM - IF ( T .GT. V ) THEN - SCALE1 = V/T - SCALE = SCALE1*SCALE - BR(1,1) = SCALE1*BR(1,1) - BR(1,2) = SCALE1*BR(1,2) - BI(1,2) = SCALE1*BI(1,2) - BR(2,2) = SCALE1*BR(2,2) - END IF - UR(1,1) = BR(1,1)/V - UI(1,1) = ZERO - UR(2,1) = ZERO - UI(2,1) = ZERO -C -C Step II: Compute U(1,2). -C - T = MAX( EPS*MAX( BR(2,2), DLAPY2( BR(1,2), BI(1,2) ) ), - $ SMLNUM ) - IF ( ABS( BR(1,1) ) .LT. T ) THEN - UR(1,2) = ZERO - UI(1,2) = ZERO - ELSE - XR = AR(1,1)*ER(1,2) + AI(1,1)*EI(1,2) - XI = AI(1,1)*ER(1,2) - AR(1,1)*EI(1,2) - XR = XR + AR(1,2)*ER(1,1) + AI(1,2)*EI(1,1) - XI = XI - AI(1,2)*ER(1,1) + AR(1,2)*EI(1,1) - XR = -BR(1,2)*V - XR*UR(1,1) - XI = BI(1,2)*V - XI*UR(1,1) - YR = AR(2,2)*ER(1,1) + AI(2,2)*EI(1,1) - YI = -AI(2,2)*ER(1,1) + AR(2,2)*EI(1,1) - YR = YR + ER(2,2)*AR(1,1) + EI(2,2)*AI(1,1) - YI = YI - EI(2,2)*AR(1,1) + ER(2,2)*AI(1,1) - T = TWO*DLAPY2( XR, XI )*SMLNUM - IF ( T .GT. DLAPY2( YR, YI ) ) THEN - SCALE1 = DLAPY2( YR, YI )/T - SCALE = SCALE1*SCALE - BR(1,1) = SCALE1*BR(1,1) - BR(1,2) = SCALE1*BR(1,2) - BI(1,2) = SCALE1*BI(1,2) - BR(2,2) = SCALE1*BR(2,2) - UR(1,1) = SCALE1*UR(1,1) - XR = SCALE1*XR - XI = SCALE1*XI - END IF - CALL DLADIV( XR, XI, YR, YI, UR(1,2), UI(1,2) ) - UI(1,2) = -UI(1,2) - END IF -C -C Step III: Compute U(2,2). -C - XR = ( ER(1,2)*UR(1,1) + ER(2,2)*UR(1,2) - EI(2,2)*UI(1,2) )*V - XI = (-EI(1,2)*UR(1,1) - ER(2,2)*UI(1,2) - EI(2,2)*UR(1,2) )*V - T = TWO*DLAPY2( XR, XI )*SMLNUM - IF ( T .GT. DLAPY2( ER(1,1), EI(1,1) ) ) THEN - SCALE1 = DLAPY2( ER(1,1), EI(1,1) )/T - SCALE = SCALE1*SCALE - UR(1,1) = SCALE1*UR(1,1) - UR(1,2) = SCALE1*UR(1,2) - UI(1,2) = SCALE1*UI(1,2) - BR(1,1) = SCALE1*BR(1,1) - BR(1,2) = SCALE1*BR(1,2) - BI(1,2) = SCALE1*BI(1,2) - BR(2,2) = SCALE1*BR(2,2) - XR = SCALE1*XR - XI = SCALE1*XI - END IF - CALL DLADIV( XR, XI, ER(1,1), -EI(1,1), YR, YI ) - YR = BR(1,2) - YR - YI = -BI(1,2) - YI - V = -TWO*( AR(2,2)*ER(2,2) + AI(2,2)*EI(2,2) ) - IF ( V .LE. ZERO ) THEN - INFO = 3 - RETURN - END IF - V = SQRT( V ) - W = DLAPY2( DLAPY2( BR(2,2), BI(2,2) ), DLAPY2( YR, YI ) ) - T = TWO*W*SMLNUM - IF ( T .GT. V ) THEN - SCALE1 = V/T - SCALE = SCALE1*SCALE - UR(1,1) = SCALE1*UR(1,1) - UR(1,2) = SCALE1*UR(1,2) - UI(1,2) = SCALE1*UI(1,2) - BR(1,1) = SCALE1*BR(1,1) - BR(1,2) = SCALE1*BR(1,2) - BI(1,2) = SCALE1*BI(1,2) - BR(2,2) = SCALE1*BR(2,2) - W = SCALE1*W - END IF - UR(2,2) = W/V - UI(2,2) = ZERO -C -C Compute matrices M1 and M2 for the reduced equation. -C - M1R(2,1) = ZERO - M1I(2,1) = ZERO - M2R(2,1) = ZERO - M2I(2,1) = ZERO - CALL DLADIV( AR(1,1), AI(1,1), ER(1,1), EI(1,1), BETAR, BETAI ) - M1R(1,1) = BETAR - M1I(1,1) = BETAI - M1R(2,2) = BETAR - M1I(2,2) = -BETAI - ALPHA = SQRT( -TWO*BETAR ) - M2R(1,1) = ALPHA - M2I(1,1) = ZERO - V = ER(1,1)*ER(2,2) - XR = ( -BR(1,1)*ER(1,2) + ER(1,1)*BR(1,2) )/V - XI = ( -BR(1,1)*EI(1,2) + ER(1,1)*BI(1,2) )/V - YR = XR - ALPHA*UR(1,2) - YI = -XI + ALPHA*UI(1,2) - IF ( ( YR.NE.ZERO ) .OR. ( YI.NE.ZERO ) ) THEN - M2R(1,2) = YR/UR(2,2) - M2I(1,2) = -YI/UR(2,2) - M2R(2,2) = BR(2,2)/( ER(2,2)*UR(2,2) ) - M2I(2,2) = ZERO - M1R(1,2) = -ALPHA*M2R(1,2) - M1I(1,2) = -ALPHA*M2I(1,2) - ELSE - M2R(1,2) = ZERO - M2I(1,2) = ZERO - M2R(2,2) = ALPHA - M2I(2,2) = ZERO - M1R(1,2) = ZERO - M1I(1,2) = ZERO - END IF - ELSE -C -C Discrete-time equation. -C -C Step I: Compute U(1,1). Set U(2,1) = 0. -C - V = ER(1,1)**2 + EI(1,1)**2 - AR(1,1)**2 - AI(1,1)**2 - IF ( V .LE. ZERO ) THEN - INFO = 3 - RETURN - END IF - V = SQRT( V ) - T = TWO*ABS( BR(1,1) )*SMLNUM - IF ( T .GT. V ) THEN - SCALE1 = V/T - SCALE = SCALE1*SCALE - BR(1,1) = SCALE1*BR(1,1) - BR(1,2) = SCALE1*BR(1,2) - BI(1,2) = SCALE1*BI(1,2) - BR(2,2) = SCALE1*BR(2,2) - END IF - UR(1,1) = BR(1,1)/V - UI(1,1) = ZERO - UR(2,1) = ZERO - UI(2,1) = ZERO -C -C Step II: Compute U(1,2). -C - T = MAX( EPS*MAX( BR(2,2), DLAPY2( BR(1,2), BI(1,2) ) ), - $ SMLNUM ) - IF ( ABS( BR(1,1) ) .LT. T ) THEN - UR(1,2) = ZERO - UI(1,2) = ZERO - ELSE - XR = AR(1,1)*AR(1,2) + AI(1,1)*AI(1,2) - XI = AI(1,1)*AR(1,2) - AR(1,1)*AI(1,2) - XR = XR - ER(1,2)*ER(1,1) - EI(1,2)*EI(1,1) - XI = XI + EI(1,2)*ER(1,1) - ER(1,2)*EI(1,1) - XR = -BR(1,2)*V - XR*UR(1,1) - XI = BI(1,2)*V - XI*UR(1,1) - YR = AR(2,2)*AR(1,1) + AI(2,2)*AI(1,1) - YI = -AI(2,2)*AR(1,1) + AR(2,2)*AI(1,1) - YR = YR - ER(2,2)*ER(1,1) - EI(2,2)*EI(1,1) - YI = YI + EI(2,2)*ER(1,1) - ER(2,2)*EI(1,1) - T = TWO*DLAPY2( XR, XI )*SMLNUM - IF ( T .GT. DLAPY2( YR, YI ) ) THEN - SCALE1 = DLAPY2( YR, YI )/T - SCALE = SCALE1*SCALE - BR(1,1) = SCALE1*BR(1,1) - BR(1,2) = SCALE1*BR(1,2) - BI(1,2) = SCALE1*BI(1,2) - BR(2,2) = SCALE1*BR(2,2) - UR(1,1) = SCALE1*UR(1,1) - XR = SCALE1*XR - XI = SCALE1*XI - END IF - CALL DLADIV( XR, XI, YR, YI, UR(1,2), UI(1,2) ) - UI(1,2) = -UI(1,2) - END IF -C -C Step III: Compute U(2,2). -C - XR = ER(1,2)*UR(1,1) + ER(2,2)*UR(1,2) - EI(2,2)*UI(1,2) - XI = -EI(1,2)*UR(1,1) - ER(2,2)*UI(1,2) - EI(2,2)*UR(1,2) - YR = AR(1,2)*UR(1,1) + AR(2,2)*UR(1,2) - AI(2,2)*UI(1,2) - YI = -AI(1,2)*UR(1,1) - AR(2,2)*UI(1,2) - AI(2,2)*UR(1,2) - V = ER(2,2)**2 + EI(2,2)**2 - AR(2,2)**2 - AI(2,2)**2 - IF ( V .LE. ZERO ) THEN - INFO = 3 - RETURN - END IF - V = SQRT( V ) - T = MAX( ABS( BR(2,2) ), ABS( BR(1,2) ), ABS( BI(1,2) ), - $ ABS( XR ), ABS( XI ), ABS( YR ), ABS( YI) ) - IF ( T .LE. SMLNUM ) T = ONE - W = ( BR(2,2)/T )**2 + ( BR(1,2)/T )**2 + ( BI(1,2)/T )**2 - - $ ( XR/T )**2 - ( XI/T )**2 + ( YR/T )**2 + ( YI/T )**2 - IF ( W .LT. ZERO ) THEN - INFO = 3 - RETURN - END IF - W = T*SQRT( W ) - T = TWO*W*SMLNUM - IF ( T .GT. V ) THEN - SCALE1 = V/T - SCALE = SCALE1*SCALE - UR(1,1) = SCALE1*UR(1,1) - UR(1,2) = SCALE1*UR(1,2) - UI(1,2) = SCALE1*UI(1,2) - BR(1,1) = SCALE1*BR(1,1) - BR(1,2) = SCALE1*BR(1,2) - BI(1,2) = SCALE1*BI(1,2) - BR(2,2) = SCALE1*BR(2,2) - W = SCALE1*W - END IF - UR(2,2) = W/V - UI(2,2) = ZERO -C -C Compute matrices M1 and M2 for the reduced equation. -C - B11 = BR(1,1)/ER(1,1) - T = ER(1,1)*ER(2,2) - B12R = ( ER(1,1)*BR(1,2) - BR(1,1)*ER(1,2) )/T - B12I = ( ER(1,1)*BI(1,2) - BR(1,1)*EI(1,2) )/T - B22 = BR(2,2)/ER(2,2) - M1R(2,1) = ZERO - M1I(2,1) = ZERO - M2R(2,1) = ZERO - M2I(2,1) = ZERO - CALL DLADIV( AR(1,1), AI(1,1), ER(1,1), EI(1,1), BETAR, BETAI ) - M1R(1,1) = BETAR - M1I(1,1) = BETAI - M1R(2,2) = BETAR - M1I(2,2) = -BETAI - V = DLAPY2( BETAR, BETAI ) - ALPHA = SQRT( ( ONE - V )*( ONE + V ) ) - M2R(1,1) = ALPHA - M2I(1,1) = ZERO - XR = ( AI(1,1)*EI(1,2) - AR(1,1)*ER(1,2) )/T + AR(1,2)/ER(2,2) - XI = ( AR(1,1)*EI(1,2) + AI(1,1)*ER(1,2) )/T - AI(1,2)/ER(2,2) - XR = -TWO*BETAI*B12I - B11*XR - XI = -TWO*BETAI*B12R - B11*XI - V = ONE + ( BETAI - BETAR )*( BETAI + BETAR ) - W = -TWO*BETAI*BETAR - CALL DLADIV( XR, XI, V, W, YR, YI ) - IF ( ( YR.NE.ZERO ) .OR. ( YI.NE.ZERO ) ) THEN - M2R(1,2) = ( YR*BETAR - YI*BETAI )/UR(2,2) - M2I(1,2) = -( YI*BETAR + YR*BETAI )/UR(2,2) - M2R(2,2) = B22/UR(2,2) - M2I(2,2) = ZERO - M1R(1,2) = -ALPHA*YR/UR(2,2) - M1I(1,2) = ALPHA*YI/UR(2,2) - ELSE - M2R(1,2) = ZERO - M2I(1,2) = ZERO - M2R(2,2) = ALPHA - M2I(2,2) = ZERO - M1R(1,2) = ZERO - M1I(1,2) = ZERO - END IF - END IF -C -C Transform U back: U := U * Q. -C (Note: Z is used as workspace.) -C - CALL DGEMM( 'N', 'N', 2, 2, 2, ONE, UR, 2, QR, 2, ZERO, ZR, 2 ) - CALL DGEMM( 'N', 'N', 2, 2, 2, MONE, UI, 2, QI, 2, ONE, ZR, 2 ) - CALL DGEMM( 'N', 'N', 2, 2, 2, ONE, UR, 2, QI, 2, ZERO, ZI, 2 ) - CALL DGEMM( 'N', 'N', 2, 2, 2, ONE, UI, 2, QR, 2, ONE, ZI, 2 ) -C -C Overwrite U with the upper triangular matrix of its -C QR-factorization. The elements on the main diagonal are real -C and non-negative. -C - CALL SG03BY( ZR(1,1), ZI(1,1), ZR(2,1), ZI(2,1), CR, CI, SR, SI, - $ L ) - QUR(1,1) = CR - QUR(1,2) = SR - QUR(2,1) = -SR - QUR(2,2) = CR - QUI(1,1) = -CI - QUI(1,2) = -SI - QUI(2,1) = -SI - QUI(2,2) = CI - CALL DGEMV( 'N', 2, 2, ONE, QUR, 2, ZR(1,2), 1, ZERO, U(1,2), 1) - CALL DGEMV( 'N', 2, 2, MONE, QUI, 2, ZI(1,2), 1, ONE, U(1,2), 1) - CALL DGEMV( 'N', 2, 2, ONE, QUI, 2, ZR(1,2), 1, ZERO, UI(1,2), 1) - CALL DGEMV( 'N', 2, 2, ONE, QUR, 2, ZI(1,2), 1, ONE, UI(1,2), 1) - U(1,1) = L - U(2,1) = ZERO - V = DLAPY2( U(2,2), UI(2,2) ) - IF ( V .NE. ZERO ) THEN - CALL DLADIV( V, ZERO, U(2,2), UI(2,2), XR, XI ) - YR = QUR(2,1) - YI = QUI(2,1) - QUR(2,1) = XR*YR - XI*YI - QUI(2,1) = XR*YI + XI*YR - YR = QUR(2,2) - YI = QUI(2,2) - QUR(2,2) = XR*YR - XI*YI - QUI(2,2) = XR*YI + XI*YR - END IF - U(2,2) = V -C -C Transform the matrices M1 and M2 back. -C -C M1 := QU * M1 * QU**H -C M2 := QB**H * M2 * QU**H -C - CALL DGEMM( 'N', 'T', 2, 2, 2, ONE, M1R, 2, QUR, 2, ZERO, TR, 2 ) - CALL DGEMM( 'N', 'T', 2, 2, 2, ONE, M1I, 2, QUI, 2, ONE, TR, 2 ) - CALL DGEMM( 'N', 'T', 2, 2, 2, MONE, M1R, 2, QUI, 2, ZERO, TI, 2 ) - CALL DGEMM( 'N', 'T', 2, 2, 2, ONE, M1I, 2, QUR, 2, ONE, TI, 2 ) - CALL DGEMM( 'N', 'N', 2, 2, 2, ONE, QUR, 2, TR, 2, ZERO, M1, - $ LDM1 ) - CALL DGEMM( 'N', 'N', 2, 2, 2, MONE, QUI, 2, TI, 2, ONE, M1, - $ LDM1 ) -C - CALL DGEMM( 'N', 'T', 2, 2, 2, ONE, M2R, 2, QUR, 2, ZERO, TR, 2 ) - CALL DGEMM( 'N', 'T', 2, 2, 2, ONE, M2I, 2, QUI, 2, ONE, TR, 2 ) - CALL DGEMM( 'N', 'T', 2, 2, 2, MONE, M2R, 2, QUI, 2, ZERO, TI, 2 ) - CALL DGEMM( 'N', 'T', 2, 2, 2, ONE, M2I, 2, QUR, 2, ONE, TI, 2 ) - CALL DGEMM( 'T', 'N', 2, 2, 2, ONE, QBR, 2, TR, 2, ZERO, M2, - $ LDM2 ) - CALL DGEMM( 'T', 'N', 2, 2, 2, ONE, QBI, 2, TI, 2, ONE, M2, - $ LDM2 ) -C -C If the transposed equation (op(K)=K**T, K=A,B,E,U) is to be -C solved, transpose the matrix U with respect to the -C anti-diagonal and the matrices M1, M2 with respect to the diagonal -C and the anti-diagonal. -C - IF ( ISTRNS ) THEN - V = U(1,1) - U(1,1) = U(2,2) - U(2,2) = V - V = M1(1,1) - M1(1,1) = M1(2,2) - M1(2,2) = V - V = M2(1,1) - M2(1,1) = M2(2,2) - M2(2,2) = V - END IF -C - RETURN -C *** Last line of SG03BX *** - END diff --git a/mex/sources/libslicot/SG03BY.f b/mex/sources/libslicot/SG03BY.f deleted file mode 100644 index 356fe0423..000000000 --- a/mex/sources/libslicot/SG03BY.f +++ /dev/null @@ -1,93 +0,0 @@ - SUBROUTINE SG03BY( XR, XI, YR, YI, CR, CI, SR, SI, Z ) -C -C SLICOT RELEASE 5.0. -C -C Copyright (c) 2002-2009 NICONET e.V. -C -C This program is free software: you can redistribute it and/or -C modify it under the terms of the GNU General Public License as -C published by the Free Software Foundation, either version 2 of -C the License, or (at your option) any later version. -C -C This program is distributed in the hope that it will be useful, -C but WITHOUT ANY WARRANTY; without even the implied warranty of -C MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the -C GNU General Public License for more details. -C -C You should have received a copy of the GNU General Public License -C along with this program. If not, see -C . -C -C PURPOSE -C -C To compute the parameters for the complex Givens rotation -C -C ( CR-CI*I SR-SI*I ) ( XR+XI*I ) ( Z ) -C ( ) * ( ) = ( ), -C ( -SR-SI*I CR+CI*I ) ( YR+YI*I ) ( 0 ) -C -C where CR, CI, SR, SI, XR, XI, YR, YI are real numbers and I is the -C imaginary unit, I = SQRT(-1). Z is a non-negative real number. -C -C ARGUMENTS -C -C Input/Output Parameters -C -C XR, XI, (input) DOUBLE PRECISION -C YR, YI (input) DOUBLE PRECISION -C The given real scalars XR, XI, YR, YI. -C -C CR, CI, (output) DOUBLE PRECISION -C SR, SI, (output) DOUBLE PRECISION -C Z (output) DOUBLE PRECISION -C The computed real scalars CR, CI, SR, SI, Z, defining the -C complex Givens rotation and Z. -C -C NUMERICAL ASPECTS -C -C The subroutine avoids unnecessary overflow. -C -C FURTHER COMMENTS -C -C In the interest of speed, this routine does not check the input -C for errors. -C -C CONTRIBUTOR -C -C T. Penzl, Technical University Chemnitz, Germany, Aug. 1998. -C -C REVISIONS -C -C Sep. 1998 (V. Sima). -C -C ****************************************************************** -C -C .. Parameters .. - DOUBLE PRECISION ONE, ZERO - PARAMETER ( ONE = 1.0D+0, ZERO = 0.0D+0 ) -C .. Scalar Arguments .. - DOUBLE PRECISION CI, CR, SI, SR, XI, XR, YI, YR, Z -C .. Intrinsic Functions .. - DOUBLE PRECISION ABS, MAX, SQRT -C .. Executable Statements .. -C - Z = MAX( ABS( XR ), ABS( XI ), ABS( YR ), ABS( YI ) ) -C - IF ( Z .EQ. ZERO ) THEN - CR = ONE - CI = ZERO - SR = ZERO - SI = ZERO - ELSE - Z = Z*SQRT( ( XR/Z )**2 + ( XI/Z )**2 + - $ ( YR/Z )**2 + ( YI/Z )**2 ) - CR = XR/Z - CI = XI/Z - SR = YR/Z - SI = YI/Z - END IF -C - RETURN -C -C *** Last line of SG03BY *** - END diff --git a/mex/sources/libslicot/TB01ID.f b/mex/sources/libslicot/TB01ID.f deleted file mode 100644 index 9dbedb634..000000000 --- a/mex/sources/libslicot/TB01ID.f +++ /dev/null @@ -1,402 +0,0 @@ - SUBROUTINE TB01ID( JOB, N, M, P, MAXRED, A, LDA, B, LDB, C, LDC, - $ SCALE, INFO ) -C -C SLICOT RELEASE 5.0. -C -C Copyright (c) 2002-2009 NICONET e.V. -C -C This program is free software: you can redistribute it and/or -C modify it under the terms of the GNU General Public License as -C published by the Free Software Foundation, either version 2 of -C the License, or (at your option) any later version. -C -C This program is distributed in the hope that it will be useful, -C but WITHOUT ANY WARRANTY; without even the implied warranty of -C MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the -C GNU General Public License for more details. -C -C You should have received a copy of the GNU General Public License -C along with this program. If not, see -C . -C -C PURPOSE -C -C To reduce the 1-norm of a system matrix -C -C S = ( A B ) -C ( C 0 ) -C -C corresponding to the triple (A,B,C), by balancing. This involves -C a diagonal similarity transformation inv(D)*A*D applied -C iteratively to A to make the rows and columns of -C -1 -C diag(D,I) * S * diag(D,I) -C -C as close in norm as possible. -C -C The balancing can be performed optionally on the following -C particular system matrices -C -C S = A, S = ( A B ) or S = ( A ) -C ( C ) -C -C ARGUMENTS -C -C Mode Parameters -C -C JOB CHARACTER*1 -C Indicates which matrices are involved in balancing, as -C follows: -C = 'A': All matrices are involved in balancing; -C = 'B': B and A matrices are involved in balancing; -C = 'C': C and A matrices are involved in balancing; -C = 'N': B and C matrices are not involved in balancing. -C -C Input/Output Parameters -C -C N (input) INTEGER -C The order of the matrix A, the number of rows of matrix B -C and the number of columns of matrix C. -C N represents the dimension of the state vector. N >= 0. -C -C M (input) INTEGER. -C The number of columns of matrix B. -C M represents the dimension of input vector. M >= 0. -C -C P (input) INTEGER. -C The number of rows of matrix C. -C P represents the dimension of output vector. P >= 0. -C -C MAXRED (input/output) DOUBLE PRECISION -C On entry, the maximum allowed reduction in the 1-norm of -C S (in an iteration) if zero rows or columns are -C encountered. -C If MAXRED > 0.0, MAXRED must be larger than one (to enable -C the norm reduction). -C If MAXRED <= 0.0, then the value 10.0 for MAXRED is -C used. -C On exit, if the 1-norm of the given matrix S is non-zero, -C the ratio between the 1-norm of the given matrix and the -C 1-norm of the balanced matrix. -C -C A (input/output) DOUBLE PRECISION array, dimension (LDA,N) -C On entry, the leading N-by-N part of this array must -C contain the system state matrix A. -C On exit, the leading N-by-N part of this array contains -C the balanced matrix inv(D)*A*D. -C -C LDA INTEGER -C The leading dimension of the array A. LDA >= max(1,N). -C -C B (input/output) DOUBLE PRECISION array, dimension (LDB,M) -C On entry, if M > 0, the leading N-by-M part of this array -C must contain the system input matrix B. -C On exit, if M > 0, the leading N-by-M part of this array -C contains the balanced matrix inv(D)*B. -C The array B is not referenced if M = 0. -C -C LDB INTEGER -C The leading dimension of the array B. -C LDB >= MAX(1,N) if M > 0. -C LDB >= 1 if M = 0. -C -C C (input/output) DOUBLE PRECISION array, dimension (LDC,N) -C On entry, if P > 0, the leading P-by-N part of this array -C must contain the system output matrix C. -C On exit, if P > 0, the leading P-by-N part of this array -C contains the balanced matrix C*D. -C The array C is not referenced if P = 0. -C -C LDC INTEGER -C The leading dimension of the array C. LDC >= MAX(1,P). -C -C SCALE (output) DOUBLE PRECISION array, dimension (N) -C The scaling factors applied to S. If D(j) is the scaling -C factor applied to row and column j, then SCALE(j) = D(j), -C for j = 1,...,N. -C -C Error Indicator -C -C INFO INTEGER -C = 0: successful exit. -C < 0: if INFO = -i, the i-th argument had an illegal -C value. -C -C METHOD -C -C Balancing consists of applying a diagonal similarity -C transformation -C -1 -C diag(D,I) * S * diag(D,I) -C -C to make the 1-norms of each row of the first N rows of S and its -C corresponding column nearly equal. -C -C Information about the diagonal matrix D is returned in the vector -C SCALE. -C -C REFERENCES -C -C [1] Anderson, E., Bai, Z., Bischof, C., Demmel, J., Dongarra, J., -C Du Croz, J., Greenbaum, A., Hammarling, S., McKenney, A., -C Ostrouchov, S., and Sorensen, D. -C LAPACK Users' Guide: Second Edition. -C SIAM, Philadelphia, 1995. -C -C NUMERICAL ASPECTS -C -C None. -C -C CONTRIBUTOR -C -C Release 3.0: V. Sima, Katholieke Univ. Leuven, Belgium, Jan. 1998. -C This subroutine is based on LAPACK routine DGEBAL, and routine -C BALABC (A. Varga, German Aerospace Research Establishment, DLR). -C -C REVISIONS -C -C - -C -C KEYWORDS -C -C Balancing, eigenvalue, matrix algebra, matrix operations, -C similarity transformation. -C -C ********************************************************************* -C -C .. Parameters .. - DOUBLE PRECISION ZERO, ONE - PARAMETER ( ZERO = 0.0D+0, ONE = 1.0D+0 ) - DOUBLE PRECISION SCLFAC - PARAMETER ( SCLFAC = 1.0D+1 ) - DOUBLE PRECISION FACTOR, MAXR - PARAMETER ( FACTOR = 0.95D+0, MAXR = 10.0D+0 ) -C .. -C .. Scalar Arguments .. - CHARACTER JOB - INTEGER INFO, LDA, LDB, LDC, M, N, P - DOUBLE PRECISION MAXRED -C .. -C .. Array Arguments .. - DOUBLE PRECISION A( LDA, * ), B( LDB, * ), C( LDC, * ), - $ SCALE( * ) -C .. -C .. Local Scalars .. - LOGICAL NOCONV, WITHB, WITHC - INTEGER I, ICA, IRA, J - DOUBLE PRECISION CA, CO, F, G, MAXNRM, RA, RO, S, SFMAX1, - $ SFMAX2, SFMIN1, SFMIN2, SNORM, SRED -C .. -C .. External Functions .. - LOGICAL LSAME - INTEGER IDAMAX - DOUBLE PRECISION DASUM, DLAMCH - EXTERNAL DASUM, DLAMCH, IDAMAX, LSAME -C .. -C .. External Subroutines .. - EXTERNAL DSCAL, XERBLA -C .. -C .. Intrinsic Functions .. - INTRINSIC ABS, MAX, MIN -C .. -C .. Executable Statements .. -C -C Test the scalar input arguments. -C - INFO = 0 - WITHB = LSAME( JOB, 'A' ) .OR. LSAME( JOB, 'B' ) - WITHC = LSAME( JOB, 'A' ) .OR. LSAME( JOB, 'C' ) -C - IF( .NOT.WITHB .AND. .NOT.WITHC .AND. .NOT.LSAME( JOB, 'N' ) ) - $ THEN - INFO = -1 - ELSE IF( N.LT.0 ) THEN - INFO = -2 - ELSE IF( M.LT.0 ) THEN - INFO = -3 - ELSE IF( P.LT.0 ) THEN - INFO = -4 - ELSE IF( MAXRED.GT.ZERO .AND. MAXRED.LT.ONE ) THEN - INFO = -5 - ELSE IF( LDA.LT.MAX( 1, N ) ) THEN - INFO = -7 - ELSE IF( ( M.GT.0 .AND. LDB.LT.MAX( 1, N ) ) .OR. - $ ( M.EQ.0 .AND. LDB.LT.1 ) ) THEN - INFO = -9 - ELSE IF( LDC.LT.MAX( 1, P ) ) THEN - INFO = -11 - END IF - IF( INFO.NE.0 ) THEN - CALL XERBLA( 'TB01ID', -INFO ) - RETURN - END IF -C - IF( N.EQ.0 ) - $ RETURN -C -C Compute the 1-norm of the required part of matrix S and exit if -C it is zero. -C - SNORM = ZERO -C - DO 10 J = 1, N - SCALE( J ) = ONE - CO = DASUM( N, A( 1, J ), 1 ) - IF( WITHC .AND. P.GT.0 ) - $ CO = CO + DASUM( P, C( 1, J ), 1 ) - SNORM = MAX( SNORM, CO ) - 10 CONTINUE -C - IF( WITHB ) THEN -C - DO 20 J = 1, M - SNORM = MAX( SNORM, DASUM( N, B( 1, J ), 1 ) ) - 20 CONTINUE -C - END IF -C - IF( SNORM.EQ.ZERO ) - $ RETURN -C -C Set some machine parameters and the maximum reduction in the -C 1-norm of S if zero rows or columns are encountered. -C - SFMIN1 = DLAMCH( 'S' ) / DLAMCH( 'P' ) - SFMAX1 = ONE / SFMIN1 - SFMIN2 = SFMIN1*SCLFAC - SFMAX2 = ONE / SFMIN2 -C - SRED = MAXRED - IF( SRED.LE.ZERO ) SRED = MAXR -C - MAXNRM = MAX( SNORM/SRED, SFMIN1 ) -C -C Balance the matrix. -C -C Iterative loop for norm reduction. -C - 30 CONTINUE - NOCONV = .FALSE. -C - DO 90 I = 1, N - CO = ZERO - RO = ZERO -C - DO 40 J = 1, N - IF( J.EQ.I ) - $ GO TO 40 - CO = CO + ABS( A( J, I ) ) - RO = RO + ABS( A( I, J ) ) - 40 CONTINUE -C - ICA = IDAMAX( N, A( 1, I ), 1 ) - CA = ABS( A( ICA, I ) ) - IRA = IDAMAX( N, A( I, 1 ), LDA ) - RA = ABS( A( I, IRA ) ) -C - IF( WITHC .AND. P.GT.0 ) THEN - CO = CO + DASUM( P, C( 1, I ), 1 ) - ICA = IDAMAX( P, C( 1, I ), 1 ) - CA = MAX( CA, ABS( C( ICA, I ) ) ) - END IF -C - IF( WITHB .AND. M.GT.0 ) THEN - RO = RO + DASUM( M, B( I, 1 ), LDB ) - IRA = IDAMAX( M, B( I, 1 ), LDB ) - RA = MAX( RA, ABS( B( I, IRA ) ) ) - END IF -C -C Special case of zero CO and/or RO. -C - IF( CO.EQ.ZERO .AND. RO.EQ.ZERO ) - $ GO TO 90 - IF( CO.EQ.ZERO ) THEN - IF( RO.LE.MAXNRM ) - $ GO TO 90 - CO = MAXNRM - END IF - IF( RO.EQ.ZERO ) THEN - IF( CO.LE.MAXNRM ) - $ GO TO 90 - RO = MAXNRM - END IF -C -C Guard against zero CO or RO due to underflow. -C - G = RO / SCLFAC - F = ONE - S = CO + RO - 50 CONTINUE - IF( CO.GE.G .OR. MAX( F, CO, CA ).GE.SFMAX2 .OR. - $ MIN( RO, G, RA ).LE.SFMIN2 )GO TO 60 - F = F*SCLFAC - CO = CO*SCLFAC - CA = CA*SCLFAC - G = G / SCLFAC - RO = RO / SCLFAC - RA = RA / SCLFAC - GO TO 50 -C - 60 CONTINUE - G = CO / SCLFAC - 70 CONTINUE - IF( G.LT.RO .OR. MAX( RO, RA ).GE.SFMAX2 .OR. - $ MIN( F, CO, G, CA ).LE.SFMIN2 )GO TO 80 - F = F / SCLFAC - CO = CO / SCLFAC - CA = CA / SCLFAC - G = G / SCLFAC - RO = RO*SCLFAC - RA = RA*SCLFAC - GO TO 70 -C -C Now balance. -C - 80 CONTINUE - IF( ( CO+RO ).GE.FACTOR*S ) - $ GO TO 90 - IF( F.LT.ONE .AND. SCALE( I ).LT.ONE ) THEN - IF( F*SCALE( I ).LE.SFMIN1 ) - $ GO TO 90 - END IF - IF( F.GT.ONE .AND. SCALE( I ).GT.ONE ) THEN - IF( SCALE( I ).GE.SFMAX1 / F ) - $ GO TO 90 - END IF - G = ONE / F - SCALE( I ) = SCALE( I )*F - NOCONV = .TRUE. -C - CALL DSCAL( N, G, A( I, 1 ), LDA ) - CALL DSCAL( N, F, A( 1, I ), 1 ) - IF( M.GT.0 ) CALL DSCAL( M, G, B( I, 1 ), LDB ) - IF( P.GT.0 ) CALL DSCAL( P, F, C( 1, I ), 1 ) -C - 90 CONTINUE -C - IF( NOCONV ) - $ GO TO 30 -C -C Set the norm reduction parameter. -C - MAXRED = SNORM - SNORM = ZERO -C - DO 100 J = 1, N - CO = DASUM( N, A( 1, J ), 1 ) - IF( WITHC .AND. P.GT.0 ) - $ CO = CO + DASUM( P, C( 1, J ), 1 ) - SNORM = MAX( SNORM, CO ) - 100 CONTINUE -C - IF( WITHB ) THEN -C - DO 110 J = 1, M - SNORM = MAX( SNORM, DASUM( N, B( 1, J ), 1 ) ) - 110 CONTINUE -C - END IF - MAXRED = MAXRED/SNORM - RETURN -C *** Last line of TB01ID *** - END diff --git a/mex/sources/libslicot/TB01IZ.f b/mex/sources/libslicot/TB01IZ.f deleted file mode 100644 index e719aa390..000000000 --- a/mex/sources/libslicot/TB01IZ.f +++ /dev/null @@ -1,409 +0,0 @@ - SUBROUTINE TB01IZ( JOB, N, M, P, MAXRED, A, LDA, B, LDB, C, LDC, - $ SCALE, INFO ) -C -C SLICOT RELEASE 5.0. -C -C Copyright (c) 2002-2009 NICONET e.V. -C -C This program is free software: you can redistribute it and/or -C modify it under the terms of the GNU General Public License as -C published by the Free Software Foundation, either version 2 of -C the License, or (at your option) any later version. -C -C This program is distributed in the hope that it will be useful, -C but WITHOUT ANY WARRANTY; without even the implied warranty of -C MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the -C GNU General Public License for more details. -C -C You should have received a copy of the GNU General Public License -C along with this program. If not, see -C . -C -C PURPOSE -C -C To reduce the 1-norm of a system matrix -C -C S = ( A B ) -C ( C 0 ) -C -C corresponding to the triple (A,B,C), by balancing. This involves -C a diagonal similarity transformation inv(D)*A*D applied -C iteratively to A to make the rows and columns of -C -1 -C diag(D,I) * S * diag(D,I) -C -C as close in norm as possible. -C -C The balancing can be performed optionally on the following -C particular system matrices -C -C S = A, S = ( A B ) or S = ( A ) -C ( C ) -C -C ARGUMENTS -C -C Mode Parameters -C -C JOB CHARACTER*1 -C Indicates which matrices are involved in balancing, as -C follows: -C = 'A': All matrices are involved in balancing; -C = 'B': B and A matrices are involved in balancing; -C = 'C': C and A matrices are involved in balancing; -C = 'N': B and C matrices are not involved in balancing. -C -C Input/Output Parameters -C -C N (input) INTEGER -C The order of the matrix A, the number of rows of matrix B -C and the number of columns of matrix C. -C N represents the dimension of the state vector. N >= 0. -C -C M (input) INTEGER. -C The number of columns of matrix B. -C M represents the dimension of input vector. M >= 0. -C -C P (input) INTEGER. -C The number of rows of matrix C. -C P represents the dimension of output vector. P >= 0. -C -C MAXRED (input/output) DOUBLE PRECISION -C On entry, the maximum allowed reduction in the 1-norm of -C S (in an iteration) if zero rows or columns are -C encountered. -C If MAXRED > 0.0, MAXRED must be larger than one (to enable -C the norm reduction). -C If MAXRED <= 0.0, then the value 10.0 for MAXRED is -C used. -C On exit, if the 1-norm of the given matrix S is non-zero, -C the ratio between the 1-norm of the given matrix and the -C 1-norm of the balanced matrix. -C -C A (input/output) COMPLEX*16 array, dimension (LDA,N) -C On entry, the leading N-by-N part of this array must -C contain the system state matrix A. -C On exit, the leading N-by-N part of this array contains -C the balanced matrix inv(D)*A*D. -C -C LDA INTEGER -C The leading dimension of the array A. LDA >= max(1,N). -C -C B (input/output) COMPLEX*16 array, dimension (LDB,M) -C On entry, if M > 0, the leading N-by-M part of this array -C must contain the system input matrix B. -C On exit, if M > 0, the leading N-by-M part of this array -C contains the balanced matrix inv(D)*B. -C The array B is not referenced if M = 0. -C -C LDB INTEGER -C The leading dimension of the array B. -C LDB >= MAX(1,N) if M > 0. -C LDB >= 1 if M = 0. -C -C C (input/output) COMPLEX*16 array, dimension (LDC,N) -C On entry, if P > 0, the leading P-by-N part of this array -C must contain the system output matrix C. -C On exit, if P > 0, the leading P-by-N part of this array -C contains the balanced matrix C*D. -C The array C is not referenced if P = 0. -C -C LDC INTEGER -C The leading dimension of the array C. LDC >= MAX(1,P). -C -C SCALE (output) DOUBLE PRECISION array, dimension (N) -C The scaling factors applied to S. If D(j) is the scaling -C factor applied to row and column j, then SCALE(j) = D(j), -C for j = 1,...,N. -C -C Error Indicator -C -C INFO INTEGER -C = 0: successful exit. -C < 0: if INFO = -i, the i-th argument had an illegal -C value. -C -C METHOD -C -C Balancing consists of applying a diagonal similarity -C transformation -C -1 -C diag(D,I) * S * diag(D,I) -C -C to make the 1-norms of each row of the first N rows of S and its -C corresponding column nearly equal. -C -C Information about the diagonal matrix D is returned in the vector -C SCALE. -C -C REFERENCES -C -C [1] Anderson, E., Bai, Z., Bischof, C., Demmel, J., Dongarra, J., -C Du Croz, J., Greenbaum, A., Hammarling, S., McKenney, A., -C Ostrouchov, S., and Sorensen, D. -C LAPACK Users' Guide: Second Edition. -C SIAM, Philadelphia, 1995. -C -C NUMERICAL ASPECTS -C -C None. -C -C CONTRIBUTOR -C -C V. Sima, Katholieke Univ. Leuven, Belgium, Jan. 1998. -C Complex version: V. Sima, Research Institute for Informatics, -C Bucharest, Nov. 2008. -C -C REVISIONS -C -C - -C -C KEYWORDS -C -C Balancing, eigenvalue, matrix algebra, matrix operations, -C similarity transformation. -C -C ********************************************************************* -C -C .. Parameters .. - DOUBLE PRECISION ZERO, ONE - PARAMETER ( ZERO = 0.0D+0, ONE = 1.0D+0 ) - DOUBLE PRECISION SCLFAC - PARAMETER ( SCLFAC = 1.0D+1 ) - DOUBLE PRECISION FACTOR, MAXR - PARAMETER ( FACTOR = 0.95D+0, MAXR = 10.0D+0 ) -C .. -C .. Scalar Arguments .. - CHARACTER JOB - INTEGER INFO, LDA, LDB, LDC, M, N, P - DOUBLE PRECISION MAXRED -C .. -C .. Array Arguments .. - COMPLEX*16 A( LDA, * ), B( LDB, * ), C( LDC, * ) - DOUBLE PRECISION SCALE( * ) -C .. -C .. Local Scalars .. - LOGICAL NOCONV, WITHB, WITHC - INTEGER I, ICA, IRA, J - DOUBLE PRECISION CA, CO, F, G, MAXNRM, RA, RO, S, SFMAX1, - $ SFMAX2, SFMIN1, SFMIN2, SNORM, SRED - COMPLEX*16 CDUM -C .. -C .. External Functions .. - LOGICAL LSAME - INTEGER IZAMAX - DOUBLE PRECISION DLAMCH, DZASUM - EXTERNAL DLAMCH, DZASUM, IZAMAX, LSAME -C .. -C .. External Subroutines .. - EXTERNAL XERBLA, ZDSCAL -C .. -C .. Intrinsic Functions .. - INTRINSIC ABS, DBLE, DIMAG, MAX, MIN -C .. -C .. Statement Functions .. - DOUBLE PRECISION CABS1 -C .. -C .. Statement Function definitions .. - CABS1( CDUM ) = ABS( DBLE( CDUM ) ) + ABS( DIMAG( CDUM ) ) -C .. -C .. Executable Statements .. -C -C Test the scalar input arguments. -C - INFO = 0 - WITHB = LSAME( JOB, 'A' ) .OR. LSAME( JOB, 'B' ) - WITHC = LSAME( JOB, 'A' ) .OR. LSAME( JOB, 'C' ) -C - IF( .NOT.WITHB .AND. .NOT.WITHC .AND. .NOT.LSAME( JOB, 'N' ) ) - $ THEN - INFO = -1 - ELSE IF( N.LT.0 ) THEN - INFO = -2 - ELSE IF( M.LT.0 ) THEN - INFO = -3 - ELSE IF( P.LT.0 ) THEN - INFO = -4 - ELSE IF( MAXRED.GT.ZERO .AND. MAXRED.LT.ONE ) THEN - INFO = -5 - ELSE IF( LDA.LT.MAX( 1, N ) ) THEN - INFO = -7 - ELSE IF( ( M.GT.0 .AND. LDB.LT.MAX( 1, N ) ) .OR. - $ ( M.EQ.0 .AND. LDB.LT.1 ) ) THEN - INFO = -9 - ELSE IF( LDC.LT.MAX( 1, P ) ) THEN - INFO = -11 - END IF - IF( INFO.NE.0 ) THEN - CALL XERBLA( 'TB01IZ', -INFO ) - RETURN - END IF -C - IF( N.EQ.0 ) - $ RETURN -C -C Compute the 1-norm of the required part of matrix S and exit if -C it is zero. -C - SNORM = ZERO -C - DO 10 J = 1, N - SCALE( J ) = ONE - CO = DZASUM( N, A( 1, J ), 1 ) - IF( WITHC .AND. P.GT.0 ) - $ CO = CO + DZASUM( P, C( 1, J ), 1 ) - SNORM = MAX( SNORM, CO ) - 10 CONTINUE -C - IF( WITHB ) THEN -C - DO 20 J = 1, M - SNORM = MAX( SNORM, DZASUM( N, B( 1, J ), 1 ) ) - 20 CONTINUE -C - END IF -C - IF( SNORM.EQ.ZERO ) - $ RETURN -C -C Set some machine parameters and the maximum reduction in the -C 1-norm of S if zero rows or columns are encountered. -C - SFMIN1 = DLAMCH( 'S' ) / DLAMCH( 'P' ) - SFMAX1 = ONE / SFMIN1 - SFMIN2 = SFMIN1*SCLFAC - SFMAX2 = ONE / SFMIN2 -C - SRED = MAXRED - IF( SRED.LE.ZERO ) SRED = MAXR -C - MAXNRM = MAX( SNORM/SRED, SFMIN1 ) -C -C Balance the matrix. -C -C Iterative loop for norm reduction. -C - 30 CONTINUE - NOCONV = .FALSE. -C - DO 90 I = 1, N - CO = ZERO - RO = ZERO -C - DO 40 J = 1, N - IF( J.EQ.I ) - $ GO TO 40 - CO = CO + CABS1( A( J, I ) ) - RO = RO + CABS1( A( I, J ) ) - 40 CONTINUE -C - ICA = IZAMAX( N, A( 1, I ), 1 ) - CA = ABS( A( ICA, I ) ) - IRA = IZAMAX( N, A( I, 1 ), LDA ) - RA = ABS( A( I, IRA ) ) -C - IF( WITHC .AND. P.GT.0 ) THEN - CO = CO + DZASUM( P, C( 1, I ), 1 ) - ICA = IZAMAX( P, C( 1, I ), 1 ) - CA = MAX( CA, ABS( C( ICA, I ) ) ) - END IF -C - IF( WITHB .AND. M.GT.0 ) THEN - RO = RO + DZASUM( M, B( I, 1 ), LDB ) - IRA = IZAMAX( M, B( I, 1 ), LDB ) - RA = MAX( RA, ABS( B( I, IRA ) ) ) - END IF -C -C Special case of zero CO and/or RO. -C - IF( CO.EQ.ZERO .AND. RO.EQ.ZERO ) - $ GO TO 90 - IF( CO.EQ.ZERO ) THEN - IF( RO.LE.MAXNRM ) - $ GO TO 90 - CO = MAXNRM - END IF - IF( RO.EQ.ZERO ) THEN - IF( CO.LE.MAXNRM ) - $ GO TO 90 - RO = MAXNRM - END IF -C -C Guard against zero CO or RO due to underflow. -C - G = RO / SCLFAC - F = ONE - S = CO + RO - 50 CONTINUE - IF( CO.GE.G .OR. MAX( F, CO, CA ).GE.SFMAX2 .OR. - $ MIN( RO, G, RA ).LE.SFMIN2 )GO TO 60 - F = F*SCLFAC - CO = CO*SCLFAC - CA = CA*SCLFAC - G = G / SCLFAC - RO = RO / SCLFAC - RA = RA / SCLFAC - GO TO 50 -C - 60 CONTINUE - G = CO / SCLFAC - 70 CONTINUE - IF( G.LT.RO .OR. MAX( RO, RA ).GE.SFMAX2 .OR. - $ MIN( F, CO, G, CA ).LE.SFMIN2 )GO TO 80 - F = F / SCLFAC - CO = CO / SCLFAC - CA = CA / SCLFAC - G = G / SCLFAC - RO = RO*SCLFAC - RA = RA*SCLFAC - GO TO 70 -C -C Now balance. -C - 80 CONTINUE - IF( ( CO+RO ).GE.FACTOR*S ) - $ GO TO 90 - IF( F.LT.ONE .AND. SCALE( I ).LT.ONE ) THEN - IF( F*SCALE( I ).LE.SFMIN1 ) - $ GO TO 90 - END IF - IF( F.GT.ONE .AND. SCALE( I ).GT.ONE ) THEN - IF( SCALE( I ).GE.SFMAX1 / F ) - $ GO TO 90 - END IF - G = ONE / F - SCALE( I ) = SCALE( I )*F - NOCONV = .TRUE. -C - CALL ZDSCAL( N, G, A( I, 1 ), LDA ) - CALL ZDSCAL( N, F, A( 1, I ), 1 ) - IF( M.GT.0 ) CALL ZDSCAL( M, G, B( I, 1 ), LDB ) - IF( P.GT.0 ) CALL ZDSCAL( P, F, C( 1, I ), 1 ) -C - 90 CONTINUE -C - IF( NOCONV ) - $ GO TO 30 -C -C Set the norm reduction parameter. -C - MAXRED = SNORM - SNORM = ZERO -C - DO 100 J = 1, N - CO = DZASUM( N, A( 1, J ), 1 ) - IF( WITHC .AND. P.GT.0 ) - $ CO = CO + DZASUM( P, C( 1, J ), 1 ) - SNORM = MAX( SNORM, CO ) - 100 CONTINUE -C - IF( WITHB ) THEN -C - DO 110 J = 1, M - SNORM = MAX( SNORM, DZASUM( N, B( 1, J ), 1 ) ) - 110 CONTINUE -C - END IF - MAXRED = MAXRED/SNORM - RETURN -C *** Last line of TB01IZ *** - END diff --git a/mex/sources/libslicot/TB01KD.f b/mex/sources/libslicot/TB01KD.f deleted file mode 100644 index a3d0a85d2..000000000 --- a/mex/sources/libslicot/TB01KD.f +++ /dev/null @@ -1,334 +0,0 @@ - SUBROUTINE TB01KD( DICO, STDOM, JOBA, N, M, P, ALPHA, A, LDA, B, - $ LDB, C, LDC, NDIM, U, LDU, WR, WI, DWORK, - $ LDWORK, INFO ) -C -C SLICOT RELEASE 5.0. -C -C Copyright (c) 2002-2009 NICONET e.V. -C -C This program is free software: you can redistribute it and/or -C modify it under the terms of the GNU General Public License as -C published by the Free Software Foundation, either version 2 of -C the License, or (at your option) any later version. -C -C This program is distributed in the hope that it will be useful, -C but WITHOUT ANY WARRANTY; without even the implied warranty of -C MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the -C GNU General Public License for more details. -C -C You should have received a copy of the GNU General Public License -C along with this program. If not, see -C . -C -C PURPOSE -C -C To compute an additive spectral decomposition of the transfer- -C function matrix of the system (A,B,C) by reducing the system -C state-matrix A to a block-diagonal form. -C The system matrices are transformed as -C A <-- inv(U)*A*U, B <--inv(U)*B and C <-- C*U. -C The leading diagonal block of the resulting A has eigenvalues -C in a suitably defined domain of interest. -C -C ARGUMENTS -C -C Mode Parameters -C -C DICO CHARACTER*1 -C Specifies the type of the system as follows: -C = 'C': continuous-time system; -C = 'D': discrete-time system. -C -C STDOM CHARACTER*1 -C Specifies whether the domain of interest is of stability -C type (left part of complex plane or inside of a circle) -C or of instability type (right part of complex plane or -C outside of a circle) as follows: -C = 'S': stability type domain; -C = 'U': instability type domain. -C -C JOBA CHARACTER*1 -C Specifies the shape of the state dynamics matrix on entry -C as follows: -C = 'S': A is in an upper real Schur form; -C = 'G': A is a general square dense matrix. -C -C Input/Output Parameters -C -C N (input) INTEGER -C The order of the state-space representation, -C i.e. the order of the matrix A. N >= 0. -C -C M (input) INTEGER -C The number of system inputs, or of columns of B. M >= 0. -C -C P (input) INTEGER -C The number of system outputs, or of rows of C. P >= 0. -C -C ALPHA (input) DOUBLE PRECISION. -C Specifies the boundary of the domain of interest for the -C eigenvalues of A. For a continuous-time system -C (DICO = 'C'), ALPHA is the boundary value for the real -C parts of eigenvalues, while for a discrete-time system -C (DICO = 'D'), ALPHA >= 0 represents the boundary value for -C the moduli of eigenvalues. -C -C A (input/output) DOUBLE PRECISION array, dimension (LDA,N) -C On entry, the leading N-by-N part of this array must -C contain the unreduced state dynamics matrix A. -C If JOBA = 'S' then A must be a matrix in real Schur form. -C On exit, the leading N-by-N part of this array contains a -C block diagonal matrix inv(U) * A * U with two diagonal -C blocks in real Schur form with the elements below the -C first subdiagonal set to zero. -C The leading NDIM-by-NDIM block of A has eigenvalues in the -C domain of interest and the trailing (N-NDIM)-by-(N-NDIM) -C block has eigenvalues outside the domain of interest. -C The domain of interest for lambda(A), the eigenvalues -C of A, is defined by the parameters ALPHA, DICO and STDOM -C as follows: -C For a continuous-time system (DICO = 'C'): -C Real(lambda(A)) < ALPHA if STDOM = 'S'; -C Real(lambda(A)) > ALPHA if STDOM = 'U'; -C For a discrete-time system (DICO = 'D'): -C Abs(lambda(A)) < ALPHA if STDOM = 'S'; -C Abs(lambda(A)) > ALPHA if STDOM = 'U'. -C -C LDA INTEGER -C The leading dimension of array A. LDA >= MAX(1,N). -C -C B (input/output) DOUBLE PRECISION array, dimension (LDB,M) -C On entry, the leading N-by-M part of this array must -C contain the input matrix B. -C On exit, the leading N-by-M part of this array contains -C the transformed input matrix inv(U) * B. -C -C LDB INTEGER -C The leading dimension of array B. LDB >= MAX(1,N). -C -C C (input/output) DOUBLE PRECISION array, dimension (LDC,N) -C On entry, the leading P-by-N part of this array must -C contain the output matrix C. -C On exit, the leading P-by-N part of this array contains -C the transformed output matrix C * U. -C -C LDC INTEGER -C The leading dimension of array C. LDC >= MAX(1,P). -C -C NDIM (output) INTEGER -C The number of eigenvalues of A lying inside the domain of -C interest for eigenvalues. -C -C U (output) DOUBLE PRECISION array, dimension (LDU,N) -C The leading N-by-N part of this array contains the -C transformation matrix used to reduce A to the block- -C diagonal form. The first NDIM columns of U span the -C invariant subspace of A corresponding to the eigenvalues -C of its leading diagonal block. The last N-NDIM columns -C of U span the reducing subspace of A corresponding to -C the eigenvalues of the trailing diagonal block of A. -C -C LDU INTEGER -C The leading dimension of array U. LDU >= max(1,N). -C -C WR, WI (output) DOUBLE PRECISION arrays, dimension (N) -C WR and WI contain the real and imaginary parts, -C respectively, of the computed eigenvalues of A. The -C eigenvalues will be in the same order that they appear on -C the diagonal of the output real Schur form of A. Complex -C conjugate pairs of eigenvalues will appear consecutively -C with the eigenvalue having the positive imaginary part -C first. -C -C Workspace -C -C DWORK DOUBLE PRECISION array, dimension (LDWORK) -C On exit, if INFO = 0, DWORK(1) returns the optimal value -C of LDWORK. -C -C LDWORK INTEGER -C The dimension of working array DWORK. -C LDWORK >= MAX(1,N) if JOBA = 'S'; -C LDWORK >= MAX(1,3*N) if JOBA = 'G'. -C For optimum performance LDWORK should be larger. -C -C Error Indicator -C -C INFO INTEGER -C = 0: successful exit; -C < 0: if INFO = -i, the i-th argument had an illegal -C value; -C = 1: the QR algorithm failed to compute all the -C eigenvalues of A; -C = 2: a failure occured during the ordering of the real -C Schur form of A; -C = 3: the separation of the two diagonal blocks failed -C because of very close eigenvalues. -C -C METHOD -C -C A similarity transformation U is determined that reduces the -C system state-matrix A to a block-diagonal form (with two diagonal -C blocks), so that the leading diagonal block of the resulting A has -C eigenvalues in a specified domain of the complex plane. The -C determined transformation is applied to the system (A,B,C) as -C A <-- inv(U)*A*U, B <-- inv(U)*B and C <-- C*U. -C -C REFERENCES -C -C [1] Safonov, M.G., Jonckheere, E.A., Verma, M., Limebeer, D.J.N. -C Synthesis of positive real multivariable feedback systems. -C Int. J. Control, pp. 817-842, 1987. -C -C NUMERICAL ASPECTS -C 3 -C The algorithm requires about 14N floating point operations. -C -C CONTRIBUTOR -C -C A. Varga, German Aerospace Center, -C DLR Oberpfaffenhofen, March 1998. -C Based on the RASP routine SADSDC. -C -C REVISIONS -C -C - -C -C KEYWORDS -C -C Invariant subspace, real Schur form, similarity transformation, -C spectral factorization. -C -C ****************************************************************** -C -C .. Parameters .. - DOUBLE PRECISION ZERO, ONE - PARAMETER ( ZERO = 0.0D0, ONE = 1.0D0 ) -C .. Scalar Arguments .. - CHARACTER DICO, JOBA, STDOM - INTEGER INFO, LDA, LDB, LDC, LDU, LDWORK, M, N, NDIM, P - DOUBLE PRECISION ALPHA -C .. Array Arguments .. - DOUBLE PRECISION A(LDA,*), B(LDB,*), C(LDC,*), DWORK(*), U(LDU,*), - $ WI(*), WR(*) -C .. Local Scalars .. - LOGICAL DISCR, LJOBG - INTEGER NDIM1, NR - DOUBLE PRECISION SCALE -C .. External Functions .. - LOGICAL LSAME - EXTERNAL LSAME -C .. External Subroutines .. - EXTERNAL DGEMM, DLASET, DTRSYL, TB01LD, XERBLA -C .. Intrinsic Functions .. - INTRINSIC MAX -C -C .. Executable Statements .. -C - INFO = 0 - DISCR = LSAME( DICO, 'D' ) - LJOBG = LSAME( JOBA, 'G' ) -C -C Check input scalar arguments. -C - IF( .NOT. ( LSAME( DICO, 'C' ) .OR. DISCR ) ) THEN - INFO = -1 - ELSE IF( .NOT. ( LSAME( STDOM, 'S' ) .OR. - $ LSAME( STDOM, 'U' ) ) ) THEN - INFO = -2 - ELSE IF( .NOT. ( LSAME( JOBA, 'S' ) .OR. LJOBG ) ) THEN - INFO = -3 - ELSE IF( N.LT.0 ) THEN - INFO = -4 - ELSE IF( M.LT.0 ) THEN - INFO = -5 - ELSE IF( P.LT.0 ) THEN - INFO = -6 - ELSE IF( DISCR .AND. ALPHA.LT.ZERO ) THEN - INFO = -7 - ELSE IF( LDA.LT.MAX( 1, N ) ) THEN - INFO = -9 - ELSE IF( LDB.LT.MAX( 1, N ) ) THEN - INFO = -11 - ELSE IF( LDC.LT.MAX( 1, P ) ) THEN - INFO = -13 - ELSE IF( LDU.LT.MAX( 1, N ) ) THEN - INFO = -16 - ELSE IF( LDWORK.LT.MAX( 1, N ) .OR. - $ LDWORK.LT.MAX( 1, 3*N ) .AND. LJOBG ) THEN - INFO = -20 - END IF -C - IF( INFO.NE.0 ) THEN -C -C Error return. -C - CALL XERBLA( 'TB01KD', -INFO ) - RETURN - END IF -C -C Quick return if possible. -C - NDIM = 0 - IF( N.EQ.0 ) - $ RETURN -C -C Reduce A to an ordered real Schur form using an orthogonal -C similarity transformation A <- U'*A*U and accumulate the -C transformations in U. The reordering of the real Schur form of A -C is performed in accordance with the values of the parameters DICO, -C STDOM and ALPHA. Apply the transformation to B and C: B <- U'*B -C and C <- C*U. The eigenvalues of A are computed in (WR,WI). -C -C Workspace: need 3*N (if JOBA = 'G'), or N (if JOBA = 'S'); -C prefer larger. -C - CALL TB01LD( DICO, STDOM, JOBA, N, M, P, ALPHA, A, LDA, B, LDB, C, - $ LDC, NDIM, U, LDU, WR, WI, DWORK, LDWORK, INFO ) -C - IF ( INFO.NE.0 ) - $ RETURN -C - IF ( NDIM.GT.0 .AND. NDIM.LT.N ) THEN -C -C Reduce A to a block-diagonal form by a similarity -C transformation of the form -C -1 ( I -X ) -C A <- T AT, where T = ( ) and X satisfies the -C ( 0 I ) -C Sylvester equation -C -C A11*X - X*A22 = A12. -C - NR = N - NDIM - NDIM1 = NDIM + 1 - CALL DTRSYL( 'N', 'N', -1, NDIM, NR, A, LDA, A(NDIM1,NDIM1), - $ LDA, A(1,NDIM1), LDA, SCALE, INFO ) - IF ( INFO.NE.0 ) THEN - INFO = 3 - RETURN - END IF -C -1 -C Compute B <- T B, C <- CT, U <- UT. -C - SCALE = ONE/SCALE - CALL DGEMM( 'N', 'N', NDIM, M, NR, SCALE, A(1,NDIM1), LDA, - $ B(NDIM1,1), LDB, ONE, B, LDB ) - CALL DGEMM( 'N', 'N', P, NR, NDIM, -SCALE, C, LDC, A(1,NDIM1), - $ LDA, ONE, C(1,NDIM1), LDC ) - CALL DGEMM( 'N', 'N', N, NR, NDIM, -SCALE, U, LDU, A(1,NDIM1), - $ LDA, ONE, U(1,NDIM1), LDU ) -C -C Set A12 to zero. -C - CALL DLASET( 'Full', NDIM, NR, ZERO, ZERO, A(1,NDIM1), LDA ) - END IF -C -C Set to zero the lower triangular part under the first subdiagonal -C of A. -C - IF ( N.GT.2 ) - $ CALL DLASET( 'L', N-2, N-2, ZERO, ZERO, A( 3, 1 ), LDA ) - RETURN -C *** Last line of TB01KD *** - END diff --git a/mex/sources/libslicot/TB01LD.f b/mex/sources/libslicot/TB01LD.f deleted file mode 100644 index 50f64c914..000000000 --- a/mex/sources/libslicot/TB01LD.f +++ /dev/null @@ -1,348 +0,0 @@ - SUBROUTINE TB01LD( DICO, STDOM, JOBA, N, M, P, ALPHA, A, LDA, B, - $ LDB, C, LDC, NDIM, U, LDU, WR, WI, DWORK, - $ LDWORK, INFO ) -C -C SLICOT RELEASE 5.0. -C -C Copyright (c) 2002-2009 NICONET e.V. -C -C This program is free software: you can redistribute it and/or -C modify it under the terms of the GNU General Public License as -C published by the Free Software Foundation, either version 2 of -C the License, or (at your option) any later version. -C -C This program is distributed in the hope that it will be useful, -C but WITHOUT ANY WARRANTY; without even the implied warranty of -C MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the -C GNU General Public License for more details. -C -C You should have received a copy of the GNU General Public License -C along with this program. If not, see -C . -C -C PURPOSE -C -C To reduce the system state matrix A to an ordered upper real -C Schur form by using an orthogonal similarity transformation -C A <-- U'*A*U and to apply the transformation to the matrices -C B and C: B <-- U'*B and C <-- C*U. -C The leading block of the resulting A has eigenvalues in a -C suitably defined domain of interest. -C -C ARGUMENTS -C -C Mode Parameters -C -C DICO CHARACTER*1 -C Specifies the type of the system as follows: -C = 'C': continuous-time system; -C = 'D': discrete-time system. -C -C STDOM CHARACTER*1 -C Specifies whether the domain of interest is of stability -C type (left part of complex plane or inside of a circle) -C or of instability type (right part of complex plane or -C outside of a circle) as follows: -C = 'S': stability type domain; -C = 'U': instability type domain. -C -C JOBA CHARACTER*1 -C Specifies the shape of the state dynamics matrix on entry -C as follows: -C = 'S': A is in an upper real Schur form; -C = 'G': A is a general square dense matrix. -C -C Input/Output Parameters -C -C N (input) INTEGER -C The order of the state-space representation, -C i.e. the order of the matrix A. N >= 0. -C -C M (input) INTEGER -C The number of system inputs, or of columns of B. M >= 0. -C -C P (input) INTEGER -C The number of system outputs, or of rows of C. P >= 0. -C -C ALPHA (input) DOUBLE PRECISION. -C Specifies the boundary of the domain of interest for the -C eigenvalues of A. For a continuous-time system -C (DICO = 'C'), ALPHA is the boundary value for the real -C parts of eigenvalues, while for a discrete-time system -C (DICO = 'D'), ALPHA >= 0 represents the boundary value -C for the moduli of eigenvalues. -C -C A (input/output) DOUBLE PRECISION array, dimension (LDA,N) -C On entry, the leading N-by-N part of this array must -C contain the unreduced state dynamics matrix A. -C If JOBA = 'S' then A must be a matrix in real Schur form. -C On exit, the leading N-by-N part of this array contains -C the ordered real Schur matrix U' * A * U with the elements -C below the first subdiagonal set to zero. -C The leading NDIM-by-NDIM part of A has eigenvalues in the -C domain of interest and the trailing (N-NDIM)-by-(N-NDIM) -C part has eigenvalues outside the domain of interest. -C The domain of interest for lambda(A), the eigenvalues -C of A, is defined by the parameters ALPHA, DICO and STDOM -C as follows: -C For a continuous-time system (DICO = 'C'): -C Real(lambda(A)) < ALPHA if STDOM = 'S'; -C Real(lambda(A)) > ALPHA if STDOM = 'U'; -C For a discrete-time system (DICO = 'D'): -C Abs(lambda(A)) < ALPHA if STDOM = 'S'; -C Abs(lambda(A)) > ALPHA if STDOM = 'U'. -C -C LDA INTEGER -C The leading dimension of array A. LDA >= MAX(1,N). -C -C B (input/output) DOUBLE PRECISION array, dimension (LDB,M) -C On entry, the leading N-by-M part of this array must -C contain the input matrix B. -C On exit, the leading N-by-M part of this array contains -C the transformed input matrix U' * B. -C -C LDB INTEGER -C The leading dimension of array B. LDB >= MAX(1,N). -C -C C (input/output) DOUBLE PRECISION array, dimension (LDC,N) -C On entry, the leading P-by-N part of this array must -C contain the output matrix C. -C On exit, the leading P-by-N part of this array contains -C the transformed output matrix C * U. -C -C LDC INTEGER -C The leading dimension of array C. LDC >= MAX(1,P). -C -C NDIM (output) INTEGER -C The number of eigenvalues of A lying inside the domain of -C interest for eigenvalues. -C -C U (output) DOUBLE PRECISION array, dimension (LDU,N) -C The leading N-by-N part of this array contains the -C orthogonal transformation matrix used to reduce A to the -C real Schur form and/or to reorder the diagonal blocks of -C real Schur form of A. The first NDIM columns of U form -C an orthogonal basis for the invariant subspace of A -C corresponding to the first NDIM eigenvalues. -C -C LDU INTEGER -C The leading dimension of array U. LDU >= max(1,N). -C -C WR, WI (output) DOUBLE PRECISION arrays, dimension (N) -C WR and WI contain the real and imaginary parts, -C respectively, of the computed eigenvalues of A. The -C eigenvalues will be in the same order that they appear on -C the diagonal of the output real Schur form of A. Complex -C conjugate pairs of eigenvalues will appear consecutively -C with the eigenvalue having the positive imaginary part -C first. -C -C Workspace -C -C DWORK DOUBLE PRECISION array, dimension (LDWORK) -C On exit, if INFO = 0, DWORK(1) returns the optimal value -C of LDWORK. -C -C LDWORK INTEGER -C The dimension of working array DWORK. -C LDWORK >= MAX(1,N) if JOBA = 'S'; -C LDWORK >= MAX(1,3*N) if JOBA = 'G'. -C For optimum performance LDWORK should be larger. -C -C Error Indicator -C -C INFO INTEGER -C = 0: successful exit; -C < 0: if INFO = -i, the i-th argument had an illegal -C value; -C = 1: the QR algorithm failed to compute all the -C eigenvalues of A; -C = 2: a failure occured during the ordering of the real -C Schur form of A. -C -C METHOD -C -C Matrix A is reduced to an ordered upper real Schur form using an -C orthogonal similarity transformation A <-- U'*A*U. This -C transformation is determined so that the leading block of the -C resulting A has eigenvalues in a suitably defined domain of -C interest. Then, the transformation is applied to the matrices B -C and C: B <-- U'*B and C <-- C*U. -C -C NUMERICAL ASPECTS -C 3 -C The algorithm requires about 14N floating point operations. -C -C CONTRIBUTOR -C -C A. Varga, German Aerospace Center, -C DLR Oberpfaffenhofen, March 1998. -C Based on the RASP routine SRSFOD. -C -C REVISIONS -C -C V. Sima, Research Institute for Informatics, Bucharest, Oct. 2001. -C -C KEYWORDS -C -C Invariant subspace, orthogonal transformation, real Schur form, -C similarity transformation. -C -C ****************************************************************** -C -C .. Parameters .. - DOUBLE PRECISION ZERO, ONE - PARAMETER ( ZERO = 0.0D0, ONE = 1.0D0 ) -C .. Scalar Arguments .. - CHARACTER DICO, JOBA, STDOM - INTEGER INFO, LDA, LDB, LDC, LDU, LDWORK, M, N, NDIM, P - DOUBLE PRECISION ALPHA -C .. Array Arguments .. - DOUBLE PRECISION A(LDA,*), B(LDB,*), C(LDC,*), DWORK(*), U(LDU,*), - $ WI(*), WR(*) -C .. Local Scalars .. - LOGICAL DISCR, LJOBG - INTEGER I, IERR, LDWP, SDIM - DOUBLE PRECISION WRKOPT -C .. Local Arrays .. - LOGICAL BWORK( 1 ) -C .. External Functions .. - LOGICAL LSAME, SELECT - EXTERNAL LSAME, SELECT -C .. External Subroutines .. - EXTERNAL DCOPY, DGEES, DGEMM, DGEMV, DLACPY, DLASET, - $ MB03QD, MB03QX, XERBLA -C .. Intrinsic Functions .. - INTRINSIC DBLE, MAX -C -C .. Executable Statements .. -C - INFO = 0 - DISCR = LSAME( DICO, 'D' ) - LJOBG = LSAME( JOBA, 'G' ) -C -C Check input scalar arguments. -C - IF( .NOT. ( LSAME( DICO, 'C' ) .OR. DISCR ) ) THEN - INFO = -1 - ELSE IF( .NOT. ( LSAME( STDOM, 'S' ) .OR. - $ LSAME( STDOM, 'U' ) ) ) THEN - INFO = -2 - ELSE IF( .NOT. ( LSAME( JOBA, 'S' ) .OR. LJOBG ) ) THEN - INFO = -3 - ELSE IF( N.LT.0 ) THEN - INFO = -4 - ELSE IF( M.LT.0 ) THEN - INFO = -5 - ELSE IF( P.LT.0 ) THEN - INFO = -6 - ELSE IF( DISCR .AND. ALPHA.LT.ZERO ) THEN - INFO = -7 - ELSE IF( LDA.LT.MAX( 1, N ) ) THEN - INFO = -9 - ELSE IF( LDB.LT.MAX( 1, N ) ) THEN - INFO = -11 - ELSE IF( LDC.LT.MAX( 1, P ) ) THEN - INFO = -13 - ELSE IF( LDU.LT.MAX( 1, N ) ) THEN - INFO = -16 - ELSE IF( LDWORK.LT.MAX( 1, N ) .OR. - $ LDWORK.LT.MAX( 1, 3*N ) .AND. LJOBG ) THEN - INFO = -20 - END IF -C - IF( INFO.NE.0 ) THEN -C -C Error return. -C - CALL XERBLA( 'TB01LD', -INFO ) - RETURN - END IF -C -C Quick return if possible. -C - NDIM = 0 - IF( N.EQ.0 ) - $ RETURN -C - IF( LSAME( JOBA, 'G' ) ) THEN -C -C Reduce A to real Schur form using an orthogonal similarity -C transformation A <- U'*A*U, accumulate the transformation in U -C and compute the eigenvalues of A in (WR,WI). -C -C Workspace: need 3*N; -C prefer larger. -C - CALL DGEES( 'Vectors', 'Not ordered', SELECT, N, A, LDA, SDIM, - $ WR, WI, U, LDU, DWORK, LDWORK, BWORK, INFO ) - WRKOPT = DWORK( 1 ) - IF( INFO.NE.0 ) THEN - INFO = 1 - RETURN - END IF - ELSE -C -C Initialize U with an identity matrix. -C - CALL DLASET( 'Full', N, N, ZERO, ONE, U, LDU ) - WRKOPT = 0 - END IF -C -C Separate the spectrum of A. The leading NDIM-by-NDIM submatrix of -C A corresponds to the eigenvalues of interest. -C Workspace: need N. -C - CALL MB03QD( DICO, STDOM, 'Update', N, 1, N, ALPHA, A, LDA, - $ U, LDU, NDIM, DWORK, INFO ) - IF( INFO.NE.0 ) - $ RETURN -C -C Compute the eigenvalues. -C - CALL MB03QX( N, A, LDA, WR, WI, IERR ) -C -C Apply the transformation: B <-- U'*B. -C - IF( LDWORK.LT.N*M ) THEN -C -C Not enough working space for using DGEMM. -C - DO 10 I = 1, M - CALL DCOPY( N, B(1,I), 1, DWORK, 1 ) - CALL DGEMV( 'Transpose', N, N, ONE, U, LDU, DWORK, 1, ZERO, - $ B(1,I), 1 ) - 10 CONTINUE -C - ELSE - CALL DLACPY( 'Full', N, M, B, LDB, DWORK, N ) - CALL DGEMM( 'Transpose', 'No transpose', N, M, N, ONE, U, LDU, - $ DWORK, N, ZERO, B, LDB ) - WRKOPT = MAX( WRKOPT, DBLE( N*M ) ) - END IF -C -C Apply the transformation: C <-- C*U. -C - IF( LDWORK.LT.N*P ) THEN -C -C Not enough working space for using DGEMM. -C - DO 20 I = 1, P - CALL DCOPY( N, C(I,1), LDC, DWORK, 1 ) - CALL DGEMV( 'Transpose', N, N, ONE, U, LDU, DWORK, 1, ZERO, - $ C(I,1), LDC ) - 20 CONTINUE -C - ELSE - LDWP = MAX( 1, P ) - CALL DLACPY( 'Full', P, N, C, LDC, DWORK, LDWP ) - CALL DGEMM( 'No transpose', 'No transpose', P, N, N, ONE, - $ DWORK, LDWP, U, LDU, ZERO, C, LDC ) - WRKOPT = MAX( WRKOPT, DBLE( N*P ) ) - END IF -C - DWORK( 1 ) = WRKOPT -C - RETURN -C *** Last line of TB01LD *** - END diff --git a/mex/sources/libslicot/TB01MD.f b/mex/sources/libslicot/TB01MD.f deleted file mode 100644 index b63aacee0..000000000 --- a/mex/sources/libslicot/TB01MD.f +++ /dev/null @@ -1,338 +0,0 @@ - SUBROUTINE TB01MD( JOBU, UPLO, N, M, A, LDA, B, LDB, U, LDU, - $ DWORK, INFO ) -C -C SLICOT RELEASE 5.0. -C -C Copyright (c) 2002-2009 NICONET e.V. -C -C This program is free software: you can redistribute it and/or -C modify it under the terms of the GNU General Public License as -C published by the Free Software Foundation, either version 2 of -C the License, or (at your option) any later version. -C -C This program is distributed in the hope that it will be useful, -C but WITHOUT ANY WARRANTY; without even the implied warranty of -C MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the -C GNU General Public License for more details. -C -C You should have received a copy of the GNU General Public License -C along with this program. If not, see -C . -C -C PURPOSE -C -C To reduce the pair (B,A) to upper or lower controller Hessenberg -C form using (and optionally accumulating) unitary state-space -C transformations. -C -C ARGUMENTS -C -C Mode Parameters -C -C JOBU CHARACTER*1 -C Indicates whether the user wishes to accumulate in a -C matrix U the unitary state-space transformations for -C reducing the system, as follows: -C = 'N': Do not form U; -C = 'I': U is initialized to the unit matrix and the -C unitary transformation matrix U is returned; -C = 'U': The given matrix U is updated by the unitary -C transformations used in the reduction. -C -C UPLO CHARACTER*1 -C Indicates whether the user wishes the pair (B,A) to be -C reduced to upper or lower controller Hessenberg form as -C follows: -C = 'U': Upper controller Hessenberg form; -C = 'L': Lower controller Hessenberg form. -C -C Input/Output Parameters -C -C N (input) INTEGER -C The actual state dimension, i.e. the order of the -C matrix A. N >= 0. -C -C M (input) INTEGER -C The actual input dimension, i.e. the number of columns of -C the matrix B. M >= 0. -C -C A (input/output) DOUBLE PRECISION array, dimension (LDA,N) -C On entry, the leading N-by-N part of this array must -C contain the state transition matrix A to be transformed. -C On exit, the leading N-by-N part of this array contains -C the transformed state transition matrix U' * A * U. -C The annihilated elements are set to zero. -C -C LDA INTEGER -C The leading dimension of array A. LDA >= MAX(1,N). -C -C B (input/output) DOUBLE PRECISION array, dimension (LDB,M) -C On entry, the leading N-by-M part of this array must -C contain the input matrix B to be transformed. -C On exit, the leading N-by-M part of this array contains -C the transformed input matrix U' * B. -C The annihilated elements are set to zero. -C -C LDB INTEGER -C The leading dimension of array B. LDB >= MAX(1,N). -C -C U (input/output) DOUBLE PRECISION array, dimension (LDU,*) -C On entry, if JOBU = 'U', then the leading N-by-N part of -C this array must contain a given matrix U (e.g. from a -C previous call to another SLICOT routine), and on exit, the -C leading N-by-N part of this array contains the product of -C the input matrix U and the state-space transformation -C matrix which reduces the given pair to controller -C Hessenberg form. -C On exit, if JOBU = 'I', then the leading N-by-N part of -C this array contains the matrix of accumulated unitary -C similarity transformations which reduces the given pair -C to controller Hessenberg form. -C If JOBU = 'N', the array U is not referenced and can be -C supplied as a dummy array (i.e. set parameter LDU = 1 and -C declare this array to be U(1,1) in the calling program). -C -C LDU INTEGER -C The leading dimension of array U. If JOBU = 'U' or -C JOBU = 'I', LDU >= MAX(1,N); if JOBU = 'N', LDU >= 1. -C -C Workspace -C -C DWORK DOUBLE PRECISION array, dimension (MAX(N,M-1)) -C -C Error Indicator -C -C INFO INTEGER -C = 0: successful exit; -C < 0: if INFO = -i, the i-th argument had an illegal -C value. -C -C METHOD -C -C The routine computes a unitary state-space transformation U, which -C reduces the pair (B,A) to one of the following controller -C Hessenberg forms: -C -C |* . . . *|* . . . . . . *| -C | . .|. .| -C | . .|. .| -C | . .|. .| -C [U'B|U'AU] = | *|. .| N -C | |* .| -C | | . .| -C | | . .| -C | | . .| -C | | * . . *| -C M N -C -C if UPLO = 'U', or -C -C |* . . * | | -C |. . | | -C |. . | | -C |. . | | -C [U'AU|U'B] = |. *| | N -C |. .|* | -C |. .|. . | -C |. .|. . | -C |. .|. . | -C |* . . . . . . *|* . . . *| -C N M -C if UPLO = 'L'. -C -C IF M >= N, then the matrix U'B is trapezoidal and U'AU is full. -C -C REFERENCES -C -C [1] Van Dooren, P. and Verhaegen, M.H.G. -C On the use of unitary state-space transformations. -C In : Contemporary Mathematics on Linear Algebra and its Role -C in Systems Theory, 47, AMS, Providence, 1985. -C -C NUMERICAL ASPECTS -C -C The algorithm requires O((N + M) x N**2) operations and is -C backward stable (see [1]). -C -C CONTRIBUTORS -C -C Release 3.0: V. Sima, Katholieke Univ. Leuven, Belgium, Dec. 1996. -C Supersedes Release 2.0 routine TB01AD by M. Vanbegin, and -C P. Van Dooren, Philips Research Laboratory, Brussels, Belgium. -C -C REVISIONS -C -C February 1997. -C -C KEYWORDS -C -C Controllability, controller Hessenberg form, orthogonal -C transformation, unitary transformation. -C -C ****************************************************************** -C -C .. Parameters .. - DOUBLE PRECISION ZERO, ONE - PARAMETER ( ZERO = 0.0D0, ONE = 1.0D0 ) -C .. Scalar Arguments .. - CHARACTER JOBU, UPLO - INTEGER INFO, LDA, LDB, LDU, M, N -C .. Array Arguments .. - DOUBLE PRECISION A(LDA,*), B(LDB,*), DWORK(*), U(LDU,*) -C .. Local Scalars .. - LOGICAL LJOBA, LJOBI, LUPLO - INTEGER II, J, M1, N1, NJ, PAR1, PAR2, PAR3, PAR4, PAR5, - $ PAR6 - DOUBLE PRECISION DZ -C .. External Functions .. - LOGICAL LSAME - EXTERNAL LSAME -C .. External Subroutines .. - EXTERNAL DLARFG, DLASET, DLATZM, XERBLA -C .. Intrinsic Functions .. - INTRINSIC MAX, MIN -C .. Executable Statements .. -C - INFO = 0 - LUPLO = LSAME( UPLO, 'U' ) - LJOBI = LSAME( JOBU, 'I' ) - LJOBA = LJOBI.OR.LSAME( JOBU, 'U' ) -C -C Test the input scalar arguments. -C - IF( .NOT.LJOBA .AND. .NOT.LSAME( JOBU, 'N' ) ) THEN - INFO = -1 - ELSE IF( .NOT.LUPLO .AND. .NOT.LSAME( UPLO, 'L' ) ) THEN - INFO = -2 - ELSE IF( N.LT.0 ) THEN - INFO = -3 - ELSE IF( M.LT.0 ) THEN - INFO = -4 - ELSE IF( LDA.LT.MAX( 1, N ) ) THEN - INFO = -6 - ELSE IF( LDB.LT.MAX( 1, N ) ) THEN - INFO = -8 - ELSE IF( .NOT.LJOBA .AND. LDU.LT.1 .OR. - $ LJOBA .AND. LDU.LT.MAX( 1, N ) ) THEN - INFO = -10 - END IF -C - IF ( INFO.NE.0 ) THEN -C -C Error return -C - CALL XERBLA( 'TB01MD', -INFO ) - RETURN - END IF -C -C Quick return if possible. -C - IF ( N.EQ.0 .OR. M.EQ.0 ) - $ RETURN -C - M1 = M + 1 - N1 = N - 1 -C - IF ( LJOBI ) THEN -C -C Initialize U to the identity matrix. -C - CALL DLASET( 'Full', N, N, ZERO, ONE, U, LDU ) - END IF -C -C Perform transformations involving both B and A. -C - DO 20 J = 1, MIN( M, N1 ) - NJ = N - J - IF ( LUPLO ) THEN - PAR1 = J - PAR2 = J - PAR3 = J + 1 - PAR4 = M - PAR5 = N - ELSE - PAR1 = M - J + 1 - PAR2 = NJ + 1 - PAR3 = 1 - PAR4 = M - J - PAR5 = NJ - END IF -C - CALL DLARFG( NJ+1, B(PAR2,PAR1), B(PAR3,PAR1), 1, DZ ) -C -C Update A. -C - CALL DLATZM( 'Left', NJ+1, N, B(PAR3,PAR1), 1, DZ, A(PAR2,1), - $ A(PAR3,1), LDA, DWORK ) - CALL DLATZM( 'Right', N, NJ+1, B(PAR3,PAR1), 1, DZ, A(1,PAR2), - $ A(1,PAR3), LDA, DWORK ) -C - IF ( LJOBA ) THEN -C -C Update U. -C - CALL DLATZM( 'Right', N, NJ+1, B(PAR3,PAR1), 1, DZ, - $ U(1,PAR2), U(1,PAR3), LDU, DWORK ) - END IF -C - IF ( J.NE.M ) THEN -C -C Update B -C - CALL DLATZM( 'Left', NJ+1, PAR4-PAR3+1, B(PAR3,PAR1), 1, DZ, - $ B(PAR2,PAR3), B(PAR3,PAR3), LDB, DWORK ) - END IF -C - DO 10 II = PAR3, PAR5 - B(II,PAR1) = ZERO - 10 CONTINUE -C - 20 CONTINUE -C - DO 40 J = M1, N1 -C -C Perform next transformations only involving A. -C - NJ = N - J - IF ( LUPLO ) THEN - PAR1 = J - M - PAR2 = J - PAR3 = J + 1 - PAR4 = N - PAR5 = J - M + 1 - PAR6 = N - ELSE - PAR1 = N + M1 - J - PAR2 = NJ + 1 - PAR3 = 1 - PAR4 = NJ - PAR5 = 1 - PAR6 = N + M - J - END IF -C - CALL DLARFG( NJ+1, A(PAR2,PAR1), A(PAR3,PAR1), 1, DZ ) -C -C Update A. -C - CALL DLATZM( 'Left', NJ+1, PAR6-PAR5+1, A(PAR3,PAR1), 1, DZ, - $ A(PAR2,PAR5), A(PAR3,PAR5), LDA, DWORK ) - CALL DLATZM( 'Right', N, NJ+1, A(PAR3,PAR1), 1, DZ, - $ A(1,PAR2), A(1,PAR3), LDA, DWORK ) -C - IF ( LJOBA ) THEN -C -C Update U. -C - CALL DLATZM( 'Right', N, NJ+1, A(PAR3,PAR1), 1, DZ, - $ U(1,PAR2), U(1,PAR3), LDU, DWORK ) - END IF -C - DO 30 II = PAR3, PAR4 - A(II,PAR1) = ZERO - 30 CONTINUE -C - 40 CONTINUE -C - RETURN -C *** Last line of TB01MD *** - END diff --git a/mex/sources/libslicot/TB01ND.f b/mex/sources/libslicot/TB01ND.f deleted file mode 100644 index cc93dd3ac..000000000 --- a/mex/sources/libslicot/TB01ND.f +++ /dev/null @@ -1,349 +0,0 @@ - SUBROUTINE TB01ND( JOBU, UPLO, N, P, A, LDA, C, LDC, U, LDU, - $ DWORK, INFO ) -C -C SLICOT RELEASE 5.0. -C -C Copyright (c) 2002-2009 NICONET e.V. -C -C This program is free software: you can redistribute it and/or -C modify it under the terms of the GNU General Public License as -C published by the Free Software Foundation, either version 2 of -C the License, or (at your option) any later version. -C -C This program is distributed in the hope that it will be useful, -C but WITHOUT ANY WARRANTY; without even the implied warranty of -C MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the -C GNU General Public License for more details. -C -C You should have received a copy of the GNU General Public License -C along with this program. If not, see -C . -C -C PURPOSE -C -C To reduce the pair (A,C) to lower or upper observer Hessenberg -C form using (and optionally accumulating) unitary state-space -C transformations. -C -C ARGUMENTS -C -C Mode Parameters -C -C JOBU CHARACTER*1 -C Indicates whether the user wishes to accumulate in a -C matrix U the unitary state-space transformations for -C reducing the system, as follows: -C = 'N': Do not form U; -C = 'I': U is initialized to the unit matrix and the -C unitary transformation matrix U is returned; -C = 'U': The given matrix U is updated by the unitary -C transformations used in the reduction. -C -C UPLO CHARACTER*1 -C Indicates whether the user wishes the pair (A,C) to be -C reduced to upper or lower observer Hessenberg form as -C follows: -C = 'U': Upper observer Hessenberg form; -C = 'L': Lower observer Hessenberg form. -C -C Input/Output Parameters -C -C N (input) INTEGER -C The actual state dimension, i.e. the order of the -C matrix A. N >= 0. -C -C P (input) INTEGER -C The actual output dimension, i.e. the number of rows of -C the matrix C. P >= 0. -C -C A (input/output) DOUBLE PRECISION array, dimension (LDA,N) -C On entry, the leading N-by-N part of this array must -C contain the state transition matrix A to be transformed. -C On exit, the leading N-by-N part of this array contains -C the transformed state transition matrix U' * A * U. -C The annihilated elements are set to zero. -C -C LDA INTEGER -C The leading dimension of array A. LDA >= MAX(1,N). -C -C C (input/output) DOUBLE PRECISION array, dimension (LDC,N) -C On entry, the leading P-by-N part of this array must -C contain the output matrix C to be transformed. -C On exit, the leading P-by-N part of this array contains -C the transformed output matrix C * U. -C The annihilated elements are set to zero. -C -C LDC INTEGER -C The leading dimension of array C. LDC >= MAX(1,P). -C -C U (input/output) DOUBLE PRECISION array, dimension (LDU,*) -C On entry, if JOBU = 'U', then the leading N-by-N part of -C this array must contain a given matrix U (e.g. from a -C previous call to another SLICOT routine), and on exit, the -C leading N-by-N part of this array contains the product of -C the input matrix U and the state-space transformation -C matrix which reduces the given pair to observer Hessenberg -C form. -C On exit, if JOBU = 'I', then the leading N-by-N part of -C this array contains the matrix of accumulated unitary -C similarity transformations which reduces the given pair -C to observer Hessenberg form. -C If JOBU = 'N', the array U is not referenced and can be -C supplied as a dummy array (i.e. set parameter LDU = 1 and -C declare this array to be U(1,1) in the calling program). -C -C LDU INTEGER -C The leading dimension of array U. If JOBU = 'U' or -C JOBU = 'I', LDU >= MAX(1,N); if JOBU = 'N', LDU >= 1. -C -C Workspace -C -C DWORK DOUBLE PRECISION array, dimension (MAX(N,P-1)) -C -C Error Indicator -C -C INFO INTEGER -C = 0: successful exit; -C < 0: if INFO = -i, the i-th argument had an illegal -C value. -C -C METHOD -C -C The routine computes a unitary state-space transformation U, which -C reduces the pair (A,C) to one of the following observer Hessenberg -C forms: -C -C N -C |* . . . . . . *| -C |. .| -C |. .| -C |. .| N -C |* .| -C |U'AU| | . .| -C |----| = | . .| -C |CU | | * . . . *| -C ------------------- -C | * . . *| -C | . .| P -C | . .| -C | *| -C -C if UPLO = 'U', or -C -C N -C |* | -C |. . | -C |. . | P -C |* . . * | -C |CU | ------------------- -C |----| = |* . . . * | -C |U'AU| |. . | -C |. . | -C |. *| -C |. .| N -C |. .| -C |. .| -C |* . . . . . . *| -C -C if UPLO = 'L'. -C -C If P >= N, then the matrix CU is trapezoidal and U'AU is full. -C -C REFERENCES -C -C [1] Van Dooren, P. and Verhaegen, M.H.G. -C On the use of unitary state-space transformations. -C In : Contemporary Mathematics on Linear Algebra and its Role -C in Systems Theory, 47, AMS, Providence, 1985. -C -C NUMERICAL ASPECTS -C -C The algorithm requires O((N + P) x N**2) operations and is -C backward stable (see [1]). -C -C CONTRIBUTORS -C -C Release 3.0: V. Sima, Katholieke Univ. Leuven, Belgium, Dec. 1996. -C Supersedes Release 2.0 routine TB01BD by M. Vanbegin, and -C P. Van Dooren, Philips Research Laboratory, Brussels, Belgium. -C -C REVISIONS -C -C February 1997. -C -C KEYWORDS -C -C Controllability, observer Hessenberg form, orthogonal -C transformation, unitary transformation. -C -C ****************************************************************** -C -C .. Parameters .. - DOUBLE PRECISION ZERO, ONE - PARAMETER ( ZERO = 0.0D0, ONE = 1.0D0 ) -C .. Scalar Arguments .. - INTEGER INFO, LDA, LDC, LDU, N, P - CHARACTER JOBU, UPLO -C .. Array Arguments .. - DOUBLE PRECISION A(LDA,*), C(LDC,*), DWORK(*), U(LDU,*) -C .. Local Scalars .. - LOGICAL LJOBA, LJOBI, LUPLO - INTEGER II, J, N1, NJ, P1, PAR1, PAR2, PAR3, PAR4, PAR5, - $ PAR6 - DOUBLE PRECISION DZ -C .. External Functions .. - LOGICAL LSAME - EXTERNAL LSAME -C .. External Subroutines .. - EXTERNAL DLARFG, DLASET, DLATZM, XERBLA -C .. Intrinsic Functions .. - INTRINSIC MAX, MIN -C .. Executable Statements .. -C - INFO = 0 - LUPLO = LSAME( UPLO, 'U' ) - LJOBI = LSAME( JOBU, 'I' ) - LJOBA = LJOBI.OR.LSAME( JOBU, 'U' ) -C -C Test the input scalar arguments. -C - IF( .NOT.LJOBA .AND. .NOT.LSAME( JOBU, 'N' ) ) THEN - INFO = -1 - ELSE IF( .NOT.LUPLO .AND. .NOT.LSAME( UPLO, 'L' ) ) THEN - INFO = -2 - ELSE IF( N.LT.0 ) THEN - INFO = -3 - ELSE IF( P.LT.0 ) THEN - INFO = -4 - ELSE IF( LDA.LT.MAX( 1, N ) ) THEN - INFO = -6 - ELSE IF( LDC.LT.MAX( 1, P ) ) THEN - INFO = -8 - ELSE IF( .NOT.LJOBA .AND. LDU.LT.1 .OR. - $ LJOBA .AND. LDU.LT.MAX( 1, N ) ) THEN - INFO = -10 - END IF -C - IF ( INFO.NE.0 ) THEN -C -C Error return -C - CALL XERBLA( 'TB01ND', -INFO ) - RETURN - END IF -C -C Quick return if possible. -C - IF ( N.EQ.0 .OR. P.EQ.0 ) - $ RETURN -C - P1 = P + 1 - N1 = N - 1 -C - IF ( LJOBI ) THEN -C -C Initialize U to the identity matrix. -C - CALL DLASET( 'Full', N, N, ZERO, ONE, U, LDU ) - END IF -C -C Perform transformations involving both C and A. -C - DO 20 J = 1, MIN( P, N1 ) - NJ = N - J - IF ( LUPLO ) THEN - PAR1 = P - J + 1 - PAR2 = NJ + 1 - PAR3 = 1 - PAR4 = P - J - PAR5 = NJ - ELSE - PAR1 = J - PAR2 = J - PAR3 = J + 1 - PAR4 = P - PAR5 = N - END IF -C - CALL DLARFG( NJ+1, C(PAR1,PAR2), C(PAR1,PAR3), LDC, DZ ) -C -C Update A. -C - CALL DLATZM( 'Left', NJ+1, N, C(PAR1,PAR3), LDC, DZ, A(PAR2,1), - $ A(PAR3,1), LDA, DWORK ) - CALL DLATZM( 'Right', N, NJ+1, C(PAR1,PAR3), LDC, DZ, - $ A(1,PAR2), A(1,PAR3), LDA, DWORK ) -C - IF ( LJOBA ) THEN -C -C Update U. -C - CALL DLATZM( 'Right', N, NJ+1, C(PAR1,PAR3), LDC, DZ, - $ U(1,PAR2), U(1,PAR3), LDU, DWORK ) - END IF -C - IF ( J.NE.P ) THEN -C -C Update C. -C - CALL DLATZM( 'Right', PAR4-PAR3+1, NJ+1, C(PAR1,PAR3), LDC, - $ DZ, C(PAR3,PAR2), C(PAR3,PAR3), LDC, DWORK ) - END IF -C - DO 10 II = PAR3, PAR5 - C(PAR1,II) = ZERO - 10 CONTINUE -C - 20 CONTINUE -C - DO 40 J = P1, N1 -C -C Perform next transformations only involving A. -C - NJ = N - J - IF ( LUPLO ) THEN - PAR1 = N + P1 - J - PAR2 = NJ + 1 - PAR3 = 1 - PAR4 = NJ - PAR5 = 1 - PAR6 = N + P - J - ELSE - PAR1 = J - P - PAR2 = J - PAR3 = J + 1 - PAR4 = N - PAR5 = J - P + 1 - PAR6 = N - END IF -C - IF ( NJ.GT.0 ) THEN -C - CALL DLARFG( NJ+1, A(PAR1,PAR2), A(PAR1,PAR3), LDA, DZ ) -C -C Update A. -C - CALL DLATZM( 'Left', NJ+1, N, A(PAR1,PAR3), LDA, DZ, - $ A(PAR2,1), A(PAR3,1), LDA, DWORK ) - CALL DLATZM( 'Right', PAR6-PAR5+1, NJ+1, A(PAR1,PAR3), LDA, - $ DZ, A(PAR5,PAR2), A(PAR5,PAR3), LDA, DWORK ) -C - IF ( LJOBA ) THEN -C -C Update U. -C - CALL DLATZM( 'Right', N, NJ+1, A(PAR1,PAR3), LDA, DZ, - $ U(1,PAR2), U(1,PAR3), LDU, DWORK ) - END IF -C - DO 30 II = PAR3, PAR4 - A(PAR1,II) = ZERO - 30 CONTINUE -C - END IF -C - 40 CONTINUE -C - RETURN -C *** Last line of TB01ND *** - END diff --git a/mex/sources/libslicot/TB01PD.f b/mex/sources/libslicot/TB01PD.f deleted file mode 100644 index c1c9594bd..000000000 --- a/mex/sources/libslicot/TB01PD.f +++ /dev/null @@ -1,352 +0,0 @@ - SUBROUTINE TB01PD( JOB, EQUIL, N, M, P, A, LDA, B, LDB, C, LDC, - $ NR, TOL, IWORK, DWORK, LDWORK, INFO ) -C -C SLICOT RELEASE 5.0. -C -C Copyright (c) 2002-2009 NICONET e.V. -C -C This program is free software: you can redistribute it and/or -C modify it under the terms of the GNU General Public License as -C published by the Free Software Foundation, either version 2 of -C the License, or (at your option) any later version. -C -C This program is distributed in the hope that it will be useful, -C but WITHOUT ANY WARRANTY; without even the implied warranty of -C MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the -C GNU General Public License for more details. -C -C You should have received a copy of the GNU General Public License -C along with this program. If not, see -C . -C -C PURPOSE -C -C To find a reduced (controllable, observable, or minimal) state- -C space representation (Ar,Br,Cr) for any original state-space -C representation (A,B,C). The matrix Ar is in upper block -C Hessenberg form. -C -C ARGUMENTS -C -C Mode Parameters -C -C JOB CHARACTER*1 -C Indicates whether the user wishes to remove the -C uncontrollable and/or unobservable parts as follows: -C = 'M': Remove both the uncontrollable and unobservable -C parts to get a minimal state-space representation; -C = 'C': Remove the uncontrollable part only to get a -C controllable state-space representation; -C = 'O': Remove the unobservable part only to get an -C observable state-space representation. -C -C EQUIL CHARACTER*1 -C Specifies whether the user wishes to preliminarily balance -C the triplet (A,B,C) as follows: -C = 'S': Perform balancing (scaling); -C = 'N': Do not perform balancing. -C -C Input/Output Parameters -C -C N (input) INTEGER -C The order of the original state-space representation, i.e. -C the order of the matrix A. N >= 0. -C -C M (input) INTEGER -C The number of system inputs. M >= 0. -C -C P (input) INTEGER -C The number of system outputs. P >= 0. -C -C A (input/output) DOUBLE PRECISION array, dimension (LDA,N) -C On entry, the leading N-by-N part of this array must -C contain the original state dynamics matrix A. -C On exit, the leading NR-by-NR part of this array contains -C the upper block Hessenberg state dynamics matrix Ar of a -C minimal, controllable, or observable realization for the -C original system, depending on the value of JOB, JOB = 'M', -C JOB = 'C', or JOB = 'O', respectively. -C -C LDA INTEGER -C The leading dimension of array A. LDA >= MAX(1,N). -C -C B (input/output) DOUBLE PRECISION array, dimension (LDB,M), -C if JOB = 'C', or (LDB,MAX(M,P)), otherwise. -C On entry, the leading N-by-M part of this array must -C contain the original input/state matrix B; if JOB = 'M', -C or JOB = 'O', the remainder of the leading N-by-MAX(M,P) -C part is used as internal workspace. -C On exit, the leading NR-by-M part of this array contains -C the transformed input/state matrix Br of a minimal, -C controllable, or observable realization for the original -C system, depending on the value of JOB, JOB = 'M', -C JOB = 'C', or JOB = 'O', respectively. -C If JOB = 'C', only the first IWORK(1) rows of B are -C nonzero. -C -C LDB INTEGER -C The leading dimension of array B. LDB >= MAX(1,N). -C -C C (input/output) DOUBLE PRECISION array, dimension (LDC,N) -C On entry, the leading P-by-N part of this array must -C contain the original state/output matrix C; if JOB = 'M', -C or JOB = 'O', the remainder of the leading MAX(M,P)-by-N -C part is used as internal workspace. -C On exit, the leading P-by-NR part of this array contains -C the transformed state/output matrix Cr of a minimal, -C controllable, or observable realization for the original -C system, depending on the value of JOB, JOB = 'M', -C JOB = 'C', or JOB = 'O', respectively. -C If JOB = 'M', or JOB = 'O', only the last IWORK(1) columns -C (in the first NR columns) of C are nonzero. -C -C LDC INTEGER -C The leading dimension of array C. -C LDC >= MAX(1,M,P) if N > 0. -C LDC >= 1 if N = 0. -C -C NR (output) INTEGER -C The order of the reduced state-space representation -C (Ar,Br,Cr) of a minimal, controllable, or observable -C realization for the original system, depending on -C JOB = 'M', JOB = 'C', or JOB = 'O'. -C -C Tolerances -C -C TOL DOUBLE PRECISION -C The tolerance to be used in rank determination when -C transforming (A, B, C). If the user sets TOL > 0, then -C the given value of TOL is used as a lower bound for the -C reciprocal condition number (see the description of the -C argument RCOND in the SLICOT routine MB03OD); a -C (sub)matrix whose estimated condition number is less than -C 1/TOL is considered to be of full rank. If the user sets -C TOL <= 0, then an implicitly computed, default tolerance -C (determined by the SLICOT routine TB01UD) is used instead. -C -C Workspace -C -C IWORK INTEGER array, dimension (N+MAX(M,P)) -C On exit, if INFO = 0, the first nonzero elements of -C IWORK(1:N) return the orders of the diagonal blocks of A. -C -C DWORK DOUBLE PRECISION array, dimension (LDWORK) -C On exit, if INFO = 0, DWORK(1) returns the optimal value -C of LDWORK. -C -C LDWORK INTEGER -C The length of the array DWORK. -C LDWORK >= MAX(1, N + MAX(N, 3*M, 3*P)). -C For optimum performance LDWORK should be larger. -C -C Error Indicator -C -C INFO INTEGER -C = 0: successful exit; -C < 0: if INFO = -i, the i-th argument had an illegal -C value. -C -C METHOD -C -C If JOB = 'M', the matrices A and B are operated on by orthogonal -C similarity transformations (made up of products of Householder -C transformations) so as to produce an upper block Hessenberg matrix -C A1 and a matrix B1 with all but its first rank(B) rows zero; this -C separates out the controllable part of the original system. -C Applying the same algorithm to the dual of this subsystem, -C therefore separates out the controllable and observable (i.e. -C minimal) part of the original system representation, with the -C final Ar upper block Hessenberg (after using pertransposition). -C If JOB = 'C', or JOB = 'O', only the corresponding part of the -C above procedure is applied. -C -C REFERENCES -C -C [1] Van Dooren, P. -C The Generalized Eigenstructure Problem in Linear System -C Theory. (Algorithm 1) -C IEEE Trans. Auto. Contr., AC-26, pp. 111-129, 1981. -C -C NUMERICAL ASPECTS -C 3 -C The algorithm requires 0(N ) operations and is backward stable. -C -C CONTRIBUTOR -C -C V. Sima, Katholieke Univ. Leuven, Belgium, Feb. 1998. -C -C REVISIONS -C -C A. Varga, DLR Oberpfaffenhofen, July 1998. -C A. Varga, DLR Oberpfaffenhofen, April 28, 1999. -C V. Sima, Research Institute for Informatics, Bucharest, Mar. 2004. -C -C KEYWORDS -C -C Hessenberg form, minimal realization, multivariable system, -C orthogonal transformation, state-space model, state-space -C representation. -C -C ****************************************************************** -C -C .. Parameters .. - INTEGER LDIZ - PARAMETER ( LDIZ = 1 ) - DOUBLE PRECISION ZERO, ONE - PARAMETER ( ZERO = 0.0D0, ONE = 1.0D0 ) -C .. Scalar Arguments .. - CHARACTER EQUIL, JOB - INTEGER INFO, LDA, LDB, LDC, LDWORK, M, N, NR, P - DOUBLE PRECISION TOL -C .. Array Arguments .. - INTEGER IWORK(*) - DOUBLE PRECISION A(LDA,*), B(LDB,*), C(LDC,*), DWORK(*) -C .. Local Scalars .. - LOGICAL LEQUIL, LNJOBC, LNJOBO - INTEGER I, INDCON, ITAU, IZ, JWORK, KL, MAXMP, NCONT, - $ WRKOPT - DOUBLE PRECISION MAXRED -C .. External Functions .. - LOGICAL LSAME - EXTERNAL LSAME -C .. External Subroutines .. - EXTERNAL AB07MD, TB01ID, TB01UD, TB01XD, XERBLA -C .. Intrinsic Functions .. - INTRINSIC INT, MAX, MIN -C .. Executable Statements .. -C - INFO = 0 - MAXMP = MAX( M, P ) - LNJOBC = .NOT.LSAME( JOB, 'C' ) - LNJOBO = .NOT.LSAME( JOB, 'O' ) - LEQUIL = LSAME( EQUIL, 'S' ) -C -C Test the input scalar arguments. -C - IF( LNJOBC .AND. LNJOBO .AND. .NOT.LSAME( JOB, 'M' ) ) THEN - INFO = -1 - ELSE IF( .NOT.LEQUIL .AND. .NOT.LSAME( EQUIL, 'N' ) ) THEN - INFO = -2 - ELSE IF( N.LT.0 ) THEN - INFO = -3 - ELSE IF( M.LT.0 ) THEN - INFO = -4 - ELSE IF( P.LT.0 ) THEN - INFO = -5 - ELSE IF( LDA.LT.MAX( 1, N ) ) THEN - INFO = -7 - ELSE IF( LDB.LT.MAX( 1, N ) ) THEN - INFO = -9 - ELSE IF( LDC.LT.1 .OR. ( N.GT.0 .AND. LDC.LT.MAXMP ) ) THEN - INFO = -11 - ELSE IF( LDWORK.LT.MAX( 1, N + MAX( N, 3*MAXMP ) ) ) THEN - INFO = -16 - END IF -C - IF ( INFO.NE.0 ) THEN -C -C Error return. -C - CALL XERBLA( 'TB01PD', -INFO ) - RETURN - END IF -C -C Quick return if possible. -C - IF ( N.EQ.0 .OR. ( LNJOBC .AND. MIN( N, P ).EQ.0 ) .OR. - $ ( LNJOBO .AND. MIN( N, M ).EQ.0 ) ) THEN - NR = 0 -C - DO 5 I = 1, N - IWORK(I) = 0 - 5 CONTINUE -C - DWORK(1) = ONE - RETURN - END IF -C -C If required, balance the triplet (A,B,C) (default MAXRED). -C Workspace: need N. -C -C (Note: Comments in the code beginning "Workspace:" describe the -C minimal amount of real workspace needed at that point in the code, -C as well as the preferred amount for good performance.) -C - IF ( LEQUIL ) THEN - MAXRED = ZERO - CALL TB01ID( 'A', N, M, P, MAXRED, A, LDA, B, LDB, C, LDC, - $ DWORK, INFO ) - WRKOPT = N - ELSE - WRKOPT = 1 - END IF -C - IZ = 1 - ITAU = 1 - JWORK = ITAU + N - IF ( LNJOBO ) THEN -C -C Separate out controllable subsystem (of order NCONT): -C A <-- Z'*A*Z, B <-- Z'*B, C <-- C*Z. -C -C Workspace: need N + MAX(N, 3*M, P). -C prefer larger. -C - CALL TB01UD( 'No Z', N, M, P, A, LDA, B, LDB, C, LDC, NCONT, - $ INDCON, IWORK, DWORK(IZ), LDIZ, DWORK(ITAU), TOL, - $ IWORK(N+1), DWORK(JWORK), LDWORK-JWORK+1, INFO ) -C - WRKOPT = INT( DWORK(JWORK) ) + JWORK - 1 - ELSE - NCONT = N - END IF -C - IF ( LNJOBC ) THEN -C -C Separate out the observable subsystem (of order NR): -C Form the dual of the subsystem of order NCONT (which is -C controllable, if JOB = 'M'), leaving rest as it is. -C - CALL AB07MD( 'Z', NCONT, M, P, A, LDA, B, LDB, C, LDC, DWORK, - $ 1, INFO ) -C -C And separate out the controllable part of this dual subsystem. -C -C Workspace: need NCONT + MAX(NCONT, 3*P, M). -C prefer larger. -C - CALL TB01UD( 'No Z', NCONT, P, M, A, LDA, B, LDB, C, LDC, NR, - $ INDCON, IWORK, DWORK(IZ), LDIZ, DWORK(ITAU), TOL, - $ IWORK(N+1), DWORK(JWORK), LDWORK-JWORK+1, INFO ) -C - WRKOPT = MAX( WRKOPT, INT( DWORK(JWORK) )+JWORK-1 ) -C -C Transpose and reorder (to get a block upper Hessenberg -C matrix A), giving, for JOB = 'M', the controllable and -C observable (i.e., minimal) part of original system. -C - IF( INDCON.GT.0 ) THEN - KL = IWORK(1) - 1 - IF ( INDCON.GE.2 ) - $ KL = KL + IWORK(2) - ELSE - KL = 0 - END IF - CALL TB01XD( 'Zero D', NR, P, M, KL, MAX( 0, NR-1 ), A, LDA, - $ B, LDB, C, LDC, DWORK, 1, INFO ) - ELSE - NR = NCONT - END IF -C -C Annihilate the trailing components of IWORK(1:N). -C - DO 10 I = INDCON + 1, N - IWORK(I) = 0 - 10 CONTINUE -C -C Set optimal workspace dimension. -C - DWORK(1) = WRKOPT - RETURN -C *** Last line of TB01PD *** - END diff --git a/mex/sources/libslicot/TB01TD.f b/mex/sources/libslicot/TB01TD.f deleted file mode 100644 index 7c52957ad..000000000 --- a/mex/sources/libslicot/TB01TD.f +++ /dev/null @@ -1,308 +0,0 @@ - SUBROUTINE TB01TD( N, M, P, A, LDA, B, LDB, C, LDC, D, LDD, LOW, - $ IGH, SCSTAT, SCIN, SCOUT, DWORK, INFO ) -C -C SLICOT RELEASE 5.0. -C -C Copyright (c) 2002-2009 NICONET e.V. -C -C This program is free software: you can redistribute it and/or -C modify it under the terms of the GNU General Public License as -C published by the Free Software Foundation, either version 2 of -C the License, or (at your option) any later version. -C -C This program is distributed in the hope that it will be useful, -C but WITHOUT ANY WARRANTY; without even the implied warranty of -C MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the -C GNU General Public License for more details. -C -C You should have received a copy of the GNU General Public License -C along with this program. If not, see -C . -C -C PURPOSE -C -C To reduce a given state-space representation (A,B,C,D) to -C balanced form by means of state permutations and state, input and -C output scalings. -C -C ARGUMENTS -C -C Input/Output Parameters -C -C N (input) INTEGER -C The order of the state-space representation, i.e. the -C order of the original state dynamics matrix A. N >= 0. -C -C M (input) INTEGER -C The number of system inputs. M >= 0. -C -C P (input) INTEGER -C The number of system outputs. P >= 0. -C -C A (input/output) DOUBLE PRECISION array, dimension (LDA,N) -C On entry, the leading N-by-N part of this array must -C contain the original state dynamics matrix A. -C On exit, the leading N-by-N part of this array contains -C the balanced state dynamics matrix A. -C -C LDA INTEGER -C The leading dimension of array A. LDA >= MAX(1,N). -C -C B (input/output) DOUBLE PRECISION array, dimension (LDB,M) -C On entry, the leading N-by-M part of this array must -C contain the original input/state matrix B. -C On exit, the leading N-by-M part of this array contains -C the balanced input/state matrix B. -C -C LDB INTEGER -C The leading dimension of array B. LDB >= MAX(1,N). -C -C C (input/output) DOUBLE PRECISION array, dimension (LDC,N) -C On entry, the leading P-by-N part of this array must -C contain the original state/output matrix C. -C On exit, the leading P-by-N part of this array contains -C the balanced state/output matrix C. -C -C LDC INTEGER -C The leading dimension of array C. LDC >= MAX(1,P). -C -C D (input/output) DOUBLE PRECISION array, dimension (LDD,M) -C On entry, the leading P-by-M part of this array must -C contain the original direct transmission matrix D. -C On exit, the leading P-by-M part of this array contains -C the scaled direct transmission matrix D. -C -C LDD INTEGER -C The leading dimension of array D. LDD >= MAX(1,P). -C -C LOW (output) INTEGER -C The index of the lower end of the balanced submatrix of A. -C -C IGH (output) INTEGER -C The index of the upper end of the balanced submatrix of A. -C -C SCSTAT (output) DOUBLE PRECISION array, dimension (N) -C This array contains the information defining the -C similarity transformations used to permute and balance -C the state dynamics matrix A, as returned from the LAPACK -C library routine DGEBAL. -C -C SCIN (output) DOUBLE PRECISION array, dimension (M) -C Contains the scalars used to scale the system inputs so -C that the columns of the final matrix B have norms roughly -C equal to the column sums of the balanced matrix A -C (see FURTHER COMMENTS). -C The j-th input of the balanced state-space representation -C is SCIN(j)*(j-th column of the permuted and balanced -C input/state matrix B). -C -C SCOUT (output) DOUBLE PRECISION array, dimension (P) -C Contains the scalars used to scale the system outputs so -C that the rows of the final matrix C have norms roughly -C equal to the row sum of the balanced matrix A. -C The i-th output of the balanced state-space representation -C is SCOUT(i)*(i-th row of the permuted and balanced -C state/ouput matrix C). -C -C Workspace -C -C DWORK DOUBLE PRECISION array, dimension (N) -C -C Error Indicator -C -C INFO INTEGER -C = 0: successful exit; -C < 0: if INFO = -i, the i-th argument had an illegal -C value. -C -C METHOD -C -C Similarity transformations are used to permute the system states -C and balance the corresponding row and column sum norms of a -C submatrix of the state dynamics matrix A. These operations are -C also applied to the input/state matrix B and the system inputs -C are then scaled (see parameter SCIN) so that the columns of the -C final matrix B have norms roughly equal to the column sum norm of -C the balanced matrix A (see FURTHER COMMENTS). -C The above operations are also applied to the matrix C, and the -C system outputs are then scaled (see parameter SCOUT) so that the -C rows of the final matrix C have norms roughly equal to the row sum -C norm of the balanced matrix A (see FURTHER COMMENTS). -C Finally, the (I,J)-th element of the direct transmission matrix D -C is scaled as -C D(I,J) = D(I,J)*(1.0/SCIN(J))*SCOUT(I), where I = 1,2,...,P -C and J = 1,2,...,M. -C -C Scaling performed to balance the row/column sum norms is by -C integer powers of the machine base so as to avoid introducing -C rounding errors. -C -C REFERENCES -C -C [1] Wilkinson, J.H. and Reinsch, C. -C Handbook for Automatic Computation, (Vol II, Linear Algebra). -C Springer-Verlag, 1971, (contribution II/11). -C -C NUMERICAL ASPECTS -C 3 -C The algorithm requires 0(N ) operations and is backward stable. -C -C FURTHER COMMENTS -C -C The columns (rows) of the final matrix B (matrix C) have norms -C 'roughly' equal to the column (row) sum norm of the balanced -C matrix A, i.e. -C size/BASE < abssum <= size -C where -C BASE = the base of the arithmetic used on the computer, which -C can be obtained from the LAPACK Library routine -C DLAMCH; -C -C size = column or row sum norm of the balanced matrix A; -C abssum = column sum norm of the balanced matrix B or row sum -C norm of the balanced matrix C. -C -C The routine is BASE dependent. -C -C CONTRIBUTOR -C -C Release 3.0: V. Sima, Katholieke Univ. Leuven, Belgium, Dec. 1996. -C Supersedes Release 2.0 routine TB01HD by T.W.C.Williams, Kingston -C Polytechnic, United Kingdom, October 1982. -C -C REVISIONS -C -C - -C -C KEYWORDS -C -C Balanced form, orthogonal transformation, similarity -C transformation, state-space model, state-space representation. -C -C ****************************************************************** -C -C .. Parameters .. - DOUBLE PRECISION ONE - PARAMETER ( ONE = 1.0D0 ) -C .. Scalar Arguments .. - INTEGER IGH, INFO, LDA, LDB, LDC, LDD, LOW, M, N, P -C .. Array Arguments .. - DOUBLE PRECISION A(LDA,*), B(LDB,*), C(LDC,*), D(LDD,*), - $ DWORK(*), SCIN(*), SCOUT(*), SCSTAT(*) -C .. Local Scalars .. - INTEGER I, J, K, KNEW, KOLD - DOUBLE PRECISION ACNORM, ARNORM, SCALE -C .. External Functions .. - DOUBLE PRECISION DLANGE - EXTERNAL DLANGE -C .. External Subroutines .. - EXTERNAL DGEBAL, DSCAL, DSWAP, TB01TY, XERBLA -C .. Intrinsic Functions .. - INTRINSIC INT, MAX -C .. Executable Statements .. -C - INFO = 0 -C -C Test the input scalar arguments. -C - IF( N.LT.0 ) THEN - INFO = -1 - ELSE IF( M.LT.0 ) THEN - INFO = -2 - ELSE IF( P.LT.0 ) THEN - INFO = -3 - ELSE IF( LDA.LT.MAX( 1, N ) ) THEN - INFO = -5 - ELSE IF( LDB.LT.MAX( 1, N ) ) THEN - INFO = -7 - ELSE IF( LDC.LT.MAX( 1, P ) ) THEN - INFO = -9 - ELSE IF( LDD.LT.MAX( 1, P ) ) THEN - INFO = -11 - END IF -C - IF ( INFO.NE.0 ) THEN -C -C Error return. -C - CALL XERBLA( 'TB01TD', -INFO ) - RETURN - END IF -C -C Quick return if possible. -C - IF ( MAX( N, M, P ).EQ.0 ) THEN - LOW = 1 - IGH = N - RETURN - END IF -C -C Permute states, and balance a submatrix of A. -C - CALL DGEBAL( 'Both', N, A, LDA, LOW, IGH, SCSTAT, INFO ) -C -C Use the information in SCSTAT on state scalings and reorderings -C to transform B and C. -C - DO 10 K = 1, N - KOLD = K - IF ( ( LOW.GT.KOLD ) .OR. ( KOLD.GT.IGH ) ) THEN - IF ( KOLD.LT.LOW ) KOLD = LOW - KOLD - KNEW = INT( SCSTAT(KOLD) ) - IF ( KNEW.NE.KOLD ) THEN -C -C Exchange rows KOLD and KNEW of B. -C - CALL DSWAP( M, B(KOLD,1), LDB, B(KNEW,1), LDB ) -C -C Exchange columns KOLD and KNEW of C. -C - CALL DSWAP( P, C(1,KOLD), 1, C(1,KNEW), 1 ) - END IF - END IF - 10 CONTINUE -C - IF ( IGH.NE.LOW ) THEN -C - DO 20 K = LOW, IGH - SCALE = SCSTAT(K) -C -C Scale the K-th row of permuted B. -C - CALL DSCAL( M, ONE/SCALE, B(K,1), LDB ) -C -C Scale the K-th column of permuted C. -C - CALL DSCAL( P, SCALE, C(1,K), 1 ) - 20 CONTINUE -C - END IF -C -C Calculate the column and row sum norms of A. -C - ACNORM = DLANGE( '1-norm', N, N, A, LDA, DWORK ) - ARNORM = DLANGE( 'I-norm', N, N, A, LDA, DWORK ) -C -C Scale the columns of B (i.e. inputs) to have norms roughly ACNORM. -C - CALL TB01TY( 1, 0, 0, N, M, ACNORM, B, LDB, SCIN ) -C -C Scale the rows of C (i.e. outputs) to have norms roughly ARNORM. -C - CALL TB01TY( 0, 0, 0, P, N, ARNORM, C, LDC, SCOUT ) -C -C Finally, apply these input and output scalings to D and set SCIN. -C - DO 40 J = 1, M - SCALE = SCIN(J) -C - DO 30 I = 1, P - D(I,J) = D(I,J)*( SCALE*SCOUT(I) ) - 30 CONTINUE -C - SCIN(J) = ONE/SCALE - 40 CONTINUE -C - RETURN -C *** Last line of TB01TD *** - END diff --git a/mex/sources/libslicot/TB01TY.f b/mex/sources/libslicot/TB01TY.f deleted file mode 100644 index 6dada6fa4..000000000 --- a/mex/sources/libslicot/TB01TY.f +++ /dev/null @@ -1,136 +0,0 @@ - SUBROUTINE TB01TY( MODE, IOFF, JOFF, NROW, NCOL, SIZE, X, LDX, - $ BVECT ) -C -C SLICOT RELEASE 5.0. -C -C Copyright (c) 2002-2009 NICONET e.V. -C -C This program is free software: you can redistribute it and/or -C modify it under the terms of the GNU General Public License as -C published by the Free Software Foundation, either version 2 of -C the License, or (at your option) any later version. -C -C This program is distributed in the hope that it will be useful, -C but WITHOUT ANY WARRANTY; without even the implied warranty of -C MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the -C GNU General Public License for more details. -C -C You should have received a copy of the GNU General Public License -C along with this program. If not, see -C . -C -C Balances the rows (MODE .EQ. 0) or columns (MODE .NE. 0) of the -C (NROW x NCOL) block of the matrix X with offset (IOFF,JOFF), i.e. -C with first (top left) element (IOFF + 1,JOFF + 1). Each non- -C zero row (column) is balanced in the sense that it is multiplied -C by that integer power of the base of the machine floating-point -C representation for which the sum of the absolute values of its -C entries (i.e. its 1-norm) satisfies -C -C (SIZE / BASE) .LT. ABSSUM .LE. SIZE -C -C for SIZE as input. (Note that this form of scaling does not -C introduce any rounding errors.) The vector BVECT then contains -C the appropriate scale factors in rows (IOFF + 1)...(IOFF + NROW) -C (columns (JOFF + 1)...(JOFF + NCOL) ). In particular, if the -C I-th row (J-th column) of the block is 'numerically' non-zero -C with 1-norm given by BASE**(-EXPT) for some real EXPT, then the -C desired scale factor (returned as element IOFF + I (JOFF + J) of -C BVECT) is BASE**IEXPT, where IEXPT is the largest integer .LE. -C EXPT: this integer is precisely the truncation INT(EXPT) except -C for negative non-integer EXPT, in which case this value is too -C high by 1 and so must be adjusted accordingly. Finally, note -C that the element of BVECT corresponding to a 'numerically' zero -C row (column) is simply set equal to 1.0. -C -C For efficiency, no tests of the input scalar parameters are -C performed. -C -C REVISIONS -C -C - -C -C ****************************************************************** -C - DOUBLE PRECISION ONE - PARAMETER ( ONE = 1.0D0 ) -C .. Scalar Arguments .. - INTEGER IOFF, JOFF, LDX, MODE, NCOL, NROW - DOUBLE PRECISION SIZE -C .. Array Arguments .. - DOUBLE PRECISION BVECT(*), X(LDX,*) -C .. Local Scalars .. - DOUBLE PRECISION ABSSUM, DIV, EPS, EXPT, SCALE, TEST - INTEGER BASE, I, IEXPT, J -C .. External Functions .. - DOUBLE PRECISION DASUM, DLAMCH - EXTERNAL DASUM, DLAMCH -C .. External Subroutines .. - EXTERNAL DSCAL -C .. Intrinsic Functions .. - INTRINSIC ABS, DBLE, INT, LOG -C .. Executable Statements .. -C - BASE = DLAMCH( 'Base' ) - EPS = DLAMCH( 'Epsilon' ) -C - DIV = ONE/LOG( DBLE( BASE ) ) - IF ( MODE.NE.0 ) THEN -C -C Balance one column at a time using its column-sum norm. -C - DO 10 J = JOFF + 1, JOFF + NCOL - ABSSUM = DASUM( NROW, X(IOFF+1,J), 1 )/ABS( SIZE ) - TEST = ABSSUM/DBLE( NROW ) - IF ( TEST.GT.EPS ) THEN -C -C Non-zero column: calculate (and apply) correct scale -C factor. -C - EXPT = -DIV*LOG( ABSSUM ) - IEXPT = INT( EXPT ) - IF ( ( IEXPT.LT.0 ) .AND. ( DBLE( IEXPT ).NE.EXPT ) ) - $ IEXPT = IEXPT - 1 - SCALE = DBLE( BASE )**IEXPT - BVECT(J) = SCALE - CALL DSCAL( NROW, SCALE, X(IOFF+1,J), 1 ) - ELSE -C -C 'Numerically' zero column: do not rescale. -C - BVECT(J) = ONE - END IF - 10 CONTINUE -C - ELSE -C -C Balance one row at a time using its row-sum norm. -C - DO 20 I = IOFF + 1, IOFF + NROW - ABSSUM = DASUM( NCOL, X(I,JOFF+1), LDX )/ABS( SIZE ) - TEST = ABSSUM/DBLE( NCOL ) - IF ( TEST.GT.EPS ) THEN -C -C Non-zero row: calculate (and apply) correct scale factor. -C - EXPT = -DIV*LOG( ABSSUM ) - IEXPT = INT( EXPT ) - IF ( ( IEXPT.LT.0 ) .AND. ( DBLE( IEXPT ).NE.EXPT ) ) - $ IEXPT = IEXPT - 1 -C - SCALE = DBLE( BASE )**IEXPT - BVECT(I) = SCALE - CALL DSCAL( NCOL, SCALE, X(I,JOFF+1), LDX ) - ELSE -C -C 'Numerically' zero row: do not rescale. -C - BVECT(I) = ONE - END IF - 20 CONTINUE -C - END IF -C - RETURN -C *** Last line of TB01TY *** - END diff --git a/mex/sources/libslicot/TB01UD.f b/mex/sources/libslicot/TB01UD.f deleted file mode 100644 index 191780145..000000000 --- a/mex/sources/libslicot/TB01UD.f +++ /dev/null @@ -1,491 +0,0 @@ - SUBROUTINE TB01UD( JOBZ, N, M, P, A, LDA, B, LDB, C, LDC, NCONT, - $ INDCON, NBLK, Z, LDZ, TAU, TOL, IWORK, DWORK, - $ LDWORK, INFO ) -C -C SLICOT RELEASE 5.0. -C -C Copyright (c) 2002-2009 NICONET e.V. -C -C This program is free software: you can redistribute it and/or -C modify it under the terms of the GNU General Public License as -C published by the Free Software Foundation, either version 2 of -C the License, or (at your option) any later version. -C -C This program is distributed in the hope that it will be useful, -C but WITHOUT ANY WARRANTY; without even the implied warranty of -C MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the -C GNU General Public License for more details. -C -C You should have received a copy of the GNU General Public License -C along with this program. If not, see -C . -C -C PURPOSE -C -C To find a controllable realization for the linear time-invariant -C multi-input system -C -C dX/dt = A * X + B * U, -C Y = C * X, -C -C where A, B, and C are N-by-N, N-by-M, and P-by-N matrices, -C respectively, and A and B are reduced by this routine to -C orthogonal canonical form using (and optionally accumulating) -C orthogonal similarity transformations, which are also applied -C to C. Specifically, the system (A, B, C) is reduced to the -C triplet (Ac, Bc, Cc), where Ac = Z' * A * Z, Bc = Z' * B, -C Cc = C * Z, with -C -C [ Acont * ] [ Bcont ] -C Ac = [ ], Bc = [ ], -C [ 0 Auncont ] [ 0 ] -C -C and -C -C [ A11 A12 . . . A1,p-1 A1p ] [ B1 ] -C [ A21 A22 . . . A2,p-1 A2p ] [ 0 ] -C [ 0 A32 . . . A3,p-1 A3p ] [ 0 ] -C Acont = [ . . . . . . . ], Bc = [ . ], -C [ . . . . . . ] [ . ] -C [ . . . . . ] [ . ] -C [ 0 0 . . . Ap,p-1 App ] [ 0 ] -C -C where the blocks B1, A21, ..., Ap,p-1 have full row ranks and -C p is the controllability index of the pair. The size of the -C block Auncont is equal to the dimension of the uncontrollable -C subspace of the pair (A, B). -C -C ARGUMENTS -C -C Mode Parameters -C -C JOBZ CHARACTER*1 -C Indicates whether the user wishes to accumulate in a -C matrix Z the orthogonal similarity transformations for -C reducing the system, as follows: -C = 'N': Do not form Z and do not store the orthogonal -C transformations; -C = 'F': Do not form Z, but store the orthogonal -C transformations in the factored form; -C = 'I': Z is initialized to the unit matrix and the -C orthogonal transformation matrix Z is returned. -C -C Input/Output Parameters -C -C N (input) INTEGER -C The order of the original state-space representation, -C i.e. the order of the matrix A. N >= 0. -C -C M (input) INTEGER -C The number of system inputs, or of columns of B. M >= 0. -C -C P (input) INTEGER -C The number of system outputs, or of rows of C. P >= 0. -C -C A (input/output) DOUBLE PRECISION array, dimension (LDA,N) -C On entry, the leading N-by-N part of this array must -C contain the original state dynamics matrix A. -C On exit, the leading NCONT-by-NCONT part contains the -C upper block Hessenberg state dynamics matrix Acont in Ac, -C given by Z' * A * Z, of a controllable realization for -C the original system. The elements below the first block- -C subdiagonal are set to zero. The leading N-by-N part -C contains the matrix Ac. -C -C LDA INTEGER -C The leading dimension of array A. LDA >= MAX(1,N). -C -C B (input/output) DOUBLE PRECISION array, dimension (LDB,M) -C On entry, the leading N-by-M part of this array must -C contain the input matrix B. -C On exit, the leading NCONT-by-M part of this array -C contains the transformed input matrix Bcont in Bc, given -C by Z' * B, with all elements but the first block set to -C zero. The leading N-by-M part contains the matrix Bc. -C -C LDB INTEGER -C The leading dimension of array B. LDB >= MAX(1,N). -C -C C (input/output) DOUBLE PRECISION array, dimension (LDC,N) -C On entry, the leading P-by-N part of this array must -C contain the output matrix C. -C On exit, the leading P-by-N part of this array contains -C the transformed output matrix Cc, given by C * Z. -C -C LDC INTEGER -C The leading dimension of array C. LDC >= MAX(1,P). -C -C NCONT (output) INTEGER -C The order of the controllable state-space representation. -C -C INDCON (output) INTEGER -C The controllability index of the controllable part of the -C system representation. -C -C NBLK (output) INTEGER array, dimension (N) -C The leading INDCON elements of this array contain the -C the orders of the diagonal blocks of Acont. -C -C Z (output) DOUBLE PRECISION array, dimension (LDZ,N) -C If JOBZ = 'I', then the leading N-by-N part of this -C array contains the matrix of accumulated orthogonal -C similarity transformations which reduces the given system -C to orthogonal canonical form. -C If JOBZ = 'F', the elements below the diagonal, with the -C array TAU, represent the orthogonal transformation matrix -C as a product of elementary reflectors. The transformation -C matrix can then be obtained by calling the LAPACK Library -C routine DORGQR. -C If JOBZ = 'N', the array Z is not referenced and can be -C supplied as a dummy array (i.e. set parameter LDZ = 1 and -C declare this array to be Z(1,1) in the calling program). -C -C LDZ INTEGER -C The leading dimension of array Z. If JOBZ = 'I' or -C JOBZ = 'F', LDZ >= MAX(1,N); if JOBZ = 'N', LDZ >= 1. -C -C TAU (output) DOUBLE PRECISION array, dimension (N) -C The elements of TAU contain the scalar factors of the -C elementary reflectors used in the reduction of B and A. -C -C Tolerances -C -C TOL DOUBLE PRECISION -C The tolerance to be used in rank determination when -C transforming (A, B). If the user sets TOL > 0, then -C the given value of TOL is used as a lower bound for the -C reciprocal condition number (see the description of the -C argument RCOND in the SLICOT routine MB03OD); a -C (sub)matrix whose estimated condition number is less than -C 1/TOL is considered to be of full rank. If the user sets -C TOL <= 0, then an implicitly computed, default tolerance, -C defined by TOLDEF = N*N*EPS, is used instead, where EPS -C is the machine precision (see LAPACK Library routine -C DLAMCH). -C -C Workspace -C -C IWORK INTEGER array, dimension (M) -C -C DWORK DOUBLE PRECISION array, dimension (LDWORK) -C On exit, if INFO = 0, DWORK(1) returns the optimal value -C of LDWORK. -C -C LDWORK INTEGER -C The length of the array DWORK. -C LDWORK >= MAX(1, N, 3*M, P). -C For optimum performance LDWORK should be larger. -C -C Error Indicator -C -C INFO INTEGER -C = 0: successful exit; -C < 0: if INFO = -i, the i-th argument had an illegal -C value. -C -C METHOD -C -C Matrix B is first QR-decomposed and the appropriate orthogonal -C similarity transformation applied to the matrix A. Leaving the -C first rank(B) states unchanged, the remaining lower left block -C of A is then QR-decomposed and the new orthogonal matrix, Q1, -C is also applied to the right of A to complete the similarity -C transformation. By continuing in this manner, a completely -C controllable state-space pair (Acont, Bcont) is found for the -C given (A, B), where Acont is upper block Hessenberg with each -C subdiagonal block of full row rank, and Bcont is zero apart from -C its (independent) first rank(B) rows. -C All orthogonal transformations determined in this process are also -C applied to the matrix C, from the right. -C NOTE that the system controllability indices are easily -C calculated from the dimensions of the blocks of Acont. -C -C REFERENCES -C -C [1] Konstantinov, M.M., Petkov, P.Hr. and Christov, N.D. -C Orthogonal Invariants and Canonical Forms for Linear -C Controllable Systems. -C Proc. 8th IFAC World Congress, Kyoto, 1, pp. 49-54, 1981. -C -C [2] Paige, C.C. -C Properties of numerical algorithms related to computing -C controllablity. -C IEEE Trans. Auto. Contr., AC-26, pp. 130-138, 1981. -C -C [3] Petkov, P.Hr., Konstantinov, M.M., Gu, D.W. and -C Postlethwaite, I. -C Optimal Pole Assignment Design of Linear Multi-Input Systems. -C Leicester University, Report 99-11, May 1996. -C -C NUMERICAL ASPECTS -C 3 -C The algorithm requires 0(N ) operations and is backward stable. -C -C FURTHER COMMENTS -C -C If the system matrices A and B are badly scaled, it would be -C useful to scale them with SLICOT routine TB01ID, before calling -C the routine. -C -C CONTRIBUTOR -C -C V. Sima, Katholieke Univ. Leuven, Belgium, Feb. 1998. -C -C REVISIONS -C -C V. Sima, Katholieke Univ. Leuven, Belgium, May 1999, Nov. 2003. -C A. Varga, DLR Oberpfaffenhofen, March 2002, Nov. 2003. -C -C KEYWORDS -C -C Controllability, minimal realization, orthogonal canonical form, -C orthogonal transformation. -C -C ****************************************************************** -C -C .. Parameters .. - DOUBLE PRECISION ZERO, ONE - PARAMETER ( ZERO = 0.0D0, ONE = 1.0D0 ) -C .. Scalar Arguments .. - CHARACTER JOBZ - INTEGER INDCON, INFO, LDA, LDB, LDC, LDWORK, LDZ, M, N, - $ NCONT, P - DOUBLE PRECISION TOL -C .. Array Arguments .. - DOUBLE PRECISION A(LDA,*), B(LDB,*), C(LDC,*), DWORK(*), TAU(*), - $ Z(LDZ,*) - INTEGER IWORK(*), NBLK(*) -C .. Local Scalars .. - LOGICAL LJOBF, LJOBI, LJOBZ - INTEGER IQR, ITAU, J, MCRT, NBL, NCRT, NI, NJ, RANK, - $ WRKOPT - DOUBLE PRECISION ANORM, BNORM, FNRM, TOLDEF -C .. Local Arrays .. - DOUBLE PRECISION SVAL(3) -C .. External Functions .. - LOGICAL LSAME - DOUBLE PRECISION DLAMCH, DLANGE, DLAPY2 - EXTERNAL DLAMCH, DLANGE, DLAPY2, LSAME -C .. External Subroutines .. - EXTERNAL DCOPY, DLACPY, DLAPMT, DLASET, DORGQR, DORMQR, - $ MB01PD, MB03OY, XERBLA -C .. Intrinsic Functions .. - INTRINSIC DBLE, INT, MAX, MIN -C .. -C .. Executable Statements .. -C - INFO = 0 - LJOBF = LSAME( JOBZ, 'F' ) - LJOBI = LSAME( JOBZ, 'I' ) - LJOBZ = LJOBF.OR.LJOBI -C -C Test the input scalar arguments. -C - IF( .NOT.LJOBZ .AND. .NOT.LSAME( JOBZ, 'N' ) ) THEN - INFO = -1 - ELSE IF( N.LT.0 ) THEN - INFO = -2 - ELSE IF( M.LT.0 ) THEN - INFO = -3 - ELSE IF( P.LT.0 ) THEN - INFO = -4 - ELSE IF( LDA.LT.MAX( 1, N ) ) THEN - INFO = -6 - ELSE IF( LDB.LT.MAX( 1, N ) ) THEN - INFO = -8 - ELSE IF( LDC.LT.MAX( 1, P ) ) THEN - INFO = -10 - ELSE IF( .NOT.LJOBZ .AND. LDZ.LT.1 .OR. - $ LJOBZ .AND. LDZ.LT.MAX( 1, N ) ) THEN - INFO = -15 - ELSE IF( LDWORK.LT.MAX( 1, N, 3*M, P ) ) THEN - INFO = -20 - END IF -C - IF ( INFO.NE.0 ) THEN -C -C Error return. -C - CALL XERBLA( 'TB01UD', -INFO ) - RETURN - END IF -C - NCONT = 0 - INDCON = 0 -C -C Calculate the absolute norms of A and B (used for scaling). -C - ANORM = DLANGE( 'M', N, N, A, LDA, DWORK ) - BNORM = DLANGE( 'M', N, M, B, LDB, DWORK ) -C -C Quick return if possible. -C - IF ( MIN( N, M ).EQ.0 .OR. BNORM.EQ.ZERO ) THEN - IF( N.GT.0 ) THEN - IF ( LJOBI ) THEN - CALL DLASET( 'Full', N, N, ZERO, ONE, Z, LDZ ) - ELSE IF ( LJOBF ) THEN - CALL DLASET( 'Full', N, N, ZERO, ZERO, Z, LDZ ) - CALL DLASET( 'Full', N, 1, ZERO, ZERO, TAU, N ) - END IF - END IF - DWORK(1) = ONE - RETURN - END IF -C -C Scale (if needed) the matrices A and B. -C - CALL MB01PD( 'S', 'G', N, N, 0, 0, ANORM, 0, NBLK, A, LDA, INFO ) - CALL MB01PD( 'S', 'G', N, M, 0, 0, BNORM, 0, NBLK, B, LDB, INFO ) -C -C Compute the Frobenius norm of [ B A ] (used for rank estimation). -C - FNRM = DLAPY2( DLANGE( 'F', N, M, B, LDB, DWORK ), - $ DLANGE( 'F', N, N, A, LDA, DWORK ) ) -C - TOLDEF = TOL - IF ( TOLDEF.LE.ZERO ) THEN -C -C Use the default tolerance in controllability determination. -C - TOLDEF = DBLE( N*N )*DLAMCH( 'EPSILON' ) - END IF -C - IF ( FNRM.LT.TOLDEF ) - $ FNRM = ONE -C - WRKOPT = 1 - NI = 0 - ITAU = 1 - NCRT = N - MCRT = M - IQR = 1 -C -C (Note: Comments in the code beginning "Workspace:" describe the -C minimal amount of real workspace needed at that point in the -C code, as well as the preferred amount for good performance. -C NB refers to the optimal block size for the immediately -C following subroutine, as returned by ILAENV.) -C - 10 CONTINUE -C -C Rank-revealing QR decomposition with column pivoting. -C The calculation is performed in NCRT rows of B starting from -C the row IQR (initialized to 1 and then set to rank(B)+1). -C Workspace: 3*MCRT. -C - CALL MB03OY( NCRT, MCRT, B(IQR,1), LDB, TOLDEF, FNRM, RANK, - $ SVAL, IWORK, TAU(ITAU), DWORK, INFO ) -C - IF ( RANK.NE.0 ) THEN - NJ = NI - NI = NCONT - NCONT = NCONT + RANK - INDCON = INDCON + 1 - NBLK(INDCON) = RANK -C -C Premultiply and postmultiply the appropriate block row -C and block column of A by Q' and Q, respectively. -C Workspace: need NCRT; -C prefer NCRT*NB. -C - CALL DORMQR( 'Left', 'Transpose', NCRT, NCRT, RANK, - $ B(IQR,1), LDB, TAU(ITAU), A(NI+1,NI+1), LDA, - $ DWORK, LDWORK, INFO ) - WRKOPT = MAX( WRKOPT, INT( DWORK(1) ) ) -C -C Workspace: need N; -C prefer N*NB. -C - CALL DORMQR( 'Right', 'No transpose', N, NCRT, RANK, - $ B(IQR,1), LDB, TAU(ITAU), A(1,NI+1), LDA, - $ DWORK, LDWORK, INFO ) - WRKOPT = MAX( WRKOPT, INT( DWORK(1) ) ) -C -C Postmultiply the appropriate block column of C by Q. -C Workspace: need P; -C prefer P*NB. -C - CALL DORMQR( 'Right', 'No transpose', P, NCRT, RANK, - $ B(IQR,1), LDB, TAU(ITAU), C(1,NI+1), LDC, - $ DWORK, LDWORK, INFO ) - WRKOPT = MAX( WRKOPT, INT( DWORK(1) ) ) -C -C If required, save transformations. -C - IF ( LJOBZ.AND.NCRT.GT.1 ) THEN - CALL DLACPY( 'L', NCRT-1, MIN( RANK, NCRT-1 ), - $ B(IQR+1,1), LDB, Z(NI+2,ITAU), LDZ ) - END IF -C -C Zero the subdiagonal elements of the current matrix. -C - IF ( RANK.GT.1 ) - $ CALL DLASET( 'L', RANK-1, RANK-1, ZERO, ZERO, B(IQR+1,1), - $ LDB ) -C -C Backward permutation of the columns of B or A. -C - IF ( INDCON.EQ.1 ) THEN - CALL DLAPMT( .FALSE., RANK, M, B(IQR,1), LDB, IWORK ) - IQR = RANK + 1 - ELSE - DO 20 J = 1, MCRT - CALL DCOPY( RANK, B(IQR,J), 1, A(NI+1,NJ+IWORK(J)), - $ 1 ) - 20 CONTINUE - END IF -C - ITAU = ITAU + RANK - IF ( RANK.NE.NCRT ) THEN - MCRT = RANK - NCRT = NCRT - RANK - CALL DLACPY( 'G', NCRT, MCRT, A(NCONT+1,NI+1), LDA, - $ B(IQR,1), LDB ) - CALL DLASET( 'G', NCRT, MCRT, ZERO, ZERO, - $ A(NCONT+1,NI+1), LDA ) - GO TO 10 - END IF - END IF -C -C If required, accumulate transformations. -C Workspace: need N; prefer N*NB. -C - IF ( LJOBI ) THEN - CALL DORGQR( N, N, ITAU-1, Z, LDZ, TAU, DWORK, - $ LDWORK, INFO ) - WRKOPT = MAX( WRKOPT, INT( DWORK(1) ) ) - END IF -C -C Annihilate the trailing blocks of B. -C - IF( IQR.LE.N ) - $ CALL DLASET( 'G', N-IQR+1, M, ZERO, ZERO, B(IQR,1), LDB ) -C -C Annihilate the trailing elements of TAU, if JOBZ = 'F'. -C - IF ( LJOBF ) THEN - DO 30 J = ITAU, N - TAU(J) = ZERO - 30 CONTINUE - END IF -C -C Undo scaling of A and B. -C - IF ( INDCON.LT.N ) THEN - NBL = INDCON + 1 - NBLK(NBL) = N - NCONT - ELSE - NBL = 0 - END IF - CALL MB01PD( 'U', 'H', N, N, 0, 0, ANORM, NBL, NBLK, A, LDA, - $ INFO ) - CALL MB01PD( 'U', 'G', NBLK(1), M, 0, 0, BNORM, 0, NBLK, B, LDB, - $ INFO ) -C -C Set optimal workspace dimension. -C - DWORK(1) = WRKOPT - RETURN -C *** Last line of TB01UD *** - END diff --git a/mex/sources/libslicot/TB01VD.f b/mex/sources/libslicot/TB01VD.f deleted file mode 100644 index 26cd1c7c3..000000000 --- a/mex/sources/libslicot/TB01VD.f +++ /dev/null @@ -1,503 +0,0 @@ - SUBROUTINE TB01VD( APPLY, N, M, L, A, LDA, B, LDB, C, LDC, D, LDD, - $ X0, THETA, LTHETA, DWORK, LDWORK, INFO ) -C -C SLICOT RELEASE 5.0. -C -C Copyright (c) 2002-2009 NICONET e.V. -C -C This program is free software: you can redistribute it and/or -C modify it under the terms of the GNU General Public License as -C published by the Free Software Foundation, either version 2 of -C the License, or (at your option) any later version. -C -C This program is distributed in the hope that it will be useful, -C but WITHOUT ANY WARRANTY; without even the implied warranty of -C MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the -C GNU General Public License for more details. -C -C You should have received a copy of the GNU General Public License -C along with this program. If not, see -C . -C -C PURPOSE -C -C To convert the linear discrete-time system given as (A, B, C, D), -C with initial state x0, into the output normal form [1], with -C parameter vector THETA. The matrix A is assumed to be stable. -C The matrices A, B, C, D and the vector x0 are converted, so that -C on exit they correspond to the system defined by THETA. -C -C ARGUMENTS -C -C Mode Parameters -C -C APPLY CHARACTER*1 -C Specifies whether or not the parameter vector should be -C transformed using a bijective mapping, as follows: -C = 'A' : apply the bijective mapping to the N vectors in -C THETA corresponding to the matrices A and C; -C = 'N' : do not apply the bijective mapping. -C The transformation performed when APPLY = 'A' allows -C to get rid of the constraints norm(THETAi) < 1, i = 1:N. -C A call of the SLICOT Library routine TB01VY associated to -C a call of TB01VD must use the same value of APPLY. -C -C Input/Output Parameters -C -C N (input) INTEGER -C The order of the system. N >= 0. -C -C M (input) INTEGER -C The number of system inputs. M >= 0. -C -C L (input) INTEGER -C The number of system outputs. L >= 0. -C -C A (input/output) DOUBLE PRECISION array, dimension (LDA,N) -C On entry, the leading N-by-N part of this array must -C contain the system state matrix A, assumed to be stable. -C On exit, the leading N-by-N part of this array contains -C the transformed system state matrix corresponding to the -C output normal form with parameter vector THETA. -C -C LDA INTEGER -C The leading dimension of array A. LDA >= MAX(1,N). -C -C B (input/output) DOUBLE PRECISION array, dimension (LDB,M) -C On entry, the leading N-by-M part of this array must -C contain the system input matrix B. -C On exit, the leading N-by-M part of this array contains -C the transformed system input matrix corresponding to the -C output normal form with parameter vector THETA. -C -C LDB INTEGER -C The leading dimension of array B. LDB >= MAX(1,N). -C -C C (input/output) DOUBLE PRECISION array, dimension (LDC,N) -C On entry, the leading L-by-N part of this array must -C contain the system output matrix C. -C On exit, the leading L-by-N part of this array contains -C the transformed system output matrix corresponding to the -C output normal form with parameter vector THETA. -C -C LDC INTEGER -C The leading dimension of array C. LDC >= MAX(1,L). -C -C D (input) DOUBLE PRECISION array, dimension (LDD,M) -C The leading L-by-M part of this array must contain the -C system input/output matrix D. -C -C LDD INTEGER -C The leading dimension of array D. LDD >= MAX(1,L). -C -C X0 (input/output) DOUBLE PRECISION array, dimension (N) -C On entry, this array must contain the initial state of the -C system, x0. -C On exit, this array contains the transformed initial state -C of the system, corresponding to the output normal form -C with parameter vector THETA. -C -C THETA (output) DOUBLE PRECISION array, dimension (LTHETA) -C The leading N*(L+M+1)+L*M part of this array contains the -C parameter vector that defines a system (A, B, C, D, x0) -C which is equivalent up to a similarity transformation to -C the system given on entry. The parameters are: -C -C THETA(1:N*L) : parameters for A, C; -C THETA(N*L+1:N*(L+M)) : parameters for B; -C THETA(N*(L+M)+1:N*(L+M)+L*M) : parameters for D; -C THETA(N*(L+M)+L*M+1:N*(L+M+1)+L*M): parameters for x0. -C -C LTHETA INTEGER -C The length of array THETA. LTHETA >= N*(L+M+1)+L*M. -C -C Workspace -C -C DWORK DOUBLE PRECISION array, dimension (LDWORK) -C On exit, if INFO = 0, DWORK(1) returns the optimal value -C of LDWORK. -C -C LDWORK INTEGER -C The length of the array DWORK. -C LDWORK >= MAX(1, N*N*L + N*L + N, -C N*N + MAX(N*N + N*MAX(N,L) + 6*N + MIN(N,L), -C N*M)). -C For optimum performance LDWORK should be larger. -C -C Error Indicator -C -C INFO INTEGER -C = 0: successful exit; -C < 0: if INFO = -i, the i-th argument had an illegal -C value; -C = 1: if the Lyapunov equation A'*Q*A - Q = -scale^2*C'*C -C could only be solved with scale = 0; -C = 2: if matrix A is not discrete-time stable; -C = 3: if the QR algorithm failed to converge for -C matrix A. -C -C METHOD -C -C The matrices A and C are converted to output normal form. -C First, the Lyapunov equation -C -C A'*Q*A - Q = -scale^2*C'*C, -C -C is solved in the Cholesky factor T, T'*T = Q, and then T is used -C to get the transformation matrix. -C -C The matrix B and the initial state x0 are transformed accordingly. -C -C Then, the QR factorization of the transposed observability matrix -C is computed, and the matrix Q is used to further transform the -C system matrices. The parameters characterizing A and C are finally -C obtained by applying a set of N orthogonal transformations. -C -C REFERENCES -C -C [1] Peeters, R.L.M., Hanzon, B., and Olivi, M. -C Balanced realizations of discrete-time stable all-pass -C systems and the tangential Schur algorithm. -C Proceedings of the European Control Conference, -C 31 August - 3 September 1999, Karlsruhe, Germany. -C Session CP-6, Discrete-time Systems, 1999. -C -C CONTRIBUTORS -C -C A. Riedel, R. Schneider, Chemnitz University of Technology, -C Oct. 2000, during a stay at University of Twente, NL. -C -C REVISIONS -C -C V. Sima, Research Institute for Informatics, Bucharest, Mar. 2001, -C Feb. 2002, Feb. 2004. -C -C KEYWORDS -C -C Asymptotically stable, Lyapunov equation, output normal form, -C parameter estimation, similarity transformation. -C -C ****************************************************************** -C -C .. Parameters .. - DOUBLE PRECISION ZERO, ONE, TWO, HALF - PARAMETER ( ZERO = 0.0D0, ONE = 1.0D0, TWO = 2.0D0, - $ HALF = 0.5D0 ) -C .. Scalar Arguments .. - CHARACTER APPLY - INTEGER INFO, L, LDA, LDB, LDC, LDD, LDWORK, LTHETA, M, - $ N -C .. Array Arguments .. - DOUBLE PRECISION A(LDA,*), B(LDB,*), C(LDC,*), D(LDD,*), - $ DWORK(*), THETA(*), X0(*) -C .. Local Scalars .. - DOUBLE PRECISION PIBY2, RI, SCALE, TI - INTEGER CA, I, IA, IN, IQ, IR, IT, ITAU, IU, IWI, IWR, - $ J, JWORK, K, LDCA, LDT, WRKOPT - LOGICAL LAPPLY -C .. External Functions .. - EXTERNAL DNRM2, LSAME - DOUBLE PRECISION DNRM2 - LOGICAL LSAME -C .. External Subroutines .. - EXTERNAL DAXPY, DCOPY, DGEMM, DGEMV, DGEQRF, DGER, - $ DLACPY, DLASET, DORMQR, DSCAL, DTRMM, DTRMV, - $ DTRSM, MA02AD, SB03OD, XERBLA -C .. Intrinsic Functions .. - INTRINSIC ATAN, INT, MAX, MIN, SQRT, TAN -C .. -C .. Executable Statements .. -C -C Check the scalar input parameters. -C - LAPPLY = LSAME( APPLY, 'A' ) -C - INFO = 0 - IF ( .NOT.( LAPPLY .OR. LSAME( APPLY, 'N' ) ) ) THEN - INFO = -1 - ELSEIF ( N.LT.0 ) THEN - INFO = -2 - ELSEIF ( M.LT.0 ) THEN - INFO = -3 - ELSEIF ( L.LT.0 ) THEN - INFO = -4 - ELSEIF ( LDA.LT.MAX( 1, N ) ) THEN - INFO = -6 - ELSEIF ( LDB.LT.MAX( 1, N ) ) THEN - INFO = -8 - ELSEIF ( LDC.LT.MAX( 1, L ) ) THEN - INFO = -10 - ELSEIF ( LDD.LT.MAX( 1, L ) ) THEN - INFO = -12 - ELSEIF ( LTHETA.LT.( N*( M + L + 1 ) + L*M ) ) THEN - INFO = -15 - ELSEIF ( LDWORK.LT.MAX( 1, N*N*L + N*L + N, N*N + - $ MAX( N*( N + MAX( N, L ) + 6 ) + - $ MIN( N, L ), N*M ) ) ) THEN - INFO = -17 - ENDIF -C -C Return if there are illegal arguments. -C - IF( INFO.NE.0 ) THEN - CALL XERBLA( 'TB01VD', -INFO ) - RETURN - ENDIF -C -C Quick return if possible. -C - IF ( MAX( N, M, L ).EQ.0 ) THEN - DWORK(1) = ONE - RETURN - ELSE IF ( N.EQ.0 ) THEN - CALL DLACPY( 'Full', L, M, D, LDD, THETA, MAX( 1, L ) ) - DWORK(1) = ONE - RETURN - ELSE IF ( L.EQ.0 ) THEN - CALL DLACPY( 'Full', N, M, B, LDB, THETA, N ) - CALL DCOPY( N, X0, 1, THETA(N*M+1), 1 ) - DWORK(1) = ONE - RETURN - ENDIF -C -C (Note: Comments in the code beginning "Workspace:" describe the -C minimal amount of real workspace needed at that point in the -C code, as well as the preferred amount for good performance. -C NB refers to the optimal block size for the immediately -C following subroutine, as returned by ILAENV.) -C - WRKOPT = 1 - PIBY2 = TWO*ATAN( ONE ) -C -C Convert A and C to output normal form. -C First, solve the Lyapunov equation -C A'*Q*A - Q = -scale^2*C'*C, -C in the Cholesky factor T, T'*T = Q, and use T to get the -C transformation matrix. Copy A and C, to preserve them. -C -C Workspace: need N*(2*N + MAX(N,L) + 6) + MIN(N,L). -C prefer larger. -C -C Initialize the indices in the workspace. -C - LDT = MAX( N, L ) - CA = 1 - IA = 1 - IT = IA + N*N - IU = IT + LDT*N - IWR = IU + N*N - IWI = IWR + N -C - JWORK = IWI + N -C - CALL DLACPY( 'Full', N, N, A, LDA, DWORK(IA), N ) - CALL DLACPY( 'Full', L, N, C, LDC, DWORK(IT), LDT ) -C - CALL SB03OD( 'Discrete', 'NotFactored', 'NoTranspose', N, L, - $ DWORK(IA), N, DWORK(IU), N, DWORK(IT), LDT, SCALE, - $ DWORK(IWR), DWORK(IWI), DWORK(JWORK), LDWORK-JWORK+1, - $ INFO ) - IF ( INFO.NE.0 ) THEN - IF ( INFO.EQ.6 ) THEN - INFO = 3 - ELSE - INFO = 2 - ENDIF - RETURN - ENDIF - WRKOPT = INT( DWORK(JWORK) ) + JWORK - 1 -C - IF ( SCALE.EQ.ZERO ) THEN - INFO = 1 - RETURN - ENDIF -C -C Compute A = T*A*T^(-1). -C - CALL DTRMM( 'Left', 'Upper', 'NoTranspose', 'NonUnit', N, N, ONE, - $ DWORK(IT), LDT, A, LDA ) -C - CALL DTRSM( 'Right', 'Upper', 'NoTranspose', 'NonUnit', N, N, ONE, - $ DWORK(IT), LDT, A, LDA ) - IF ( M.GT.0 ) THEN -C -C Compute B = (1/scale)*T*B. -C - CALL DTRMM( 'Left', 'Upper', 'NoTranspose', 'NonUnit', N, M, - $ ONE/SCALE, DWORK(IT), LDT, B, LDB ) - ENDIF -C -C Compute x0 = (1/scale)*T*x0. -C - CALL DTRMV( 'Upper', 'NoTranspose', 'NonUnit', N, DWORK(IT), LDT, - $ X0, 1 ) - CALL DSCAL( N, ONE/SCALE, X0, 1 ) -C -C Compute C = scale*C*T^(-1). -C - CALL DTRSM( 'Right', 'Upper', 'NoTranspose', 'NonUnit', L, N, - $ SCALE, DWORK(IT), LDT, C, LDC ) -C -C Now, the system has been transformed to the output normal form. -C Build the transposed observability matrix in DWORK(CA) and compute -C its QR factorization. -C - CALL MA02AD( 'Full', L, N, C, LDC, DWORK(CA), N ) -C - DO 10 I = 1, N - 1 - CALL DGEMM( 'Transpose', 'NoTranspose', N, L, N, ONE, A, LDA, - $ DWORK(CA+(I-1)*N*L), N, ZERO, DWORK(CA+I*N*L), N ) - 10 CONTINUE -C -C Compute the QR factorization. -C -C Workspace: need N*N*L + N + L*N. -C prefer N*N*L + N + NB*L*N. -C - ITAU = CA + N*N*L - JWORK = ITAU + N - CALL DGEQRF( N, L*N, DWORK(CA), N, DWORK(ITAU), DWORK(JWORK), - $ LDWORK-JWORK+1, INFO ) - WRKOPT = MAX( WRKOPT, INT( DWORK(JWORK) ) + JWORK - 1 ) -C -C Compute Q such that R has all diagonal elements nonnegative. -C Only the first N*N part of R is needed. Move the details -C of the QR factorization process, to gain memory and efficiency. -C -C Workspace: need 2*N*N + 2*N. -C prefer 2*N*N + N + NB*N. -C - IR = N*N + 1 - IF ( L.NE.2 ) - $ CALL DCOPY( N, DWORK(ITAU), 1, DWORK(IR+N*N), 1 ) - CALL DLACPY( 'Lower', N, N, DWORK(CA), N, DWORK(IR), N ) - ITAU = IR + N*N - JWORK = ITAU + N -C - IQ = 1 - CALL DLASET( 'Full', N, N, ZERO, ONE, DWORK(IQ), N ) -C - DO 20 I = 1, N - IF ( DWORK(IR+(I-1)*(N+1)).LT.ZERO ) - $ DWORK(IQ+(I-1)*(N+1))= -ONE - 20 CONTINUE -C - CALL DORMQR( 'Left', 'NoTranspose', N, N, N, DWORK(IR), N, - $ DWORK(ITAU), DWORK(IQ), N, DWORK(JWORK), - $ LDWORK-JWORK+1, INFO ) - WRKOPT = MAX( WRKOPT, INT( DWORK(JWORK) ) + JWORK - 1 ) - JWORK = IR -C -C Now, the transformation matrix Q is in DWORK(IQ). -C -C Compute A = Q'*A*Q. -C - CALL DGEMM( 'Transpose', 'NoTranspose', N, N, N, ONE, DWORK(IQ), - $ N, A, LDA, ZERO, DWORK(JWORK), N ) - CALL DGEMM( 'NoTranspose', 'NoTranspose', N, N, N, ONE, - $ DWORK(JWORK), N, DWORK(IQ), N, ZERO, A, LDA ) -C - IF ( M.GT.0 ) THEN -C -C Compute B = Q'*B. -C Workspace: need N*N + N*M. -C - CALL DLACPY( 'Full', N, M, B, LDB, DWORK(JWORK), N ) - CALL DGEMM( 'Transpose', 'NoTranspose', N, M, N, ONE, - $ DWORK(IQ), N, DWORK(JWORK), N, ZERO, B, LDB ) - ENDIF -C -C Compute C = C*Q. -C Workspace: need N*N + N*L. -C - CALL DLACPY( 'Full', L, N, C, LDC, DWORK(JWORK), L ) - CALL DGEMM( 'NoTranspose', 'NoTranspose', L, N, N, ONE, - $ DWORK(JWORK), L, DWORK(IQ), N, ZERO, C, LDC ) -C -C Compute x0 = Q'*x0. -C - CALL DCOPY( N, X0, 1, DWORK(JWORK), 1 ) - CALL DGEMV( 'Transpose', N, N, ONE, DWORK(IQ), N, DWORK(JWORK), - $ 1, ZERO, X0, 1 ) -C -C Now, copy C and A into the workspace to make it easier to read out -C the corresponding part of THETA, and to apply the transformations. -C - LDCA = N + L -C - DO 30 I = 1, N - CALL DCOPY( L, C(1,I), 1, DWORK(CA+(I-1)*LDCA), 1 ) - CALL DCOPY( N, A(1,I), 1, DWORK(CA+L+(I-1)*LDCA), 1 ) - 30 CONTINUE -C - JWORK = CA + LDCA*N -C -C The parameters characterizing A and C are extracted in this loop. -C Workspace: need N*(N + L + 1). -C - DO 60 I = 1, N - CALL DCOPY( L, DWORK(CA+1+(N-I)*(LDCA+1)), 1, THETA((I-1)*L+1), - $ 1 ) - RI = DWORK(CA+(N-I)*(LDCA+1)) - TI = DNRM2( L, THETA((I-1)*L+1), 1 ) -C -C Multiply the part of [C; A] which will be currently transformed -C with Ui = [ -THETAi, Si; RI, THETAi' ] from the left, without -C storing Ui. Ui has the size (L+1)-by-(L+1). -C - CALL DGEMV( 'Transpose', L, N, ONE, DWORK(CA+N-I+1), LDCA, - $ THETA((I-1)*L+1), 1, ZERO, DWORK(JWORK), 1 ) -C - IF ( TI.GT.ZERO ) THEN - CALL DGER( L, N, (RI-ONE)/TI/TI, THETA((I-1)*L+1), 1, - $ DWORK(JWORK), 1, DWORK(CA+N-I+1), LDCA ) - ELSE -C -C The call below is for the limiting case. -C - CALL DGER( L, N, -HALF, THETA((I-1)*L+1), 1, - $ DWORK(JWORK), 1, DWORK(CA+N-I+1), LDCA ) - ENDIF -C - CALL DGER( L, N, -ONE, THETA((I-1)*L+1), 1, DWORK(CA+N-I), - $ LDCA, DWORK(CA+N-I+1), LDCA ) - CALL DAXPY( N, RI, DWORK(CA+N-I), LDCA, DWORK(JWORK), 1 ) -C -C Move these results to their appropriate locations. -C - DO 50 J = 1, N - IN = CA + N - I + ( J - 1 )*LDCA - DO 40 K = IN + 1, IN + L - DWORK(K-1) = DWORK(K) - 40 CONTINUE - DWORK(IN+L) = DWORK(JWORK+J-1) - 50 CONTINUE -C -C Now, apply the bijective mapping, which allows to get rid -C of the constraint norm(THETAi) < 1. -C - IF ( LAPPLY .AND. TI.NE.ZERO ) - $ CALL DSCAL( L, TAN( TI*PIBY2 )/TI, THETA((I-1)*L+1), 1 ) -C - 60 CONTINUE -C - IF ( M.GT.0 ) THEN -C -C The next part of THETA is B. -C - CALL DLACPY( 'Full', N, M, B, LDB, THETA(N*L+1), N ) -C -C Copy the matrix D. -C - CALL DLACPY( 'Full', L, M, D, LDD, THETA(N*(L+M)+1), L ) - ENDIF -C -C Copy the initial state x0. -C - CALL DCOPY( N, X0, 1, THETA(N*(L+M)+L*M+1), 1 ) -C - DWORK(1) = WRKOPT - RETURN -C -C *** Last line of TB01VD *** - END diff --git a/mex/sources/libslicot/TB01VY.f b/mex/sources/libslicot/TB01VY.f deleted file mode 100644 index d18361a20..000000000 --- a/mex/sources/libslicot/TB01VY.f +++ /dev/null @@ -1,317 +0,0 @@ - SUBROUTINE TB01VY( APPLY, N, M, L, THETA, LTHETA, A, LDA, B, LDB, - $ C, LDC, D, LDD, X0, DWORK, LDWORK, INFO ) -C -C SLICOT RELEASE 5.0. -C -C Copyright (c) 2002-2009 NICONET e.V. -C -C This program is free software: you can redistribute it and/or -C modify it under the terms of the GNU General Public License as -C published by the Free Software Foundation, either version 2 of -C the License, or (at your option) any later version. -C -C This program is distributed in the hope that it will be useful, -C but WITHOUT ANY WARRANTY; without even the implied warranty of -C MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the -C GNU General Public License for more details. -C -C You should have received a copy of the GNU General Public License -C along with this program. If not, see -C . -C -C PURPOSE -C -C To convert the linear discrete-time system given as its output -C normal form [1], with parameter vector THETA, into the state-space -C representation (A, B, C, D), with the initial state x0. -C -C ARGUMENTS -C -C Mode Parameters -C -C APPLY CHARACTER*1 -C Specifies whether or not the parameter vector should be -C transformed using a bijective mapping, as follows: -C = 'A' : apply the bijective mapping to the N vectors in -C THETA corresponding to the matrices A and C; -C = 'N' : do not apply the bijective mapping. -C The transformation performed when APPLY = 'A' allows -C to get rid of the constraints norm(THETAi) < 1, i = 1:N. -C A call of the SLICOT Library routine TB01VD associated to -C a call of TB01VY must use the same value of APPLY. -C -C Input/Output Parameters -C -C N (input) INTEGER -C The order of the system. N >= 0. -C -C M (input) INTEGER -C The number of system inputs. M >= 0. -C -C L (input) INTEGER -C The number of system outputs. L >= 0. -C -C THETA (input) DOUBLE PRECISION array, dimension (LTHETA) -C The leading N*(L+M+1)+L*M part of this array must contain -C the parameter vector that defines a system (A, B, C, D), -C with the initial state x0. The parameters are: -C -C THETA(1:N*L) : parameters for A, C; -C THETA(N*L+1:N*(L+M)) : parameters for B; -C THETA(N*(L+M)+1:N*(L+M)+L*M) : parameters for D; -C THETA(N*(L+M)+L*M+1:N*(L+M+1)+L*M): parameters for x0. -C -C LTHETA INTEGER -C The length of array THETA. LTHETA >= N*(L+M+1)+L*M. -C -C A (output) DOUBLE PRECISION array, dimension (LDA,N) -C The leading N-by-N part of this array contains the system -C state matrix corresponding to the output normal form with -C parameter vector THETA. -C -C LDA INTEGER -C The leading dimension of array A. LDA >= MAX(1,N). -C -C B (output) DOUBLE PRECISION array, dimension (LDB,M) -C The leading N-by-M part of this array contains the system -C input matrix corresponding to the output normal form with -C parameter vector THETA. -C -C LDB INTEGER -C The leading dimension of array B. LDB >= MAX(1,N). -C -C C (output) DOUBLE PRECISION array, dimension (LDC,N) -C The leading L-by-N part of this array contains the system -C output matrix corresponding to the output normal form with -C parameter vector THETA. -C -C LDC INTEGER -C The leading dimension of array C. LDC >= MAX(1,L). -C -C D (output) DOUBLE PRECISION array, dimension (LDD,M) -C The leading L-by-M part of this array contains the system -C input/output matrix corresponding to the output normal -C form with parameter vector THETA. -C -C LDD INTEGER -C The leading dimension of array D. LDD >= MAX(1,L). -C -C X0 (output) DOUBLE PRECISION array, dimension (N) -C This array contains the initial state of the system, x0, -C corresponding to the output normal form with parameter -C vector THETA. -C -C Workspace -C -C DWORK DOUBLE PRECISION array, dimension (LDWORK) -C -C LDWORK INTEGER -C The length of the array DWORK. -C LDWORK >= N*(N+L+1). -C -C Error Indicator -C -C INFO INTEGER -C = 0: successful exit; -C < 0: if INFO = -i, the i-th argument had an illegal -C value. -C -C METHOD -C -C The parameters characterizing A and C are used to build N -C orthogonal transformations, which are then applied to recover -C these matrices. -C -C CONTRIBUTORS -C -C A. Riedel, R. Schneider, Chemnitz University of Technology, -C Oct. 2000, during a stay at University of Twente, NL. -C -C REVISIONS -C -C V. Sima, Research Institute for Informatics, Bucharest, Mar. 2001, -C Feb. 2002, Feb. 2004. -C -C KEYWORDS -C -C Asymptotically stable, output normal form, parameter estimation, -C similarity transformation. -C -C ****************************************************************** -C -C .. Parameters .. - DOUBLE PRECISION ZERO, ONE, HALF - PARAMETER ( ZERO = 0.0D0, ONE = 1.0D0, HALF = 0.5D0 ) -C .. Scalar Arguments .. - CHARACTER APPLY - INTEGER INFO, L, LDA, LDB, LDC, LDD, LDWORK, LTHETA, M, - $ N -C .. Array Arguments .. - DOUBLE PRECISION A(LDA,*), B(LDB,*), C(LDC,*), D(LDD,*), - $ DWORK(*), THETA(*), X0(*) -C .. Local Scalars .. - DOUBLE PRECISION FACTOR, RI, TI, TOBYPI - INTEGER CA, JWORK, I, IN, J, K, LDCA - LOGICAL LAPPLY -C .. External Functions .. - EXTERNAL DNRM2, LSAME - DOUBLE PRECISION DNRM2 - LOGICAL LSAME -C .. External Subroutines .. - EXTERNAL DAXPY, DCOPY, DGEMV, DGER, DLACPY, DSCAL, - $ XERBLA -C .. Intrinsic Functions .. - INTRINSIC ATAN, MAX, SQRT -C .. -C .. Executable Statements .. -C -C Check the scalar input parameters. -C - LAPPLY = LSAME( APPLY, 'A' ) -C - INFO = 0 - IF ( .NOT.( LAPPLY .OR. LSAME( APPLY, 'N' ) ) ) THEN - INFO = -1 - ELSEIF ( N.LT.0 ) THEN - INFO = -2 - ELSEIF ( M.LT.0 ) THEN - INFO = -3 - ELSEIF ( L.LT.0 ) THEN - INFO = -4 - ELSEIF ( LTHETA.LT.( N*( L + M + 1 ) + L*M ) ) THEN - INFO = -6 - ELSEIF ( LDA.LT.MAX( 1, N ) ) THEN - INFO = -8 - ELSEIF ( LDB.LT.MAX( 1, N ) ) THEN - INFO = -10 - ELSEIF ( LDC.LT.MAX( 1, L ) ) THEN - INFO = -12 - ELSEIF ( LDD.LT.MAX( 1, L ) ) THEN - INFO = -14 - ELSEIF ( LDWORK.LT.N*( N + L + 1 ) ) THEN - INFO = -17 - ENDIF -C -C Return if there are illegal arguments. -C - IF( INFO.NE.0 ) THEN - CALL XERBLA( 'TB01VY', -INFO ) - RETURN - ENDIF -C -C Quick return if possible. -C - IF ( MAX( N, M, L ).EQ.0 ) - $ RETURN -C - IF ( M.GT.0 ) THEN -C -C Copy the matrix B from THETA. -C - CALL DLACPY( 'Full', N, M, THETA(N*L+1), N, B, LDB ) -C -C Copy the matrix D. -C - CALL DLACPY( 'Full', L, M, THETA(N*(L+M)+1), L, D, LDD ) - ENDIF -C - IF ( N.EQ.0 ) THEN - RETURN - ELSE IF ( L.EQ.0 ) THEN - CALL DCOPY( N, THETA(N*M+1), 1, X0, 1 ) - RETURN - END IF -C -C Initialize the indices in the workspace. -C - LDCA = N + L -C - CA = 1 -C - JWORK = CA + N*LDCA - TOBYPI = HALF/ATAN( ONE ) -C -C Generate the matrices C and A from their parameters. -C Start with the block matrix [0; I], where 0 is a block of zeros -C of size L-by-N, and I is the identity matrix of order N. -C - DWORK(CA) = ZERO - CALL DCOPY( N*(L+N), DWORK(CA), 0, DWORK(CA), 1 ) - DWORK(CA+L) = ONE - CALL DCOPY( N, DWORK(CA+L), 0, DWORK(CA+L), LDCA+1 ) -C -C Now, read out THETA(1 : N*L) and perform the transformations -C defined by the parameters in THETA. -C - DO 30 I = N, 1, -1 -C -C Save THETAi in the first column of C and use the copy for -C further processing. -C - CALL DCOPY( L, THETA((I-1)*L+1), 1, C, 1 ) - TI = DNRM2( L, C, 1 ) - IF ( LAPPLY .AND. TI.NE.ZERO ) THEN -C -C Apply the bijective mapping which guarantees that TI < 1. -C - FACTOR = TOBYPI*ATAN( TI )/TI -C -C Scale THETAi and apply the same scaling on TI. -C - CALL DSCAL( L, FACTOR, C, 1 ) - TI = TI*FACTOR - END IF -C -C RI = sqrt( 1 - TI**2 ). -C - RI = SQRT( ( ONE - TI )*( ONE + TI ) ) -C -C Multiply a certain part of DWORK(CA) with Ui' from the left, -C where Ui = [ -THETAi, Si; RI, THETAi' ] is (L+1)-by-(L+1), but -C Ui is not stored. -C - CALL DGEMV( 'Transpose', L, N, -ONE, DWORK(CA+N-I), LDCA, C, 1, - $ ZERO, DWORK(JWORK), 1 ) -C - IF ( TI.GT.ZERO ) THEN - CALL DGER( L, N, (ONE-RI)/TI/TI, C, 1, DWORK(JWORK), 1, - $ DWORK(CA+N-I), LDCA ) - ELSE -C -C The call below is for the limiting case. -C - CALL DGER( L, N, HALF, C, 1, DWORK(JWORK), 1, - $ DWORK(CA+N-I), LDCA ) - ENDIF -C - CALL DGER( L, N, ONE, C, 1, DWORK(CA+N-I+L), LDCA, - $ DWORK(CA+N-I), LDCA ) - CALL DAXPY( N, RI, DWORK(CA+N-I+L), LDCA, DWORK(JWORK), 1 ) -C -C Move these results to their appropriate locations. -C - DO 20 J = 1, N - IN = CA + N - I + ( J - 1 )*LDCA - DO 10 K = IN + L, IN + 1, -1 - DWORK(K) = DWORK(K-1) - 10 CONTINUE - DWORK(IN) = DWORK(JWORK+J-1) - 20 CONTINUE -C - 30 CONTINUE -C -C Now, DWORK(CA) = [C; A]. Copy to C and A. -C - DO 40 I = 1, N - CALL DCOPY( L, DWORK(CA+(I-1)*LDCA), 1, C(1,I), 1 ) - CALL DCOPY( N, DWORK(CA+L+(I-1)*LDCA), 1, A(1,I), 1 ) - 40 CONTINUE -C -C Copy the initial state x0. -C - CALL DCOPY( N, THETA(N*(L+M)+L*M+1), 1, X0, 1 ) -C - RETURN -C -C *** Last line of TB01VY *** - END diff --git a/mex/sources/libslicot/TB01WD.f b/mex/sources/libslicot/TB01WD.f deleted file mode 100644 index 36dd01231..000000000 --- a/mex/sources/libslicot/TB01WD.f +++ /dev/null @@ -1,259 +0,0 @@ - SUBROUTINE TB01WD( N, M, P, A, LDA, B, LDB, C, LDC, U, LDU, - $ WR, WI, DWORK, LDWORK, INFO ) -C -C SLICOT RELEASE 5.0. -C -C Copyright (c) 2002-2009 NICONET e.V. -C -C This program is free software: you can redistribute it and/or -C modify it under the terms of the GNU General Public License as -C published by the Free Software Foundation, either version 2 of -C the License, or (at your option) any later version. -C -C This program is distributed in the hope that it will be useful, -C but WITHOUT ANY WARRANTY; without even the implied warranty of -C MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the -C GNU General Public License for more details. -C -C You should have received a copy of the GNU General Public License -C along with this program. If not, see -C . -C -C PURPOSE -C -C To reduce the system state matrix A to an upper real Schur form -C by using an orthogonal similarity transformation A <-- U'*A*U and -C to apply the transformation to the matrices B and C: B <-- U'*B -C and C <-- C*U. -C -C ARGUMENTS -C -C Input/Output Parameters -C -C N (input) INTEGER -C The order of the original state-space representation, -C i.e. the order of the matrix A. N >= 0. -C -C M (input) INTEGER -C The number of system inputs, or of columns of B. M >= 0. -C -C P (input) INTEGER -C The number of system outputs, or of rows of C. P >= 0. -C -C A (input/output) DOUBLE PRECISION array, dimension (LDA,N) -C On entry, the leading N-by-N part of this array must -C contain the original state dynamics matrix A. -C On exit, the leading N-by-N part of this array contains -C the matrix U' * A * U in real Schur form. The elements -C below the first subdiagonal are set to zero. -C Note: A matrix is in real Schur form if it is upper -C quasi-triangular with 1-by-1 and 2-by-2 blocks. -C 2-by-2 blocks are standardized in the form -C [ a b ] -C [ c a ] -C where b*c < 0. The eigenvalues of such a block -C are a +- sqrt(bc). -C -C LDA INTEGER -C The leading dimension of array A. LDA >= MAX(1,N). -C -C B (input/output) DOUBLE PRECISION array, dimension (LDB,M) -C On entry, the leading N-by-M part of this array must -C contain the input matrix B. -C On exit, the leading N-by-M part of this array contains -C the transformed input matrix U' * B. -C -C LDB INTEGER -C The leading dimension of array B. LDB >= MAX(1,N). -C -C C (input/output) DOUBLE PRECISION array, dimension (LDC,N) -C On entry, the leading P-by-N part of this array must -C contain the output matrix C. -C On exit, the leading P-by-N part of this array contains -C the transformed output matrix C * U. -C -C LDC INTEGER -C The leading dimension of array C. LDC >= MAX(1,P). -C -C U (output) DOUBLE PRECISION array, dimension (LDU,N) -C The leading N-by-N part of this array contains the -C orthogonal transformation matrix used to reduce A to the -C real Schur form. The columns of U are the Schur vectors of -C matrix A. -C -C LDU INTEGER -C The leading dimension of array U. LDU >= max(1,N). -C -C WR, WI (output) DOUBLE PRECISION arrays, dimension (N) -C WR and WI contain the real and imaginary parts, -C respectively, of the computed eigenvalues of A. The -C eigenvalues will be in the same order that they appear on -C the diagonal of the output real Schur form of A. Complex -C conjugate pairs of eigenvalues will appear consecutively -C with the eigenvalue having the positive imaginary part -C first. -C -C Workspace -C -C DWORK DOUBLE PRECISION array, dimension (LDWORK) -C On exit, if INFO = 0, DWORK(1) returns the optimal value -C of LDWORK. -C -C LDWORK INTEGER -C The dimension of working array DWORK. LWORK >= 3*N. -C For optimum performance LDWORK should be larger. -C -C Error Indicator -C -C INFO INTEGER -C = 0: successful exit; -C < 0: if INFO = -i, the i-th argument had an illegal -C value; -C > 0: if INFO = i, the QR algorithm failed to compute -C all the eigenvalues; elements i+1:N of WR and WI -C contain those eigenvalues which have converged; -C U contains the matrix which reduces A to its -C partially converged Schur form. -C -C METHOD -C -C Matrix A is reduced to a real Schur form using an orthogonal -C similarity transformation A <- U'*A*U. Then, the transformation -C is applied to the matrices B and C: B <-- U'*B and C <-- C*U. -C -C NUMERICAL ASPECTS -C 3 -C The algorithm requires about 10N floating point operations. -C -C CONTRIBUTOR -C -C A. Varga, German Aerospace Center, -C DLR Oberpfaffenhofen, March 1998. -C Based on the RASP routine SRSFDC. -C -C REVISIONS -C -C - -C -C KEYWORDS -C -C Orthogonal transformation, real Schur form, similarity -C transformation. -C -C ****************************************************************** -C -C .. Parameters .. - DOUBLE PRECISION ZERO, ONE - PARAMETER ( ZERO = 0.0D0, ONE = 1.0D0 ) -C .. Scalar Arguments .. - INTEGER INFO, LDA, LDB, LDC, LDU, LDWORK, M, N, P -C .. Array Arguments .. - DOUBLE PRECISION A(LDA,*), B(LDB,*), C(LDC,*), DWORK(*), U(LDU,*), - $ WI(*), WR(*) -C .. Local Scalars .. - INTEGER I, LDWP, SDIM - DOUBLE PRECISION WRKOPT -C .. Local Arrays .. - LOGICAL BWORK( 1 ) -C .. External Functions .. - LOGICAL LSAME, SELECT - EXTERNAL LSAME, SELECT -C .. External Subroutines .. - EXTERNAL DCOPY, DGEES, DGEMM, DGEMV, DLACPY, XERBLA -C .. Intrinsic Functions .. - INTRINSIC DBLE, MAX -C -C .. Executable Statements .. -C - INFO = 0 -C -C Check input parameters. -C - IF( N.LT.0 ) THEN - INFO = -1 - ELSE IF( M.LT.0 ) THEN - INFO = -2 - ELSE IF( P.LT.0 ) THEN - INFO = -3 - ELSE IF( LDA.LT.MAX( 1, N ) ) THEN - INFO = -5 - ELSE IF( LDB.LT.MAX( 1, N ) ) THEN - INFO = -7 - ELSE IF( LDC.LT.MAX( 1, P ) ) THEN - INFO = -9 - ELSE IF( LDU.LT.MAX( 1, N ) ) THEN - INFO = -11 - ELSE IF( LDWORK.LT.3*N ) THEN - INFO = -15 - END IF -C - IF( INFO.NE.0 ) THEN -C -C Error return. -C - CALL XERBLA( 'TB01WD', -INFO ) - RETURN - END IF -C -C Quick return if possible. -C - IF( N.EQ.0 ) - $ RETURN -C -C Reduce A to real Schur form using an orthogonal similarity -C transformation A <- U'*A*U, accumulate the transformation in U -C and compute the eigenvalues of A in (WR,WI). -C -C Workspace: need 3*N; -C prefer larger. -C - CALL DGEES( 'Vectors', 'Not ordered', SELECT, N, A, LDA, SDIM, - $ WR, WI, U, LDU, DWORK, LDWORK, BWORK, INFO ) - WRKOPT = DWORK( 1 ) - IF( INFO.NE.0 ) - $ RETURN -C -C Apply the transformation: B <-- U'*B. -C - IF( LDWORK.LT.N*M ) THEN -C -C Not enough working space for using DGEMM. -C - DO 10 I = 1, M - CALL DCOPY( N, B(1,I), 1, DWORK, 1 ) - CALL DGEMV( 'Transpose', N, N, ONE, U, LDU, DWORK, 1, ZERO, - $ B(1,I), 1 ) - 10 CONTINUE -C - ELSE - CALL DLACPY( 'Full', N, M, B, LDB, DWORK, N ) - CALL DGEMM( 'Transpose', 'No transpose', N, M, N, ONE, U, LDU, - $ DWORK, N, ZERO, B, LDB ) - WRKOPT = MAX( WRKOPT, DBLE( N*M ) ) - END IF -C -C Apply the transformation: C <-- C*U. -C - IF( LDWORK.LT.N*P ) THEN -C -C Not enough working space for using DGEMM. -C - DO 20 I = 1, P - CALL DCOPY( N, C(I,1), LDC, DWORK, 1 ) - CALL DGEMV( 'Transpose', N, N, ONE, U, LDU, DWORK, 1, ZERO, - $ C(I,1), LDC ) - 20 CONTINUE -C - ELSE - LDWP = MAX( 1, P ) - CALL DLACPY( 'Full', P, N, C, LDC, DWORK, LDWP ) - CALL DGEMM( 'No transpose', 'No transpose', P, N, N, ONE, - $ DWORK, LDWP, U, LDU, ZERO, C, LDC ) - WRKOPT = MAX( WRKOPT, DBLE( N*P ) ) - END IF -C - DWORK( 1 ) = WRKOPT -C - RETURN -C *** Last line of TB01WD *** - END diff --git a/mex/sources/libslicot/TB01XD.f b/mex/sources/libslicot/TB01XD.f deleted file mode 100644 index 78bf92957..000000000 --- a/mex/sources/libslicot/TB01XD.f +++ /dev/null @@ -1,284 +0,0 @@ - SUBROUTINE TB01XD( JOBD, N, M, P, KL, KU, A, LDA, B, LDB, C, LDC, - $ D, LDD, INFO ) -C -C SLICOT RELEASE 5.0. -C -C Copyright (c) 2002-2009 NICONET e.V. -C -C This program is free software: you can redistribute it and/or -C modify it under the terms of the GNU General Public License as -C published by the Free Software Foundation, either version 2 of -C the License, or (at your option) any later version. -C -C This program is distributed in the hope that it will be useful, -C but WITHOUT ANY WARRANTY; without even the implied warranty of -C MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the -C GNU General Public License for more details. -C -C You should have received a copy of the GNU General Public License -C along with this program. If not, see -C . -C -C PURPOSE -C -C To apply a special transformation to a system given as a triple -C (A,B,C), -C -C A <-- P * A' * P, B <-- P * C', C <-- B' * P, -C -C where P is a matrix with 1 on the secondary diagonal, and with 0 -C in the other entries. Matrix A can be specified as a band matrix. -C Optionally, matrix D of the system can be transposed. This -C transformation is actually a special similarity transformation of -C the dual system. -C -C ARGUMENTS -C -C Mode Parameters -C -C JOBD CHARACTER*1 -C Specifies whether or not a non-zero matrix D appears in -C the given state space model: -C = 'D': D is present; -C = 'Z': D is assumed a zero matrix. -C -C Input/Output Parameters -C -C N (input) INTEGER -C The order of the matrix A, the number of rows of matrix B -C and the number of columns of matrix C. -C N represents the dimension of the state vector. N >= 0. -C -C M (input) INTEGER. -C The number of columns of matrix B. -C M represents the dimension of input vector. M >= 0. -C -C P (input) INTEGER. -C The number of rows of matrix C. -C P represents the dimension of output vector. P >= 0. -C -C KL (input) INTEGER -C The number of subdiagonals of A to be transformed. -C MAX( 0, N-1 ) >= KL >= 0. -C -C KU (input) INTEGER -C The number of superdiagonals of A to be transformed. -C MAX( 0, N-1 ) >= KU >= 0. -C -C A (input/output) DOUBLE PRECISION array, dimension (LDA,N) -C On entry, the leading N-by-N part of this array must -C contain the system state matrix A. -C On exit, the leading N-by-N part of this array contains -C the transformed (pertransposed) matrix P*A'*P. -C -C LDA INTEGER -C The leading dimension of the array A. LDA >= MAX(1,N). -C -C B (input/output) DOUBLE PRECISION array, dimension -C (LDB,MAX(M,P)) -C On entry, the leading N-by-M part of this array must -C contain the original input/state matrix B. -C On exit, the leading N-by-P part of this array contains -C the dual input/state matrix P*C'. -C -C LDB INTEGER -C The leading dimension of the array B. -C LDB >= MAX(1,N) if M > 0 or P > 0. -C LDB >= 1 if M = 0 and P = 0. -C -C C (input/output) DOUBLE PRECISION array, dimension (LDC,N) -C On entry, the leading P-by-N part of this array must -C contain the original state/output matrix C. -C On exit, the leading M-by-N part of this array contains -C the dual state/output matrix B'*P. -C -C LDC INTEGER -C The leading dimension of array C. -C LDC >= MAX(1,M,P) if N > 0. -C LDC >= 1 if N = 0. -C -C D (input/output) DOUBLE PRECISION array, dimension -C (LDD,MAX(M,P)) -C On entry, if JOBD = 'D', the leading P-by-M part of this -C array must contain the original direct transmission -C matrix D. -C On exit, if JOBD = 'D', the leading M-by-P part of this -C array contains the transposed direct transmission matrix -C D'. The array D is not referenced if JOBD = 'Z'. -C -C LDD INTEGER -C The leading dimension of array D. -C LDD >= MAX(1,M,P) if JOBD = 'D'. -C LDD >= 1 if JOBD = 'Z'. -C -C Error Indicator -C -C INFO INTEGER -C = 0: successful exit. -C < 0: if INFO = -i, the i-th argument had an illegal -C value. -C -C METHOD -C -C The rows and/or columns of the matrices of the triplet (A,B,C) -C and, optionally, of the matrix D are swapped in a special way. -C -C NUMERICAL ASPECTS -C -C None. -C -C CONTRIBUTOR -C -C V. Sima, Katholieke Univ. Leuven, Belgium, Feb. 1998. -C Partly based on routine DMPTR (A. Varga, German Aerospace -C Research Establishment, DLR, Aug. 1992). -C -C -C REVISIONS -C -C 07-31-1998, 04-25-1999, A. Varga. -C 03-16-2004, V. Sima. -C -C KEYWORDS -C -C Matrix algebra, matrix operations, similarity transformation. -C -C ********************************************************************* -C -C .. -C .. Scalar Arguments .. - CHARACTER JOBD - INTEGER INFO, KL, KU, LDA, LDB, LDC, LDD, M, N, P -C .. -C .. Array Arguments .. - DOUBLE PRECISION A( LDA, * ), B( LDB, * ), C( LDC, * ), - $ D( LDD, * ) -C .. -C .. Local Scalars .. - LOGICAL LJOBD - INTEGER J, J1, LDA1, MAXMP, MINMP, NM1 -C .. -C .. External functions .. - LOGICAL LSAME - EXTERNAL LSAME -C .. -C .. External Subroutines .. - EXTERNAL DCOPY, DSWAP, XERBLA -C .. -C .. Intrinsic Functions .. - INTRINSIC MAX, MIN -C .. -C .. Executable Statements .. -C -C Test the scalar input arguments. -C - INFO = 0 - LJOBD = LSAME( JOBD, 'D' ) - MAXMP = MAX( M, P ) - MINMP = MIN( M, P ) - NM1 = N - 1 -C - IF( .NOT.LJOBD .AND. .NOT.LSAME( JOBD, 'Z' ) ) THEN - INFO = -1 - ELSE IF( N.LT.0 ) THEN - INFO = -2 - ELSE IF( M.LT.0 ) THEN - INFO = -3 - ELSE IF( P.LT.0 ) THEN - INFO = -4 - ELSE IF( KL.LT.0 .OR. KL.GT.MAX( 0, NM1 ) ) THEN - INFO = -5 - ELSE IF( KU.LT.0 .OR. KU.GT.MAX( 0, NM1 ) ) THEN - INFO = -6 - ELSE IF( LDA.LT.MAX( 1, N ) ) THEN - INFO = -8 - ELSE IF( ( MAXMP.GT.0 .AND. LDB.LT.MAX( 1, N ) ) .OR. - $ ( MINMP.EQ.0 .AND. LDB.LT.1 ) ) THEN - INFO = -10 - ELSE IF( LDC.LT.1 .OR. ( N.GT.0 .AND. LDC.LT.MAXMP ) ) THEN - INFO = -12 - ELSE IF( LDD.LT.1 .OR. ( LJOBD .AND. LDD.LT.MAXMP ) ) THEN - INFO = -14 - END IF -C - IF( INFO.NE.0 ) THEN -C -C Error return. -C - CALL XERBLA( 'TB01XD', -INFO ) - RETURN - END IF -C -C Quick return if possible. -C - IF ( LJOBD ) THEN -C -C Replace D by D', if non-scalar. -C - DO 5 J = 1, MAXMP - IF ( J.LT.MINMP ) THEN - CALL DSWAP( MINMP-J, D(J+1,J), 1, D(J,J+1), LDD ) - ELSE IF ( J.GT.P ) THEN - CALL DCOPY( P, D(1,J), 1, D(J,1), LDD ) - ELSE IF ( J.GT.M ) THEN - CALL DCOPY( M, D(J,1), LDD, D(1,J), 1 ) - END IF - 5 CONTINUE -C - END IF -C - IF( N.EQ.0 ) - $ RETURN -C -C Replace matrix A by P*A'*P. -C - IF ( KL.EQ.NM1 .AND. KU.EQ.NM1 ) THEN -C -C Full matrix A. -C - DO 10 J = 1, NM1 - CALL DSWAP( N-J, A( 1, J ), 1, A( N-J+1, J+1 ), -LDA ) - 10 CONTINUE -C - ELSE -C -C Band matrix A. -C - LDA1 = LDA + 1 -C -C Pertranspose the KL subdiagonals. -C - DO 20 J = 1, MIN( KL, N-2 ) - J1 = ( N - J )/2 - CALL DSWAP( J1, A(J+1,1), LDA1, A(N-J1+1,N-J1+1-J), -LDA1 ) - 20 CONTINUE -C -C Pertranspose the KU superdiagonals. -C - DO 30 J = 1, MIN( KU, N-2 ) - J1 = ( N - J )/2 - CALL DSWAP( J1, A(1,J+1), LDA1, A(N-J1+1-J,N-J1+1), -LDA1 ) - 30 CONTINUE -C -C Pertranspose the diagonal. -C - J1 = N/2 - CALL DSWAP( J1, A(1,1), LDA1, A(N-J1+1,N-J1+1), -LDA1 ) -C - END IF -C -C Replace matrix B by P*C' and matrix C by B'*P. -C - DO 40 J = 1, MAXMP - IF ( J.LE.MINMP ) THEN - CALL DSWAP( N, B(1,J), 1, C(J,1), -LDC ) - ELSE IF ( J.GT.P ) THEN - CALL DCOPY( N, B(1,J), 1, C(J,1), -LDC ) - ELSE - CALL DCOPY( N, C(J,1), -LDC, B(1,J), 1 ) - END IF - 40 CONTINUE -C - RETURN -C *** Last line of TB01XD *** - END diff --git a/mex/sources/libslicot/TB01XZ.f b/mex/sources/libslicot/TB01XZ.f deleted file mode 100644 index ef73d0ce3..000000000 --- a/mex/sources/libslicot/TB01XZ.f +++ /dev/null @@ -1,280 +0,0 @@ - SUBROUTINE TB01XZ( JOBD, N, M, P, KL, KU, A, LDA, B, LDB, C, LDC, - $ D, LDD, INFO ) -C -C SLICOT RELEASE 5.0. -C -C Copyright (c) 2002-2009 NICONET e.V. -C -C This program is free software: you can redistribute it and/or -C modify it under the terms of the GNU General Public License as -C published by the Free Software Foundation, either version 2 of -C the License, or (at your option) any later version. -C -C This program is distributed in the hope that it will be useful, -C but WITHOUT ANY WARRANTY; without even the implied warranty of -C MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the -C GNU General Public License for more details. -C -C You should have received a copy of the GNU General Public License -C along with this program. If not, see -C . -C -C PURPOSE -C -C To apply a special transformation to a system given as a triple -C (A,B,C), -C -C A <-- P * A' * P, B <-- P * C', C <-- B' * P, -C -C where P is a matrix with 1 on the secondary diagonal, and with 0 -C in the other entries. Matrix A can be specified as a band matrix. -C Optionally, matrix D of the system can be transposed. This -C transformation is actually a special similarity transformation of -C the dual system. -C -C ARGUMENTS -C -C Mode Parameters -C -C JOBD CHARACTER*1 -C Specifies whether or not a non-zero matrix D appears in -C the given state space model: -C = 'D': D is present; -C = 'Z': D is assumed a zero matrix. -C -C Input/Output Parameters -C -C N (input) INTEGER -C The order of the matrix A, the number of rows of matrix B -C and the number of columns of matrix C. -C N represents the dimension of the state vector. N >= 0. -C -C M (input) INTEGER. -C The number of columns of matrix B. -C M represents the dimension of input vector. M >= 0. -C -C P (input) INTEGER. -C The number of rows of matrix C. -C P represents the dimension of output vector. P >= 0. -C -C KL (input) INTEGER -C The number of subdiagonals of A to be transformed. -C MAX( 0, N-1 ) >= KL >= 0. -C -C KU (input) INTEGER -C The number of superdiagonals of A to be transformed. -C MAX( 0, N-1 ) >= KU >= 0. -C -C A (input/output) COMPLEX*16 array, dimension (LDA,N) -C On entry, the leading N-by-N part of this array must -C contain the system state matrix A. -C On exit, the leading N-by-N part of this array contains -C the transformed (pertransposed) matrix P*A'*P. -C -C LDA INTEGER -C The leading dimension of the array A. LDA >= MAX(1,N). -C -C B (input/output) COMPLEX*16 array, dimension (LDB,MAX(M,P)) -C On entry, the leading N-by-M part of this array must -C contain the original input/state matrix B. -C On exit, the leading N-by-P part of this array contains -C the dual input/state matrix P*C'. -C -C LDB INTEGER -C The leading dimension of the array B. -C LDB >= MAX(1,N) if M > 0 or P > 0. -C LDB >= 1 if M = 0 and P = 0. -C -C C (input/output) COMPLEX*16 array, dimension (LDC,N) -C On entry, the leading P-by-N part of this array must -C contain the original state/output matrix C. -C On exit, the leading M-by-N part of this array contains -C the dual state/output matrix B'*P. -C -C LDC INTEGER -C The leading dimension of array C. -C LDC >= MAX(1,M,P) if N > 0. -C LDC >= 1 if N = 0. -C -C D (input/output) COMPLEX*16 array, dimension (LDD,MAX(M,P)) -C On entry, if JOBD = 'D', the leading P-by-M part of this -C array must contain the original direct transmission -C matrix D. -C On exit, if JOBD = 'D', the leading M-by-P part of this -C array contains the transposed direct transmission matrix -C D'. The array D is not referenced if JOBD = 'Z'. -C -C LDD INTEGER -C The leading dimension of array D. -C LDD >= MAX(1,M,P) if JOBD = 'D'. -C LDD >= 1 if JOBD = 'Z'. -C -C Error Indicator -C -C INFO INTEGER -C = 0: successful exit. -C < 0: if INFO = -i, the i-th argument had an illegal -C value. -C -C METHOD -C -C The rows and/or columns of the matrices of the triplet (A,B,C) -C and, optionally, of the matrix D are swapped in a special way. -C -C NUMERICAL ASPECTS -C -C None. -C -C CONTRIBUTOR -C -C V. Sima, Katholieke Univ. Leuven, Belgium, Jan. 1998. -C Complex version: V. Sima, Research Institute for Informatics, -C Bucharest, Nov. 2008. -C -C REVISIONS -C -C - -C -C KEYWORDS -C -C Matrix algebra, matrix operations, similarity transformation. -C -C ********************************************************************* -C -C .. -C .. Scalar Arguments .. - CHARACTER JOBD - INTEGER INFO, KL, KU, LDA, LDB, LDC, LDD, M, N, P -C .. -C .. Array Arguments .. - COMPLEX*16 A( LDA, * ), B( LDB, * ), C( LDC, * ), - $ D( LDD, * ) -C .. -C .. Local Scalars .. - LOGICAL LJOBD - INTEGER J, J1, LDA1, MAXMP, MINMP, NM1 -C .. -C .. External functions .. - LOGICAL LSAME - EXTERNAL LSAME -C .. -C .. External Subroutines .. - EXTERNAL XERBLA, ZCOPY, ZSWAP -C .. -C .. Intrinsic Functions .. - INTRINSIC MAX, MIN -C .. -C .. Executable Statements .. -C -C Test the scalar input arguments. -C - INFO = 0 - LJOBD = LSAME( JOBD, 'D' ) - MAXMP = MAX( M, P ) - MINMP = MIN( M, P ) - NM1 = N - 1 -C - IF( .NOT.LJOBD .AND. .NOT.LSAME( JOBD, 'Z' ) ) THEN - INFO = -1 - ELSE IF( N.LT.0 ) THEN - INFO = -2 - ELSE IF( M.LT.0 ) THEN - INFO = -3 - ELSE IF( P.LT.0 ) THEN - INFO = -4 - ELSE IF( KL.LT.0 .OR. KL.GT.MAX( 0, NM1 ) ) THEN - INFO = -5 - ELSE IF( KU.LT.0 .OR. KU.GT.MAX( 0, NM1 ) ) THEN - INFO = -6 - ELSE IF( LDA.LT.MAX( 1, N ) ) THEN - INFO = -8 - ELSE IF( ( MAXMP.GT.0 .AND. LDB.LT.MAX( 1, N ) ) .OR. - $ ( MINMP.EQ.0 .AND. LDB.LT.1 ) ) THEN - INFO = -10 - ELSE IF( LDC.LT.1 .OR. ( N.GT.0 .AND. LDC.LT.MAXMP ) ) THEN - INFO = -12 - ELSE IF( LDD.LT.1 .OR. ( LJOBD .AND. LDD.LT.MAXMP ) ) THEN - INFO = -14 - END IF -C - IF( INFO.NE.0 ) THEN -C -C Error return. -C - CALL XERBLA( 'TB01XZ', -INFO ) - RETURN - END IF -C -C Quick return if possible. -C - IF ( LJOBD ) THEN -C -C Replace D by D', if non-scalar. -C - DO 5 J = 1, MAXMP - IF ( J.LT.MINMP ) THEN - CALL ZSWAP( MINMP-J, D(J+1,J), 1, D(J,J+1), LDD ) - ELSE IF ( J.GT.P ) THEN - CALL ZCOPY( P, D(1,J), 1, D(J,1), LDD ) - ELSE IF ( J.GT.M ) THEN - CALL ZCOPY( M, D(J,1), LDD, D(1,J), 1 ) - END IF - 5 CONTINUE -C - END IF -C - IF( N.EQ.0 ) - $ RETURN -C -C Replace matrix A by P*A'*P. -C - IF ( KL.EQ.NM1 .AND. KU.EQ.NM1 ) THEN -C -C Full matrix A. -C - DO 10 J = 1, NM1 - CALL ZSWAP( N-J, A( 1, J ), 1, A( N-J+1, J+1 ), -LDA ) - 10 CONTINUE -C - ELSE -C -C Band matrix A. -C - LDA1 = LDA + 1 -C -C Pertranspose the KL subdiagonals. -C - DO 20 J = 1, MIN( KL, N-2 ) - J1 = ( N - J )/2 - CALL ZSWAP( J1, A(J+1,1), LDA1, A(N-J1+1,N-J1+1-J), -LDA1 ) - 20 CONTINUE -C -C Pertranspose the KU superdiagonals. -C - DO 30 J = 1, MIN( KU, N-2 ) - J1 = ( N - J )/2 - CALL ZSWAP( J1, A(1,J+1), LDA1, A(N-J1+1-J,N-J1+1), -LDA1 ) - 30 CONTINUE -C -C Pertranspose the diagonal. -C - J1 = N/2 - CALL ZSWAP( J1, A(1,1), LDA1, A(N-J1+1,N-J1+1), -LDA1 ) -C - END IF -C -C Replace matrix B by P*C' and matrix C by B'*P. -C - DO 40 J = 1, MAXMP - IF ( J.LE.MINMP ) THEN - CALL ZSWAP( N, B(1,J), 1, C(J,1), -LDC ) - ELSE IF ( J.GT.P ) THEN - CALL ZCOPY( N, B(1,J), 1, C(J,1), -LDC ) - ELSE - CALL ZCOPY( N, C(J,1), -LDC, B(1,J), 1 ) - END IF - 40 CONTINUE -C - RETURN -C *** Last line of TB01XZ *** - END diff --git a/mex/sources/libslicot/TB01YD.f b/mex/sources/libslicot/TB01YD.f deleted file mode 100644 index f653ffab5..000000000 --- a/mex/sources/libslicot/TB01YD.f +++ /dev/null @@ -1,188 +0,0 @@ - SUBROUTINE TB01YD( N, M, P, A, LDA, B, LDB, C, LDC, INFO ) -C -C SLICOT RELEASE 5.0. -C -C Copyright (c) 2002-2009 NICONET e.V. -C -C This program is free software: you can redistribute it and/or -C modify it under the terms of the GNU General Public License as -C published by the Free Software Foundation, either version 2 of -C the License, or (at your option) any later version. -C -C This program is distributed in the hope that it will be useful, -C but WITHOUT ANY WARRANTY; without even the implied warranty of -C MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the -C GNU General Public License for more details. -C -C You should have received a copy of the GNU General Public License -C along with this program. If not, see -C . -C -C PURPOSE -C -C To apply a special similarity transformation to a system given as -C a triple (A,B,C), -C -C A <-- P * A * P, B <-- P * B, C <-- C * P, -C -C where P is a matrix with 1 on the secondary diagonal, and with 0 -C in the other entries. -C -C ARGUMENTS -C -C Input/Output Parameters -C -C N (input) INTEGER -C The order of the matrix A, the number of rows of matrix B -C and the number of columns of matrix C. -C N represents the dimension of the state vector. N >= 0. -C -C M (input) INTEGER. -C The number of columns of matrix B. -C M represents the dimension of input vector. M >= 0. -C -C P (input) INTEGER. -C The number of rows of matrix C. -C P represents the dimension of output vector. P >= 0. -C -C A (input/output) DOUBLE PRECISION array, dimension (LDA,N) -C On entry, the leading N-by-N part of this array must -C contain the system state matrix A. -C On exit, the leading N-by-N part of this array contains -C the transformed matrix P*A*P. -C -C LDA INTEGER -C The leading dimension of the array A. LDA >= MAX(1,N). -C -C B (input/output) DOUBLE PRECISION array, dimension (LDB,M) -C On entry, the leading N-by-M part of this array must -C contain the system input matrix B. -C On exit, the leading N-by-M part of this array contains -C the transformed matrix P*B. -C -C LDB INTEGER -C The leading dimension of the array B. -C LDB >= MAX(1,N) if M > 0. -C LDB >= 1 if M = 0. -C -C C (input/output) DOUBLE PRECISION array, dimension (LDC,N) -C On entry, the leading P-by-N part of this array must -C contain the system output matrix C. -C On exit, the leading P-by-N part of this array contains -C the transformed matrix C*P. -C -C LDC INTEGER -C The leading dimension of the array C. LDC >= MAX(1,P). -C -C Error Indicator -C -C INFO INTEGER -C = 0: successful exit. -C < 0: if INFO = -i, the i-th argument had an illegal -C value. -C -C METHOD -C -C The rows and/or columns of the matrices of the triplet (A,B,C) -C are swapped in a special way. -C -C NUMERICAL ASPECTS -C -C None. -C -C CONTRIBUTOR -C -C V. Sima, Katholieke Univ. Leuven, Belgium, Feb. 1998. -C -C -C REVISIONS -C -C V. Sima, Research Institute for Informatics, Bucharest, Mar. 2004. -C -C KEYWORDS -C -C Matrix algebra, matrix operations, similarity transformation. -C -C ********************************************************************* -C -C .. -C .. Scalar Arguments .. - INTEGER INFO, LDA, LDB, LDC, M, N, P -C .. -C .. Array Arguments .. - DOUBLE PRECISION A( LDA, * ), B( LDB, * ), C( LDC, * ) -C .. -C .. Local Scalars .. - INTEGER J, NBY2 -C .. -C .. External Subroutines .. - EXTERNAL DSWAP, XERBLA -C .. -C .. Intrinsic Functions .. - INTRINSIC MAX, MOD -C .. -C .. Executable Statements .. -C -C Test the scalar input arguments. -C - INFO = 0 -C - IF( N.LT.0 ) THEN - INFO = -1 - ELSE IF( M.LT.0 ) THEN - INFO = -2 - ELSE IF( P.LT.0 ) THEN - INFO = -3 - ELSE IF( LDA.LT.MAX( 1, N ) ) THEN - INFO = -5 - ELSE IF( LDB.LT.1 .OR. ( M.GT.0 .AND. LDB.LT.N ) ) THEN - INFO = -7 - ELSE IF( LDC.LT.MAX( 1, P ) ) THEN - INFO = -9 - END IF -C - IF( INFO.NE.0 ) THEN -C -C Error return. -C - CALL XERBLA( 'TB01YD', -INFO ) - RETURN - END IF -C - IF( N.LE.1 ) - $ RETURN -C -C Transform the matrix A. -C - NBY2 = N/2 -C - DO 10 J = 1, NBY2 - CALL DSWAP( N, A( 1, J ), -1, A( 1, N-J+1 ), 1 ) - 10 CONTINUE -C - IF( MOD( N, 2 ).NE.0 .AND. N.GT.2 ) - $ CALL DSWAP( NBY2, A( NBY2+2, NBY2+1 ), -1, A( 1, NBY2+1 ), 1 ) -C - IF( M.GT.0 ) THEN -C -C Transform the matrix B. -C - DO 20 J = 1, NBY2 - CALL DSWAP( M, B( J, 1 ), LDB, B( N-J+1, 1 ), LDB ) - 20 CONTINUE -C - END IF -C - IF( P.GT.0 ) THEN -C -C Transform the matrix C. -C - DO 30 J = 1, NBY2 - CALL DSWAP( P, C( 1, J ), 1, C( 1, N-J+1 ), 1 ) - 30 CONTINUE -C - END IF -C - RETURN -C *** Last line of TB01YD *** - END diff --git a/mex/sources/libslicot/TB01ZD.f b/mex/sources/libslicot/TB01ZD.f deleted file mode 100644 index 6f8acc3a4..000000000 --- a/mex/sources/libslicot/TB01ZD.f +++ /dev/null @@ -1,440 +0,0 @@ - SUBROUTINE TB01ZD( JOBZ, N, P, A, LDA, B, C, LDC, NCONT, Z, LDZ, - $ TAU, TOL, DWORK, LDWORK, INFO ) -C -C SLICOT RELEASE 5.0. -C -C Copyright (c) 2002-2009 NICONET e.V. -C -C This program is free software: you can redistribute it and/or -C modify it under the terms of the GNU General Public License as -C published by the Free Software Foundation, either version 2 of -C the License, or (at your option) any later version. -C -C This program is distributed in the hope that it will be useful, -C but WITHOUT ANY WARRANTY; without even the implied warranty of -C MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the -C GNU General Public License for more details. -C -C You should have received a copy of the GNU General Public License -C along with this program. If not, see -C . -C -C PURPOSE -C -C To find a controllable realization for the linear time-invariant -C single-input system -C -C dX/dt = A * X + B * U, -C Y = C * X, -C -C where A is an N-by-N matrix, B is an N element vector, C is an -C P-by-N matrix, and A and B are reduced by this routine to -C orthogonal canonical form using (and optionally accumulating) -C orthogonal similarity transformations, which are also applied -C to C. -C -C ARGUMENTS -C -C Mode Parameters -C -C JOBZ CHARACTER*1 -C Indicates whether the user wishes to accumulate in a -C matrix Z the orthogonal similarity transformations for -C reducing the system, as follows: -C = 'N': Do not form Z and do not store the orthogonal -C transformations; -C = 'F': Do not form Z, but store the orthogonal -C transformations in the factored form; -C = 'I': Z is initialized to the unit matrix and the -C orthogonal transformation matrix Z is returned. -C -C Input/Output Parameters -C -C N (input) INTEGER -C The order of the original state-space representation, -C i.e. the order of the matrix A. N >= 0. -C -C P (input) INTEGER -C The number of system outputs, or of rows of C. P >= 0. -C -C A (input/output) DOUBLE PRECISION array, dimension (LDA,N) -C On entry, the leading N-by-N part of this array must -C contain the original state dynamics matrix A. -C On exit, the leading NCONT-by-NCONT upper Hessenberg -C part of this array contains the canonical form of the -C state dynamics matrix, given by Z' * A * Z, of a -C controllable realization for the original system. The -C elements below the first subdiagonal are set to zero. -C -C LDA INTEGER -C The leading dimension of array A. LDA >= MAX(1,N). -C -C B (input/output) DOUBLE PRECISION array, dimension (N) -C On entry, the original input/state vector B. -C On exit, the leading NCONT elements of this array contain -C canonical form of the input/state vector, given by Z' * B, -C with all elements but B(1) set to zero. -C -C C (input/output) DOUBLE PRECISION array, dimension (LDC,N) -C On entry, the leading P-by-N part of this array must -C contain the output/state matrix C. -C On exit, the leading P-by-N part of this array contains -C the transformed output/state matrix, given by C * Z, and -C the leading P-by-NCONT part contains the output/state -C matrix of the controllable realization. -C -C LDC INTEGER -C The leading dimension of array C. LDC >= MAX(1,P). -C -C NCONT (output) INTEGER -C The order of the controllable state-space representation. -C -C Z (output) DOUBLE PRECISION array, dimension (LDZ,N) -C If JOBZ = 'I', then the leading N-by-N part of this array -C contains the matrix of accumulated orthogonal similarity -C transformations which reduces the given system to -C orthogonal canonical form. -C If JOBZ = 'F', the elements below the diagonal, with the -C array TAU, represent the orthogonal transformation matrix -C as a product of elementary reflectors. The transformation -C matrix can then be obtained by calling the LAPACK Library -C routine DORGQR. -C If JOBZ = 'N', the array Z is not referenced and can be -C supplied as a dummy array (i.e. set parameter LDZ = 1 and -C declare this array to be Z(1,1) in the calling program). -C -C LDZ INTEGER -C The leading dimension of array Z. If JOBZ = 'I' or -C JOBZ = 'F', LDZ >= MAX(1,N); if JOBZ = 'N', LDZ >= 1. -C -C TAU (output) DOUBLE PRECISION array, dimension (N) -C The elements of TAU contain the scalar factors of the -C elementary reflectors used in the reduction of B and A. -C -C Tolerances -C -C TOL DOUBLE PRECISION -C The tolerance to be used in determining the -C controllability of (A,B). If the user sets TOL > 0, then -C the given value of TOL is used as an absolute tolerance; -C elements with absolute value less than TOL are considered -C neglijible. If the user sets TOL <= 0, then an implicitly -C computed, default tolerance, defined by -C TOLDEF = N*EPS*MAX( NORM(A), NORM(B) ) is used instead, -C where EPS is the machine precision (see LAPACK Library -C routine DLAMCH). -C -C Workspace -C -C DWORK DOUBLE PRECISION array, dimension (LDWORK) -C On exit, if INFO = 0, DWORK(1) returns the optimal value -C of LDWORK. -C -C LDWORK INTEGER -C The length of the array DWORK. LDWORK >= MAX(1,N,P). -C For optimum performance LDWORK should be larger. -C -C Error Indicator -C -C INFO INTEGER -C = 0: successful exit; -C < 0: if INFO = -i, the i-th argument had an illegal -C value. -C -C METHOD -C -C The Householder matrix which reduces all but the first element -C of vector B to zero is found and this orthogonal similarity -C transformation is applied to the matrix A. The resulting A is then -C reduced to upper Hessenberg form by a sequence of Householder -C transformations. Finally, the order of the controllable state- -C space representation (NCONT) is determined by finding the position -C of the first sub-diagonal element of A which is below an -C appropriate zero threshold, either TOL or TOLDEF (see parameter -C TOL); if NORM(B) is smaller than this threshold, NCONT is set to -C zero, and no computations for reducing the system to orthogonal -C canonical form are performed. -C All orthogonal transformations determined in this process are also -C applied to the matrix C, from the right. -C -C REFERENCES -C -C [1] Konstantinov, M.M., Petkov, P.Hr. and Christov, N.D. -C Orthogonal Invariants and Canonical Forms for Linear -C Controllable Systems. -C Proc. 8th IFAC World Congress, Kyoto, 1, pp. 49-54, 1981. -C -C [2] Hammarling, S.J. -C Notes on the use of orthogonal similarity transformations in -C control. -C NPL Report DITC 8/82, August 1982. -C -C [3] Paige, C.C -C Properties of numerical algorithms related to computing -C controllability. -C IEEE Trans. Auto. Contr., AC-26, pp. 130-138, 1981. -C -C NUMERICAL ASPECTS -C 3 -C The algorithm requires 0(N ) operations and is backward stable. -C -C CONTRIBUTOR -C -C V. Sima, Katholieke Univ. Leuven, Belgium, Feb. 1998. -C -C REVISIONS -C -C V. Sima, Research Institute for Informatics, Bucharest, Oct. 2001, -C Sept. 2003. -C -C KEYWORDS -C -C Controllability, minimal realization, orthogonal canonical form, -C orthogonal transformation. -C -C ****************************************************************** -C -C .. Parameters .. - DOUBLE PRECISION ZERO, ONE - PARAMETER ( ZERO = 0.0D0, ONE = 1.0D0 ) -C .. Scalar Arguments .. - CHARACTER JOBZ - INTEGER INFO, LDA, LDC, LDWORK, LDZ, N, NCONT, P - DOUBLE PRECISION TOL -C .. Array Arguments .. - DOUBLE PRECISION A(LDA,*), B(*), C(LDC,*), DWORK(*), TAU(*), - $ Z(LDZ,*) -C .. Local Scalars .. - LOGICAL LJOBF, LJOBI, LJOBZ - INTEGER ITAU, J - DOUBLE PRECISION ANORM, B1, BNORM, FANORM, FBNORM, H, THRESH, - $ TOLDEF, WRKOPT -C .. Local Arrays .. - DOUBLE PRECISION NBLK(1) -C .. External Functions .. - LOGICAL LSAME - DOUBLE PRECISION DLAMCH, DLANGE - EXTERNAL DLAMCH, DLANGE, LSAME -C .. External Subroutines .. - EXTERNAL DGEHRD, DLACPY, DLARF, DLARFG, DLASET, DORGQR, - $ DORMHR, MB01PD, XERBLA -C .. Intrinsic Functions .. - INTRINSIC ABS, DBLE, MAX -C .. Executable Statements .. -C - INFO = 0 - LJOBF = LSAME( JOBZ, 'F' ) - LJOBI = LSAME( JOBZ, 'I' ) - LJOBZ = LJOBF.OR.LJOBI -C -C Test the input scalar arguments. -C - IF( .NOT.LJOBZ .AND. .NOT.LSAME( JOBZ, 'N' ) ) THEN - INFO = -1 - ELSE IF( N.LT.0 ) THEN - INFO = -2 - ELSE IF( P.LT.0 ) THEN - INFO = -3 - ELSE IF( LDA.LT.MAX( 1, N ) ) THEN - INFO = -5 - ELSE IF( LDC.LT.MAX( 1, P ) ) THEN - INFO = -8 - ELSE IF( LDZ.LT.1 .OR. ( LJOBZ .AND. LDZ.LT.N ) ) THEN - INFO = -11 - ELSE IF( LDWORK.LT.MAX( 1, N, P ) ) THEN - INFO = -15 - END IF -C - IF ( INFO.NE.0 ) THEN -C -C Error return. -C - CALL XERBLA( 'TB01ZD', -INFO ) - RETURN - END IF -C -C Quick return if possible. -C - NCONT = 0 - DWORK(1) = ONE - IF ( N.EQ.0 ) - $ RETURN -C -C (Note: Comments in the code beginning "Workspace:" describe the -C minimal amount of real workspace needed at that point in the -C code, as well as the preferred amount for good performance. -C NB refers to the optimal block size for the immediately -C following subroutine, as returned by ILAENV.) -C - WRKOPT = ONE -C -C Calculate the absolute norms of A and B (used for scaling). -C - ANORM = DLANGE( 'Max', N, N, A, LDA, DWORK ) - BNORM = DLANGE( 'Max', N, 1, B, N, DWORK ) -C -C Return if matrix B is zero. -C - IF( BNORM.EQ.ZERO ) THEN - IF( LJOBF ) THEN - CALL DLASET( 'Full', N, N, ZERO, ZERO, Z, LDZ ) - CALL DLASET( 'Full', N, 1, ZERO, ZERO, TAU, N ) - ELSE IF( LJOBI ) THEN - CALL DLASET( 'Full', N, N, ZERO, ONE, Z, LDZ ) - END IF - RETURN - END IF -C -C Scale (if needed) the matrices A and B. -C - CALL MB01PD( 'S', 'G', N, N, 0, 0, ANORM, 0, NBLK, A, LDA, INFO ) - CALL MB01PD( 'S', 'G', N, 1, 0, 0, BNORM, 0, NBLK, B, N, INFO ) -C -C Calculate the Frobenius norm of A and the 1-norm of B (used for -C controlability test). -C - FANORM = DLANGE( 'Frobenius', N, N, A, LDA, DWORK ) - FBNORM = DLANGE( '1-norm', N, 1, B, N, DWORK ) -C - TOLDEF = TOL - IF ( TOLDEF.LE.ZERO ) THEN -C -C Use the default tolerance in controllability determination. -C - THRESH = DBLE(N)*DLAMCH( 'EPSILON' ) - TOLDEF = THRESH*MAX( FANORM, FBNORM ) - END IF -C - ITAU = 1 - IF ( FBNORM.GT.TOLDEF ) THEN -C -C B is not negligible compared with A. -C - IF ( N.GT.1 ) THEN -C -C Transform B by a Householder matrix Z1: store vector -C describing this temporarily in B and in the local scalar H. -C - CALL DLARFG( N, B(1), B(2), 1, H ) -C - B1 = B(1) - B(1) = ONE -C -C Form Z1 * A * Z1. -C Workspace: need N. -C - CALL DLARF( 'Right', N, N, B, 1, H, A, LDA, DWORK ) - CALL DLARF( 'Left', N, N, B, 1, H, A, LDA, DWORK ) -C -C Form C * Z1. -C Workspace: need P. -C - CALL DLARF( 'Right', P, N, B, 1, H, C, LDC, DWORK ) -C - B(1) = B1 - TAU(1) = H - ITAU = ITAU + 1 - ELSE - B1 = B(1) - TAU(1) = ZERO - END IF -C -C Reduce modified A to upper Hessenberg form by an orthogonal -C similarity transformation with matrix Z2. -C Workspace: need N; prefer N*NB. -C - CALL DGEHRD( N, 1, N, A, LDA, TAU(ITAU), DWORK, LDWORK, INFO ) - WRKOPT = DWORK(1) -C -C Form C * Z2. -C Workspace: need P; prefer P*NB. -C - CALL DORMHR( 'Right', 'No transpose', P, N, 1, N, A, LDA, - $ TAU(ITAU), C, LDC, DWORK, LDWORK, INFO ) - WRKOPT = MAX( WRKOPT, DWORK(1) ) -C - IF ( LJOBZ ) THEN -C -C Save the orthogonal transformations used, so that they could -C be accumulated by calling DORGQR routine. -C - IF ( N.GT.1 ) - $ CALL DLACPY( 'Full', N-1, 1, B(2), N-1, Z(2,1), LDZ ) - IF ( N.GT.2 ) - $ CALL DLACPY( 'Lower', N-2, N-2, A(3,1), LDA, Z(3,2), - $ LDZ ) - IF ( LJOBI ) THEN -C -C Form the orthogonal transformation matrix Z = Z1 * Z2. -C Workspace: need N; prefer N*NB. -C - CALL DORGQR( N, N, N, Z, LDZ, TAU, DWORK, LDWORK, INFO ) - WRKOPT = MAX( WRKOPT, DWORK(1) ) - END IF - END IF -C -C Annihilate the lower part of A and B. -C - IF ( N.GT.2 ) - $ CALL DLASET( 'Lower', N-2, N-2, ZERO, ZERO, A(3,1), LDA ) - IF ( N.GT.1 ) - $ CALL DLASET( 'Full', N-1, 1, ZERO, ZERO, B(2), N-1 ) -C -C Find NCONT by checking sizes of the sub-diagonal elements of -C transformed A. -C - IF ( TOL.LE.ZERO ) - $ TOLDEF = THRESH*MAX( FANORM, ABS( B1 ) ) -C - J = 1 -C -C WHILE ( J < N and ABS( A(J+1,J) ) > TOLDEF ) DO -C - 10 CONTINUE - IF ( J.LT.N ) THEN - IF ( ABS( A(J+1,J) ).GT.TOLDEF ) THEN - J = J + 1 - GO TO 10 - END IF - END IF -C -C END WHILE 10 -C -C First negligible sub-diagonal element found, if any: set NCONT. -C - NCONT = J - IF ( J.LT.N ) - $ A(J+1,J) = ZERO -C -C Undo scaling of A and B. -C - CALL MB01PD( 'U', 'H', NCONT, NCONT, 0, 0, ANORM, 0, NBLK, A, - $ LDA, INFO ) - CALL MB01PD( 'U', 'G', 1, 1, 0, 0, BNORM, 0, NBLK, B, N, INFO ) - IF ( NCONT.LT.N ) - $ CALL MB01PD( 'U', 'G', N, N-NCONT, 0, 0, ANORM, 0, NBLK, - $ A(1,NCONT+1), LDA, INFO ) - ELSE -C -C B is negligible compared with A. No computations for reducing -C the system to orthogonal canonical form have been performed, -C except scaling (which is undoed). -C - CALL MB01PD( 'U', 'G', N, N, 0, 0, ANORM, 0, NBLK, A, LDA, - $ INFO ) - CALL MB01PD( 'U', 'G', N, 1, 0, 0, BNORM, 0, NBLK, B, N, INFO ) - IF( LJOBF ) THEN - CALL DLASET( 'Full', N, N, ZERO, ZERO, Z, LDZ ) - CALL DLASET( 'Full', N, 1, ZERO, ZERO, TAU, N ) - ELSE IF( LJOBI ) THEN - CALL DLASET( 'Full', N, N, ZERO, ONE, Z, LDZ ) - END IF - END IF -C -C Set optimal workspace dimension. -C - DWORK(1) = WRKOPT -C - RETURN -C *** Last line of TB01ZD *** - END diff --git a/mex/sources/libslicot/TB03AD.f b/mex/sources/libslicot/TB03AD.f deleted file mode 100644 index 318c2f323..000000000 --- a/mex/sources/libslicot/TB03AD.f +++ /dev/null @@ -1,746 +0,0 @@ - SUBROUTINE TB03AD( LERI, EQUIL, N, M, P, A, LDA, B, LDB, C, LDC, - $ D, LDD, NR, INDEX, PCOEFF, LDPCO1, LDPCO2, - $ QCOEFF, LDQCO1, LDQCO2, VCOEFF, LDVCO1, LDVCO2, - $ TOL, IWORK, DWORK, LDWORK, INFO ) -C -C SLICOT RELEASE 5.0. -C -C Copyright (c) 2002-2009 NICONET e.V. -C -C This program is free software: you can redistribute it and/or -C modify it under the terms of the GNU General Public License as -C published by the Free Software Foundation, either version 2 of -C the License, or (at your option) any later version. -C -C This program is distributed in the hope that it will be useful, -C but WITHOUT ANY WARRANTY; without even the implied warranty of -C MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the -C GNU General Public License for more details. -C -C You should have received a copy of the GNU General Public License -C along with this program. If not, see -C . -C -C PURPOSE -C -C To find a relatively prime left polynomial matrix representation -C inv(P(s))*Q(s) or right polynomial matrix representation -C Q(s)*inv(P(s)) with the same transfer matrix T(s) as that of a -C given state-space representation, i.e. -C -C inv(P(s))*Q(s) = Q(s)*inv(P(s)) = T(s) = C*inv(s*I-A)*B + D. -C -C ARGUMENTS -C -C Mode Parameters -C -C LERI CHARACTER*1 -C Indicates whether the left polynomial matrix -C representation or the right polynomial matrix -C representation is required as follows: -C = 'L': A left matrix fraction is required; -C = 'R': A right matrix fraction is required. -C -C EQUIL CHARACTER*1 -C Specifies whether the user wishes to balance the triplet -C (A,B,C), before computing a minimal state-space -C representation, as follows: -C = 'S': Perform balancing (scaling); -C = 'N': Do not perform balancing. -C -C Input/Output Parameters -C -C N (input) INTEGER -C The order of the state-space representation, i.e. the -C order of the original state dynamics matrix A. N >= 0. -C -C M (input) INTEGER -C The number of system inputs. M >= 0. -C -C P (input) INTEGER -C The number of system outputs. P >= 0. -C -C A (input/output) DOUBLE PRECISION array, dimension (LDA,N) -C On entry, the leading N-by-N part of this array must -C contain the original state dynamics matrix A. -C On exit, the leading NR-by-NR part of this array contains -C the upper block Hessenberg state dynamics matrix Amin of a -C minimal realization for the original system. -C -C LDA INTEGER -C The leading dimension of array A. LDA >= MAX(1,N). -C -C B (input/output) DOUBLE PRECISION array, dimension -C (LDB,MAX(M,P)) -C On entry, the leading N-by-M part of this array must -C contain the original input/state matrix B; the remainder -C of the leading N-by-MAX(M,P) part is used as internal -C workspace. -C On exit, the leading NR-by-M part of this array contains -C the transformed input/state matrix Bmin. -C -C LDB INTEGER -C The leading dimension of array B. LDB >= MAX(1,N). -C -C C (input/output) DOUBLE PRECISION array, dimension (LDC,N) -C On entry, the leading P-by-N part of this array must -C contain the original state/output matrix C; the remainder -C of the leading MAX(M,P)-by-N part is used as internal -C workspace. -C On exit, the leading P-by-NR part of this array contains -C the transformed state/output matrix Cmin. -C -C LDC INTEGER -C The leading dimension of array C. LDC >= MAX(1,M,P). -C -C D (input) DOUBLE PRECISION array, dimension (LDD,MAX(M,P)) -C The leading P-by-M part of this array must contain the -C original direct transmission matrix D; the remainder of -C the leading MAX(M,P)-by-MAX(M,P) part is used as internal -C workspace. -C -C LDD INTEGER -C The leading dimension of array D. LDD >= MAX(1,M,P). -C -C NR (output) INTEGER -C The order of the minimal state-space representation -C (Amin,Bmin,Cmin). -C -C INDEX (output) INTEGER array, dimension (P), if LERI = 'L', or -C dimension (M), if LERI = 'R'. -C If LERI = 'L', INDEX(I), I = 1,2,...,P, contains the -C maximum degree of the polynomials in the I-th row of the -C denominator matrix P(s) of the left polynomial matrix -C representation. -C These elements are ordered so that -C INDEX(1) >= INDEX(2) >= ... >= INDEX(P). -C If LERI = 'R', INDEX(I), I = 1,2,...,M, contains the -C maximum degree of the polynomials in the I-th column of -C the denominator matrix P(s) of the right polynomial -C matrix representation. -C These elements are ordered so that -C INDEX(1) >= INDEX(2) >= ... >= INDEX(M). -C -C PCOEFF (output) DOUBLE PRECISION array, dimension -C (LDPCO1,LDPCO2,N+1) -C If LERI = 'L' then porm = P, otherwise porm = M. -C The leading porm-by-porm-by-kpcoef part of this array -C contains the coefficients of the denominator matrix P(s), -C where kpcoef = MAX(INDEX(I)) + 1. -C PCOEFF(I,J,K) is the coefficient in s**(INDEX(iorj)-K+1) -C of polynomial (I,J) of P(s), where K = 1,2,...,kpcoef; if -C LERI = 'L' then iorj = I, otherwise iorj = J. -C Thus for LERI = 'L', P(s) = -C diag(s**INDEX(I))*(PCOEFF(.,.,1)+PCOEFF(.,.,2)/s+...). -C -C LDPCO1 INTEGER -C The leading dimension of array PCOEFF. -C LDPCO1 >= MAX(1,P), if LERI = 'L'; -C LDPCO1 >= MAX(1,M), if LERI = 'R'. -C -C LDPCO2 INTEGER -C The second dimension of array PCOEFF. -C LDPCO2 >= MAX(1,P), if LERI = 'L'; -C LDPCO2 >= MAX(1,M), if LERI = 'R'. -C -C QCOEFF (output) DOUBLE PRECISION array, dimension -C (LDQCO1,LDQCO2,N+1) -C If LERI = 'L' then porp = M, otherwise porp = P. -C If LERI = 'L', the leading porm-by-porp-by-kpcoef part -C of this array contains the coefficients of the numerator -C matrix Q(s). -C If LERI = 'R', the leading porp-by-porm-by-kpcoef part -C of this array contains the coefficients of the numerator -C matrix Q(s). -C QCOEFF(I,J,K) is defined as for PCOEFF(I,J,K). -C -C LDQCO1 INTEGER -C The leading dimension of array QCOEFF. -C LDQCO1 >= MAX(1,P), if LERI = 'L'; -C LDQCO1 >= MAX(1,M,P), if LERI = 'R'. -C -C LDQCO2 INTEGER -C The second dimension of array QCOEFF. -C LDQCO2 >= MAX(1,M), if LERI = 'L'; -C LDQCO2 >= MAX(1,M,P), if LERI = 'R'. -C -C VCOEFF (output) DOUBLE PRECISION array, dimension -C (LDVCO1,LDVCO2,N+1) -C The leading porm-by-NR-by-kpcoef part of this array -C contains the coefficients of the intermediate matrix V(s). -C VCOEFF(I,J,K) is defined as for PCOEFF(I,J,K). -C -C LDVCO1 INTEGER -C The leading dimension of array VCOEFF. -C LDVCO1 >= MAX(1,P), if LERI = 'L'; -C LDVCO1 >= MAX(1,M), if LERI = 'R'. -C -C LDVCO2 INTEGER -C The second dimension of array VCOEFF. LDVCO2 >= MAX(1,N). -C -C Tolerances -C -C TOL DOUBLE PRECISION -C The tolerance to be used in rank determination when -C transforming (A, B, C). If the user sets TOL > 0, then -C the given value of TOL is used as a lower bound for the -C reciprocal condition number (see the description of the -C argument RCOND in the SLICOT routine MB03OD); a -C (sub)matrix whose estimated condition number is less than -C 1/TOL is considered to be of full rank. If the user sets -C TOL <= 0, then an implicitly computed, default tolerance -C (determined by the SLICOT routine TB01UD) is used instead. -C -C Workspace -C -C IWORK INTEGER array, dimension (N+MAX(M,P)) -C On exit, if INFO = 0, the first nonzero elements of -C IWORK(1:N) return the orders of the diagonal blocks of A. -C -C DWORK DOUBLE PRECISION array, dimension (LDWORK) -C On exit, if INFO = 0, DWORK(1) returns the optimal value -C of LDWORK. -C -C LDWORK INTEGER -C The length of the array DWORK. -C LDWORK >= MAX(1, N + MAX(N, 3*M, 3*P), PM*(PM + 2)) -C where PM = P, if LERI = 'L'; -C PM = M, if LERI = 'R'. -C For optimum performance LDWORK should be larger. -C -C Error Indicator -C -C INFO INTEGER -C = 0: successful exit; -C < 0: if INFO = -i, the i-th argument had an illegal -C value; -C = 1: if a singular matrix was encountered during the -C computation of V(s); -C = 2: if a singular matrix was encountered during the -C computation of P(s). -C -C METHOD -C -C The method for a left matrix fraction will be described here: -C right matrix fractions are dealt with by constructing a left -C fraction for the dual of the original system. The first step is to -C obtain, by means of orthogonal similarity transformations, a -C minimal state-space representation (Amin,Bmin,Cmin,D) for the -C original system (A,B,C,D), where Amin is lower block Hessenberg -C with all its superdiagonal blocks upper triangular and Cmin has -C all but its first rank(C) columns zero. The number and dimensions -C of the blocks of Amin now immediately yield the row degrees of -C P(s) with P(s) row proper: furthermore, the P-by-NR polynomial -C matrix V(s) (playing a similar role to S(s) in Wolovich's -C Structure Theorem) can be calculated a column block at a time, in -C reverse order, from Amin. P(s) is then found as if it were the -C O-th column block of V(s) (using Cmin as well as Amin), while -C Q(s) = (V(s) * Bmin) + (P(s) * D). Finally, a special similarity -C transformation is used to put Amin in an upper block Hessenberg -C form. -C -C REFERENCES -C -C [1] Williams, T.W.C. -C An Orthogonal Structure Theorem for Linear Systems. -C Kingston Polytechnic Control Systems Research Group, -C Internal Report 82/2, July 1982. -C -C [2] Patel, R.V. -C On Computing Matrix Fraction Descriptions and Canonical -C Forms of Linear Time-Invariant Systems. -C UMIST Control Systems Centre Report 489, 1980. -C (Algorithms 1 and 2, extensively modified). -C -C NUMERICAL ASPECTS -C 3 -C The algorithm requires 0(N ) operations. -C -C CONTRIBUTOR -C -C V. Sima, Katholieke Univ. Leuven, Belgium, March 1998. -C Supersedes Release 3.0 routine TB01SD. -C -C REVISIONS -C -C V. Sima, Research Institute for Informatics, Bucharest, Mar. 2000. -C -C KEYWORDS -C -C Canonical form, coprime matrix fraction, dual system, elementary -C polynomial operations, Hessenberg form, minimal realization, -C orthogonal transformation, polynomial matrix, state-space -C representation, transfer matrix. -C -C ****************************************************************** -C -C .. Parameters .. - DOUBLE PRECISION ZERO, ONE - PARAMETER ( ZERO = 0.0D0, ONE = 1.0D0 ) -C .. Scalar Arguments .. - CHARACTER EQUIL, LERI - INTEGER INFO, LDA, LDB, LDC, LDD, LDPCO1, LDPCO2, - $ LDQCO1, LDQCO2, LDVCO1, LDVCO2, LDWORK, M, N, - $ NR, P - DOUBLE PRECISION TOL -C .. Array Arguments .. - INTEGER INDEX(*), IWORK(*) - DOUBLE PRECISION A(LDA,*), B(LDB,*), C(LDC,*), D(LDD,*), - $ DWORK(*), PCOEFF(LDPCO1,LDPCO2,*), - $ QCOEFF(LDQCO1,LDQCO2,*), VCOEFF(LDVCO1,LDVCO2,*) -C .. Local Scalars .. - LOGICAL LEQUIL, LLERIL, LLERIR - INTEGER I, IC, IFIRST, INDBLK, INPLUS, IOFF, IRANKC, - $ ISTART, ISTOP, ITAU, IZ, JOFF, JWORK, K, KMAX, - $ KPCOEF, KPLUS, KWORK, LDWRIC, MAXMP, MPLIM, - $ MWORK, NCOL, NCONT, NREFLC, NROW, PWORK, WRKOPT - DOUBLE PRECISION MAXRED -C .. External Functions .. - LOGICAL LSAME - EXTERNAL LSAME -C .. External Subroutines .. - EXTERNAL AB07MD, DGEMM, DGEQRF, DGETRF, DLACPY, DLASET, - $ DORMQR, DTRSM, MA02GD, TB01ID, TB01UD, TB01YD, - $ TB03AY, TC01OD, XERBLA -C .. Intrinsic Functions .. - INTRINSIC INT, MAX -C .. Executable Statements .. -C - INFO = 0 - LLERIL = LSAME( LERI, 'L' ) - LLERIR = LSAME( LERI, 'R' ) - LEQUIL = LSAME( EQUIL, 'S' ) - MAXMP = MAX( M, P ) - MPLIM = MAX( 1, MAXMP ) - IF ( LLERIR ) THEN -C -C Initialization for right matrix fraction. -C - PWORK = M - MWORK = P - ELSE -C -C Initialization for left matrix fraction. -C - PWORK = P - MWORK = M - END IF -C -C Test the input scalar arguments. -C - IF( .NOT.LLERIL .AND. .NOT.LLERIR ) THEN - INFO = -1 - ELSE IF( .NOT.LEQUIL .AND. .NOT.LSAME( EQUIL, 'N' ) ) THEN - INFO = -2 - ELSE IF( N.LT.0 ) THEN - INFO = -3 - ELSE IF( M.LT.0 ) THEN - INFO = -4 - ELSE IF( P.LT.0 ) THEN - INFO = -5 - ELSE IF( LDA.LT.MAX( 1, N ) ) THEN - INFO = -7 - ELSE IF( LDB.LT.MAX( 1, N ) ) THEN - INFO = -9 - ELSE IF( LDC.LT.MPLIM ) THEN - INFO = -11 - ELSE IF( LDD.LT.MPLIM ) THEN - INFO = -13 - ELSE IF( LDPCO1.LT.MAX( 1, PWORK ) ) THEN - INFO = -17 - ELSE IF( LDPCO2.LT.MAX( 1, PWORK ) ) THEN - INFO = -18 - ELSE IF( LDQCO1.LT.MAX( 1, PWORK ) .OR. LLERIR .AND. - $ LDQCO1.LT.MPLIM ) THEN - INFO = -20 - ELSE IF( LDQCO2.LT.MAX( 1, MWORK ) .OR. LLERIR .AND. - $ LDQCO2.LT.MPLIM ) THEN - INFO = -21 - ELSE IF( LDVCO1.LT.MAX( 1, PWORK ) ) THEN - INFO = -23 - ELSE IF( LDVCO2.LT.MAX( 1, N ) ) THEN - INFO = -24 - ELSE IF( LDWORK.LT.MAX( 1, N + MAX( N, 3*MAXMP ), - $ PWORK*( PWORK + 2 ) ) ) THEN - INFO = -28 - END IF -C - IF ( INFO.NE.0 ) THEN -C -C Error return. -C - CALL XERBLA( 'TB03AD', -INFO ) - RETURN - END IF -C -C Quick return if possible. -C - IF ( MAX( N, M, P ).EQ.0 ) THEN - NR = 0 - DWORK(1) = ONE - RETURN - END IF -C - IF ( LLERIR ) THEN -C -C For right matrix fraction, obtain dual system. -C - CALL AB07MD( 'D', N, M, P, A, LDA, B, LDB, C, LDC, D, LDD, - $ INFO ) - END IF -C -C Obtain minimal realization, in canonical form, for this system. -C Part of the code in SLICOT routine TB01PD is included in-line -C here. (TB01PD cannot be directly used.) -C -C (Note: Comments in the code beginning "Workspace:" describe the -C minimal amount of real workspace needed at that point in the -C code, as well as the preferred amount for good performance. -C NB refers to the optimal block size for the immediately -C following subroutine, as returned by ILAENV.) -C -C If required, balance the triplet (A,B,C) (default MAXRED). -C Workspace: need N. -C - IF ( LEQUIL ) THEN - MAXRED = ZERO - CALL TB01ID( 'A', N, MWORK, PWORK, MAXRED, A, LDA, B, LDB, C, - $ LDC, DWORK, INFO ) - END IF -C - IZ = 1 - ITAU = 1 - JWORK = ITAU + N -C -C Separate out controllable subsystem (of order NCONT): -C A <-- Z'*A*Z, B <-- Z'*B, C <-- C*Z. -C -C Workspace: need N + MAX(N, 3*MWORK, PWORK). -C prefer larger. -C - CALL TB01UD( 'No Z', N, MWORK, PWORK, A, LDA, B, LDB, C, LDC, - $ NCONT, INDBLK, IWORK, DWORK(IZ), 1, DWORK(ITAU), TOL, - $ IWORK(N+1), DWORK(JWORK), LDWORK-JWORK+1, INFO ) -C - WRKOPT = INT( DWORK(JWORK) ) + JWORK - 1 -C -C Separate out the observable subsystem (of order NR): -C Form the dual of the subsystem of order NCONT (which is -C controllable), leaving rest as it is. -C - CALL AB07MD( 'Z', NCONT, MWORK, PWORK, A, LDA, B, LDB, C, LDC, - $ DWORK, 1, INFO ) -C -C And separate out the controllable part of this dual subsystem. -C -C Workspace: need NCONT + MAX(NCONT, 3*PWORK, MWORK). -C prefer larger. -C - CALL TB01UD( 'No Z', NCONT, PWORK, MWORK, A, LDA, B, LDB, C, LDC, - $ NR, INDBLK, IWORK, DWORK(IZ), 1, DWORK(ITAU), TOL, - $ IWORK(N+1), DWORK(JWORK), LDWORK-JWORK+1, INFO ) -C - WRKOPT = MAX( WRKOPT, INT( DWORK(JWORK) )+JWORK-1 ) -C -C Retranspose, giving controllable and observable (i.e. minimal) -C part of original system. -C - CALL AB07MD( 'Z', NR, PWORK, MWORK, A, LDA, B, LDB, C, LDC, DWORK, - $ 1, INFO ) -C -C Annihilate the trailing components of IWORK(1:N). -C - DO 10 I = INDBLK + 1, N - IWORK(I) = 0 - 10 CONTINUE -C -C Initialize polynomial matrices P(s), Q(s) and V(s) to zero. -C - DO 20 K = 1, N + 1 - CALL DLASET( 'Full', PWORK, PWORK, ZERO, ZERO, PCOEFF(1,1,K), - $ LDPCO1 ) - CALL DLASET( 'Full', PWORK, MWORK, ZERO, ZERO, QCOEFF(1,1,K), - $ LDQCO1 ) - CALL DLASET( 'Full', PWORK, NR, ZERO, ZERO, VCOEFF(1,1,K), - $ LDVCO1 ) - 20 CONTINUE -C -C Finish initializing V(s), and set up row degrees of P(s). -C - INPLUS = INDBLK + 1 - ISTART = 1 - JOFF = NR -C - DO 40 K = 1, INDBLK - KWORK = INPLUS - K - KPLUS = KWORK + 1 - ISTOP = IWORK(KWORK) - JOFF = JOFF - ISTOP -C - DO 30 I = ISTART, ISTOP - INDEX(I) = KWORK - VCOEFF(I,JOFF+I,KPLUS) = ONE - 30 CONTINUE -C - ISTART = ISTOP + 1 - 40 CONTINUE -C -C ISTART = IWORK(1)+1 now: if .LE. PWORK, set up final rows of P(s). -C - DO 50 I = ISTART, PWORK - INDEX(I) = 0 - PCOEFF(I,I,1) = ONE - 50 CONTINUE -C -C Triangularize the superdiagonal blocks of Amin. -C - NROW = IWORK(INDBLK) - IOFF = NR - NROW - KMAX = INDBLK - 1 - ITAU = 1 - IFIRST = 0 - IF ( INDBLK.GT.2 ) IFIRST = IOFF - IWORK(KMAX) -C -C QR decomposition of each superdiagonal block of A in turn -C (done in reverse order to preserve upper triangular blocks in A). -C - DO 60 K = 1, KMAX -C -C Calculate dimensions of new block & its position in A. -C - KWORK = INDBLK - K - NCOL = NROW - NROW = IWORK(KWORK) - JOFF = IOFF - IOFF = IOFF - NROW - NREFLC = MIN( NROW, NCOL ) - JWORK = ITAU + NREFLC - IF ( KWORK.GE.2 ) IFIRST = IFIRST - IWORK(KWORK-1) -C -C Find QR decomposition of this (full rank) block: -C block = QR. No pivoting is needed. -C -C Workspace: need MIN(NROW,NCOL) + NCOL; -C prefer MIN(NROW,NCOL) + NCOL*NB. -C - CALL DGEQRF( NROW, NCOL, A(IOFF+1,JOFF+1), LDA, DWORK(ITAU), - $ DWORK(JWORK), LDWORK-JWORK+1, INFO ) -C - WRKOPT = MAX( WRKOPT, INT( DWORK(JWORK) )+JWORK-1 ) -C -C Premultiply appropriate row block of A by Q'. -C -C Workspace: need MIN(NROW,NCOL) + JOFF; -C prefer MIN(NROW,NCOL) + JOFF*NB. -C - CALL DORMQR( 'Left', 'Transpose', NROW, JOFF, NREFLC, - $ A(IOFF+1,JOFF+1), LDA, DWORK(ITAU), A(IOFF+1,1), - $ LDA, DWORK(JWORK), LDWORK-JWORK+1, INFO ) -C - WRKOPT = MAX( WRKOPT, INT( DWORK(JWORK) )+JWORK-1 ) -C -C Premultiply appropriate row block of B by Q' also. -C -C Workspace: need MIN(NROW,NCOL) + MWORK; -C prefer MIN(NROW,NCOL) + MWORK*NB. -C - CALL DORMQR( 'Left', 'Transpose', NROW, MWORK, NREFLC, - $ A(IOFF+1,JOFF+1), LDA, DWORK(ITAU), B(IOFF+1,1), - $ LDB, DWORK(JWORK), LDWORK-JWORK+1, INFO ) -C - WRKOPT = MAX( WRKOPT, INT( DWORK(JWORK) )+JWORK-1 ) -C -C And postmultiply the non-zero part of appropriate column -C block of A by Q. -C -C Workspace: need MIN(NROW,NCOL) + NR; -C prefer MIN(NROW,NCOL) + NR*NB. -C - CALL DORMQR( 'Right', 'No Transpose', NR-IFIRST, NROW, NREFLC, - $ A(IOFF+1,JOFF+1), LDA, DWORK(ITAU), - $ A(IFIRST+1,IOFF+1), LDA, DWORK(JWORK), - $ LDWORK-JWORK+1, INFO ) -C - WRKOPT = MAX( WRKOPT, INT( DWORK(JWORK) )+JWORK-1 ) -C -C Annihilate the lower triangular part of the block in A. -C - IF ( K.NE.KMAX .AND. NROW.GT.1 ) - $ CALL DLASET( 'Lower', NROW-1, NCOL, ZERO, ZERO, - $ A(IOFF+2,JOFF+1), LDA ) -C - 60 CONTINUE -C -C Finally: postmultiply non-zero columns of C by Q (K = KMAX). -C -C Workspace: need MIN(NROW,NCOL) + PWORK; -C prefer MIN(NROW,NCOL) + PWORK*NB. -C - CALL DORMQR( 'Right', 'No Transpose', PWORK, NROW, NREFLC, - $ A(IOFF+1,JOFF+1), LDA, DWORK(ITAU), C, LDC, - $ DWORK(JWORK), LDWORK-JWORK+1, INFO ) -C - WRKOPT = MAX( WRKOPT, INT( DWORK(JWORK) )+JWORK-1 ) -C -C Annihilate the lower triangular part of the block in A. -C - IF ( NROW.GT.1 ) - $ CALL DLASET( 'Lower', NROW-1, NCOL, ZERO, ZERO, - $ A(IOFF+2,JOFF+1), LDA ) -C -C Calculate the (PWORK x NR) polynomial matrix V(s) ... -C - CALL TB03AY( NR, A, LDA, INDBLK, IWORK, VCOEFF, LDVCO1, LDVCO2, - $ PCOEFF, LDPCO1, LDPCO2, INFO) -C - IF ( INFO.NE.0 ) THEN - INFO = 1 - RETURN - ELSE -C -C And then use this matrix to calculate P(s): first store -C C1 from C. -C - IC = 1 - IRANKC = IWORK(1) - LDWRIC = MAX( 1, PWORK ) - CALL DLACPY( 'Full', PWORK, IRANKC, C, LDC, DWORK(IC), LDWRIC ) -C - IF ( IRANKC.LT.PWORK ) THEN -C -C rank(C) .LT. PWORK: obtain QR decomposition of C1, -C giving R and Q. -C -C Workspace: need PWORK*IRANKC + 2*IRANKC; -C prefer PWORK*IRANKC + IRANKC + IRANKC*NB. -C - ITAU = IC + LDWRIC*IRANKC - JWORK = ITAU + IRANKC -C - CALL DGEQRF( PWORK, IRANKC, DWORK(IC), LDWRIC, DWORK(ITAU), - $ DWORK(JWORK), LDWORK-JWORK+1, INFO ) -C - WRKOPT = MAX( WRKOPT, INT( DWORK(JWORK) )+JWORK-1 ) -C -C First IRANKC rows of Pbar(s) are given by Wbar(s) * inv(R). -C Check for zero diagonal elements of R. -C - DO 70 I = 1, IRANKC - IF ( DWORK(IC+(I-1)*LDWRIC+I-1).EQ.ZERO ) THEN -C -C Error return. -C - INFO = 2 - RETURN - END IF - 70 CONTINUE -C - NROW = IRANKC -C - DO 80 K = 1, INPLUS - CALL DTRSM( 'Right', 'Upper', 'No Transpose', 'Non-unit', - $ NROW, IRANKC, ONE, DWORK(IC), LDWRIC, - $ PCOEFF(1,1,K), LDPCO1 ) - NROW = IWORK(K) - 80 CONTINUE -C -C P(s) itself is now given by Pbar(s) * Q'. -C - NROW = PWORK -C - DO 90 K = 1, INPLUS -C -C Workspace: need PWORK*IRANKC + IRANKC + NROW; -C prefer PWORK*IRANKC + IRANKC + NROW*NB. -C - CALL DORMQR( 'Right', 'Transpose', NROW, PWORK, IRANKC, - $ DWORK(IC), LDWRIC, DWORK(ITAU), - $ PCOEFF(1,1,K), LDPCO1, DWORK(JWORK), - $ LDWORK-JWORK+1, INFO ) - WRKOPT = MAX( WRKOPT, INT( DWORK(JWORK) )+JWORK-1 ) - NROW = IWORK(K) - 90 CONTINUE -C - ELSE -C -C Special case rank(C) = PWORK, full: -C no QR decomposition (P(s)=Wbar(s)*inv(C1)). -C - CALL DGETRF( PWORK, PWORK, DWORK(IC), LDWRIC, IWORK(N+1), - $ INFO ) -C - IF ( INFO.NE.0 ) THEN -C -C Error return. -C - INFO = 2 - RETURN - ELSE -C - NROW = IRANKC -C -C Workspace: need PWORK*IRANKC + N. -C - DO 100 K = 1, INPLUS - CALL DTRSM( 'Right', 'Upper', 'No Transpose', - $ 'Non-unit', NROW, PWORK, ONE, DWORK(IC), - $ LDWRIC, PCOEFF(1,1,K), LDPCO1 ) - CALL DTRSM( 'Right', 'Lower', 'No Transpose', 'Unit', - $ NROW, PWORK, ONE, DWORK(IC), LDWRIC, - $ PCOEFF(1,1,K), LDPCO1 ) - CALL MA02GD( NROW, PCOEFF(1,1,K), LDPCO1, 1, PWORK, - $ IWORK(N+1), -1 ) - NROW = IWORK(K) - 100 CONTINUE - END IF - END IF -C -C Finally, Q(s) = V(s) * B + P(s) * D can now be evaluated. -C - NROW = PWORK -C - DO 110 K = 1, INPLUS - CALL DGEMM( 'No transpose', 'No transpose', NROW, MWORK, - $ NR, ONE, VCOEFF(1,1,K), LDVCO1, B, LDB, ZERO, - $ QCOEFF(1,1,K), LDQCO1 ) - CALL DGEMM( 'No transpose', 'No transpose', NROW, MWORK, - $ PWORK, ONE, PCOEFF(1,1,K), LDPCO1, D, LDD, ONE, - $ QCOEFF(1,1,K), LDQCO1 ) - NROW = IWORK(K) - 110 CONTINUE -C - END IF -C - IF ( LLERIR ) THEN -C -C For right matrix fraction, return to original (dual of dual) -C system. -C - CALL AB07MD( 'Z', NR, MWORK, PWORK, A, LDA, B, LDB, C, LDC, - $ DWORK, 1, INFO ) -C -C Also, obtain the dual of the polynomial matrix representation. -C - KPCOEF = 0 -C - DO 120 I = 1, PWORK - KPCOEF = MAX( KPCOEF, INDEX(I) ) - 120 CONTINUE -C - KPCOEF = KPCOEF + 1 - CALL TC01OD( 'L', MWORK, PWORK, KPCOEF, PCOEFF, LDPCO1, - $ LDPCO2, QCOEFF, LDQCO1, LDQCO2, INFO ) - ELSE -C -C Reorder the rows and columns of the system, to get an upper -C block Hessenberg matrix A of the minimal system. -C - CALL TB01YD( NR, M, P, A, LDA, B, LDB, C, LDC, INFO ) - END IF -C -C Set optimal workspace dimension. -C - DWORK(1) = WRKOPT - RETURN -C *** Last line of TB03AD *** - END diff --git a/mex/sources/libslicot/TB03AY.f b/mex/sources/libslicot/TB03AY.f deleted file mode 100644 index eeffc6e23..000000000 --- a/mex/sources/libslicot/TB03AY.f +++ /dev/null @@ -1,159 +0,0 @@ - SUBROUTINE TB03AY( NR, A, LDA, INDBLK, NBLK, VCOEFF, LDVCO1, - $ LDVCO2, PCOEFF, LDPCO1, LDPCO2, INFO ) -C -C SLICOT RELEASE 5.0. -C -C Copyright (c) 2002-2009 NICONET e.V. -C -C This program is free software: you can redistribute it and/or -C modify it under the terms of the GNU General Public License as -C published by the Free Software Foundation, either version 2 of -C the License, or (at your option) any later version. -C -C This program is distributed in the hope that it will be useful, -C but WITHOUT ANY WARRANTY; without even the implied warranty of -C MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the -C GNU General Public License for more details. -C -C You should have received a copy of the GNU General Public License -C along with this program. If not, see -C . -C -C PURPOSE -C -C To calculate the (PWORK-by-NR) polynomial matrix V(s) one -C (PWORK-by-NBLK(L-1)) block V:L-1(s) at a time, in reverse order -C (L = INDBLK,...,1). At each stage, the (NBLK(L)-by-NBLK(L)) poly- -C nomial matrix W(s) = V2(s) * A2 is formed, where V2(s) is that -C part of V(s) already computed and A2 is the subdiagonal (incl.) -C part of the L-th column block of A; W(s) is temporarily stored in -C the top left part of P(s), as is subsequently the further matrix -C Wbar(s) = s * V:L(s) - W(s). Then, except for the final stage -C L = 1 (when the next step is to calculate P(s) itself, not here), -C the top left part of V:L-1(s) is given by Wbar(s) * inv(R), where -C R is the upper triangular part of the L-th superdiagonal block of -C A. Finally, note that the coefficient matrices W(.,.,K) can only -C be non-zero for K = L + 1,...,INPLUS, with each of these matrices -C having only its first NBLK(L-1) rows non-trivial. Similarly, -C Wbar(.,.,K) (and so clearly V:L-1(.,.,K) ) can only be non-zero -C for K = L,...,INPLUS, with each of these having only its first -C NBLK(K-1) rows non-trivial except for K = L, which has NBLK(L) -C such rows. -C -C REVISIONS -C -C - -C -C KEYWORDS -C -C Coprime matrix fraction, elementary polynomial operations, -C polynomial matrix, state-space representation, transfer matrix. -C -C NOTE: In the interests of speed, this routine does not check the -C inputs for errors. -C -C ****************************************************************** -C -C .. Parameters .. - DOUBLE PRECISION ZERO, ONE - PARAMETER ( ZERO = 0.0D0, ONE = 1.0D0 ) -C .. Scalar Arguments .. - INTEGER INDBLK, INFO, LDA, LDPCO1, LDPCO2, LDVCO1, - $ LDVCO2, NR -C .. Array Arguments .. - INTEGER NBLK(*) - DOUBLE PRECISION A(LDA,*), PCOEFF(LDPCO1,LDPCO2,*), - $ VCOEFF(LDVCO1,LDVCO2,*) -C .. Local Scalars .. - INTEGER I, INPLUS, IOFF, J, JOFF, K, KPLUS, L, LSTART, - $ LSTOP, LWORK, NCOL, NROW -C .. External Subroutines .. - EXTERNAL DAXPY, DGEMM, DLACPY, DSCAL, DTRSM -C .. Executable Statements .. -C - INFO = 0 - INPLUS = INDBLK + 1 - JOFF = NR -C -C Calculate each column block V:LWORK-1(s) of V(s) in turn. -C - DO 70 L = 1, INDBLK - LWORK = INPLUS - L -C -C Determine number of columns of V:LWORK(s) & its position in V. -C - NCOL = NBLK(LWORK) - JOFF = JOFF - NCOL -C -C Find limits for V2(s) * A2 calculation: skips zero rows -C in V(s). -C - LSTART = JOFF + 1 - LSTOP = JOFF -C -C Calculate W(s) and store (temporarily) in top left part -C of P(s). -C - DO 10 K = LWORK + 1, INPLUS - NROW = NBLK(K-1) - LSTOP = LSTOP + NROW - CALL DGEMM( 'No transpose', 'No transpose', NROW, NCOL, - $ LSTOP-LSTART+1, ONE, VCOEFF(1,LSTART,K), LDVCO1, - $ A(LSTART,JOFF+1), LDA, ZERO, PCOEFF(1,1,K), - $ LDPCO1 ) - 10 CONTINUE -C -C Replace W(s) by Wbar(s) = s * V:L(s) - W(s). -C - NROW = NCOL -C - DO 30 K = LWORK, INDBLK - KPLUS = K + 1 -C - DO 20 J = 1, NCOL - CALL DSCAL( NROW, -ONE, PCOEFF(1,J,K), 1 ) - CALL DAXPY( NROW, ONE, VCOEFF(1,JOFF+J,KPLUS), 1, - $ PCOEFF(1,J,K), 1 ) - 20 CONTINUE -C - NROW = NBLK(K) - 30 CONTINUE -C - DO 40 J = 1, NCOL - CALL DSCAL( NROW, -ONE, PCOEFF(1,J,INPLUS), 1 ) - 40 CONTINUE -C - IF ( LWORK.NE.1 ) THEN -C -C If not final stage, use the upper triangular R (from A) -C to calculate V:L-1(s), finally storing this new block. -C - IOFF = JOFF - NBLK(LWORK-1) -C - DO 50 I = 1, NCOL - IF ( A(IOFF+I,JOFF+I).EQ.ZERO ) THEN -C -C Error return. -C - INFO = I - RETURN - END IF - 50 CONTINUE -C - NROW = NBLK(LWORK) -C - DO 60 K = LWORK, INPLUS - CALL DLACPY( 'Full', NROW, NCOL, PCOEFF(1,1,K), LDPCO1, - $ VCOEFF(1,IOFF+1,K), LDVCO1 ) - CALL DTRSM( 'Right', 'Upper', 'No Transpose', 'Non-unit', - $ NROW, NCOL, ONE, A(IOFF+1,JOFF+1), LDA, - $ VCOEFF(1,IOFF+1,K), LDVCO1 ) - NROW = NBLK(K) - 60 CONTINUE -C - END IF - 70 CONTINUE -C - RETURN -C *** Last line of TB03AY *** - END diff --git a/mex/sources/libslicot/TB04AD.f b/mex/sources/libslicot/TB04AD.f deleted file mode 100644 index d864d1914..000000000 --- a/mex/sources/libslicot/TB04AD.f +++ /dev/null @@ -1,395 +0,0 @@ - SUBROUTINE TB04AD( ROWCOL, N, M, P, A, LDA, B, LDB, C, LDC, D, - $ LDD, NR, INDEX, DCOEFF, LDDCOE, UCOEFF, LDUCO1, - $ LDUCO2, TOL1, TOL2, IWORK, DWORK, LDWORK, - $ INFO ) -C -C SLICOT RELEASE 5.0. -C -C Copyright (c) 2002-2009 NICONET e.V. -C -C This program is free software: you can redistribute it and/or -C modify it under the terms of the GNU General Public License as -C published by the Free Software Foundation, either version 2 of -C the License, or (at your option) any later version. -C -C This program is distributed in the hope that it will be useful, -C but WITHOUT ANY WARRANTY; without even the implied warranty of -C MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the -C GNU General Public License for more details. -C -C You should have received a copy of the GNU General Public License -C along with this program. If not, see -C . -C -C PURPOSE -C -C To find the transfer matrix T(s) of a given state-space -C representation (A,B,C,D). T(s) is expressed as either row or -C column polynomial vectors over monic least common denominator -C polynomials. -C -C ARGUMENTS -C -C Mode Parameters -C -C ROWCOL CHARACTER*1 -C Indicates whether the transfer matrix T(s) is required -C as rows or columns over common denominators as follows: -C = 'R': T(s) is required as rows over common denominators; -C = 'C': T(s) is required as columns over common -C denominators. -C -C Input/Output Parameters -C -C N (input) INTEGER -C The order of the state-space representation, i.e. the -C order of the original state dynamics matrix A. N >= 0. -C -C M (input) INTEGER -C The number of system inputs. M >= 0. -C -C P (input) INTEGER -C The number of system outputs. P >= 0. -C -C A (input/output) DOUBLE PRECISION array, dimension (LDA,N) -C On entry, the leading N-by-N part of this array must -C contain the original state dynamics matrix A. -C On exit, the leading NR-by-NR part of this array contains -C the upper block Hessenberg state dynamics matrix A of a -C transformed representation for the original system: this -C is completely controllable if ROWCOL = 'R', or completely -C observable if ROWCOL = 'C'. -C -C LDA INTEGER -C The leading dimension of array A. LDA >= MAX(1,N). -C -C B (input/output) DOUBLE PRECISION array, dimension (LDB,M), -C if ROWCOL = 'R', and (LDB,MAX(M,P)) if ROWCOL = 'C'. -C On entry, the leading N-by-M part of this array must -C contain the original input/state matrix B; if -C ROWCOL = 'C', the remainder of the leading N-by-MAX(M,P) -C part is used as internal workspace. -C On exit, the leading NR-by-M part of this array contains -C the transformed input/state matrix B. -C -C LDB INTEGER -C The leading dimension of array B. LDB >= MAX(1,N). -C -C C (input/output) DOUBLE PRECISION array, dimension (LDC,N) -C On entry, the leading P-by-N part of this array must -C contain the original state/output matrix C; if -C ROWCOL = 'C', the remainder of the leading MAX(M,P)-by-N -C part is used as internal workspace. -C On exit, the leading P-by-NR part of this array contains -C the transformed state/output matrix C. -C -C LDC INTEGER -C The leading dimension of array C. -C LDC >= MAX(1,P) if ROWCOL = 'R'; -C LDC >= MAX(1,M,P) if ROWCOL = 'C'. -C -C D (input) DOUBLE PRECISION array, dimension (LDD,M), -C if ROWCOL = 'R', and (LDD,MAX(M,P)) if ROWCOL = 'C'. -C The leading P-by-M part of this array must contain the -C original direct transmission matrix D; if ROWCOL = 'C', -C this array is modified internally, but restored on exit, -C and the remainder of the leading MAX(M,P)-by-MAX(M,P) -C part is used as internal workspace. -C -C LDD INTEGER -C The leading dimension of array D. -C LDD >= MAX(1,P) if ROWCOL = 'R'; -C LDD >= MAX(1,M,P) if ROWCOL = 'C'. -C -C NR (output) INTEGER -C The order of the transformed state-space representation. -C -C INDEX (output) INTEGER array, dimension (porm), where porm = P, -C if ROWCOL = 'R', and porm = M, if ROWCOL = 'C'. -C The degrees of the denominator polynomials. -C -C DCOEFF (output) DOUBLE PRECISION array, dimension (LDDCOE,N+1) -C The leading porm-by-kdcoef part of this array contains -C the coefficients of each denominator polynomial, where -C kdcoef = MAX(INDEX(I)) + 1. -C DCOEFF(I,K) is the coefficient in s**(INDEX(I)-K+1) of -C the I-th denominator polynomial, where K = 1,2,...,kdcoef. -C -C LDDCOE INTEGER -C The leading dimension of array DCOEFF. -C LDDCOE >= MAX(1,P) if ROWCOL = 'R'; -C LDDCOE >= MAX(1,M) if ROWCOL = 'C'. -C -C UCOEFF (output) DOUBLE PRECISION array, dimension -C (LDUCO1,LDUCO2,N+1) -C If ROWCOL = 'R' then porp = M, otherwise porp = P. -C The leading porm-by-porp-by-kdcoef part of this array -C contains the coefficients of the numerator matrix U(s). -C UCOEFF(I,J,K) is the coefficient in s**(INDEX(iorj)-K+1) -C of polynomial (I,J) of U(s), where K = 1,2,...,kdcoef; -C if ROWCOL = 'R' then iorj = I, otherwise iorj = J. -C Thus for ROWCOL = 'R', U(s) = -C diag(s**INDEX(I))*(UCOEFF(.,.,1)+UCOEFF(.,.,2)/s+...). -C -C LDUCO1 INTEGER -C The leading dimension of array UCOEFF. -C LDUCO1 >= MAX(1,P) if ROWCOL = 'R'; -C LDUCO1 >= MAX(1,M) if ROWCOL = 'C'. -C -C LDUCO2 INTEGER -C The second dimension of array UCOEFF. -C LDUCO2 >= MAX(1,M) if ROWCOL = 'R'; -C LDUCO2 >= MAX(1,P) if ROWCOL = 'C'. -C -C Tolerances -C -C TOL1 DOUBLE PRECISION -C The tolerance to be used in determining the i-th row of -C T(s), where i = 1,2,...,porm. If the user sets TOL1 > 0, -C then the given value of TOL1 is used as an absolute -C tolerance; elements with absolute value less than TOL1 are -C considered neglijible. If the user sets TOL1 <= 0, then -C an implicitly computed, default tolerance, defined in -C the SLICOT Library routine TB01ZD, is used instead. -C -C TOL2 DOUBLE PRECISION -C The tolerance to be used to separate out a controllable -C subsystem of (A,B,C). If the user sets TOL2 > 0, then -C the given value of TOL2 is used as a lower bound for the -C reciprocal condition number (see the description of the -C argument RCOND in the SLICOT routine MB03OD); a -C (sub)matrix whose estimated condition number is less than -C 1/TOL2 is considered to be of full rank. If the user sets -C TOL2 <= 0, then an implicitly computed, default tolerance, -C defined in the SLICOT Library routine TB01UD, is used -C instead. -C -C Workspace -C -C IWORK DOUBLE PRECISION array, dimension (N+MAX(M,P)) -C On exit, if INFO = 0, the first nonzero elements of -C IWORK(1:N) return the orders of the diagonal blocks of A. -C -C DWORK DOUBLE PRECISION array, dimension (LDWORK) -C On exit, if INFO = 0, DWORK(1) returns the optimal value -C of LDWORK. -C -C LDWORK INTEGER -C The length of the array DWORK. -C LDWORK >= MAX(1, N*(N + 1) + MAX(N*MP + 2*N + MAX(N,MP), -C 3*MP, PM)), -C where MP = M, PM = P, if ROWCOL = 'R'; -C MP = P, PM = M, if ROWCOL = 'C'. -C For optimum performance LDWORK should be larger. -C -C Error Indicator -C -C INFO INTEGER -C = 0: successful exit; -C < 0: if INFO = -i, the i-th argument had an illegal -C value. -C -C METHOD -C -C The method for transfer matrices factorized by rows will be -C described here: T(s) factorized by columns is dealt with by -C operating on the dual of the original system. Each row of -C T(s) is simply a single-output relatively left prime polynomial -C matrix representation, so can be calculated by applying a -C simplified version of the Orthogonal Structure Theorem to a -C minimal state-space representation for the corresponding row of -C the given system. A minimal state-space representation is obtained -C using the Orthogonal Canonical Form to first separate out a -C completely controllable one for the overall system and then, for -C each row in turn, applying it again to the resulting dual SIMO -C (single-input multi-output) system. Note that the elements of the -C transformed matrix A so calculated are individually scaled in a -C way which guarantees a monic denominator polynomial. -C -C REFERENCES -C -C [1] Williams, T.W.C. -C An Orthogonal Structure Theorem for Linear Systems. -C Control Systems Research Group, Kingston Polytechnic, -C Internal Report 82/2, 1982. -C -C NUMERICAL ASPECTS -C 3 -C The algorithm requires 0(N ) operations. -C -C CONTRIBUTOR -C -C V. Sima, Katholieke Univ. Leuven, Belgium, March 1998. -C Supersedes Release 3.0 routine TB01QD. -C -C REVISIONS -C -C - -C -C KEYWORDS -C -C Controllability, dual system, minimal realization, orthogonal -C canonical form, orthogonal transformation, polynomial matrix, -C transfer matrix. -C -C ****************************************************************** -C -C .. Parameters .. - DOUBLE PRECISION ZERO - PARAMETER ( ZERO = 0.0D0 ) -C .. Scalar Arguments .. - CHARACTER ROWCOL - INTEGER INFO, LDA, LDB, LDC, LDD, LDDCOE, LDUCO1, - $ LDUCO2, LDWORK, M, N, NR, P - DOUBLE PRECISION TOL1, TOL2 -C .. Array Arguments .. - INTEGER INDEX(*), IWORK(*) - DOUBLE PRECISION A(LDA,*), B(LDB,*), C(LDC,*), D(LDD,*), - $ DCOEFF(LDDCOE,*), DWORK(*), - $ UCOEFF(LDUCO1,LDUCO2,*) -C .. Local Scalars .. - LOGICAL LROCOC, LROCOR - CHARACTER*1 JOBD - INTEGER I, IA, ITAU, J, JWORK, K, KDCOEF, MAXMP, MAXMPN, - $ MPLIM, MWORK, N1, PWORK -C .. External Functions .. - LOGICAL LSAME - EXTERNAL LSAME -C .. External Subroutines .. - EXTERNAL AB07MD, DLASET, DSWAP, TB01XD, TB04AY, XERBLA -C .. Intrinsic Functions .. - INTRINSIC DBLE, MAX -C .. Executable Statements .. -C - INFO = 0 - LROCOR = LSAME( ROWCOL, 'R' ) - LROCOC = LSAME( ROWCOL, 'C' ) - MAXMP = MAX( M, P ) - MPLIM = MAX( 1, MAXMP ) - MAXMPN = MAX( MAXMP, N ) - N1 = MAX( 1, N ) - IF ( LROCOR ) THEN -C -C T(s) given as rows over common denominators. -C - PWORK = P - MWORK = M - ELSE -C -C T(s) given as columns over common denominators. -C - PWORK = M - MWORK = P - END IF -C -C Test the input scalar arguments. -C - IF( .NOT.LROCOR .AND. .NOT.LROCOC ) THEN - INFO = -1 - ELSE IF( N.LT.0 ) THEN - INFO = -2 - ELSE IF( M.LT.0 ) THEN - INFO = -3 - ELSE IF( P.LT.0 ) THEN - INFO = -4 - ELSE IF( LDA.LT.N1 ) THEN - INFO = -6 - ELSE IF( LDB.LT.N1 ) THEN - INFO = -8 - ELSE IF( ( LROCOC .AND. LDC.LT.MPLIM ) - $ .OR. LDC.LT.MAX( 1, P ) ) THEN - INFO = -10 - ELSE IF( ( LROCOC .AND. LDD.LT.MPLIM ) - $ .OR. LDD.LT.MAX( 1, P ) ) THEN - INFO = -12 - ELSE IF( LDDCOE.LT.MAX( 1, PWORK ) ) THEN - INFO = -16 - ELSE IF( LDUCO1.LT.MAX( 1, PWORK ) ) THEN - INFO = -18 - ELSE IF( LDUCO2.LT.MAX( 1, MWORK ) ) THEN - INFO = -19 - ELSE IF( LDWORK.LT.MAX( 1, N*( N + 1 ) + - $ MAX( N*MWORK + 2*N + MAX( N, MWORK ), - $ 3*MWORK, PWORK ) ) ) THEN - INFO = -24 - END IF -C - IF ( INFO.NE.0 ) THEN -C -C Error return. -C - CALL XERBLA( 'TB04AD', -INFO ) - RETURN - END IF -C -C Quick return if possible. -C - IF ( MAXMPN.EQ.0 ) - $ RETURN -C - JOBD = 'D' - IA = 1 - ITAU = IA + N*N - JWORK = ITAU + N -C - IF ( LROCOC ) THEN -C -C Initialization for T(s) given as columns over common -C denominators. -C - CALL AB07MD( JOBD, N, M, P, A, LDA, B, LDB, C, LDC, D, LDD, - $ INFO ) - END IF -C -C Initialize polynomial matrix U(s) to zero. -C - DO 10 K = 1, N + 1 - CALL DLASET( 'Full', PWORK, MWORK, ZERO, ZERO, UCOEFF(1,1,K), - $ LDUCO1 ) - 10 CONTINUE -C -C Calculate T(s) by applying the Orthogonal Structure Theorem to -C each of the PWORK MISO subsystems (A,B,C:I,D:I) in turn. -C - CALL TB04AY( N, MWORK, PWORK, A, LDA, B, LDB, C, LDC, D, LDD, - $ NR, INDEX, DCOEFF, LDDCOE, UCOEFF, LDUCO1, LDUCO2, - $ DWORK(IA), N1, DWORK(ITAU), TOL1, TOL2, IWORK, - $ DWORK(JWORK), LDWORK-JWORK+1, INFO ) - DWORK(1) = DWORK(JWORK) + DBLE( JWORK-1 ) -C - IF ( LROCOC ) THEN -C -C For T(s) factorized by columns, return to original (dual of -C dual) system, and reorder the rows and columns to get an upper -C block Hessenberg state dynamics matrix. -C - CALL TB01XD( JOBD, N, MWORK, PWORK, IWORK(1)+IWORK(2)-1, N-1, - $ A, LDA, B, LDB, C, LDC, D, LDD, INFO ) -C - IF ( MPLIM.NE.1 ) THEN -C -C Also, transpose U(s) (not 1-by-1). -C - KDCOEF = 0 -C - DO 20 I = 1, PWORK - KDCOEF = MAX( KDCOEF, INDEX(I) ) - 20 CONTINUE -C - KDCOEF = KDCOEF + 1 -C - DO 50 K = 1, KDCOEF -C - DO 40 J = 1, MPLIM - 1 - CALL DSWAP( MPLIM-J, UCOEFF(J+1,J,K), 1, - $ UCOEFF(J,J+1,K), LDUCO1 ) - 40 CONTINUE -C - 50 CONTINUE -C - END IF - END IF -C - RETURN -C *** Last line of TB04AD *** - END diff --git a/mex/sources/libslicot/TB04AY.f b/mex/sources/libslicot/TB04AY.f deleted file mode 100644 index afce62c3b..000000000 --- a/mex/sources/libslicot/TB04AY.f +++ /dev/null @@ -1,246 +0,0 @@ - SUBROUTINE TB04AY( N, MWORK, PWORK, A, LDA, B, LDB, C, LDC, D, - $ LDD, NCONT, INDEXD, DCOEFF, LDDCOE, UCOEFF, - $ LDUCO1, LDUCO2, AT, N1, TAU, TOL1, TOL2, IWORK, - $ DWORK, LDWORK, INFO ) -C -C SLICOT RELEASE 5.0. -C -C Copyright (c) 2002-2009 NICONET e.V. -C -C This program is free software: you can redistribute it and/or -C modify it under the terms of the GNU General Public License as -C published by the Free Software Foundation, either version 2 of -C the License, or (at your option) any later version. -C -C This program is distributed in the hope that it will be useful, -C but WITHOUT ANY WARRANTY; without even the implied warranty of -C MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the -C GNU General Public License for more details. -C -C You should have received a copy of the GNU General Public License -C along with this program. If not, see -C . -C -C Calculates the (PWORK x MWORK) transfer matrix T(s), in the form -C of polynomial row vectors over monic least common denominator -C polynomials, of a given state-space representation (ssr). Each -C such row of T(s) is simply a single-output relatively left prime -C polynomial matrix representation (pmr), so can be calculated by -C applying a simplified version of the Orthogonal Structure -C Theorem to a minimal ssr for the corresponding row of the given -C system: such an ssr is obtained by using the Orthogonal Canon- -C ical Form to first separate out a completely controllable one -C for the overall system and then, for each row in turn, applying -C it again to the resulting dual SIMO system. The Orthogonal -C Structure Theorem produces non-monic denominator and V:I(s) -C polynomials: this is avoided here by first scaling AT (the -C transpose of the controllable part of A, found in this routine) -C by suitable products of its sub-diagonal elements (these are then -C no longer needed, so freeing the entire lower triangle for -C storing the coefficients of V(s) apart from the leading 1's, -C which are treated implicitly). These polynomials are calculated -C in reverse order (IW = NMINL - 1,...,1), the monic denominator -C D:I(s) found exactly as if it were V:0(s), and finally the -C numerator vector U:I(s) obtained from the Orthogonal Structure -C Theorem relation. -C -C ****************************************************************** -C - DOUBLE PRECISION ONE - PARAMETER ( ONE = 1.0D0 ) -C .. Scalar Arguments .. - INTEGER INFO, LDA, LDB, LDC, LDD, LDDCOE, LDUCO1, - $ LDUCO2, LDWORK, MWORK, N, N1, NCONT, PWORK - DOUBLE PRECISION TOL1, TOL2 -C .. Array Arguments .. - INTEGER INDEXD(*), IWORK(*) - DOUBLE PRECISION A(LDA,*), AT(N1,*), B(LDB,*), C(LDC,*), - $ D(LDD,*), DCOEFF(LDDCOE,*), DWORK(*), - $ UCOEFF(LDUCO1,LDUCO2,*), TAU(*) -C .. Local Scalars .. - INTEGER I, IB, IBI, IC, INDCON, IS, IV, IVMIN1, IWPLUS, - $ IZ, J, JWORK, K, L, LWORK, MAXM, NMINL, NPLUS, - $ WRKOPT - DOUBLE PRECISION TEMP -C .. External Functions .. - DOUBLE PRECISION DDOT - EXTERNAL DDOT -C .. External Subroutines .. - EXTERNAL DAXPY, DCOPY, DSCAL, TB01UD, TB01ZD -C .. Intrinsic Functions .. - INTRINSIC INT, MAX -C .. Executable Statements .. -C -C Separate out controllable subsystem (of order NCONT). -C -C Workspace: MAX(N, 3*MWORK, PWORK). -C - CALL TB01UD( 'No Z', N, MWORK, PWORK, A, LDA, B, LDB, C, LDC, - $ NCONT, INDCON, IWORK, AT, 1, TAU, TOL2, IWORK(N+1), - $ DWORK, LDWORK, INFO ) - WRKOPT = INT( DWORK(1) ) -C - IS = 1 - IC = IS + NCONT - IZ = IC - IB = IC + NCONT - LWORK = IB + MWORK*NCONT - MAXM = MAX( 1, MWORK ) -C -C Calculate each row of T(s) in turn. -C - DO 140 I = 1, PWORK -C -C Form the dual of I-th NCONT-order MISO subsystem ... -C - CALL DCOPY( NCONT, C(I,1), LDC, DWORK(IC), 1 ) -C - DO 10 J = 1, NCONT - CALL DCOPY( NCONT, A(J,1), LDA, AT(1,J), 1 ) - CALL DCOPY( MWORK, B(J,1), LDB, DWORK((J-1)*MAXM+IB), 1 ) - 10 CONTINUE -C -C and separate out its controllable part, giving minimal -C state-space realization for row I. -C -C Workspace: MWORK*NCONT + 2*NCONT + MAX(NCONT,MWORK). -C - CALL TB01ZD( 'No Z', NCONT, MWORK, AT, N1, DWORK(IC), - $ DWORK(IB), MAXM, NMINL, DWORK(IZ), 1, TAU, TOL1, - $ DWORK(LWORK), LDWORK-LWORK+1, INFO ) - WRKOPT = MAX( WRKOPT, INT( DWORK(LWORK) )+LWORK-1 ) -C -C Store degree of (monic) denominator, and leading coefficient -C vector of numerator. -C - INDEXD(I) = NMINL - DCOEFF(I,1) = ONE - CALL DCOPY( MWORK, D(I,1), LDD, UCOEFF(I,1,1), LDUCO1 ) -C - IF ( NMINL.EQ.1 ) THEN -C -C Finish off numerator, denominator for simple case NMINL=1. -C - TEMP = -AT(1,1) - DCOEFF(I,2) = TEMP - CALL DCOPY( MWORK, D(I,1), LDD, UCOEFF(I,1,2), LDUCO1 ) - CALL DSCAL( MWORK, TEMP, UCOEFF(I,1,2), LDUCO1 ) - CALL DAXPY( MWORK, DWORK(IC), DWORK(IB), 1, UCOEFF(I,1,2), - $ LDUCO1 ) - ELSE IF ( NMINL.GT.1 ) THEN -C -C Set up factors for scaling upper triangle of AT ... -C - CALL DCOPY( NMINL-1, AT(2,1), N1+1, DWORK(IC+1), 1 ) - NPLUS = NMINL + 1 -C - DO 20 L = IS, IS + NMINL - 1 - DWORK(L) = ONE - 20 CONTINUE -C -C and scale it, row by row, starting with row NMINL. -C - DO 40 JWORK = NMINL, 1, -1 -C - DO 30 J = JWORK, NMINL - AT(JWORK,J) = DWORK(IS+J-1)*AT(JWORK,J) - 30 CONTINUE -C -C Update scale factors for next row. -C - CALL DSCAL( NMINL-JWORK+1, DWORK(IC+JWORK-1), - $ DWORK(IS+JWORK-1), 1 ) - 40 CONTINUE -C -C Calculate each monic polynomial V:JWORK(s) in turn: -C K-th coefficient stored as AT(IV,K-1). -C - DO 70 IV = 2, NMINL - JWORK = NPLUS - IV - IWPLUS = JWORK + 1 - IVMIN1 = IV - 1 -C -C Set up coefficients due to leading 1's of existing -C V:I(s)'s. -C - DO 50 K = 1, IVMIN1 - AT(IV,K) = -AT(IWPLUS,JWORK+K) - 50 CONTINUE -C - IF ( IV.NE.2 ) THEN -C -C Then add contribution from s * V:JWORK+1(s) term. -C - CALL DAXPY( IV-2, ONE, AT(IVMIN1,1), N1, AT(IV,1), - $ N1 ) -C -C Finally, add effect of lower coefficients of existing -C V:I(s)'s. -C - DO 60 K = 2, IVMIN1 - AT(IV,K) = AT(IV,K) - DDOT( K-1, - $ AT(IWPLUS,JWORK+1), N1, - $ AT(IV-K+1,1), -(N1+1) ) - 60 CONTINUE -C - END IF - 70 CONTINUE -C -C Determine denominator polynomial D(s) as if it were V:0(s). -C - DO 80 K = 2, NPLUS - DCOEFF(I,K) = -AT(1,K-1) - 80 CONTINUE -C - CALL DAXPY( NMINL-1, ONE, AT(NMINL,1), N1, DCOEFF(I,2), - $ LDDCOE ) -C - DO 90 K = 3, NPLUS - DCOEFF(I,K) = DCOEFF(I,K) - DDOT( K-2, AT, N1, - $ AT(NMINL-K+3,1), -(N1+1) ) - 90 CONTINUE -C -C Scale (B' * Z), stored in DWORK(IB). -C - IBI = IB -C - DO 100 L = 1, NMINL - CALL DSCAL( MWORK, DWORK(IS+L-1), DWORK(IBI), 1 ) - IBI = IBI + MAXM - 100 CONTINUE -C -C Evaluate numerator polynomial vector (V(s) * B) + (D(s) -C * D:I): first set up coefficients due to D:I and leading -C 1's of V(s). -C - IBI = IB -C - DO 110 K = 2, NPLUS - CALL DCOPY( MWORK, DWORK(IBI), 1, UCOEFF(I,1,K), LDUCO1 ) - CALL DAXPY( MWORK, DCOEFF(I,K), D(I,1), LDD, - $ UCOEFF(I,1,K), LDUCO1 ) - IBI = IBI + MAXM - 110 CONTINUE -C -C Add contribution from lower coefficients of V(s). -C - DO 130 K = 3, NPLUS -C - DO 120 J = 1, MWORK - UCOEFF(I,J,K) = UCOEFF(I,J,K) + DDOT( K-2, - $ AT(NMINL-K+3,1), -(N1+1), - $ DWORK(IB+J-1), MAXM ) - 120 CONTINUE -C - 130 CONTINUE -C - END IF - 140 CONTINUE -C -C Set optimal workspace dimension. -C - DWORK(1) = WRKOPT -C - RETURN -C *** Last line of TB04AY *** - END diff --git a/mex/sources/libslicot/TB04BD.f b/mex/sources/libslicot/TB04BD.f deleted file mode 100644 index 0d8d5d0c0..000000000 --- a/mex/sources/libslicot/TB04BD.f +++ /dev/null @@ -1,600 +0,0 @@ - SUBROUTINE TB04BD( JOBD, ORDER, EQUIL, N, M, P, MD, A, LDA, B, - $ LDB, C, LDC, D, LDD, IGN, LDIGN, IGD, LDIGD, - $ GN, GD, TOL, IWORK, DWORK, LDWORK, INFO ) -C -C SLICOT RELEASE 5.0. -C -C Copyright (c) 2002-2009 NICONET e.V. -C -C This program is free software: you can redistribute it and/or -C modify it under the terms of the GNU General Public License as -C published by the Free Software Foundation, either version 2 of -C the License, or (at your option) any later version. -C -C This program is distributed in the hope that it will be useful, -C but WITHOUT ANY WARRANTY; without even the implied warranty of -C MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the -C GNU General Public License for more details. -C -C You should have received a copy of the GNU General Public License -C along with this program. If not, see -C . -C -C PURPOSE -C -C To compute the transfer function matrix G of a state-space -C representation (A,B,C,D) of a linear time-invariant multivariable -C system, using the pole-zeros method. Each element of the transfer -C function matrix is returned in a cancelled, minimal form, with -C numerator and denominator polynomials stored either in increasing -C or decreasing order of the powers of the indeterminate. -C -C ARGUMENTS -C -C Mode Parameters -C -C JOBD CHARACTER*1 -C Specifies whether or not a non-zero matrix D appears in -C the given state-space model: -C = 'D': D is present; -C = 'Z': D is assumed to be a zero matrix. -C -C ORDER CHARACTER*1 -C Specifies the order in which the polynomial coefficients -C are stored, as follows: -C = 'I': Increasing order of powers of the indeterminate; -C = 'D': Decreasing order of powers of the indeterminate. -C -C EQUIL CHARACTER*1 -C Specifies whether the user wishes to preliminarily -C equilibrate the triplet (A,B,C) as follows: -C = 'S': perform equilibration (scaling); -C = 'N': do not perform equilibration. -C -C Input/Output Parameters -C -C N (input) INTEGER -C The order of the system (A,B,C,D). N >= 0. -C -C M (input) INTEGER -C The number of the system inputs. M >= 0. -C -C P (input) INTEGER -C The number of the system outputs. P >= 0. -C -C MD (input) INTEGER -C The maximum degree of the polynomials in G, plus 1. An -C upper bound for MD is N+1. MD >= 1. -C -C A (input/output) DOUBLE PRECISION array, dimension (LDA,N) -C On entry, the leading N-by-N part of this array must -C contain the original state dynamics matrix A. -C On exit, if EQUIL = 'S', the leading N-by-N part of this -C array contains the balanced matrix inv(S)*A*S, as returned -C by SLICOT Library routine TB01ID. -C If EQUIL = 'N', this array is unchanged on exit. -C -C LDA INTEGER -C The leading dimension of array A. LDA >= MAX(1,N). -C -C B (input/output) DOUBLE PRECISION array, dimension (LDB,M) -C On entry, the leading N-by-M part of this array must -C contain the input matrix B. -C On exit, the contents of B are destroyed: all elements but -C those in the first row are set to zero. -C -C LDB INTEGER -C The leading dimension of array B. LDB >= MAX(1,N). -C -C C (input/output) DOUBLE PRECISION array, dimension (LDC,N) -C On entry, the leading P-by-N part of this array must -C contain the output matrix C. -C On exit, if EQUIL = 'S', the leading P-by-N part of this -C array contains the balanced matrix C*S, as returned by -C SLICOT Library routine TB01ID. -C If EQUIL = 'N', this array is unchanged on exit. -C -C LDC INTEGER -C The leading dimension of array C. LDC >= MAX(1,P). -C -C D (input) DOUBLE PRECISION array, dimension (LDD,M) -C If JOBD = 'D', the leading P-by-M part of this array must -C contain the matrix D. -C If JOBD = 'Z', the array D is not referenced. -C -C LDD INTEGER -C The leading dimension of array D. -C LDD >= MAX(1,P), if JOBD = 'D'; -C LDD >= 1, if JOBD = 'Z'. -C -C IGN (output) INTEGER array, dimension (LDIGN,M) -C The leading P-by-M part of this array contains the degrees -C of the numerator polynomials in the transfer function -C matrix G. Specifically, the (i,j) element of IGN contains -C the degree of the numerator polynomial of the transfer -C function G(i,j) from the j-th input to the i-th output. -C -C LDIGN INTEGER -C The leading dimension of array IGN. LDIGN >= max(1,P). -C -C IGD (output) INTEGER array, dimension (LDIGD,M) -C The leading P-by-M part of this array contains the degrees -C of the denominator polynomials in the transfer function -C matrix G. Specifically, the (i,j) element of IGD contains -C the degree of the denominator polynomial of the transfer -C function G(i,j). -C -C LDIGD INTEGER -C The leading dimension of array IGD. LDIGD >= max(1,P). -C -C GN (output) DOUBLE PRECISION array, dimension (P*M*MD) -C This array contains the coefficients of the numerator -C polynomials, Num(i,j), of the transfer function matrix G. -C The polynomials are stored in a column-wise order, i.e., -C Num(1,1), Num(2,1), ..., Num(P,1), Num(1,2), Num(2,2), -C ..., Num(P,2), ..., Num(1,M), Num(2,M), ..., Num(P,M); -C MD memory locations are reserved for each polynomial, -C hence, the (i,j) polynomial is stored starting from the -C location ((j-1)*P+i-1)*MD+1. The coefficients appear in -C increasing or decreasing order of the powers of the -C indeterminate, according to ORDER. -C -C GD (output) DOUBLE PRECISION array, dimension (P*M*MD) -C This array contains the coefficients of the denominator -C polynomials, Den(i,j), of the transfer function matrix G. -C The polynomials are stored in the same way as the -C numerator polynomials. -C -C Tolerances -C -C TOL DOUBLE PRECISION -C The tolerance to be used in determining the -C controllability of a single-input system (A,b) or (A',c'), -C where b and c' are columns in B and C' (C transposed). If -C the user sets TOL > 0, then the given value of TOL is used -C as an absolute tolerance; elements with absolute value -C less than TOL are considered neglijible. If the user sets -C TOL <= 0, then an implicitly computed, default tolerance, -C defined by TOLDEF = N*EPS*MAX( NORM(A), NORM(bc) ) is used -C instead, where EPS is the machine precision (see LAPACK -C Library routine DLAMCH), and bc denotes the currently used -C column in B or C' (see METHOD). -C -C Workspace -C -C IWORK INTEGER array, dimension (N) -C -C DWORK DOUBLE PRECISION array, dimension (LDWORK) -C On exit, if INFO = 0, DWORK(1) returns the optimal value -C of LDWORK. -C -C LDWORK INTEGER -C The length of the array DWORK. -C LDWORK >= MAX(1, N*(N+P) + -C MAX( N + MAX( N,P ), N*(2*N+5))) -C If N >= P, N >= 1, the formula above can be written as -C LDWORK >= N*(3*N + P + 5). -C For optimum performance LDWORK should be larger. -C -C Error Indicator -C -C INFO INTEGER -C = 0: successful exit; -C < 0: if INFO = -i, the i-th argument had an illegal -C value; -C = 1: the QR algorithm failed to converge when trying to -C compute the zeros of a transfer function; -C = 2: the QR algorithm failed to converge when trying to -C compute the poles of a transfer function. -C The errors INFO = 1 or 2 are unlikely to appear. -C -C METHOD -C -C The routine implements the pole-zero method proposed in [1]. -C This method is based on an algorithm for computing the transfer -C function of a single-input single-output (SISO) system. -C Let (A,b,c,d) be a SISO system. Its transfer function is computed -C as follows: -C -C 1) Find a controllable realization (Ac,bc,cc) of (A,b,c). -C 2) Find an observable realization (Ao,bo,co) of (Ac,bc,cc). -C 3) Compute the r eigenvalues of Ao (the poles of (Ao,bo,co)). -C 4) Compute the zeros of (Ao,bo,co,d). -C 5) Compute the gain of (Ao,bo,co,d). -C -C This algorithm can be implemented using only orthogonal -C transformations [1]. However, for better efficiency, the -C implementation in TB04BD uses one elementary transformation -C in Step 4 and r elementary transformations in Step 5 (to reduce -C an upper Hessenberg matrix to upper triangular form). These -C special elementary transformations are numerically stable -C in practice. -C -C In the multi-input multi-output (MIMO) case, the algorithm -C computes each element (i,j) of the transfer function matrix G, -C for i = 1 : P, and for j = 1 : M. For efficiency reasons, Step 1 -C is performed once for each value of j (each column of B). The -C matrices Ac and Ao result in Hessenberg form. -C -C REFERENCES -C -C [1] Varga, A. and Sima, V. -C Numerically Stable Algorithm for Transfer Function Matrix -C Evaluation. -C Int. J. Control, vol. 33, nr. 6, pp. 1123-1133, 1981. -C -C NUMERICAL ASPECTS -C -C The algorithm is numerically stable in practice and requires about -C 20*N**3 floating point operations at most, but usually much less. -C -C FURTHER COMMENTS -C -C For maximum efficiency of index calculations, GN and GD are -C implemented as one-dimensional arrays. -C -C CONTRIBUTORS -C -C V. Sima, Research Institute for Informatics, Bucharest, May 2002. -C Partly based on the BIMASC Library routine TSMT1 by A. Varga. -C -C REVISIONS -C -C - -C -C KEYWORDS -C -C Eigenvalue, state-space representation, transfer function, zeros. -C -C ****************************************************************** -C -C .. Parameters .. - DOUBLE PRECISION ZERO, ONE, C100 - PARAMETER ( ZERO = 0.0D0, ONE = 1.0D0, C100 = 100.0D0 ) -C .. Scalar Arguments .. - CHARACTER EQUIL, JOBD, ORDER - DOUBLE PRECISION TOL - INTEGER INFO, LDA, LDB, LDC, LDD, LDIGD, LDIGN, LDWORK, - $ M, MD, N, P -C .. Array Arguments .. - DOUBLE PRECISION A(LDA,*), B(LDB,*), C(LDC,*), D(LDD,*), - $ DWORK(*), GD(*), GN(*) - INTEGER IGD(LDIGD,*), IGN(LDIGN,*), IWORK(*) -C .. Local Scalars .. - DOUBLE PRECISION ANORM, DIJ, EPSN, MAXRED, TOLDEF, X - INTEGER I, IA, IAC, IAS, IB, IC, ICC, IERR, IIP, IM, - $ IP, IPM1, IRP, ITAU, ITAU1, IZ, J, JJ, JWORK, - $ JWORK1, K, L, NCONT, WRKOPT - LOGICAL ASCEND, DIJNZ, FNDEIG, WITHD -C .. Local Arrays .. - DOUBLE PRECISION Z(1) -C .. External Functions .. - LOGICAL LSAME - DOUBLE PRECISION DLAMCH, DLANGE - EXTERNAL DLAMCH, DLANGE, LSAME -C .. External Subroutines .. - EXTERNAL DAXPY, DCOPY, DHSEQR, DLACPY, MA02AD, MC01PD, - $ MC01PY, TB01ID, TB01ZD, TB04BX, XERBLA -C .. Intrinsic Functions .. - INTRINSIC ABS, DBLE, INT, MAX, MIN -C .. -C .. Executable Statements .. -C -C Test the input scalar parameters. -C - INFO = 0 - WITHD = LSAME( JOBD, 'D' ) - ASCEND = LSAME( ORDER, 'I' ) - IF( .NOT.WITHD .AND. .NOT.LSAME( JOBD, 'Z' ) ) THEN - INFO = -1 - ELSE IF( .NOT.ASCEND .AND. .NOT.LSAME( ORDER, 'D' ) ) THEN - INFO = -2 - ELSE IF( .NOT. ( LSAME( EQUIL, 'S' ) .OR. - $ LSAME( EQUIL, 'N' ) ) ) THEN - INFO = -3 - ELSE IF( N.LT.0 ) THEN - INFO = -4 - ELSE IF( M.LT.0 ) THEN - INFO = -5 - ELSE IF( P.LT.0 ) THEN - INFO = -6 - ELSE IF( MD.LT.1 ) THEN - INFO = -7 - ELSE IF( LDA.LT.MAX( 1, N ) ) THEN - INFO = -9 - ELSE IF( LDB.LT.MAX( 1, N ) ) THEN - INFO = -11 - ELSE IF( LDC.LT.MAX( 1, P ) ) THEN - INFO = -13 - ELSE IF( LDD.LT.1 .OR. ( WITHD .AND. LDD.LT.P ) ) THEN - INFO = -15 - ELSE IF( LDIGN.LT.MAX( 1, P ) ) THEN - INFO = -17 - ELSE IF( LDIGD.LT.MAX( 1, P ) ) THEN - INFO = -19 - ELSE IF( LDWORK.LT.MAX( 1, N*( N + P ) + - $ MAX( N + MAX( N, P ), N*( 2*N + 5 ) ) ) - $ ) THEN - INFO = -25 - END IF -C - IF ( INFO.NE.0 ) THEN -C -C Error return. -C - CALL XERBLA( 'TB04BD', -INFO ) - RETURN - END IF -C -C Initialize GN and GD to zero. -C - Z(1) = ZERO - CALL DCOPY( P*M*MD, Z, 0, GN, 1 ) - CALL DCOPY( P*M*MD, Z, 0, GD, 1 ) -C -C Quick return if possible. -C - IF( MIN( N, P, M ).EQ.0 ) THEN - IF( MIN( P, M ).GT.0 ) THEN - K = 1 -C - DO 20 J = 1, M -C - DO 10 I = 1, P - IGN(I,J) = 0 - IGD(I,J) = 0 - IF ( WITHD ) - $ GN(K) = D(I,J) - GD(K) = ONE - K = K + MD - 10 CONTINUE -C - 20 CONTINUE -C - END IF - DWORK(1) = ONE - RETURN - END IF -C -C Prepare the computation of the default tolerance. -C - TOLDEF = TOL - IF( TOLDEF.LE.ZERO ) THEN - EPSN = DBLE( N )*DLAMCH( 'Epsilon' ) - ANORM = DLANGE( 'Frobenius', N, N, A, LDA, DWORK ) - END IF -C -C Initializations. -C - IA = 1 - IC = IA + N*N - ITAU = IC + P*N - JWORK = ITAU + N - IAC = ITAU -C - K = 1 - DIJ = ZERO -C -C (Note: Comments in the code beginning "Workspace:" describe the -C minimal amount of real workspace needed at that point in the -C code, as well as the preferred amount for good performance.) -C - IF( LSAME( EQUIL, 'S' ) ) THEN -C -C Scale simultaneously the matrices A, B and C: -C A <- inv(S)*A*S, B <- inv(S)*B and C <- C*S, where S is a -C diagonal scaling matrix. -C Workspace: need N. -C - MAXRED = C100 - CALL TB01ID( 'All', N, M, P, MAXRED, A, LDA, B, LDB, C, LDC, - $ DWORK, IERR ) - END IF -C -C Compute the transfer function matrix of the system (A,B,C,D). -C - DO 80 J = 1, M -C -C Save A and C. -C Workspace: need W1 = N*(N+P). -C - CALL DLACPY( 'Full', N, N, A, LDA, DWORK(IA), N ) - CALL DLACPY( 'Full', P, N, C, LDC, DWORK(IC), P ) -C -C Remove the uncontrollable part of the system (A,B(J),C). -C Workspace: need W1+N+MAX(N,P); -C prefer larger. -C - CALL TB01ZD( 'No Z', N, P, DWORK(IA), N, B(1,J), DWORK(IC), P, - $ NCONT, Z, 1, DWORK(ITAU), TOL, DWORK(JWORK), - $ LDWORK-JWORK+1, IERR ) - IF ( J.EQ.1 ) - $ WRKOPT = INT( DWORK(JWORK) ) + JWORK - 1 -C - IB = IAC + NCONT*NCONT - ICC = IB + NCONT - ITAU1 = ICC + NCONT - IRP = ITAU1 - IIP = IRP + NCONT - IAS = IIP + NCONT - JWORK1 = IAS + NCONT*NCONT -C - DO 70 I = 1, P - IF ( WITHD ) - $ DIJ = D(I,J) - IF ( NCONT.GT.0 ) THEN -C -C Form the matrices of the state-space representation of -C the dual system for the controllable part. -C Workspace: need W2 = W1+N*(N+2). -C - CALL MA02AD( 'Full', NCONT, NCONT, DWORK(IA), N, - $ DWORK(IAC), NCONT ) - CALL DCOPY( NCONT, B(1,J), 1, DWORK(IB), 1 ) - CALL DCOPY( NCONT, DWORK(IC+I-1), P, DWORK(ICC), 1 ) -C -C Remove the unobservable part of the system (A,B(J),C(I)). -C Workspace: need W2+2*N; -C prefer larger. -C - CALL TB01ZD( 'No Z', NCONT, 1, DWORK(IAC), NCONT, - $ DWORK(ICC), DWORK(IB), 1, IP, Z, 1, - $ DWORK(ITAU1), TOL, DWORK(IIP), LDWORK-IIP+1, - $ IERR ) - IF ( I.EQ.1 ) - $ WRKOPT = MAX( WRKOPT, INT( DWORK(IIP) ) + IIP - 1 ) -C - IF ( IP.GT.0 ) THEN -C -C Save the state matrix of the minimal part. -C Workspace: need W3 = W2+N*(N+2). -C - CALL DLACPY( 'Full', IP, IP, DWORK(IAC), NCONT, - $ DWORK(IAS), IP ) -C -C Compute the poles of the transfer function. -C Workspace: need W3+N; -C prefer larger. -C - CALL DHSEQR( 'Eigenvalues', 'No vectors', IP, 1, IP, - $ DWORK(IAC), NCONT, DWORK(IRP), - $ DWORK(IIP), Z, 1, DWORK(JWORK1), - $ LDWORK-JWORK1+1, IERR ) - IF ( IERR.NE.0 ) THEN - INFO = 2 - RETURN - END IF - WRKOPT = MAX( WRKOPT, - $ INT( DWORK(JWORK1) ) + JWORK1 - 1 ) -C -C Compute the zeros of the transfer function. -C - IPM1 = IP - 1 - DIJNZ = WITHD .AND. DIJ.NE.ZERO - FNDEIG = DIJNZ .OR. IPM1.GT.0 - IF ( .NOT.FNDEIG ) THEN - IZ = 0 - ELSE IF ( DIJNZ ) THEN -C -C Add the contribution due to D(i,j). -C Note that the matrix whose eigenvalues have to -C be computed remains in an upper Hessenberg form. -C - IZ = IP - CALL DLACPY( 'Full', IZ, IZ, DWORK(IAS), IP, - $ DWORK(IAC), NCONT ) - CALL DAXPY( IZ, -DWORK(ICC)/DIJ, DWORK(IB), 1, - $ DWORK(IAC), NCONT ) - ELSE - IF( TOL.LE.ZERO ) - $ TOLDEF = EPSN*MAX( ANORM, - $ DLANGE( 'Frobenius', IP, 1, - $ DWORK(IB), 1, DWORK ) - $ ) -C - DO 30 IM = 1, IPM1 - IF ( ABS( DWORK(IB+IM-1) ).GT.TOLDEF ) GO TO 40 - 30 CONTINUE -C - IZ = 0 - GO TO 50 -C - 40 CONTINUE -C -C Restore (part of) the saved state matrix. -C - IZ = IP - IM - CALL DLACPY( 'Full', IZ, IZ, DWORK(IAS+IM*(IP+1)), - $ IP, DWORK(IAC), NCONT ) -C -C Apply the output injection. -C - CALL DAXPY( IZ, -DWORK(IAS+IM*(IP+1)-IP)/ - $ DWORK(IB+IM-1), DWORK(IB+IM), 1, - $ DWORK(IAC), NCONT ) - END IF -C - IF ( FNDEIG ) THEN -C -C Find the zeros. -C Workspace: need W3+N; -C prefer larger. -C - CALL DHSEQR( 'Eigenvalues', 'No vectors', IZ, 1, - $ IZ, DWORK(IAC), NCONT, GN(K), GD(K), - $ Z, 1, DWORK(JWORK1), LDWORK-JWORK1+1, - $ IERR ) - IF ( IERR.NE.0 ) THEN - INFO = 1 - RETURN - END IF - END IF -C -C Compute the gain. -C - 50 CONTINUE - IF ( DIJNZ ) THEN - X = DIJ - ELSE - CALL TB04BX( IP, IZ, DWORK(IAS), IP, DWORK(ICC), - $ DWORK(IB), DIJ, DWORK(IRP), - $ DWORK(IIP), GN(K), GD(K), X, IWORK ) - END IF -C -C Form the numerator coefficients in increasing or -C decreasing powers of the indeterminate. -C IAS is used here as pointer to the workspace. -C - IF ( ASCEND ) THEN - CALL MC01PD( IZ, GN(K), GD(K), DWORK(IB), - $ DWORK(IAS), IERR ) - ELSE - CALL MC01PY( IZ, GN(K), GD(K), DWORK(IB), - $ DWORK(IAS), IERR ) - END IF - JJ = K -C - DO 60 L = IB, IB + IZ - GN(JJ) = DWORK(L)*X - JJ = JJ + 1 - 60 CONTINUE -C -C Form the denominator coefficients. -C - IF ( ASCEND ) THEN - CALL MC01PD( IP, DWORK(IRP), DWORK(IIP), GD(K), - $ DWORK(IAS), IERR ) - ELSE - CALL MC01PY( IP, DWORK(IRP), DWORK(IIP), GD(K), - $ DWORK(IAS), IERR ) - END IF - IGN(I,J) = IZ - IGD(I,J) = IP - ELSE -C -C Null element. -C - IGN(I,J) = 0 - IGD(I,J) = 0 - GN(K) = DIJ - GD(K) = ONE - END IF -C - ELSE -C -C Null element. -C - IGN(I,J) = 0 - IGD(I,J) = 0 - GN(K) = DIJ - GD(K) = ONE - END IF -C - K = K + MD - 70 CONTINUE -C - 80 CONTINUE -C - RETURN -C *** Last line of TB04BD *** - END diff --git a/mex/sources/libslicot/TB04BV.f b/mex/sources/libslicot/TB04BV.f deleted file mode 100644 index 10b58b592..000000000 --- a/mex/sources/libslicot/TB04BV.f +++ /dev/null @@ -1,343 +0,0 @@ - SUBROUTINE TB04BV( ORDER, P, M, MD, IGN, LDIGN, IGD, LDIGD, GN, - $ GD, D, LDD, TOL, INFO ) -C -C SLICOT RELEASE 5.0. -C -C Copyright (c) 2002-2009 NICONET e.V. -C -C This program is free software: you can redistribute it and/or -C modify it under the terms of the GNU General Public License as -C published by the Free Software Foundation, either version 2 of -C the License, or (at your option) any later version. -C -C This program is distributed in the hope that it will be useful, -C but WITHOUT ANY WARRANTY; without even the implied warranty of -C MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the -C GNU General Public License for more details. -C -C You should have received a copy of the GNU General Public License -C along with this program. If not, see -C . -C -C PURPOSE -C -C To separate the strictly proper part G0 from the constant part D -C of an P-by-M proper transfer function matrix G. -C -C ARGUMENTS -C -C Mode Parameters -C -C ORDER CHARACTER*1 -C Specifies the order in which the polynomial coefficients -C of the transfer function matrix are stored, as follows: -C = 'I': Increasing order of powers of the indeterminate; -C = 'D': Decreasing order of powers of the indeterminate. -C -C Input/Output Parameters -C -C P (input) INTEGER -C The number of the system outputs. P >= 0. -C -C M (input) INTEGER -C The number of the system inputs. M >= 0. -C -C MD (input) INTEGER -C The maximum degree of the polynomials in G, plus 1, i.e., -C MD = MAX(IGD(I,J)) + 1. -C I,J -C -C IGN (input/output) INTEGER array, dimension (LDIGN,M) -C On entry, the leading P-by-M part of this array must -C contain the degrees of the numerator polynomials in G: -C the (i,j) element of IGN must contain the degree of the -C numerator polynomial of the polynomial ratio G(i,j). -C On exit, the leading P-by-M part of this array contains -C the degrees of the numerator polynomials in G0. -C -C LDIGN INTEGER -C The leading dimension of array IGN. LDIGN >= max(1,P). -C -C IGD (input) INTEGER array, dimension (LDIGD,M) -C The leading P-by-M part of this array must contain the -C degrees of the denominator polynomials in G (and G0): -C the (i,j) element of IGD contains the degree of the -C denominator polynomial of the polynomial ratio G(i,j). -C -C LDIGD INTEGER -C The leading dimension of array IGD. LDIGD >= max(1,P). -C -C GN (input/output) DOUBLE PRECISION array, dimension (P*M*MD) -C On entry, this array must contain the coefficients of the -C numerator polynomials, Num(i,j), of the transfer function -C matrix G. The polynomials are stored in a column-wise -C order, i.e., Num(1,1), Num(2,1), ..., Num(P,1), Num(1,2), -C Num(2,2), ..., Num(P,2), ..., Num(1,M), Num(2,M), ..., -C Num(P,M); MD memory locations are reserved for each -C polynomial, hence, the (i,j) polynomial is stored starting -C from the location ((j-1)*P+i-1)*MD+1. The coefficients -C appear in increasing or decreasing order of the powers -C of the indeterminate, according to ORDER. -C On exit, this array contains the coefficients of the -C numerator polynomials of the strictly proper part G0 of -C the transfer function matrix G, stored similarly. -C -C GD (input) DOUBLE PRECISION array, dimension (P*M*MD) -C This array must contain the coefficients of the -C denominator polynomials, Den(i,j), of the transfer -C function matrix G. The polynomials are stored as for the -C numerator polynomials. -C -C D (output) DOUBLE PRECISION array, dimension (LDD,M) -C The leading P-by-M part of this array contains the -C matrix D. -C -C LDD INTEGER -C The leading dimension of array D. LDD >= max(1,P). -C -C Tolerances -C -C TOL DOUBLE PRECISION -C The tolerance to be used in determining the degrees of -C the numerators Num0(i,j) of the strictly proper part of -C the transfer function matrix G. If the user sets TOL > 0, -C then the given value of TOL is used as an absolute -C tolerance; the leading coefficients with absolute value -C less than TOL are considered neglijible. If the user sets -C TOL <= 0, then an implicitly computed, default tolerance, -C defined by TOLDEF = IGN(i,j)*EPS*NORM( Num(i,j) ) is used -C instead, where EPS is the machine precision (see LAPACK -C Library routine DLAMCH), and NORM denotes the infinity -C norm (the maximum coefficient in absolute value). -C -C Error Indicator -C -C INFO INTEGER -C = 0: successful exit; -C < 0: if INFO = -i, the i-th argument had an illegal -C value; -C = 1: if the transfer function matrix is not proper; -C = 2: if a denominator polynomial is null. -C -C METHOD -C -C The (i,j) entry of the real matrix D is zero, if the degree of -C Num(i,j), IGN(i,j), is less than the degree of Den(i,j), IGD(i,j), -C and it is given by the ratio of the leading coefficients of -C Num(i,j) and Den(i,j), if IGN(i,j) is equal to IGD(i,j), -C for i = 1 : P, and for j = 1 : M. -C -C FURTHER COMMENTS -C -C For maximum efficiency of index calculations, GN and GD are -C implemented as one-dimensional arrays. -C -C CONTRIBUTORS -C -C V. Sima, Research Institute for Informatics, Bucharest, May 2002. -C Based on the BIMASC Library routine TMPRP by A. Varga. -C -C REVISIONS -C -C V. Sima, Research Institute for Informatics, Bucharest, Feb. 2004. -C -C KEYWORDS -C -C State-space representation, transfer function. -C -C ****************************************************************** -C -C .. Parameters .. - DOUBLE PRECISION ZERO - PARAMETER ( ZERO = 0.0D0 ) -C .. Scalar Arguments .. - CHARACTER ORDER - DOUBLE PRECISION TOL - INTEGER INFO, LDD, LDIGD, LDIGN, M, MD, P -C .. Array Arguments .. - DOUBLE PRECISION D(LDD,*), GD(*), GN(*) - INTEGER IGD(LDIGD,*), IGN(LDIGN,*) -C .. Local Scalars .. - LOGICAL ASCEND - INTEGER I, II, J, K, KK, KM, ND, NN - DOUBLE PRECISION DIJ, EPS, TOLDEF -C .. External Functions .. - LOGICAL LSAME - INTEGER IDAMAX - DOUBLE PRECISION DLAMCH - EXTERNAL DLAMCH, IDAMAX, LSAME -C .. External Subroutines .. - EXTERNAL DAXPY, XERBLA -C .. Intrinsic Functions .. - INTRINSIC ABS, DBLE, MAX, MIN -C .. -C .. Executable Statements .. -C -C Test the input scalar parameters. -C - INFO = 0 - ASCEND = LSAME( ORDER, 'I' ) - IF( .NOT.ASCEND .AND. .NOT.LSAME( ORDER, 'D' ) ) THEN - INFO = -1 - ELSE IF( P.LT.0 ) THEN - INFO = -2 - ELSE IF( M.LT.0 ) THEN - INFO = -3 - ELSE IF( MD.LT.1 ) THEN - INFO = -4 - ELSE IF( LDIGN.LT.MAX( 1, P ) ) THEN - INFO = -6 - ELSE IF( LDIGD.LT.MAX( 1, P ) ) THEN - INFO = -8 - ELSE IF( LDD.LT.MAX( 1, P ) ) THEN - INFO = -12 - END IF -C - IF ( INFO.NE.0 ) THEN -C -C Error return. -C - CALL XERBLA( 'TB04BV', -INFO ) - RETURN - END IF -C -C Quick return if possible. -C - IF( MIN( P, M ).EQ.0 ) - $ RETURN -C -C Prepare the computation of the default tolerance. -C - TOLDEF = TOL - IF( TOLDEF.LE.ZERO ) - $ EPS = DLAMCH( 'Epsilon' ) -C - K = 1 -C - IF ( ASCEND ) THEN -C -C Polynomial coefficients are stored in increasing order. -C - DO 40 J = 1, M -C - DO 30 I = 1, P - NN = IGN(I,J) - ND = IGD(I,J) - IF ( NN.GT.ND ) THEN -C -C Error return: the transfer function matrix is -C not proper. -C - INFO = 1 - RETURN - ELSE IF ( NN.LT.ND .OR. ( ND.EQ.0 .AND. GN(K).EQ.ZERO ) ) - $ THEN - D(I,J) = ZERO - ELSE -C -C Here NN = ND. -C - KK = K + NN -C - IF ( GD(KK).EQ.ZERO ) THEN -C -C Error return: the denominator is null. -C - INFO = 2 - RETURN - ENDIF -C - DIJ = GN(KK) / GD(KK) - D(I,J) = DIJ - GN(KK) = ZERO - IF ( NN.GT.0 ) THEN - CALL DAXPY( NN, -DIJ, GD(K), 1, GN(K), 1 ) - IF ( TOL.LE.ZERO ) - $ TOLDEF = DBLE( NN )*EPS* - $ ABS( GN(IDAMAX( NN, GN(K), 1 ) ) ) - KM = NN - DO 10 II = 1, KM - KK = KK - 1 - NN = NN - 1 - IF ( ABS( GN(KK) ).GT.TOLDEF ) - $ GO TO 20 - 10 CONTINUE -C - 20 CONTINUE -C - IGN(I,J) = NN - ENDIF - ENDIF - K = K + MD - 30 CONTINUE -C - 40 CONTINUE -C - ELSE -C -C Polynomial coefficients are stored in decreasing order. -C - DO 90 J = 1, M -C - DO 80 I = 1, P - NN = IGN(I,J) - ND = IGD(I,J) - IF ( NN.GT.ND ) THEN -C -C Error return: the transfer function matrix is -C not proper. -C - INFO = 1 - RETURN - ELSE IF ( NN.LT.ND .OR. ( ND.EQ.0 .AND. GN(K).EQ.ZERO ) ) - $ THEN - D(I,J) = ZERO - ELSE -C -C Here NN = ND. -C - KK = K -C - IF ( GD(KK).EQ.ZERO ) THEN -C -C Error return: the denominator is null. -C - INFO = 2 - RETURN - ENDIF -C - DIJ = GN(KK) / GD(KK) - D(I,J) = DIJ - GN(KK) = ZERO - IF ( NN.GT.0 ) THEN - CALL DAXPY( NN, -DIJ, GD(K+1), 1, GN(K+1), 1 ) - IF ( TOL.LE.ZERO ) - $ TOLDEF = DBLE( NN )*EPS* - $ ABS( GN(IDAMAX( NN, GN(K+1), 1 ) ) ) - KM = NN - DO 50 II = 1, KM - KK = KK + 1 - NN = NN - 1 - IF ( ABS( GN(KK) ).GT.TOLDEF ) - $ GO TO 60 - 50 CONTINUE -C - 60 CONTINUE -C - IGN(I,J) = NN - DO 70 II = 0, NN - GN(K+II) = GN(KK+II) - 70 CONTINUE -C - ENDIF - ENDIF - K = K + MD - 80 CONTINUE -C - 90 CONTINUE -C - ENDIF -C - RETURN -C *** Last line of TB04BV *** - END diff --git a/mex/sources/libslicot/TB04BW.f b/mex/sources/libslicot/TB04BW.f deleted file mode 100644 index 7fb2a3217..000000000 --- a/mex/sources/libslicot/TB04BW.f +++ /dev/null @@ -1,280 +0,0 @@ - SUBROUTINE TB04BW( ORDER, P, M, MD, IGN, LDIGN, IGD, LDIGD, GN, - $ GD, D, LDD, INFO ) -C -C SLICOT RELEASE 5.0. -C -C Copyright (c) 2002-2009 NICONET e.V. -C -C This program is free software: you can redistribute it and/or -C modify it under the terms of the GNU General Public License as -C published by the Free Software Foundation, either version 2 of -C the License, or (at your option) any later version. -C -C This program is distributed in the hope that it will be useful, -C but WITHOUT ANY WARRANTY; without even the implied warranty of -C MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the -C GNU General Public License for more details. -C -C You should have received a copy of the GNU General Public License -C along with this program. If not, see -C . -C -C PURPOSE -C -C To compute the sum of an P-by-M rational matrix G and a real -C P-by-M matrix D. -C -C ARGUMENTS -C -C Mode Parameters -C -C ORDER CHARACTER*1 -C Specifies the order in which the polynomial coefficients -C of the rational matrix are stored, as follows: -C = 'I': Increasing order of powers of the indeterminate; -C = 'D': Decreasing order of powers of the indeterminate. -C -C Input/Output Parameters -C -C P (input) INTEGER -C The number of the system outputs. P >= 0. -C -C M (input) INTEGER -C The number of the system inputs. M >= 0. -C -C MD (input) INTEGER -C The maximum degree of the polynomials in G, plus 1, i.e., -C MD = MAX(IGN(I,J),IGD(I,J)) + 1. -C I,J -C -C IGN (input/output) INTEGER array, dimension (LDIGN,M) -C On entry, the leading P-by-M part of this array must -C contain the degrees of the numerator polynomials in G: -C the (i,j) element of IGN must contain the degree of the -C numerator polynomial of the polynomial ratio G(i,j). -C On exit, the leading P-by-M part of this array contains -C the degrees of the numerator polynomials in G + D. -C -C LDIGN INTEGER -C The leading dimension of array IGN. LDIGN >= max(1,P). -C -C IGD (input) INTEGER array, dimension (LDIGD,M) -C The leading P-by-M part of this array must contain the -C degrees of the denominator polynomials in G (and G + D): -C the (i,j) element of IGD contains the degree of the -C denominator polynomial of the polynomial ratio G(i,j). -C -C LDIGD INTEGER -C The leading dimension of array IGD. LDIGD >= max(1,P). -C -C GN (input/output) DOUBLE PRECISION array, dimension (P*M*MD) -C On entry, this array must contain the coefficients of the -C numerator polynomials, Num(i,j), of the rational matrix G. -C The polynomials are stored in a column-wise order, i.e., -C Num(1,1), Num(2,1), ..., Num(P,1), Num(1,2), Num(2,2), -C ..., Num(P,2), ..., Num(1,M), Num(2,M), ..., Num(P,M); -C MD memory locations are reserved for each polynomial, -C hence, the (i,j) polynomial is stored starting from the -C location ((j-1)*P+i-1)*MD+1. The coefficients appear in -C increasing or decreasing order of the powers of the -C indeterminate, according to ORDER. -C On exit, this array contains the coefficients of the -C numerator polynomials of the rational matrix G + D, -C stored similarly. -C -C GD (input) DOUBLE PRECISION array, dimension (P*M*MD) -C This array must contain the coefficients of the -C denominator polynomials, Den(i,j), of the rational -C matrix G. The polynomials are stored as for the -C numerator polynomials. -C -C D (input) DOUBLE PRECISION array, dimension (LDD,M) -C The leading P-by-M part of this array must contain the -C matrix D. -C -C LDD INTEGER -C The leading dimension of array D. LDD >= max(1,P). -C -C Error Indicator -C -C INFO INTEGER -C = 0: successful exit; -C < 0: if INFO = -i, the i-th argument had an illegal -C value. -C -C METHOD -C -C The (i,j) entry of the real matrix D is added to the (i,j) entry -C of the matrix G, g(i,j), which is a ratio of two polynomials, -C for i = 1 : P, and for j = 1 : M. If g(i,j) = 0, it is assumed -C that its denominator is 1. -C -C NUMERICAL ASPECTS -C -C The algorithm is numerically stable. -C -C FURTHER COMMENTS -C -C Often, the rational matrix G is found from a state-space -C representation (A,B,C), and D corresponds to the direct -C feedthrough matrix of the system. The sum G + D gives the -C transfer function matrix of the system (A,B,C,D). -C For maximum efficiency of index calculations, GN and GD are -C implemented as one-dimensional arrays. -C -C CONTRIBUTORS -C -C V. Sima, Research Institute for Informatics, Bucharest, May 2002. -C Based on the BIMASC Library routine TMCADD by A. Varga. -C -C REVISIONS -C -C V. Sima, Research Institute for Informatics, Bucharest, Feb. 2004. -C -C KEYWORDS -C -C State-space representation, transfer function. -C -C ****************************************************************** -C -C .. Parameters .. - DOUBLE PRECISION ZERO - PARAMETER ( ZERO = 0.0D0 ) -C .. Scalar Arguments .. - CHARACTER ORDER - INTEGER INFO, LDD, LDIGD, LDIGN, M, MD, P -C .. Array Arguments .. - DOUBLE PRECISION D(LDD,*), GD(*), GN(*) - INTEGER IGD(LDIGD,*), IGN(LDIGN,*) -C .. Local Scalars .. - LOGICAL ASCEND - INTEGER I, II, J, K, KK, KM, ND, NN - DOUBLE PRECISION DIJ -C .. External Functions .. - LOGICAL LSAME - EXTERNAL LSAME -C .. External Subroutines .. - EXTERNAL DAXPY, XERBLA -C .. Intrinsic Functions .. - INTRINSIC MAX, MIN -C .. -C .. Executable Statements .. -C -C Test the input scalar parameters. -C - INFO = 0 - ASCEND = LSAME( ORDER, 'I' ) - IF( .NOT.ASCEND .AND. .NOT.LSAME( ORDER, 'D' ) ) THEN - INFO = -1 - ELSE IF( P.LT.0 ) THEN - INFO = -2 - ELSE IF( M.LT.0 ) THEN - INFO = -3 - ELSE IF( MD.LT.1 ) THEN - INFO = -4 - ELSE IF( LDIGN.LT.MAX( 1, P ) ) THEN - INFO = -6 - ELSE IF( LDIGD.LT.MAX( 1, P ) ) THEN - INFO = -8 - ELSE IF( LDD.LT.MAX( 1, P ) ) THEN - INFO = -12 - END IF -C - IF ( INFO.NE.0 ) THEN -C -C Error return. -C - CALL XERBLA( 'TB04BW', -INFO ) - RETURN - END IF -C -C Quick return if possible. -C - IF( MIN( P, M ).EQ.0 ) - $ RETURN -C - K = 1 -C - IF ( ASCEND ) THEN -C -C Polynomial coefficients are stored in increasing order. -C - DO 30 J = 1, M -C - DO 20 I = 1, P - DIJ = D(I,J) - IF ( DIJ.NE.ZERO ) THEN - NN = IGN(I,J) - ND = IGD(I,J) - IF ( NN.EQ.0 .AND. ND.EQ.0 ) THEN - IF ( GN(K).EQ.ZERO ) THEN - GN(K) = DIJ - ELSE - GN(K) = GN(K) + DIJ*GD(K) - ENDIF - ELSE - KM = MIN( NN, ND ) + 1 - CALL DAXPY( KM, DIJ, GD(K), 1, GN(K), 1 ) - IF ( NN.LT.ND ) THEN -C - DO 10 II = K + KM, K + ND - GN(II) = DIJ*GD(II) - 10 CONTINUE -C - IGN(I,J) = ND - ENDIF - ENDIF - ENDIF - K = K + MD - 20 CONTINUE -C - 30 CONTINUE -C - ELSE -C -C Polynomial coefficients are stored in decreasing order. -C - DO 60 J = 1, M -C - DO 50 I = 1, P - DIJ = D(I,J) - IF ( DIJ.NE.ZERO ) THEN - NN = IGN(I,J) - ND = IGD(I,J) - IF ( NN.EQ.0 .AND. ND.EQ.0 ) THEN - IF ( GN(K).EQ.ZERO ) THEN - GN(K) = DIJ - ELSE - GN(K) = GN(K) + DIJ*GD(K) - ENDIF - ELSE - KM = MIN( NN, ND ) + 1 - IF ( NN.LT.ND ) THEN - KK = K + ND - NN -C - DO 35 II = K + NN, K, -1 - GN(II+ND-NN) = GN(II) - 35 CONTINUE -C - DO 40 II = K, KK - 1 - GN(II) = DIJ*GD(II) - 40 CONTINUE -C - IGN(I,J) = ND - CALL DAXPY( KM, DIJ, GD(KK), 1, GN(KK), 1 ) - ELSE - KK = K + NN - ND - CALL DAXPY( KM, DIJ, GD(K), 1, GN(KK), 1 ) - ENDIF - ENDIF - ENDIF - K = K + MD - 50 CONTINUE -C - 60 CONTINUE -C - ENDIF -C - RETURN -C *** Last line of TB04BW *** - END diff --git a/mex/sources/libslicot/TB04BX.f b/mex/sources/libslicot/TB04BX.f deleted file mode 100644 index ff0e004f1..000000000 --- a/mex/sources/libslicot/TB04BX.f +++ /dev/null @@ -1,246 +0,0 @@ - SUBROUTINE TB04BX( IP, IZ, A, LDA, B, C, D, PR, PI, ZR, ZI, GAIN, - $ IWORK ) -C -C SLICOT RELEASE 5.0. -C -C Copyright (c) 2002-2009 NICONET e.V. -C -C This program is free software: you can redistribute it and/or -C modify it under the terms of the GNU General Public License as -C published by the Free Software Foundation, either version 2 of -C the License, or (at your option) any later version. -C -C This program is distributed in the hope that it will be useful, -C but WITHOUT ANY WARRANTY; without even the implied warranty of -C MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the -C GNU General Public License for more details. -C -C You should have received a copy of the GNU General Public License -C along with this program. If not, see -C . -C -C PURPOSE -C -C To compute the gain of a single-input single-output linear system, -C given its state-space representation (A,b,c,d), and its poles and -C zeros. The matrix A is assumed to be in an upper Hessenberg form. -C The gain is computed using the formula -C -C -1 IP IZ -C g = (c*( S0*I - A ) *b + d)*Prod( S0 - Pi )/Prod( S0 - Zi ) , -C i=1 i=1 (1) -C -C where Pi, i = 1 : IP, and Zj, j = 1 : IZ, are the poles and zeros, -C respectively, and S0 is a real scalar different from all poles and -C zeros. -C -C ARGUMENTS -C -C Input/Output Parameters -C -C IP (input) INTEGER -C The number of the system poles. IP >= 0. -C -C IZ (input) INTEGER -C The number of the system zeros. IZ >= 0. -C -C A (input/output) DOUBLE PRECISION array, dimension (LDA,IP) -C On entry, the leading IP-by-IP part of this array must -C contain the state dynamics matrix A in an upper Hessenberg -C form. The elements below the second diagonal are not -C referenced. -C On exit, the leading IP-by-IP upper Hessenberg part of -C this array contains the LU factorization of the matrix -C A - S0*I, as computed by SLICOT Library routine MB02SD. -C -C LDA INTEGER -C The leading dimension of array A. LDA >= max(1,IP). -C -C B (input/output) DOUBLE PRECISION array, dimension (IP) -C On entry, this array must contain the system input -C vector b. -C On exit, this array contains the solution of the linear -C system ( A - S0*I )x = b . -C -C C (input) DOUBLE PRECISION array, dimension (IP) -C This array must contain the system output vector c. -C -C D (input) DOUBLE PRECISION -C The variable must contain the system feedthrough scalar d. -C -C PR (input) DOUBLE PRECISION array, dimension (IP) -C This array must contain the real parts of the system -C poles. Pairs of complex conjugate poles must be stored in -C consecutive memory locations. -C -C PI (input) DOUBLE PRECISION array, dimension (IP) -C This array must contain the imaginary parts of the system -C poles. -C -C ZR (input) DOUBLE PRECISION array, dimension (IZ) -C This array must contain the real parts of the system -C zeros. Pairs of complex conjugate zeros must be stored in -C consecutive memory locations. -C -C ZI (input) DOUBLE PRECISION array, dimension (IZ) -C This array must contain the imaginary parts of the system -C zeros. -C -C GAIN (output) DOUBLE PRECISION -C The gain of the linear system (A,b,c,d), given by (1). -C -C Workspace -C -C IWORK INTEGER array, dimension (IP) -C On exit, it contains the pivot indices; for 1 <= i <= IP, -C row i of the matrix A - S0*I was interchanged with -C row IWORK(i). -C -C METHOD -C -C The routine implements the method presented in [1]. A suitable -C value of S0 is chosen based on the system poles and zeros. -C Then, the LU factorization of the upper Hessenberg, nonsingular -C matrix A - S0*I is computed and used to solve the linear system -C in (1). -C -C REFERENCES -C -C [1] Varga, A. and Sima, V. -C Numerically Stable Algorithm for Transfer Function Matrix -C Evaluation. -C Int. J. Control, vol. 33, nr. 6, pp. 1123-1133, 1981. -C -C NUMERICAL ASPECTS -C -C The algorithm is numerically stable in practice and requires -C O(IP*IP) floating point operations. -C -C CONTRIBUTORS -C -C V. Sima, Research Institute for Informatics, Bucharest, May 2002. -C Partly based on the BIMASC Library routine GAIN by A. Varga. -C -C REVISIONS -C -C - -C -C KEYWORDS -C -C Eigenvalue, state-space representation, transfer function, zeros. -C -C ****************************************************************** -C -C .. Parameters .. - DOUBLE PRECISION ZERO, ONE, TWO, P1, ONEP1 - PARAMETER ( ZERO = 0.0D0, ONE = 1.0D0, TWO = 2.0D0, - $ P1 = 0.1D0, ONEP1 = 1.1D0 ) -C .. Scalar Arguments .. - DOUBLE PRECISION D, GAIN - INTEGER IP, IZ, LDA -C .. Array Arguments .. - DOUBLE PRECISION A(LDA,*), B(*), C(*), PI(*), PR(*), ZI(*), - $ ZR(*) - INTEGER IWORK(*) -C .. Local Scalars .. - INTEGER I, INFO - DOUBLE PRECISION S0, S -C .. External Functions .. - DOUBLE PRECISION DDOT - EXTERNAL DDOT -C .. External Subroutines .. - EXTERNAL MB02RD, MB02SD -C .. Intrinsic Functions .. - INTRINSIC ABS, MAX -C .. -C .. Executable Statements .. -C -C For efficiency, the input scalar parameters are not checked. -C -C Quick return if possible. -C - IF( IP.EQ.0 ) THEN - GAIN = ZERO - RETURN - END IF -C -C Compute a suitable value for S0 . -C - S0 = ZERO -C - DO 10 I = 1, IP - S = ABS( PR(I) ) - IF ( PI(I).NE.ZERO ) - $ S = S + ABS( PI(I) ) - S0 = MAX( S0, S ) - 10 CONTINUE -C - DO 20 I = 1, IZ - S = ABS( ZR(I) ) - IF ( ZI(I).NE.ZERO ) - $ S = S + ABS( ZI(I) ) - S0 = MAX( S0, S ) - 20 CONTINUE -C - S0 = TWO*S0 + P1 - IF ( S0.LE.ONE ) - $ S0 = ONEP1 -C -C Form A - S0*I . -C - DO 30 I = 1, IP - A(I,I) = A(I,I) - S0 - 30 CONTINUE -C -C Compute the LU factorization of the matrix A - S0*I -C (guaranteed to be nonsingular). -C - CALL MB02SD( IP, A, LDA, IWORK, INFO ) -C -C Solve the linear system (A - S0*I)*x = b . -C - CALL MB02RD( 'No Transpose', IP, 1, A, LDA, IWORK, B, IP, INFO ) -C -1 -C Compute c*(S0*I - A) *b + d . -C - GAIN = D - DDOT( IP, C, 1, B, 1 ) -C -C Multiply by the products in terms of poles and zeros in (1). -C - I = 1 -C -C WHILE ( I <= IP ) DO -C - 40 IF ( I.LE.IP ) THEN - IF ( PI(I).EQ.ZERO ) THEN - GAIN = GAIN*( S0 - PR(I) ) - I = I + 1 - ELSE - GAIN = GAIN*( S0*( S0 - TWO*PR(I) ) + PR(I)**2 + PI(I)**2 ) - I = I + 2 - END IF - GO TO 40 - END IF -C -C END WHILE 40 -C - I = 1 -C -C WHILE ( I <= IZ ) DO -C - 50 IF ( I.LE.IZ ) THEN - IF ( ZI(I).EQ.ZERO ) THEN - GAIN = GAIN/( S0 - ZR(I) ) - I = I + 1 - ELSE - GAIN = GAIN/( S0*( S0 - TWO*ZR(I) ) + ZR(I)**2 + ZI(I)**2 ) - I = I + 2 - END IF - GO TO 50 - END IF -C -C END WHILE 50 -C - RETURN -C *** Last line of TB04BX *** - END diff --git a/mex/sources/libslicot/TB04CD.f b/mex/sources/libslicot/TB04CD.f deleted file mode 100644 index 012548bec..000000000 --- a/mex/sources/libslicot/TB04CD.f +++ /dev/null @@ -1,568 +0,0 @@ - SUBROUTINE TB04CD( JOBD, EQUIL, N, M, P, NPZ, A, LDA, B, LDB, C, - $ LDC, D, LDD, NZ, LDNZ, NP, LDNP, ZEROSR, - $ ZEROSI, POLESR, POLESI, GAINS, LDGAIN, TOL, - $ IWORK, DWORK, LDWORK, INFO ) -C -C SLICOT RELEASE 5.0. -C -C Copyright (c) 2002-2009 NICONET e.V. -C -C This program is free software: you can redistribute it and/or -C modify it under the terms of the GNU General Public License as -C published by the Free Software Foundation, either version 2 of -C the License, or (at your option) any later version. -C -C This program is distributed in the hope that it will be useful, -C but WITHOUT ANY WARRANTY; without even the implied warranty of -C MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the -C GNU General Public License for more details. -C -C You should have received a copy of the GNU General Public License -C along with this program. If not, see -C . -C -C PURPOSE -C -C To compute the transfer function matrix G of a state-space -C representation (A,B,C,D) of a linear time-invariant multivariable -C system, using the pole-zeros method. The transfer function matrix -C is returned in a minimal pole-zero-gain form. -C -C ARGUMENTS -C -C Mode Parameters -C -C JOBD CHARACTER*1 -C Specifies whether or not a non-zero matrix D appears in -C the given state-space model: -C = 'D': D is present; -C = 'Z': D is assumed to be a zero matrix. -C -C EQUIL CHARACTER*1 -C Specifies whether the user wishes to preliminarily -C equilibrate the triplet (A,B,C) as follows: -C = 'S': perform equilibration (scaling); -C = 'N': do not perform equilibration. -C -C Input/Output Parameters -C -C N (input) INTEGER -C The order of the system (A,B,C,D). N >= 0. -C -C M (input) INTEGER -C The number of the system inputs. M >= 0. -C -C P (input) INTEGER -C The number of the system outputs. P >= 0. -C -C NPZ (input) INTEGER -C The maximum number of poles or zeros of the single-input -C single-output channels in the system. An upper bound -C for NPZ is N. NPZ >= 0. -C -C A (input/output) DOUBLE PRECISION array, dimension (LDA,N) -C On entry, the leading N-by-N part of this array must -C contain the original state dynamics matrix A. -C On exit, if EQUIL = 'S', the leading N-by-N part of this -C array contains the balanced matrix inv(S)*A*S, as returned -C by SLICOT Library routine TB01ID. -C If EQUIL = 'N', this array is unchanged on exit. -C -C LDA INTEGER -C The leading dimension of array A. LDA >= MAX(1,N). -C -C B (input/output) DOUBLE PRECISION array, dimension (LDB,M) -C On entry, the leading N-by-M part of this array must -C contain the input matrix B. -C On exit, the contents of B are destroyed: all elements but -C those in the first row are set to zero. -C -C LDB INTEGER -C The leading dimension of array B. LDB >= MAX(1,N). -C -C C (input/output) DOUBLE PRECISION array, dimension (LDC,N) -C On entry, the leading P-by-N part of this array must -C contain the output matrix C. -C On exit, if EQUIL = 'S', the leading P-by-N part of this -C array contains the balanced matrix C*S, as returned by -C SLICOT Library routine TB01ID. -C If EQUIL = 'N', this array is unchanged on exit. -C -C LDC INTEGER -C The leading dimension of array C. LDC >= MAX(1,P). -C -C D (input) DOUBLE PRECISION array, dimension (LDD,M) -C If JOBD = 'D', the leading P-by-M part of this array must -C contain the matrix D. -C If JOBD = 'Z', the array D is not referenced. -C -C LDD INTEGER -C The leading dimension of array D. -C LDD >= MAX(1,P), if JOBD = 'D'; -C LDD >= 1, if JOBD = 'Z'. -C -C NZ (output) INTEGER array, dimension (LDNZ,M) -C The leading P-by-M part of this array contains the numbers -C of zeros of the elements of the transfer function -C matrix G. Specifically, the (i,j) element of NZ contains -C the number of zeros of the transfer function G(i,j) from -C the j-th input to the i-th output. -C -C LDNZ INTEGER -C The leading dimension of array NZ. LDNZ >= max(1,P). -C -C NP (output) INTEGER array, dimension (LDNP,M) -C The leading P-by-M part of this array contains the numbers -C of poles of the elements of the transfer function -C matrix G. Specifically, the (i,j) element of NP contains -C the number of poles of the transfer function G(i,j). -C -C LDNP INTEGER -C The leading dimension of array NP. LDNP >= max(1,P). -C -C ZEROSR (output) DOUBLE PRECISION array, dimension (P*M*NPZ) -C This array contains the real parts of the zeros of the -C transfer function matrix G. The real parts of the zeros -C are stored in a column-wise order, i.e., for the transfer -C functions (1,1), (2,1), ..., (P,1), (1,2), (2,2), ..., -C (P,2), ..., (1,M), (2,M), ..., (P,M); NPZ memory locations -C are reserved for each transfer function, hence, the real -C parts of the zeros for the (i,j) transfer function -C are stored starting from the location ((j-1)*P+i-1)*NPZ+1. -C Pairs of complex conjugate zeros are stored in consecutive -C memory locations. Note that only the first NZ(i,j) entries -C are initialized for the (i,j) transfer function. -C -C ZEROSI (output) DOUBLE PRECISION array, dimension (P*M*NPZ) -C This array contains the imaginary parts of the zeros of -C the transfer function matrix G, stored in a similar way -C as the real parts of the zeros. -C -C POLESR (output) DOUBLE PRECISION array, dimension (P*M*NPZ) -C This array contains the real parts of the poles of the -C transfer function matrix G, stored in the same way as -C the zeros. Note that only the first NP(i,j) entries are -C initialized for the (i,j) transfer function. -C -C POLESI (output) DOUBLE PRECISION array, dimension (P*M*NPZ) -C This array contains the imaginary parts of the poles of -C the transfer function matrix G, stored in the same way as -C the poles. -C -C GAINS (output) DOUBLE PRECISION array, dimension (LDGAIN,M) -C The leading P-by-M part of this array contains the gains -C of the transfer function matrix G. Specifically, -C GAINS(i,j) contains the gain of the transfer function -C G(i,j). -C -C LDGAIN INTEGER -C The leading dimension of array GAINS. LDGAIN >= max(1,P). -C -C Tolerances -C -C TOL DOUBLE PRECISION -C The tolerance to be used in determining the -C controllability of a single-input system (A,b) or (A',c'), -C where b and c' are columns in B and C' (C transposed). If -C the user sets TOL > 0, then the given value of TOL is used -C as an absolute tolerance; elements with absolute value -C less than TOL are considered neglijible. If the user sets -C TOL <= 0, then an implicitly computed, default tolerance, -C defined by TOLDEF = N*EPS*MAX( NORM(A), NORM(bc) ) is used -C instead, where EPS is the machine precision (see LAPACK -C Library routine DLAMCH), and bc denotes the currently used -C column in B or C' (see METHOD). -C -C Workspace -C -C IWORK INTEGER array, dimension (N) -C -C DWORK DOUBLE PRECISION array, dimension (LDWORK) -C On exit, if INFO = 0, DWORK(1) returns the optimal value -C of LDWORK. -C -C LDWORK INTEGER -C The length of the array DWORK. -C LDWORK >= MAX(1, N*(N+P) + -C MAX( N + MAX( N,P ), N*(2*N+3))) -C If N >= P, N >= 1, the formula above can be written as -C LDWORK >= N*(3*N + P + 3). -C For optimum performance LDWORK should be larger. -C -C Error Indicator -C -C INFO INTEGER -C = 0: successful exit; -C < 0: if INFO = -i, the i-th argument had an illegal -C value; -C = 1: the QR algorithm failed to converge when trying to -C compute the zeros of a transfer function; -C = 2: the QR algorithm failed to converge when trying to -C compute the poles of a transfer function. -C The errors INFO = 1 or 2 are unlikely to appear. -C -C METHOD -C -C The routine implements the pole-zero method proposed in [1]. -C This method is based on an algorithm for computing the transfer -C function of a single-input single-output (SISO) system. -C Let (A,b,c,d) be a SISO system. Its transfer function is computed -C as follows: -C -C 1) Find a controllable realization (Ac,bc,cc) of (A,b,c). -C 2) Find an observable realization (Ao,bo,co) of (Ac,bc,cc). -C 3) Compute the r eigenvalues of Ao (the poles of (Ao,bo,co)). -C 4) Compute the zeros of (Ao,bo,co,d). -C 5) Compute the gain of (Ao,bo,co,d). -C -C This algorithm can be implemented using only orthogonal -C transformations [1]. However, for better efficiency, the -C implementation in TB04CD uses one elementary transformation -C in Step 4 and r elementary transformations in Step 5 (to reduce -C an upper Hessenberg matrix to upper triangular form). These -C special elementary transformations are numerically stable -C in practice. -C -C In the multi-input multi-output (MIMO) case, the algorithm -C computes each element (i,j) of the transfer function matrix G, -C for i = 1 : P, and for j = 1 : M. For efficiency reasons, Step 1 -C is performed once for each value of j (each column of B). The -C matrices Ac and Ao result in Hessenberg form. -C -C REFERENCES -C -C [1] Varga, A. and Sima, V. -C Numerically Stable Algorithm for Transfer Function Matrix -C Evaluation. -C Int. J. Control, vol. 33, nr. 6, pp. 1123-1133, 1981. -C -C NUMERICAL ASPECTS -C -C The algorithm is numerically stable in practice and requires about -C 20*N**3 floating point operations at most, but usually much less. -C -C CONTRIBUTORS -C -C V. Sima, Research Institute for Informatics, Bucharest, May 2002. -C -C REVISIONS -C -C - -C -C KEYWORDS -C -C Eigenvalue, state-space representation, transfer function, zeros. -C -C ****************************************************************** -C -C .. Parameters .. - DOUBLE PRECISION ZERO, ONE, C100 - PARAMETER ( ZERO = 0.0D0, ONE = 1.0D0, C100 = 100.0D0 ) -C .. Scalar Arguments .. - CHARACTER EQUIL, JOBD - DOUBLE PRECISION TOL - INTEGER INFO, LDA, LDB, LDC, LDD, LDGAIN, LDNP, LDNZ, - $ LDWORK, M, N, NPZ, P -C .. Array Arguments .. - DOUBLE PRECISION A(LDA,*), B(LDB,*), C(LDC,*), D(LDD,*), - $ DWORK(*), GAINS(LDGAIN,*), POLESI(*), - $ POLESR(*), ZEROSI(*), ZEROSR(*) - INTEGER IWORK(*), NP(LDNP,*), NZ(LDNZ,*) -C .. Local Scalars .. - DOUBLE PRECISION ANORM, DIJ, EPSN, MAXRED, TOLDEF - INTEGER I, IA, IAC, IAS, IB, IC, ICC, IERR, IM, IP, - $ IPM1, ITAU, ITAU1, IZ, J, JWK, JWORK, JWORK1, - $ K, NCONT, WRKOPT - LOGICAL DIJNZ, FNDEIG, WITHD -C .. Local Arrays .. - DOUBLE PRECISION Z(1) -C .. External Functions .. - LOGICAL LSAME - DOUBLE PRECISION DLAMCH, DLANGE - EXTERNAL DLAMCH, DLANGE, LSAME -C .. External Subroutines .. - EXTERNAL DAXPY, DCOPY, DHSEQR, DLACPY, MA02AD, TB01ID, - $ TB01ZD, TB04BX, XERBLA -C .. Intrinsic Functions .. - INTRINSIC ABS, DBLE, INT, MAX, MIN -C .. -C .. Executable Statements .. -C -C Test the input scalar parameters. -C - INFO = 0 - WITHD = LSAME( JOBD, 'D' ) - IF( .NOT.WITHD .AND. .NOT.LSAME( JOBD, 'Z' ) ) THEN - INFO = -1 - ELSE IF( .NOT. ( LSAME( EQUIL, 'S' ) .OR. - $ LSAME( EQUIL, 'N' ) ) ) THEN - INFO = -2 - ELSE IF( N.LT.0 ) THEN - INFO = -3 - ELSE IF( M.LT.0 ) THEN - INFO = -4 - ELSE IF( P.LT.0 ) THEN - INFO = -5 - ELSE IF( NPZ.LT.0 ) THEN - INFO = -6 - ELSE IF( LDA.LT.MAX( 1, N ) ) THEN - INFO = -8 - ELSE IF( LDB.LT.MAX( 1, N ) ) THEN - INFO = -10 - ELSE IF( LDC.LT.MAX( 1, P ) ) THEN - INFO = -12 - ELSE IF( LDD.LT.1 .OR. ( WITHD .AND. LDD.LT.P ) ) THEN - INFO = -14 - ELSE IF( LDNZ.LT.MAX( 1, P ) ) THEN - INFO = -16 - ELSE IF( LDNP.LT.MAX( 1, P ) ) THEN - INFO = -18 - ELSE IF( LDGAIN.LT.MAX( 1, P ) ) THEN - INFO = -24 - ELSE IF( LDWORK.LT.MAX( 1, N*( N + P ) + - $ MAX( N + MAX( N, P ), N*( 2*N + 3 ) ) ) - $ ) THEN - INFO = -28 - END IF -C - IF ( INFO.NE.0 ) THEN -C -C Error return. -C - CALL XERBLA( 'TB04CD', -INFO ) - RETURN - END IF -C -C Quick return if possible. -C - DIJ = ZERO - IF( MIN( N, P, M ).EQ.0 ) THEN - IF( MIN( P, M ).GT.0 ) THEN -C - DO 20 J = 1, M -C - DO 10 I = 1, P - NZ(I,J) = 0 - NP(I,J) = 0 - IF ( WITHD ) - $ DIJ = D(I,J) - GAINS(I,J) = DIJ - 10 CONTINUE -C - 20 CONTINUE -C - END IF - DWORK(1) = ONE - RETURN - END IF -C -C Prepare the computation of the default tolerance. -C - TOLDEF = TOL - IF( TOLDEF.LE.ZERO ) THEN - EPSN = DBLE( N )*DLAMCH( 'Epsilon' ) - ANORM = DLANGE( 'Frobenius', N, N, A, LDA, DWORK ) - END IF -C -C Initializations. -C - IA = 1 - IC = IA + N*N - ITAU = IC + P*N - JWORK = ITAU + N - IAC = ITAU -C - K = 1 -C -C (Note: Comments in the code beginning "Workspace:" describe the -C minimal amount of real workspace needed at that point in the -C code, as well as the preferred amount for good performance.) -C - IF( LSAME( EQUIL, 'S' ) ) THEN -C -C Scale simultaneously the matrices A, B and C: -C A <- inv(S)*A*S, B <- inv(S)*B and C <- C*S, where S is a -C diagonal scaling matrix. -C Workspace: need N. -C - MAXRED = C100 - CALL TB01ID( 'All', N, M, P, MAXRED, A, LDA, B, LDB, C, LDC, - $ DWORK, IERR ) - END IF -C -C Compute the transfer function matrix of the system (A,B,C,D), -C in the pole-zero-gain form. -C - DO 80 J = 1, M -C -C Save A and C. -C Workspace: need W1 = N*(N+P). -C - CALL DLACPY( 'Full', N, N, A, LDA, DWORK(IA), N ) - CALL DLACPY( 'Full', P, N, C, LDC, DWORK(IC), P ) -C -C Remove the uncontrollable part of the system (A,B(J),C). -C Workspace: need W1+N+MAX(N,P); -C prefer larger. -C - CALL TB01ZD( 'No Z', N, P, DWORK(IA), N, B(1,J), DWORK(IC), P, - $ NCONT, Z, 1, DWORK(ITAU), TOL, DWORK(JWORK), - $ LDWORK-JWORK+1, IERR ) - IF ( J.EQ.1 ) - $ WRKOPT = INT( DWORK(JWORK) ) + JWORK - 1 -C - IB = IAC + NCONT*NCONT - ICC = IB + NCONT - ITAU1 = ICC + NCONT - JWK = ITAU1 + NCONT - IAS = ITAU1 - JWORK1 = IAS + NCONT*NCONT -C - DO 70 I = 1, P - IF ( NCONT.GT.0 ) THEN - IF ( WITHD ) - $ DIJ = D(I,J) -C -C Form the matrices of the state-space representation of -C the dual system for the controllable part. -C Workspace: need W2 = W1+N*(N+2). -C - CALL MA02AD( 'Full', NCONT, NCONT, DWORK(IA), N, - $ DWORK(IAC), NCONT ) - CALL DCOPY( NCONT, B(1,J), 1, DWORK(IB), 1 ) - CALL DCOPY( NCONT, DWORK(IC+I-1), P, DWORK(ICC), 1 ) -C -C Remove the unobservable part of the system (A,B(J),C(I)). -C Workspace: need W2+2*N; -C prefer larger. -C - CALL TB01ZD( 'No Z', NCONT, 1, DWORK(IAC), NCONT, - $ DWORK(ICC), DWORK(IB), 1, IP, Z, 1, - $ DWORK(ITAU1), TOL, DWORK(JWK), LDWORK-JWK+1, - $ IERR ) - IF ( I.EQ.1 ) - $ WRKOPT = MAX( WRKOPT, INT( DWORK(JWK) ) + JWK - 1 ) -C - IF ( IP.GT.0 ) THEN -C -C Save the state matrix of the minimal part. -C Workspace: need W3 = W2+N*N. -C - CALL DLACPY( 'Full', IP, IP, DWORK(IAC), NCONT, - $ DWORK(IAS), IP ) -C -C Compute the poles of the transfer function. -C Workspace: need W3+N; -C prefer larger. -C - CALL DHSEQR( 'Eigenvalues', 'No vectors', IP, 1, IP, - $ DWORK(IAC), NCONT, POLESR(K), POLESI(K), - $ Z, 1, DWORK(JWORK1), LDWORK-JWORK1+1, - $ IERR ) - IF ( IERR.NE.0 ) THEN - INFO = 2 - RETURN - END IF - WRKOPT = MAX( WRKOPT, - $ INT( DWORK(JWORK1) ) + JWORK1 - 1 ) -C -C Compute the zeros of the transfer function. -C - IPM1 = IP - 1 - DIJNZ = WITHD .AND. DIJ.NE.ZERO - FNDEIG = DIJNZ .OR. IPM1.GT.0 - IF ( .NOT.FNDEIG ) THEN - IZ = 0 - ELSE IF ( DIJNZ ) THEN -C -C Add the contribution due to D(i,j). -C Note that the matrix whose eigenvalues have to -C be computed remains in an upper Hessenberg form. -C - IZ = IP - CALL DLACPY( 'Full', IZ, IZ, DWORK(IAS), IP, - $ DWORK(IAC), NCONT ) - CALL DAXPY( IZ, -DWORK(ICC)/DIJ, DWORK(IB), 1, - $ DWORK(IAC), NCONT ) - ELSE - IF( TOL.LE.ZERO ) - $ TOLDEF = EPSN*MAX( ANORM, - $ DLANGE( 'Frobenius', IP, 1, - $ DWORK(IB), 1, DWORK ) - $ ) -C - DO 30 IM = 1, IPM1 - IF ( ABS( DWORK(IB+IM-1) ).GT.TOLDEF ) GO TO 40 - 30 CONTINUE -C - IZ = 0 - GO TO 50 -C - 40 CONTINUE -C -C Restore (part of) the saved state matrix. -C - IZ = IP - IM - CALL DLACPY( 'Full', IZ, IZ, DWORK(IAS+IM*(IP+1)), - $ IP, DWORK(IAC), NCONT ) -C -C Apply the output injection. -C - CALL DAXPY( IZ, -DWORK(IAS+IM*(IP+1)-IP)/ - $ DWORK(IB+IM-1), DWORK(IB+IM), 1, - $ DWORK(IAC), NCONT ) - END IF -C - IF ( FNDEIG ) THEN -C -C Find the zeros. -C Workspace: need W3+N; -C prefer larger. -C - CALL DHSEQR( 'Eigenvalues', 'No vectors', IZ, 1, - $ IZ, DWORK(IAC), NCONT, ZEROSR(K), - $ ZEROSI(K), Z, 1, DWORK(JWORK1), - $ LDWORK-JWORK1+1, IERR ) - IF ( IERR.NE.0 ) THEN - INFO = 1 - RETURN - END IF - END IF -C -C Compute the gain. -C - 50 CONTINUE - IF ( DIJNZ ) THEN - GAINS(I,J) = DIJ - ELSE - CALL TB04BX( IP, IZ, DWORK(IAS), IP, DWORK(ICC), - $ DWORK(IB), DIJ, POLESR(K), POLESI(K), - $ ZEROSR(K), ZEROSI(K), GAINS(I,J), - $ IWORK ) - END IF - NZ(I,J) = IZ - NP(I,J) = IP - ELSE -C -C Null element. -C - NZ(I,J) = 0 - NP(I,J) = 0 - END IF -C - ELSE -C -C Null element. -C - NZ(I,J) = 0 - NP(I,J) = 0 - END IF -C - K = K + NPZ - 70 CONTINUE -C - 80 CONTINUE -C - RETURN -C *** Last line of TB04CD *** - END diff --git a/mex/sources/libslicot/TB05AD.f b/mex/sources/libslicot/TB05AD.f deleted file mode 100644 index c7b93e918..000000000 --- a/mex/sources/libslicot/TB05AD.f +++ /dev/null @@ -1,545 +0,0 @@ - SUBROUTINE TB05AD( BALEIG, INITA, N, M, P, FREQ, A, LDA, B, LDB, - $ C, LDC, RCOND, G, LDG, EVRE, EVIM, HINVB, - $ LDHINV, IWORK, DWORK, LDWORK, ZWORK, LZWORK, - $ INFO ) -C -C SLICOT RELEASE 5.0. -C -C Copyright (c) 2002-2009 NICONET e.V. -C -C This program is free software: you can redistribute it and/or -C modify it under the terms of the GNU General Public License as -C published by the Free Software Foundation, either version 2 of -C the License, or (at your option) any later version. -C -C This program is distributed in the hope that it will be useful, -C but WITHOUT ANY WARRANTY; without even the implied warranty of -C MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the -C GNU General Public License for more details. -C -C You should have received a copy of the GNU General Public License -C along with this program. If not, see -C . -C -C PURPOSE -C -C To find the complex frequency response matrix (transfer matrix) -C G(freq) of the state-space representation (A,B,C) given by -C -1 -C G(freq) = C * ((freq*I - A) ) * B -C -C where A, B and C are real N-by-N, N-by-M and P-by-N matrices -C respectively and freq is a complex scalar. -C -C ARGUMENTS -C -C Mode Parameters -C -C BALEIG CHARACTER*1 -C Determines whether the user wishes to balance matrix A -C and/or compute its eigenvalues and/or estimate the -C condition number of the problem as follows: -C = 'N': The matrix A should not be balanced and neither -C the eigenvalues of A nor the condition number -C estimate of the problem are to be calculated; -C = 'C': The matrix A should not be balanced and only an -C estimate of the condition number of the problem -C is to be calculated; -C = 'B' or 'E' and INITA = 'G': The matrix A is to be -C balanced and its eigenvalues calculated; -C = 'A' and INITA = 'G': The matrix A is to be balanced, -C and its eigenvalues and an estimate of the -C condition number of the problem are to be -C calculated. -C -C INITA CHARACTER*1 -C Specifies whether or not the matrix A is already in upper -C Hessenberg form as follows: -C = 'G': The matrix A is a general matrix; -C = 'H': The matrix A is in upper Hessenberg form and -C neither balancing nor the eigenvalues of A are -C required. -C INITA must be set to 'G' for the first call to the -C routine, unless the matrix A is already in upper -C Hessenberg form and neither balancing nor the eigenvalues -C of A are required. Thereafter, it must be set to 'H' for -C all subsequent calls. -C -C Input/Output Parameters -C -C N (input) INTEGER -C The number of states, i.e. the order of the state -C transition matrix A. N >= 0. -C -C M (input) INTEGER -C The number of inputs, i.e. the number of columns in the -C matrix B. M >= 0. -C -C P (input) INTEGER -C The number of outputs, i.e. the number of rows in the -C matrix C. P >= 0. -C -C FREQ (input) COMPLEX*16 -C The frequency freq at which the frequency response matrix -C (transfer matrix) is to be evaluated. -C -C A (input/output) DOUBLE PRECISION array, dimension (LDA,N) -C On entry, the leading N-by-N part of this array must -C contain the state transition matrix A. -C If INITA = 'G', then, on exit, the leading N-by-N part of -C this array contains an upper Hessenberg matrix similar to -C (via an orthogonal matrix consisting of a sequence of -C Householder transformations) the original state transition -C matrix A. -C -C LDA INTEGER -C The leading dimension of array A. LDA >= MAX(1,N). -C -C B (input/output) DOUBLE PRECISION array, dimension (LDB,M) -C On entry, the leading N-by-M part of this array must -C contain the input/state matrix B. -C If INITA = 'G', then, on exit, the leading N-by-M part of -C this array contains the product of the transpose of the -C orthogonal transformation matrix used to reduce A to upper -C Hessenberg form and the original input/state matrix B. -C -C LDB INTEGER -C The leading dimension of array B. LDB >= MAX(1,N). -C -C C (input/output) DOUBLE PRECISION array, dimension (LDC,N) -C On entry, the leading P-by-N part of this array must -C contain the state/output matrix C. -C If INITA = 'G', then, on exit, the leading P-by-N part of -C this array contains the product of the original output/ -C state matrix C and the orthogonal transformation matrix -C used to reduce A to upper Hessenberg form. -C -C LDC INTEGER -C The leading dimension of array C. LDC >= MAX(1,P). -C -C RCOND (output) DOUBLE PRECISION -C If BALEIG = 'C' or BALEIG = 'A', then RCOND contains an -C estimate of the reciprocal of the condition number of -C matrix H with respect to inversion (see METHOD). -C -C G (output) COMPLEX*16 array, dimension (LDG,M) -C The leading P-by-M part of this array contains the -C frequency response matrix G(freq). -C -C LDG INTEGER -C The leading dimension of array G. LDG >= MAX(1,P). -C -C EVRE, (output) DOUBLE PRECISION arrays, dimension (N) -C EVIM If INITA = 'G' and BALEIG = 'B' or 'E' or BALEIG = 'A', -C then these arrays contain the real and imaginary parts, -C respectively, of the eigenvalues of the matrix A. -C Otherwise, these arrays are not referenced. -C -C HINVB (output) COMPLEX*16 array, dimension (LDHINV,M) -C The leading N-by-M part of this array contains the -C -1 -C product H B. -C -C LDHINV INTEGER -C The leading dimension of array HINVB. LDHINV >= MAX(1,N). -C -C Workspace -C -C IWORK INTEGER array, dimension (N) -C -C DWORK DOUBLE PRECISION array, dimension (LDWORK) -C On exit, if INFO = 0, DWORK(1) returns the optimal value -C of LDWORK. -C -C LDWORK INTEGER -C The length of the array DWORK. -C LDWORK >= MAX(1, N - 1 + MAX(N,M,P)), -C if INITA = 'G' and BALEIG = 'N', or 'B', or 'E'; -C LDWORK >= MAX(1, N + MAX(N,M-1,P-1)), -C if INITA = 'G' and BALEIG = 'C', or 'A'; -C LDWORK >= MAX(1, 2*N), -C if INITA = 'H' and BALEIG = 'C', or 'A'; -C LDWORK >= 1, otherwise. -C For optimum performance when INITA = 'G' LDWORK should be -C larger. -C -C ZWORK COMPLEX*16 array, dimension (LZWORK) -C -C LZWORK INTEGER -C The length of the array ZWORK. -C LZWORK >= MAX(1,N*N+2*N), if BALEIG = 'C', or 'A'; -C LZWORK >= MAX(1,N*N), otherwise. -C -C Error Indicator -C -C INFO INTEGER -C = 0: successful exit; -C < 0: if INFO = -i, the i-th argument had an illegal -C value; -C = 1: if more than 30*N iterations are required to -C isolate all the eigenvalues of the matrix A; the -C computations are continued; -C = 2: if either FREQ is too near to an eigenvalue of the -C matrix A, or RCOND is less than EPS, where EPS is -C the machine precision (see LAPACK Library routine -C DLAMCH). -C -C METHOD -C -C The matrix A is first balanced (if BALEIG = 'B' or 'E', or -C BALEIG = 'A') and then reduced to upper Hessenberg form; the same -C transformations are applied to the matrix B and the matrix C. -C The complex Hessenberg matrix H = (freq*I - A) is then used -C -1 -C to solve for C * H * B. -C -C Depending on the input values of parameters BALEIG and INITA, -C the eigenvalues of matrix A and the condition number of -C matrix H with respect to inversion are also calculated. -C -C REFERENCES -C -C [1] Laub, A.J. -C Efficient Calculation of Frequency Response Matrices from -C State-Space Models. -C ACM TOMS, 12, pp. 26-33, 1986. -C -C NUMERICAL ASPECTS -C 3 -C The algorithm requires 0(N ) operations. -C -C CONTRIBUTOR -C -C Release 3.0: V. Sima, Katholieke Univ. Leuven, Belgium, Dec. 1996. -C Supersedes Release 2.0 routine TB01FD by A.J.Laub, University of -C Southern California, Los Angeles, CA 90089, United States of -C America, June 1982. -C -C REVISIONS -C -C V. Sima, February 22, 1998 (changed the name of TB01RD). -C V. Sima, February 12, 1999, August 7, 2003. -C A. Markovski, Technical University of Sofia, September 30, 2003. -C V. Sima, October 1, 2003. -C -C KEYWORDS -C -C Frequency response, Hessenberg form, matrix algebra, input output -C description, multivariable system, orthogonal transformation, -C similarity transformation, state-space representation, transfer -C matrix. -C -C ****************************************************************** -C -C .. Parameters .. - DOUBLE PRECISION ZERO, ONE - PARAMETER ( ZERO = 0.0D0, ONE = 1.0D0 ) - COMPLEX*16 CZERO - PARAMETER ( CZERO = ( 0.0D0, 0.0D0 ) ) -C .. Scalar Arguments .. - CHARACTER BALEIG, INITA - INTEGER INFO, LDA, LDB, LDC, LDG, LDHINV, LDWORK, - $ LZWORK, M, N, P - DOUBLE PRECISION RCOND - COMPLEX*16 FREQ -C .. Array Arguments .. - INTEGER IWORK(*) - DOUBLE PRECISION A(LDA,*), B(LDB,*), C(LDC,*), DWORK(*), EVIM(*), - $ EVRE(*) - COMPLEX*16 ZWORK(*), G(LDG,*), HINVB(LDHINV,*) -C .. Local Scalars .. - CHARACTER BALANC - LOGICAL LBALBA, LBALEA, LBALEB, LBALEC, LINITA - INTEGER I, IGH, IJ, ITAU, J, JJ, JP, JWORK, K, LOW, - $ WRKOPT - DOUBLE PRECISION HNORM, T -C .. External Functions .. - LOGICAL LSAME - DOUBLE PRECISION DASUM, DLAMCH - EXTERNAL DASUM, DLAMCH, LSAME -C .. External Subroutines .. - EXTERNAL DGEBAL, DGEHRD, DHSEQR, DORMHR, DSCAL, DSWAP, - $ MB02RZ, MB02SZ, MB02TZ, XERBLA, ZLASET -C .. Intrinsic Functions .. - INTRINSIC DBLE, DCMPLX, INT, MAX, MIN -C .. Executable Statements .. -C - INFO = 0 - LBALEC = LSAME( BALEIG, 'C' ) - LBALEB = LSAME( BALEIG, 'B' ) .OR. LSAME( BALEIG, 'E' ) - LBALEA = LSAME( BALEIG, 'A' ) - LBALBA = LBALEB.OR.LBALEA - LINITA = LSAME( INITA, 'G' ) -C -C Test the input scalar arguments. -C - IF( .NOT.LBALEC .AND. .NOT.LBALBA .AND. - $ .NOT.LSAME( BALEIG, 'N' ) ) THEN - INFO = -1 - ELSE IF( .NOT.LINITA .AND. .NOT.LSAME( INITA, 'H' ) ) THEN - INFO = -2 - ELSE IF( N.LT.0 ) THEN - INFO = -3 - ELSE IF( M.LT.0 ) THEN - INFO = -4 - ELSE IF( P.LT.0 ) THEN - INFO = -5 - ELSE IF( LDA.LT.MAX( 1, N ) ) THEN - INFO = -8 - ELSE IF( LDB.LT.MAX( 1, N ) ) THEN - INFO = -10 - ELSE IF( LDC.LT.MAX( 1, P ) ) THEN - INFO = -12 - ELSE IF( LDG.LT.MAX( 1, P ) ) THEN - INFO = -15 - ELSE IF( LDHINV.LT.MAX( 1, N ) ) THEN - INFO = -19 - ELSE IF( ( LINITA .AND. .NOT.LBALEC .AND. .NOT.LBALEA .AND. - $ LDWORK.LT.N - 1 + MAX( N, M, P ) ) .OR. - $ ( LINITA .AND. ( LBALEC .OR. LBALEA ) .AND. - $ LDWORK.LT.N + MAX( N, M-1, P-1 ) ) .OR. - $ ( .NOT.LINITA .AND. ( LBALEC .OR. LBALEA ) .AND. - $ LDWORK.LT.2*N ) .OR. ( LDWORK.LT.1 ) ) THEN - INFO = -22 - ELSE IF( ( ( LBALEC .OR. LBALEA ) .AND. LZWORK.LT.N*( N + 2 ) ) - $ .OR. ( LZWORK.LT.MAX( 1, N*N ) ) ) THEN - INFO = -24 - END IF -C - IF ( INFO.NE.0 ) THEN -C -C Error return -C - CALL XERBLA( 'TB05AD', -INFO ) - RETURN - END IF -C -C Quick return if possible. -C - IF ( N.EQ.0 ) THEN - IF ( MIN( M, P ).GT.0 ) - $ CALL ZLASET( 'Full', P, M, CZERO, CZERO, G, LDG ) - RCOND = ONE - DWORK(1) = ONE - RETURN - END IF -C -C (Note: Comments in the code beginning "Workspace:" describe the -C minimal amount of real workspace needed at that point in the -C code, as well as the preferred amount for good performance. -C NB refers to the optimal block size for the immediately -C following subroutine, as returned by ILAENV.) -C - WRKOPT = 1 -C - IF ( LINITA ) THEN - BALANC = 'N' - IF ( LBALBA ) BALANC = 'B' -C -C Workspace: need N. -C - CALL DGEBAL( BALANC, N, A, LDA, LOW, IGH, DWORK, INFO ) - IF ( LBALBA ) THEN -C -C Adjust B and C matrices based on information in the -C vector DWORK which describes the balancing of A and is -C defined in the subroutine DGEBAL. -C - DO 10 J = 1, N - JJ = J - IF ( JJ.LT.LOW .OR. JJ.GT.IGH ) THEN - IF ( JJ.LT.LOW ) JJ = LOW - JJ - JP = DWORK(JJ) - IF ( JP.NE.JJ ) THEN -C -C Permute rows of B. -C - IF ( M.GT.0 ) - $ CALL DSWAP( M, B(JJ,1), LDB, B(JP,1), LDB ) -C -C Permute columns of C. -C - IF ( P.GT.0 ) - $ CALL DSWAP( P, C(1,JJ), 1, C(1,JP), 1 ) - END IF - END IF - 10 CONTINUE -C - IF ( IGH.NE.LOW ) THEN -C - DO 20 J = LOW, IGH - T = DWORK(J) -C -C Scale rows of permuted B. -C - IF ( M.GT.0 ) - $ CALL DSCAL( M, ONE/T, B(J,1), LDB ) -C -C Scale columns of permuted C. -C - IF ( P.GT.0 ) - $ CALL DSCAL( P, T, C(1,J), 1 ) - 20 CONTINUE -C - END IF - END IF -C -C Reduce A to Hessenberg form by orthogonal similarities and -C accumulate the orthogonal transformations into B and C. -C Workspace: need 2*N - 1; prefer N - 1 + N*NB. -C - ITAU = 1 - JWORK = ITAU + N - 1 - CALL DGEHRD( N, LOW, IGH, A, LDA, DWORK(ITAU), DWORK(JWORK), - $ LDWORK-JWORK+1, INFO ) - WRKOPT = MAX( WRKOPT, INT( DWORK(JWORK) )+JWORK-1 ) -C -C Workspace: need N - 1 + M; prefer N - 1 + M*NB. -C - CALL DORMHR( 'Left', 'Transpose', N, M, LOW, IGH, A, LDA, - $ DWORK(ITAU), B, LDB, DWORK(JWORK), LDWORK-JWORK+1, - $ INFO ) - WRKOPT = MAX( WRKOPT, INT( DWORK(JWORK) )+JWORK-1 ) -C -C Workspace: need N - 1 + P; prefer N - 1 + P*NB. -C - CALL DORMHR( 'Right', 'No transpose', P, N, LOW, IGH, A, LDA, - $ DWORK(ITAU), C, LDC, DWORK(JWORK), LDWORK-JWORK+1, - $ INFO ) - WRKOPT = MAX( WRKOPT, INT( DWORK(JWORK) )+JWORK-1 ) - IF ( LBALBA ) THEN -C -C Temporarily store Hessenberg form of A in array ZWORK. -C - IJ = 0 - DO 40 J = 1, N -C - DO 30 I = 1, N - IJ = IJ + 1 - ZWORK(IJ) = DCMPLX( A(I,J), ZERO ) - 30 CONTINUE -C - 40 CONTINUE -C -C Compute the eigenvalues of A if that option is requested. -C Workspace: need N. -C - CALL DHSEQR( 'Eigenvalues', 'No Schur', N, LOW, IGH, A, LDA, - $ EVRE, EVIM, DWORK, 1, DWORK, LDWORK, INFO ) -C -C Restore upper Hessenberg form of A. -C - IJ = 0 - DO 60 J = 1, N -C - DO 50 I = 1, N - IJ = IJ + 1 - A(I,J) = DBLE( ZWORK(IJ) ) - 50 CONTINUE -C - 60 CONTINUE -C - IF ( INFO.GT.0 ) THEN -C -C DHSEQR could not evaluate the eigenvalues of A. -C - INFO = 1 - END IF - END IF - END IF -C -C Update H := (FREQ * I) - A with appropriate value of FREQ. -C - IJ = 0 - JJ = 1 - DO 80 J = 1, N -C - DO 70 I = 1, N - IJ = IJ + 1 - ZWORK(IJ) = -DCMPLX( A(I,J), ZERO ) - 70 CONTINUE -C - ZWORK(JJ) = FREQ + ZWORK(JJ) - JJ = JJ + N + 1 - 80 CONTINUE -C - IF ( LBALEC .OR. LBALEA ) THEN -C -C Efficiently compute the 1-norm of the matrix for condition -C estimation. -C - HNORM = ZERO - JJ = 1 -C - DO 90 J = 1, N - T = ABS( ZWORK(JJ) ) + DASUM( J-1, A(1,J), 1 ) - IF ( J.LT.N ) T = T + ABS( A(J+1,J) ) - HNORM = MAX( HNORM, T ) - JJ = JJ + N + 1 - 90 CONTINUE -C - END IF -C -C Factor the complex Hessenberg matrix. -C - CALL MB02SZ( N, ZWORK, N, IWORK, INFO ) - IF ( INFO.NE.0 ) INFO = 2 -C - IF ( LBALEC .OR. LBALEA ) THEN -C -C Estimate the condition of the matrix. -C -C Workspace: need 2*N. -C - CALL MB02TZ( '1-norm', N, HNORM, ZWORK, N, IWORK, RCOND, DWORK, - $ ZWORK(N*N+1), INFO ) - WRKOPT = MAX( WRKOPT, 2*N ) - IF ( RCOND.LT.DLAMCH( 'Epsilon' ) ) INFO = 2 - END IF -C - IF ( INFO.NE.0 ) THEN -C -C Error return: Linear system is numerically or exactly singular. -C - RETURN - END IF -C -C Compute (H-INVERSE)*B. -C - DO 110 J = 1, M -C - DO 100 I = 1, N - HINVB(I,J) = DCMPLX( B(I,J), ZERO ) - 100 CONTINUE -C - 110 CONTINUE -C - CALL MB02RZ( 'No transpose', N, M, ZWORK, N, IWORK, HINVB, LDHINV, - $ INFO ) -C -C Compute C*(H-INVERSE)*B. -C - DO 150 J = 1, M -C - DO 120 I = 1, P - G(I,J) = CZERO - 120 CONTINUE -C - DO 140 K = 1, N -C - DO 130 I = 1, P - G(I,J) = G(I,J) + DCMPLX( C(I,K), ZERO )*HINVB(K,J) - 130 CONTINUE -C - 140 CONTINUE -C - 150 CONTINUE -C -C G now contains the desired frequency response matrix. -C Set the optimal workspace. -C - DWORK(1) = WRKOPT -C - RETURN -C *** Last line of TB05AD *** - END diff --git a/mex/sources/libslicot/TC01OD.f b/mex/sources/libslicot/TC01OD.f deleted file mode 100644 index 3e7bd25ad..000000000 --- a/mex/sources/libslicot/TC01OD.f +++ /dev/null @@ -1,236 +0,0 @@ - SUBROUTINE TC01OD( LERI, M, P, INDLIM, PCOEFF, LDPCO1, LDPCO2, - $ QCOEFF, LDQCO1, LDQCO2, INFO ) -C -C SLICOT RELEASE 5.0. -C -C Copyright (c) 2002-2009 NICONET e.V. -C -C This program is free software: you can redistribute it and/or -C modify it under the terms of the GNU General Public License as -C published by the Free Software Foundation, either version 2 of -C the License, or (at your option) any later version. -C -C This program is distributed in the hope that it will be useful, -C but WITHOUT ANY WARRANTY; without even the implied warranty of -C MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the -C GNU General Public License for more details. -C -C You should have received a copy of the GNU General Public License -C along with this program. If not, see -C . -C -C PURPOSE -C -C To find the dual right (left) polynomial matrix representation of -C a given left (right) polynomial matrix representation, where the -C right and left polynomial matrix representations are of the form -C Q(s)*inv(P(s)) and inv(P(s))*Q(s) respectively. -C -C ARGUMENTS -C -C Mode Parameters -C -C LERI CHARACTER*1 -C Indicates whether a left or right matrix fraction is input -C as follows: -C = 'L': A left matrix fraction is input; -C = 'R': A right matrix fraction is input. -C -C Input/Output Parameters -C -C M (input) INTEGER -C The number of system inputs. M >= 0. -C -C P (input) INTEGER -C The number of system outputs. P >= 0. -C -C INDLIM (input) INTEGER -C The highest value of K for which PCOEFF(.,.,K) and -C QCOEFF(.,.,K) are to be transposed. -C K = kpcoef + 1, where kpcoef is the maximum degree of the -C polynomials in P(s). INDLIM >= 1. -C -C PCOEFF (input/output) DOUBLE PRECISION array, dimension -C (LDPCO1,LDPCO2,INDLIM) -C If LERI = 'L' then porm = P, otherwise porm = M. -C On entry, the leading porm-by-porm-by-INDLIM part of this -C array must contain the coefficients of the denominator -C matrix P(s). -C PCOEFF(I,J,K) is the coefficient in s**(INDLIM-K) of -C polynomial (I,J) of P(s), where K = 1,2,...,INDLIM. -C On exit, the leading porm-by-porm-by-INDLIM part of this -C array contains the coefficients of the denominator matrix -C P'(s) of the dual system. -C -C LDPCO1 INTEGER -C The leading dimension of array PCOEFF. -C LDPCO1 >= MAX(1,P) if LERI = 'L', -C LDPCO1 >= MAX(1,M) if LERI = 'R'. -C -C LDPCO2 INTEGER -C The second dimension of array PCOEFF. -C LDPCO2 >= MAX(1,P) if LERI = 'L', -C LDPCO2 >= MAX(1,M) if LERI = 'R'. -C -C QCOEFF (input/output) DOUBLE PRECISION array, dimension -C (LDQCO1,LDQCO2,INDLIM) -C On entry, the leading P-by-M-by-INDLIM part of this array -C must contain the coefficients of the numerator matrix -C Q(s). -C QCOEFF(I,J,K) is the coefficient in s**(INDLIM-K) of -C polynomial (I,J) of Q(s), where K = 1,2,...,INDLIM. -C On exit, the leading M-by-P-by-INDLIM part of the array -C contains the coefficients of the numerator matrix Q'(s) -C of the dual system. -C -C LDQCO1 INTEGER -C The leading dimension of array QCOEFF. -C LDQCO1 >= MAX(1,M,P). -C -C LDQCO2 INTEGER -C The second dimension of array QCOEFF. -C LDQCO2 >= MAX(1,M,P). -C -C Error Indicator -C -C INFO INTEGER -C = 0: successful exit; -C < 0: if INFO = -i, the i-th argument had an illegal -C value. -C -C METHOD -C -C If the given M-input/P-output left (right) polynomial matrix -C representation has numerator matrix Q(s) and denominator matrix -C P(s), its dual P-input/M-output right (left) polynomial matrix -C representation simply has numerator matrix Q'(s) and denominator -C matrix P'(s). -C -C REFERENCES -C -C None. -C -C NUMERICAL ASPECTS -C -C None. -C -C CONTRIBUTOR -C -C Release 3.0: V. Sima, Katholieke Univ. Leuven, Belgium, Dec. 1996. -C Supersedes Release 2.0 routine TC01CD by T.W.C.Williams, Kingston -C Polytechnic, United Kingdom, March 1982. -C -C REVISIONS -C -C - -C -C KEYWORDS -C -C Coprime matrix fraction, elementary polynomial operations, -C polynomial matrix, state-space representation, transfer matrix. -C -C ****************************************************************** -C -C .. Scalar Arguments .. - CHARACTER LERI - INTEGER INFO, INDLIM, LDPCO1, LDPCO2, LDQCO1, LDQCO2, M, - $ P -C .. Array Arguments .. - DOUBLE PRECISION PCOEFF(LDPCO1,LDPCO2,*), QCOEFF(LDQCO1,LDQCO2,*) -C .. Local Scalars .. - LOGICAL LLERI - INTEGER J, K, MINMP, MPLIM, PORM -C .. External Functions .. - LOGICAL LSAME - EXTERNAL LSAME -C .. External Subroutines .. - EXTERNAL DCOPY, DSWAP, XERBLA -C .. Intrinsic Functions .. - INTRINSIC MAX, MIN -C .. Executable Statements .. -C - INFO = 0 - LLERI = LSAME( LERI, 'L' ) - MPLIM = MAX( M, P ) - MINMP = MIN( M, P ) -C -C Test the input scalar arguments. -C - IF( .NOT.LLERI .AND. .NOT.LSAME( LERI, 'R' ) ) THEN - INFO = -1 - ELSE IF( M.LT.0 ) THEN - INFO = -2 - ELSE IF( P.LT.0 ) THEN - INFO = -3 - ELSE IF( INDLIM.LT.1 ) THEN - INFO = -4 - ELSE IF( ( LLERI .AND. LDPCO1.LT.MAX( 1, P ) ) .OR. - $ ( .NOT.LLERI .AND. LDPCO1.LT.MAX( 1, M ) ) ) THEN - INFO = -6 - ELSE IF( ( LLERI .AND. LDPCO2.LT.MAX( 1, P ) ) .OR. - $ ( .NOT.LLERI .AND. LDPCO2.LT.MAX( 1, M ) ) ) THEN - INFO = -7 - ELSE IF( LDQCO1.LT.MAX( 1, MPLIM ) ) THEN - INFO = -9 - ELSE IF( LDQCO2.LT.MAX( 1, MPLIM ) ) THEN - INFO = -10 - END IF -C - IF ( INFO.NE.0 ) THEN -C -C Error return. -C - CALL XERBLA( 'TC01OD', -INFO ) - RETURN - END IF -C -C Quick return if possible. -C - IF ( M.EQ.0 .OR. P.EQ.0 ) - $ RETURN -C - IF ( MPLIM.NE.1 ) THEN -C -C Non-scalar system: transpose numerator matrix Q(s). -C - DO 20 K = 1, INDLIM -C - DO 10 J = 1, MPLIM - IF ( J.LT.MINMP ) THEN - CALL DSWAP( MINMP-J, QCOEFF(J+1,J,K), 1, - $ QCOEFF(J,J+1,K), LDQCO1 ) - ELSE IF ( J.GT.P ) THEN - CALL DCOPY( P, QCOEFF(1,J,K), 1, QCOEFF(J,1,K), - $ LDQCO1 ) - ELSE IF ( J.GT.M ) THEN - CALL DCOPY( M, QCOEFF(J,1,K), LDQCO1, QCOEFF(1,J,K), - $ 1 ) - END IF - 10 CONTINUE -C - 20 CONTINUE -C -C Find dimension of denominator matrix P(s): M (P) for -C right (left) polynomial matrix representation. -C - PORM = M - IF ( LLERI ) PORM = P - IF ( PORM.NE.1 ) THEN -C -C Non-scalar P(s): transpose it. -C - DO 40 K = 1, INDLIM -C - DO 30 J = 1, PORM - 1 - CALL DSWAP( PORM-J, PCOEFF(J+1,J,K), 1, - $ PCOEFF(J,J+1,K), LDPCO1 ) - 30 CONTINUE -C - 40 CONTINUE -C - END IF - END IF -C - RETURN -C *** Last line of TC01OD *** - END diff --git a/mex/sources/libslicot/TC04AD.f b/mex/sources/libslicot/TC04AD.f deleted file mode 100644 index d0ce99d13..000000000 --- a/mex/sources/libslicot/TC04AD.f +++ /dev/null @@ -1,483 +0,0 @@ - SUBROUTINE TC04AD( LERI, M, P, INDEX, PCOEFF, LDPCO1, LDPCO2, - $ QCOEFF, LDQCO1, LDQCO2, N, RCOND, A, LDA, B, - $ LDB, C, LDC, D, LDD, IWORK, DWORK, LDWORK, - $ INFO ) -C -C SLICOT RELEASE 5.0. -C -C Copyright (c) 2002-2009 NICONET e.V. -C -C This program is free software: you can redistribute it and/or -C modify it under the terms of the GNU General Public License as -C published by the Free Software Foundation, either version 2 of -C the License, or (at your option) any later version. -C -C This program is distributed in the hope that it will be useful, -C but WITHOUT ANY WARRANTY; without even the implied warranty of -C MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the -C GNU General Public License for more details. -C -C You should have received a copy of the GNU General Public License -C along with this program. If not, see -C . -C -C PURPOSE -C -C To find a state-space representation (A,B,C,D) with the same -C transfer matrix T(s) as that of a given left or right polynomial -C matrix representation, i.e. -C -C C*inv(sI-A)*B + D = T(s) = inv(P(s))*Q(s) = Q(s)*inv(P(s)). -C -C ARGUMENTS -C -C Mode Parameters -C -C LERI CHARACTER*1 -C Indicates whether a left polynomial matrix representation -C or a right polynomial matrix representation is input as -C follows: -C = 'L': A left matrix fraction is input; -C = 'R': A right matrix fraction is input. -C -C Input/Output Parameters -C -C M (input) INTEGER -C The number of system inputs. M >= 0. -C -C P (input) INTEGER -C The number of system outputs. P >= 0. -C -C INDEX (input) INTEGER array, dimension (MAX(M,P)) -C If LERI = 'L', INDEX(I), I = 1,2,...,P, must contain the -C maximum degree of the polynomials in the I-th row of the -C denominator matrix P(s) of the given left polynomial -C matrix representation. -C If LERI = 'R', INDEX(I), I = 1,2,...,M, must contain the -C maximum degree of the polynomials in the I-th column of -C the denominator matrix P(s) of the given right polynomial -C matrix representation. -C -C PCOEFF (input) DOUBLE PRECISION array, dimension -C (LDPCO1,LDPCO2,kpcoef), where kpcoef = MAX(INDEX(I)) + 1. -C If LERI = 'L' then porm = P, otherwise porm = M. -C The leading porm-by-porm-by-kpcoef part of this array must -C contain the coefficients of the denominator matrix P(s). -C PCOEFF(I,J,K) is the coefficient in s**(INDEX(iorj)-K+1) -C of polynomial (I,J) of P(s), where K = 1,2,...,kpcoef; if -C LERI = 'L' then iorj = I, otherwise iorj = J. -C Thus for LERI = 'L', P(s) = -C diag(s**INDEX(I))*(PCOEFF(.,.,1)+PCOEFF(.,.,2)/s+...). -C If LERI = 'R', PCOEFF is modified by the routine but -C restored on exit. -C -C LDPCO1 INTEGER -C The leading dimension of array PCOEFF. -C LDPCO1 >= MAX(1,P) if LERI = 'L', -C LDPCO1 >= MAX(1,M) if LERI = 'R'. -C -C LDPCO2 INTEGER -C The second dimension of array PCOEFF. -C LDPCO2 >= MAX(1,P) if LERI = 'L', -C LDPCO2 >= MAX(1,M) if LERI = 'R'. -C -C QCOEFF (input) DOUBLE PRECISION array, dimension -C (LDQCO1,LDQCO2,kpcoef) -C If LERI = 'L' then porp = M, otherwise porp = P. -C The leading porm-by-porp-by-kpcoef part of this array must -C contain the coefficients of the numerator matrix Q(s). -C QCOEFF(I,J,K) is defined as for PCOEFF(I,J,K). -C If LERI = 'R', QCOEFF is modified by the routine but -C restored on exit. -C -C LDQCO1 INTEGER -C The leading dimension of array QCOEFF. -C LDQCO1 >= MAX(1,P) if LERI = 'L', -C LDQCO1 >= MAX(1,M,P) if LERI = 'R'. -C -C LDQCO2 INTEGER -C The second dimension of array QCOEFF. -C LDQCO2 >= MAX(1,M) if LERI = 'L', -C LDQCO2 >= MAX(1,M,P) if LERI = 'R'. -C -C N (output) INTEGER -C The order of the resulting state-space representation. -C porm -C That is, N = SUM INDEX(I). -C I=1 -C -C RCOND (output) DOUBLE PRECISION -C The estimated reciprocal of the condition number of the -C leading row (if LERI = 'L') or the leading column (if -C LERI = 'R') coefficient matrix of P(s). -C If RCOND is nearly zero, P(s) is nearly row or column -C non-proper. -C -C A (output) DOUBLE PRECISION array, dimension (LDA,N) -C The leading N-by-N part of this array contains the state -C dynamics matrix A. -C -C LDA INTEGER -C The leading dimension of array A. LDA >= MAX(1,N). -C -C B (output) DOUBLE PRECISION array, dimension (LDB,MAX(M,P)) -C The leading N-by-M part of this array contains the -C input/state matrix B; the remainder of the leading -C N-by-MAX(M,P) part is used as internal workspace. -C -C LDB INTEGER -C The leading dimension of array B. LDB >= MAX(1,N). -C -C C (output) DOUBLE PRECISION array, dimension (LDC,N) -C The leading P-by-N part of this array contains the -C state/output matrix C; the remainder of the leading -C MAX(M,P)-by-N part is used as internal workspace. -C -C LDC INTEGER -C The leading dimension of array C. LDC >= MAX(1,M,P). -C -C D (output) DOUBLE PRECISION array, dimension (LDD,MAX(M,P)) -C The leading P-by-M part of this array contains the direct -C transmission matrix D; the remainder of the leading -C MAX(M,P)-by-MAX(M,P) part is used as internal workspace. -C -C LDD INTEGER -C The leading dimension of array D. LDD >= MAX(1,M,P). -C -C Workspace -C -C IWORK INTEGER array, dimension (2*MAX(M,P)) -C -C DWORK DOUBLE PRECISION array, dimension (LDWORK) -C On exit, if INFO = 0, DWORK(1) returns the optimal value -C of LDWORK. -C -C LDWORK INTEGER -C The length of the array DWORK. -C LDWORK >= MAX(1,MAX(M,P)*(MAX(M,P)+4)). -C For optimum performance LDWORK should be larger. -C -C Error Indicator -C -C INFO INTEGER -C = 0: successful exit; -C < 0: if INFO = -i, the i-th argument had an illegal -C value; -C = 1: if P(s) is not row (if LERI = 'L') or column -C (if LERI = 'R') proper. Consequently, no state-space -C representation is calculated. -C -C METHOD -C -C The method for a left matrix fraction will be described here; -C right matrix fractions are dealt with by obtaining the dual left -C polynomial matrix representation and constructing an equivalent -C state-space representation for this. The first step is to check -C if the denominator matrix P(s) is row proper; if it is not then -C the routine returns with the Error Indicator (INFO) set to 1. -C Otherwise, Wolovich's Observable Structure Theorem is used to -C construct a state-space representation (A,B,C,D) in observable -C companion form. The sizes of the blocks of matrix A and matrix C -C here are precisely the row degrees of P(s), while their -C 'non-trivial' columns are given easily from its coefficients. -C Similarly, the matrix D is obtained from the leading coefficients -C of P(s) and of the numerator matrix Q(s), while matrix B is given -C by the relation Sbar(s)B = Q(s) - P(s)D, where Sbar(s) is a -C polynomial matrix whose (j,k)(th) element is given by -C -C j-u(k-1)-1 -C ( s , j = u(k-1)+1,u(k-1)+2,....,u(k) -C Sbar = ( -C j,k ( 0 , otherwise -C -C k -C u(k) = SUM d , k = 1,2,...,M and d ,d ,...,d are the -C i=1 i 1 2 M -C controllability indices. For convenience in solving this, C' and B -C are initially set up to contain the coefficients of P(s) and Q(s), -C respectively, stored by rows. -C -C REFERENCES -C -C [1] Wolovich, W.A. -C Linear Multivariate Systems, (Theorem 4.3.3). -C Springer-Verlag, 1974. -C -C NUMERICAL ASPECTS -C 3 -C The algorithm requires 0(N ) operations. -C -C CONTRIBUTOR -C -C Release 3.0: V. Sima, Katholieke Univ. Leuven, Belgium, Dec. 1996. -C Supersedes Release 2.0 routine TC01BD by T.W.C.Williams, Kingston -C Polytechnic, United Kingdom, March 1982. -C -C REVISIONS -C -C February 22, 1998 (changed the name of TC01ND). -C May 12, 1998. -C -C KEYWORDS -C -C Coprime matrix fraction, elementary polynomial operations, -C polynomial matrix, state-space representation, transfer matrix. -C -C ****************************************************************** -C -C .. Parameters .. - DOUBLE PRECISION ZERO, ONE - PARAMETER ( ZERO = 0.0D0, ONE = 1.0D0 ) -C .. Scalar Arguments .. - CHARACTER LERI - INTEGER INFO, LDA, LDB, LDC, LDD, LDPCO1, LDPCO2, - $ LDQCO1, LDQCO2, LDWORK, M, N, P - DOUBLE PRECISION RCOND -C .. Array Arguments .. - INTEGER INDEX(*), IWORK(*) - DOUBLE PRECISION A(LDA,*), B(LDB,*), C(LDC,*), D(LDD,*), - $ DWORK(*), PCOEFF(LDPCO1,LDPCO2,*), - $ QCOEFF(LDQCO1,LDQCO2,*) -C .. Local Scalars .. - LOGICAL LLERI - INTEGER I, IA, IBIAS, J, JA, JC, JW, JWORK, LDW, K, - $ KPCOEF, KSTOP, MAXIND, MINDEX, MWORK, PWORK, - $ WRKOPT - DOUBLE PRECISION DWNORM -C .. External Functions .. - LOGICAL LSAME - DOUBLE PRECISION DLAMCH, DLANGE - EXTERNAL LSAME, DLAMCH, DLANGE -C .. External Subroutines .. - EXTERNAL AB07MD, DCOPY, DGECON, DGEMM, DGETRF, DGETRI, - $ DGETRS, DLACPY, DLASET, TC01OD, XERBLA -C .. Intrinsic Functions .. - INTRINSIC INT, MAX -C .. Executable Statements .. -C - INFO = 0 - LLERI = LSAME( LERI, 'L' ) - MINDEX = MAX( M, P ) -C -C Test the input scalar arguments. -C - IF( .NOT.LLERI .AND. .NOT.LSAME( LERI, 'R' ) ) THEN - INFO = -1 - ELSE IF( M.LT.0 ) THEN - INFO = -2 - ELSE IF( P.LT.0 ) THEN - INFO = -3 - ELSE IF( ( LLERI .AND. LDPCO1.LT.MAX( 1, P ) ) .OR. - $ ( .NOT.LLERI .AND. LDPCO1.LT.MAX( 1, M ) ) ) THEN - INFO = -6 - ELSE IF( ( LLERI .AND. LDPCO2.LT.MAX( 1, P ) ) .OR. - $ ( .NOT.LLERI .AND. LDPCO2.LT.MAX( 1, M ) ) ) THEN - INFO = -7 - ELSE IF( ( LLERI .AND. LDQCO1.LT.MAX( 1, P ) ) .OR. - $ ( .NOT.LLERI .AND. LDQCO1.LT.MAX( 1, MINDEX ) ) ) THEN - INFO = -9 - ELSE IF( ( LLERI .AND. LDQCO2.LT.MAX( 1, M ) ) .OR. - $ ( .NOT.LLERI .AND. LDQCO2.LT.MAX( 1, MINDEX ) ) ) THEN - INFO = -10 - END IF -C - N = 0 - IF ( INFO.EQ.0 ) THEN - IF ( LLERI ) THEN - PWORK = P - MWORK = M - ELSE - PWORK = M - MWORK = P - END IF -C - MAXIND = 0 - DO 10 I = 1, PWORK - N = N + INDEX(I) - IF ( INDEX(I).GT.MAXIND ) MAXIND = INDEX(I) - 10 CONTINUE - KPCOEF = MAXIND + 1 - END IF -C - IF( LDA.LT.MAX( 1, N ) ) THEN - INFO = -14 - ELSE IF( LDB.LT.MAX( 1, N ) ) THEN - INFO = -16 - ELSE IF( LDC.LT.MAX( 1, MINDEX ) ) THEN - INFO = -18 - ELSE IF( LDD.LT.MAX( 1, MINDEX ) ) THEN - INFO = -20 - ELSE IF( LDWORK.LT.MAX( 1, MINDEX*( MINDEX + 4 ) ) ) THEN - INFO = -23 - END IF -C - IF ( INFO.NE.0 ) THEN -C -C Error return. -C - CALL XERBLA( 'TC04AD', -INFO ) - RETURN - END IF -C -C Quick return if possible. -C - IF ( M.EQ.0 .OR. P.EQ.0 ) THEN - N = 0 - RCOND = ONE - DWORK(1) = ONE - RETURN - END IF -C - IF ( .NOT.LLERI ) THEN -C -C Initialization for right matrix fraction: obtain the dual -C system. -C - CALL TC01OD( 'R', M, P, KPCOEF, PCOEFF, LDPCO1, LDPCO2, - $ QCOEFF, LDQCO1, LDQCO2, INFO ) - END IF -C -C Store leading row coefficient matrix of P(s). -C - LDW = MAX( 1, PWORK ) - CALL DLACPY( 'Full', PWORK, PWORK, PCOEFF, LDPCO1, DWORK, LDW ) -C -C Check if P(s) is row proper: if not, exit. -C - DWNORM = DLANGE( '1-norm', PWORK, PWORK, DWORK, LDW, DWORK ) -C - CALL DGETRF( PWORK, PWORK, DWORK, LDW, IWORK, INFO ) -C -C Workspace: need PWORK*(PWORK + 4). -C -C (Note: Comments in the code beginning "Workspace:" describe the -C minimal amount of real workspace needed at that point in the -C code, as well as the preferred amount for good performance. -C NB refers to the optimal block size for the immediately -C following subroutine, as returned by ILAENV.) -C - JWORK = LDW*PWORK + 1 -C - CALL DGECON( '1-norm', PWORK, DWORK, LDW, DWNORM, RCOND, - $ DWORK(JWORK), IWORK(PWORK+1), INFO ) -C - WRKOPT = MAX( 1, PWORK*(PWORK + 4) ) -C - IF ( RCOND.LE.DLAMCH( 'Epsilon' ) ) THEN -C -C Error return: P(s) is not row proper. -C - INFO = 1 - RETURN - ELSE -C -C Calculate the order of equivalent state-space representation, -C and initialize A. -C - CALL DLASET( 'Full', N, N, ZERO, ZERO, A, LDA ) -C - DWORK(JWORK) = ONE - IF ( N.GT.1 ) CALL DCOPY( N-1, DWORK(JWORK), 0, A(2,1), LDA+1 ) -C -C Find the PWORK ordered 'non-trivial' columns row by row, -C in PWORK row blocks, the I-th having INDEX(I) rows. -C - IBIAS = 2 -C - DO 50 I = 1, PWORK - KSTOP = INDEX(I) + 1 - IF ( KSTOP.NE.1 ) THEN - IBIAS = IBIAS + INDEX(I) -C -C These rows given from the lower coefficients of row I -C of P(s). -C - DO 40 K = 2, KSTOP - IA = IBIAS - K -C - DO 20 J = 1, PWORK - DWORK(JWORK+J-1) = -PCOEFF(I,J,K) - 20 CONTINUE -C - CALL DGETRS( 'Transpose', PWORK, 1, DWORK, LDW, - $ IWORK, DWORK(JWORK), LDW, INFO ) -C - JA = 0 -C - DO 30 J = 1, PWORK - IF ( INDEX(J).NE.0 ) THEN - JA = JA + INDEX(J) - A(IA,JA) = DWORK(JWORK+J-1) - END IF - 30 CONTINUE -C -C Also, set up B and C (temporarily) for use when -C finding B. -C - CALL DCOPY( MWORK, QCOEFF(I,1,K), LDQCO1, B(IA,1), - $ LDB ) - CALL DCOPY( PWORK, PCOEFF(I,1,K), LDPCO1, C(1,IA), 1 ) - 40 CONTINUE -C - END IF - 50 CONTINUE -C -C Calculate D from the leading coefficients of P and Q. -C - CALL DLACPY( 'Full', PWORK, MWORK, QCOEFF, LDQCO1, D, LDD ) -C - CALL DGETRS( 'No transpose', PWORK, MWORK, DWORK, LDW, IWORK, - $ D, LDD, INFO ) -C -C For B and C as set up above, desired B = B - (C' * D). -C - CALL DGEMM( 'Transpose', 'No transpose', N, MWORK, PWORK, -ONE, - $ C, LDC, D, LDD, ONE, B, LDB ) -C -C Finally, calculate C: zero, apart from ... -C - CALL DLASET( 'Full', PWORK, N, ZERO, ZERO, C, LDC ) -C -C PWORK ordered 'non-trivial' columns, equal to those -C of inv(DWORK). -C -C Workspace: need PWORK*(PWORK + 1); -C prefer PWORK*PWORK + PWORK*NB. -C - CALL DGETRI( PWORK, DWORK, LDW, IWORK, DWORK(JWORK), - $ LDWORK-JWORK+1, INFO ) -C - WRKOPT = MAX( WRKOPT, INT( DWORK(JWORK) )+JWORK-1 ) - JC = 0 - JW = 1 -C - DO 60 J = 1, PWORK - IF ( INDEX(J).NE.0 ) THEN - JC = JC + INDEX(J) - CALL DCOPY( PWORK, DWORK(JW), 1, C(1,JC), 1 ) - END IF - JW = JW + LDW - 60 CONTINUE -C - END IF -C -C For right matrix fraction, return to original (dual of dual) -C system. -C - IF ( .NOT.LLERI ) THEN - CALL TC01OD( 'L', MWORK, PWORK, KPCOEF, PCOEFF, LDPCO1, - $ LDPCO2, QCOEFF, LDQCO1, LDQCO2, INFO ) -C -C Also, obtain dual of state-space representation. -C - CALL AB07MD( 'D', N, MWORK, PWORK, A, LDA, B, LDB, C, LDC, D, - $ LDD, INFO ) - END IF -C -C Set optimal workspace dimension. -C - DWORK(1) = WRKOPT -C - RETURN -C *** Last line of TC04AD *** - END diff --git a/mex/sources/libslicot/TC05AD.f b/mex/sources/libslicot/TC05AD.f deleted file mode 100644 index fc9f65ab0..000000000 --- a/mex/sources/libslicot/TC05AD.f +++ /dev/null @@ -1,403 +0,0 @@ - SUBROUTINE TC05AD( LERI, M, P, SVAL, INDEX, PCOEFF, LDPCO1, - $ LDPCO2, QCOEFF, LDQCO1, LDQCO2, RCOND, CFREQR, - $ LDCFRE, IWORK, DWORK, ZWORK, INFO ) -C -C SLICOT RELEASE 5.0. -C -C Copyright (c) 2002-2009 NICONET e.V. -C -C This program is free software: you can redistribute it and/or -C modify it under the terms of the GNU General Public License as -C published by the Free Software Foundation, either version 2 of -C the License, or (at your option) any later version. -C -C This program is distributed in the hope that it will be useful, -C but WITHOUT ANY WARRANTY; without even the implied warranty of -C MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the -C GNU General Public License for more details. -C -C You should have received a copy of the GNU General Public License -C along with this program. If not, see -C . -C -C PURPOSE -C -C To evaluate the transfer matrix T(s) of a left polynomial matrix -C representation [T(s) = inv(P(s))*Q(s)] or a right polynomial -C matrix representation [T(s) = Q(s)*inv(P(s))] at any specified -C complex frequency s = SVAL. -C -C This routine will calculate the standard frequency response -C matrix at frequency omega if SVAL is supplied as (0.0,omega). -C -C ARGUMENTS -C -C Mode Parameters -C -C LERI CHARACTER*1 -C Indicates whether a left polynomial matrix representation -C or a right polynomial matrix representation is to be used -C to evaluate the transfer matrix as follows: -C = 'L': A left matrix fraction is input; -C = 'R': A right matrix fraction is input. -C -C Input/Output Parameters -C -C M (input) INTEGER -C The number of system inputs. M >= 0. -C -C P (input) INTEGER -C The number of system outputs. P >= 0. -C -C SVAL (input) COMPLEX*16 -C The frequency at which the transfer matrix or the -C frequency respose matrix is to be evaluated. -C For a standard frequency response set the real part -C of SVAL to zero. -C -C INDEX (input) INTEGER array, dimension (MAX(M,P)) -C If LERI = 'L', INDEX(I), I = 1,2,...,P, must contain the -C maximum degree of the polynomials in the I-th row of the -C denominator matrix P(s) of the given left polynomial -C matrix representation. -C If LERI = 'R', INDEX(I), I = 1,2,...,M, must contain the -C maximum degree of the polynomials in the I-th column of -C the denominator matrix P(s) of the given right polynomial -C matrix representation. -C -C PCOEFF (input) DOUBLE PRECISION array, dimension -C (LDPCO1,LDPCO2,kpcoef), where kpcoef = MAX(INDEX(I)) + 1. -C If LERI = 'L' then porm = P, otherwise porm = M. -C The leading porm-by-porm-by-kpcoef part of this array must -C contain the coefficients of the denominator matrix P(s). -C PCOEFF(I,J,K) is the coefficient in s**(INDEX(iorj)-K+1) -C of polynomial (I,J) of P(s), where K = 1,2,...,kpcoef; if -C LERI = 'L' then iorj = I, otherwise iorj = J. -C Thus for LERI = 'L', P(s) = -C diag(s**INDEX(I))*(PCOEFF(.,.,1)+PCOEFF(.,.,2)/s+...). -C If LERI = 'R', PCOEFF is modified by the routine but -C restored on exit. -C -C LDPCO1 INTEGER -C The leading dimension of array PCOEFF. -C LDPCO1 >= MAX(1,P) if LERI = 'L', -C LDPCO1 >= MAX(1,M) if LERI = 'R'. -C -C LDPCO2 INTEGER -C The second dimension of array PCOEFF. -C LDPCO2 >= MAX(1,P) if LERI = 'L', -C LDPCO2 >= MAX(1,M) if LERI = 'R'. -C -C QCOEFF (input) DOUBLE PRECISION array, dimension -C (LDQCO1,LDQCO2,kpcoef) -C If LERI = 'L' then porp = M, otherwise porp = P. -C The leading porm-by-porp-by-kpcoef part of this array must -C contain the coefficients of the numerator matrix Q(s). -C QCOEFF(I,J,K) is defined as for PCOEFF(I,J,K). -C If LERI = 'R', QCOEFF is modified by the routine but -C restored on exit. -C -C LDQCO1 INTEGER -C The leading dimension of array QCOEFF. -C LDQCO1 >= MAX(1,P) if LERI = 'L', -C LDQCO1 >= MAX(1,M,P) if LERI = 'R'. -C -C LDQCO2 INTEGER -C The second dimension of array QCOEFF. -C LDQCO2 >= MAX(1,M) if LERI = 'L', -C LDQCO2 >= MAX(1,M,P) if LERI = 'R'. -C -C RCOND (output) DOUBLE PRECISION -C The estimated reciprocal of the condition number of the -C denominator matrix P(SVAL). -C If RCOND is nearly zero, SVAL is approximately a system -C pole. -C -C CFREQR (output) COMPLEX*16 array, dimension (LDCFRE,MAX(M,P)) -C The leading porm-by-porp part of this array contains the -C frequency response matrix T(SVAL). -C -C LDCFRE INTEGER -C The leading dimension of array CFREQR. -C LDCFRE >= MAX(1,P) if LERI = 'L', -C LDCFRE >= MAX(1,M,P) if LERI = 'R'. -C -C Workspace -C -C IWORK INTEGER array, dimension (liwork) -C where liwork = P, if LERI = 'L', -C liwork = M, if LERI = 'R'. -C -C DWORK DOUBLE PRECISION array, dimension (ldwork) -C where ldwork = 2*P, if LERI = 'L', -C ldwork = 2*M, if LERI = 'R'. -C -C ZWORK COMPLEX*16 array, dimension (lzwork), -C where lzwork = P*(P+2), if LERI = 'L', -C lzwork = M*(M+2), if LERI = 'R'. -C -C Error Indicator -C -C INFO INTEGER -C = 0: successful exit; -C < 0: if INFO = -i, the i-th argument had an illegal -C value; -C = 1: if P(SVAL) is exactly or nearly singular; -C no frequency response is calculated. -C -C METHOD -C -C The method for a left matrix fraction will be described here; -C right matrix fractions are dealt with by obtaining the dual left -C fraction and calculating its frequency response (see SLICOT -C Library routine TC01OD). The first step is to calculate the -C complex value P(SVAL) of the denominator matrix P(s) at the -C desired frequency SVAL. If P(SVAL) is approximately singular, -C SVAL is approximately a pole of this system and so the frequency -C response matrix T(SVAL) is not calculated; in this case, the -C routine returns with the Error Indicator (INFO) set to 1. -C Otherwise, the complex value Q(SVAL) of the numerator matrix Q(s) -C at frequency SVAL is calculated in a similar way to P(SVAL), and -C the desired response matrix T(SVAL) = inv(P(SVAL))*Q(SVAL) is -C found by solving the corresponding system of complex linear -C equations. -C -C REFERENCES -C -C None -C -C NUMERICAL ASPECTS -C 3 -C The algorithm requires 0(N ) operations. -C -C CONTRIBUTOR -C -C Release 3.0: V. Sima, Katholieke Univ. Leuven, Belgium, Dec. 1996. -C Supersedes Release 2.0 routine TC01AD by T.W.C.Williams, Kingston -C Polytechnic, United Kingdom, March 1982. -C -C REVISIONS -C -C February 22, 1998 (changed the name of TC01MD). -C -C KEYWORDS -C -C Coprime matrix fraction, elementary polynomial operations, -C polynomial matrix, state-space representation, transfer matrix. -C -C ****************************************************************** -C -C .. Parameters .. - DOUBLE PRECISION ZERO, ONE - PARAMETER ( ZERO = 0.0D0, ONE = 1.0D0 ) -C .. Scalar Arguments .. - CHARACTER LERI - INTEGER INFO, LDCFRE, LDPCO1, LDPCO2, LDQCO1, LDQCO2, M, - $ P - DOUBLE PRECISION RCOND - COMPLEX*16 SVAL -C .. Array Arguments .. - INTEGER INDEX(*), IWORK(*) - DOUBLE PRECISION DWORK(*), PCOEFF(LDPCO1,LDPCO2,*), - $ QCOEFF(LDQCO1,LDQCO2,*) - COMPLEX*16 CFREQR(LDCFRE,*), ZWORK(*) -C .. Local Scalars .. - LOGICAL LLERI - INTEGER I, IZWORK, IJ, INFO1, J, K, KPCOEF, LDZWOR, - $ MAXIND, MINMP, MPLIM, MWORK, PWORK - DOUBLE PRECISION CNORM -C .. External Functions .. - LOGICAL LSAME - DOUBLE PRECISION DLAMCH, ZLANGE - EXTERNAL DLAMCH, LSAME, ZLANGE -C .. External Subroutines .. - EXTERNAL TC01OD, XERBLA, ZCOPY, ZGECON, ZGETRF, ZGETRS, - $ ZSWAP -C .. Intrinsic Functions .. - INTRINSIC DCMPLX, MAX, MIN -C .. Executable Statements .. -C - INFO = 0 - LLERI = LSAME( LERI, 'L' ) - MPLIM = MAX( M, P ) -C -C Test the input scalar arguments. -C - IF( .NOT.LLERI .AND. .NOT.LSAME( LERI, 'R' ) ) THEN - INFO = -1 - ELSE IF( M.LT.0 ) THEN - INFO = -2 - ELSE IF( P.LT.0 ) THEN - INFO = -3 - ELSE IF( ( LLERI .AND. LDPCO1.LT.MAX( 1, P ) ) .OR. - $ ( .NOT.LLERI .AND. LDPCO1.LT.MAX( 1, M ) ) ) THEN - INFO = -7 - ELSE IF( ( LLERI .AND. LDPCO2.LT.MAX( 1, P ) ) .OR. - $ ( .NOT.LLERI .AND. LDPCO2.LT.MAX( 1, M ) ) ) THEN - INFO = -8 - ELSE IF( ( LLERI .AND. LDQCO1.LT.MAX( 1, P ) ) .OR. - $ ( .NOT.LLERI .AND. LDQCO1.LT.MAX( 1, M, P ) ) ) THEN - INFO = -10 - ELSE IF( ( LLERI .AND. LDQCO2.LT.MAX( 1, M ) ) .OR. - $ ( .NOT.LLERI .AND. LDQCO2.LT.MAX( 1, MPLIM ) ) ) THEN - INFO = -11 - ELSE IF( ( LLERI .AND. LDCFRE.LT.MAX( 1, P ) ) .OR. - $ ( .NOT.LLERI .AND. LDCFRE.LT.MAX( 1, MPLIM ) ) ) THEN - INFO = -14 - END IF -C - IF ( INFO.NE.0 ) THEN -C -C Error return. -C - CALL XERBLA( 'TC05AD', -INFO ) - RETURN - END IF -C -C Quick return if possible. -C - IF ( M.EQ.0 .OR. P.EQ.0 ) THEN - RCOND = ONE - RETURN - END IF -C - IF ( LLERI ) THEN -C -C Initialization for left matrix fraction. -C - PWORK = P - MWORK = M - ELSE -C -C Initialization for right matrix fraction: obtain dual system. -C - PWORK = M - MWORK = P - IF ( MPLIM.GT.1 ) - $ CALL TC01OD( 'R', M, P, KPCOEF, PCOEFF, LDPCO1, LDPCO2, - $ QCOEFF, LDQCO1, LDQCO2, INFO ) - END IF -C - LDZWOR = PWORK - IZWORK = LDZWOR*LDZWOR + 1 - MAXIND = 0 -C - DO 10 I = 1, PWORK - IF ( INDEX(I).GT.MAXIND ) MAXIND = INDEX(I) - 10 CONTINUE -C - KPCOEF = MAXIND + 1 -C -C Calculate the complex denominator matrix P(SVAL), row by row. -C - DO 50 I = 1, PWORK - IJ = I -C - DO 20 J = 1, PWORK - ZWORK(IJ) = DCMPLX( PCOEFF(I,J,1), ZERO ) - IJ = IJ + PWORK - 20 CONTINUE -C -C Possibly non-constant row: finish evaluating it. -C - DO 40 K = 2, INDEX(I) + 1 -C - IJ = I -C - DO 30 J = 1, PWORK - ZWORK(IJ) = ( SVAL*ZWORK(IJ) ) + - $ DCMPLX( PCOEFF(I,J,K), ZERO ) - IJ = IJ + PWORK - 30 CONTINUE -C - 40 CONTINUE -C - 50 CONTINUE -C -C Check if this P(SVAL) is singular: if so, don't compute T(SVAL). -C Note that DWORK is not actually referenced in ZLANGE routine. -C - CNORM = ZLANGE( '1-norm', PWORK, PWORK, ZWORK, LDZWOR, DWORK ) -C - CALL ZGETRF( PWORK, PWORK, ZWORK, LDZWOR, IWORK, INFO ) -C - IF ( INFO.GT.0 ) THEN -C -C Singular matrix. Set INFO and RCOND for error return. -C - INFO = 1 - RCOND = ZERO - ELSE -C -C Estimate the reciprocal condition of P(SVAL). -C Workspace: ZWORK: PWORK*PWORK + 2*PWORK, DWORK: 2*PWORK. -C - CALL ZGECON( '1-norm', PWORK, ZWORK, LDZWOR, CNORM, RCOND, - $ ZWORK(IZWORK), DWORK, INFO ) -C - IF ( RCOND.LE.DLAMCH( 'Epsilon' ) ) THEN -C -C Nearly singular matrix. Set INFO for error return. -C - INFO = 1 - ELSE -C -C Calculate the complex numerator matrix Q(SVAL), row by row. -C - DO 90 I = 1, PWORK -C - DO 60 J = 1, MWORK - CFREQR(I,J) = DCMPLX( QCOEFF(I,J,1), ZERO ) - 60 CONTINUE -C -C Possibly non-constant row: finish evaluating it. -C - DO 80 K = 2, INDEX(I) + 1 -C - DO 70 J = 1, MWORK - CFREQR(I,J) = ( SVAL*CFREQR(I,J) ) + - $ DCMPLX( QCOEFF(I,J,K), ZERO ) - 70 CONTINUE -C - 80 CONTINUE -C - 90 CONTINUE -C -C Now calculate frequency response T(SVAL). -C - CALL ZGETRS( 'No transpose', PWORK, MWORK, ZWORK, LDZWOR, - $ IWORK, CFREQR, LDCFRE, INFO ) - END IF - END IF -C -C For right matrix fraction, return to original (dual of the dual) -C system. -C - IF ( ( .NOT.LLERI ) .AND. ( MPLIM.NE.1 ) ) THEN - CALL TC01OD( 'L', MWORK, PWORK, KPCOEF, PCOEFF, LDPCO1, - $ LDPCO2, QCOEFF, LDQCO1, LDQCO2, INFO1 ) -C - IF ( INFO.EQ.0 ) THEN -C -C Also, transpose T(SVAL) here if this was successfully -C calculated. -C - MINMP = MIN( M, P ) -C - DO 100 J = 1, MPLIM - IF ( J.LT.MINMP ) THEN - CALL ZSWAP( MINMP-J, CFREQR(J+1,J), 1, CFREQR(J,J+1), - $ LDCFRE ) - ELSE IF ( J.GT.P ) THEN - CALL ZCOPY( P, CFREQR(1,J), 1, CFREQR(J,1), LDCFRE ) - ELSE IF ( J.GT.M ) THEN - CALL ZCOPY( M, CFREQR(J,1), LDCFRE, CFREQR(1,J), 1 ) - END IF - 100 CONTINUE -C - END IF - END IF -C - RETURN -C *** Last line of TC05AD *** - END diff --git a/mex/sources/libslicot/TD03AD.f b/mex/sources/libslicot/TD03AD.f deleted file mode 100644 index b06678a78..000000000 --- a/mex/sources/libslicot/TD03AD.f +++ /dev/null @@ -1,581 +0,0 @@ - SUBROUTINE TD03AD( ROWCOL, LERI, EQUIL, M, P, INDEXD, DCOEFF, - $ LDDCOE, UCOEFF, LDUCO1, LDUCO2, NR, A, LDA, B, - $ LDB, C, LDC, D, LDD, INDEXP, PCOEFF, LDPCO1, - $ LDPCO2, QCOEFF, LDQCO1, LDQCO2, VCOEFF, LDVCO1, - $ LDVCO2, TOL, IWORK, DWORK, LDWORK, INFO ) -C -C SLICOT RELEASE 5.0. -C -C Copyright (c) 2002-2009 NICONET e.V. -C -C This program is free software: you can redistribute it and/or -C modify it under the terms of the GNU General Public License as -C published by the Free Software Foundation, either version 2 of -C the License, or (at your option) any later version. -C -C This program is distributed in the hope that it will be useful, -C but WITHOUT ANY WARRANTY; without even the implied warranty of -C MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the -C GNU General Public License for more details. -C -C You should have received a copy of the GNU General Public License -C along with this program. If not, see -C . -C -C PURPOSE -C -C To find a relatively prime left or right polynomial matrix -C representation for a proper transfer matrix T(s) given as either -C row or column polynomial vectors over common denominator -C polynomials, possibly with uncancelled common terms. -C -C ARGUMENTS -C -C Mode Parameters -C -C ROWCOL CHARACTER*1 -C Indicates whether T(s) is to be factorized by rows or by -C columns as follows: -C = 'R': T(s) is factorized by rows; -C = 'C': T(s) is factorized by columns. -C -C LERI CHARACTER*1 -C Indicates whether a left or a right polynomial matrix -C representation is required as follows: -C = 'L': A left polynomial matrix representation -C inv(P(s))*Q(s) is required; -C = 'R': A right polynomial matrix representation -C Q(s)*inv(P(s)) is required. -C -C EQUIL CHARACTER*1 -C Specifies whether the user wishes to balance the triplet -C (A,B,C), before computing a minimal state-space -C representation, as follows: -C = 'S': Perform balancing (scaling); -C = 'N': Do not perform balancing. -C -C Input/Output Parameters -C -C M (input) INTEGER -C The number of system inputs. M >= 0. -C -C P (input) INTEGER -C The number of system outputs. P >= 0. -C -C INDEXD (input) INTEGER array, dimension (P), if ROWCOL = 'R', or -C dimension (M), if ROWCOL = 'C'. -C The leading pormd elements of this array must contain the -C row degrees of the denominator polynomials in D(s). -C pormd = P if the transfer matrix T(s) is given as row -C polynomial vectors over denominator polynomials; -C pormd = M if the transfer matrix T(s) is given as column -C polynomial vectors over denominator polynomials. -C -C DCOEFF (input) DOUBLE PRECISION array, dimension (LDDCOE,kdcoef), -C where kdcoef = MAX(INDEXD(I)) + 1. -C The leading pormd-by-kdcoef part of this array must -C contain the coefficients of each denominator polynomial. -C DCOEFF(I,K) is the coefficient in s**(INDEXD(I)-K+1) of -C the I-th denominator polynomial in D(s), where K = 1,2, -C ...,kdcoef. -C -C LDDCOE INTEGER -C The leading dimension of array DCOEFF. -C LDDCOE >= MAX(1,P), if ROWCOL = 'R'; -C LDDCOE >= MAX(1,M), if ROWCOL = 'C'. -C -C UCOEFF (input) DOUBLE PRECISION array, dimension -C (LDUCO1,LDUCO2,kdcoef) -C The leading P-by-M-by-kdcoef part of this array must -C contain the coefficients of the numerator matrix U(s); -C if ROWCOL = 'C', this array is modified internally but -C restored on exit, and the remainder of the leading -C MAX(M,P)-by-MAX(M,P)-by-kdcoef part is used as internal -C workspace. -C UCOEFF(I,J,K) is the coefficient in s**(INDEXD(iorj)-K+1) -C of polynomial (I,J) of U(s), where K = 1,2,...,kdcoef; -C iorj = I if T(s) is given as row polynomial vectors over -C denominator polynomials; iorj = J if T(s) is given as -C column polynomial vectors over denominator polynomials. -C Thus for ROWCOL = 'R', U(s) = -C diag(s**INDEXD(I))*(UCOEFF(.,.,1)+UCOEFF(.,.,2)/s+...). -C -C LDUCO1 INTEGER -C The leading dimension of array UCOEFF. -C LDUCO1 >= MAX(1,P), if ROWCOL = 'R'; -C LDUCO1 >= MAX(1,M,P), if ROWCOL = 'C'. -C -C LDUCO2 INTEGER -C The second dimension of array UCOEFF. -C LDUCO2 >= MAX(1,M), if ROWCOL = 'R'; -C LDUCO2 >= MAX(1,M,P), if ROWCOL = 'C'. -C -C NR (output) INTEGER -C The order of the resulting minimal realization, i.e. the -C order of the state dynamics matrix A. -C -C A (output) DOUBLE PRECISION array, dimension (LDA,N), -C pormd -C where N = SUM INDEXD(I) -C I=1 -C The leading NR-by-NR part of this array contains the upper -C block Hessenberg state dynamics matrix A. -C -C LDA INTEGER -C The leading dimension of array A. LDA >= MAX(1,N). -C -C B (output) DOUBLE PRECISION array, dimension (LDB,MAX(M,P)) -C The leading NR-by-M part of this array contains the -C input/state matrix B; the remainder of the leading -C N-by-MAX(M,P) part is used as internal workspace. -C -C LDB INTEGER -C The leading dimension of array B. LDB >= MAX(1,N). -C -C C (output) DOUBLE PRECISION array, dimension (LDC,N) -C The leading P-by-NR part of this array contains the -C state/output matrix C; the remainder of the leading -C MAX(M,P)-by-N part is used as internal workspace. -C -C LDC INTEGER -C The leading dimension of array C. LDC >= MAX(1,M,P). -C -C D (output) DOUBLE PRECISION array, dimension (LDD,MAX(M,P)) -C The leading P-by-M part of this array contains the direct -C transmission matrix D; the remainder of the leading -C MAX(M,P)-by-MAX(M,P) part is used as internal workspace. -C -C LDD INTEGER -C The leading dimension of array D. LDD >= MAX(1,M,P). -C -C INDEXP (output) INTEGER array, dimension (P), if ROWCOL = 'R', or -C dimension (M), if ROWCOL = 'C'. -C The leading pormp elements of this array contain the -C row (column if ROWCOL = 'C') degrees of the denominator -C matrix P(s). -C pormp = P if a left polynomial matrix representation -C is requested; pormp = M if a right polynomial matrix -C representation is requested. -C These elements are ordered so that -C INDEXP(1) >= INDEXP(2) >= ... >= INDEXP(pormp). -C -C PCOEFF (output) DOUBLE PRECISION array, dimension -C (LDPCO1,LDPCO2,N+1) -C The leading pormp-by-pormp-by-kpcoef part of this array -C contains the coefficients of the denominator matrix P(s), -C where kpcoef = MAX(INDEXP(I)) + 1. -C PCOEFF(I,J,K) is the coefficient in s**(INDEXP(iorj)-K+1) -C of polynomial (I,J) of P(s), where K = 1,2,...,kpcoef; -C iorj = I if a left polynomial matrix representation is -C requested; iorj = J if a right polynomial matrix -C representation is requested. -C Thus for a left polynomial matrix representation, P(s) = -C diag(s**INDEXP(I))*(PCOEFF(.,.,1)+PCOEFF(.,.,2)/s+...). -C -C LDPCO1 INTEGER -C The leading dimension of array PCOEFF. -C LDPCO1 >= MAX(1,P), if ROWCOL = 'R'; -C LDPCO1 >= MAX(1,M), if ROWCOL = 'C'. -C -C LDPCO2 INTEGER -C The second dimension of array PCOEFF. -C LDPCO2 >= MAX(1,P), if ROWCOL = 'R'; -C LDPCO2 >= MAX(1,M), if ROWCOL = 'C'. -C -C QCOEFF (output) DOUBLE PRECISION array, dimension -C (LDQCO1,LDQCO2,N+1) -C The leading pormp-by-pormd-by-kpcoef part of this array -C contains the coefficients of the numerator matrix Q(s). -C QCOEFF(I,J,K) is defined as for PCOEFF(I,J,K). -C -C LDQCO1 INTEGER -C The leading dimension of array QCOEFF. -C If LERI = 'L', LDQCO1 >= MAX(1,PM), -C where PM = P, if ROWCOL = 'R'; -C PM = M, if ROWCOL = 'C'. -C If LERI = 'R', LDQCO1 >= MAX(1,M,P). -C -C LDQCO2 INTEGER -C The second dimension of array QCOEFF. -C If LERI = 'L', LDQCO2 >= MAX(1,MP), -C where MP = M, if ROWCOL = 'R'; -C MP = P, if ROWCOL = 'C'. -C If LERI = 'R', LDQCO2 >= MAX(1,M,P). -C -C VCOEFF (output) DOUBLE PRECISION array, dimension -C (LDVCO1,LDVCO2,N+1) -C The leading pormp-by-NR-by-kpcoef part of this array -C contains the coefficients of the intermediate matrix -C V(s) as produced by SLICOT Library routine TB03AD. -C -C LDVCO1 INTEGER -C The leading dimension of array VCOEFF. -C LDVCO1 >= MAX(1,P), if ROWCOL = 'R'; -C LDVCO1 >= MAX(1,M), if ROWCOL = 'C'. -C -C LDVCO2 INTEGER -C The second dimension of array VCOEFF. LDVCO2 >= MAX(1,N). -C -C Tolerances -C -C TOL DOUBLE PRECISION -C The tolerance to be used in rank determination when -C transforming (A, B, C). If the user sets TOL > 0, then -C the given value of TOL is used as a lower bound for the -C reciprocal condition number (see the description of the -C argument RCOND in the SLICOT routine MB03OD); a -C (sub)matrix whose estimated condition number is less than -C 1/TOL is considered to be of full rank. If the user sets -C TOL <= 0, then an implicitly computed, default tolerance -C (determined by the SLICOT routine TB01UD) is used instead. -C -C Workspace -C -C IWORK INTEGER array, dimension (N+MAX(M,P)) -C On exit, if INFO = 0, the first nonzero elements of -C IWORK(1:N) return the orders of the diagonal blocks of A. -C -C DWORK DOUBLE PRECISION array, dimension (LDWORK) -C On exit, if INFO = 0, DWORK(1) returns the optimal value -C of LDWORK. -C -C LDWORK INTEGER -C The length of the array DWORK. -C LDWORK >= MAX(1, N + MAX(N, 3*M, 3*P), PM*(PM + 2)) -C where PM = P, if ROWCOL = 'R'; -C PM = M, if ROWCOL = 'C'. -C For optimum performance LDWORK should be larger. -C -C Error Indicator -C -C INFO INTEGER -C = 0: successful exit; -C < 0: if INFO = -i, the i-th argument had an illegal -C value; -C > 0: if INFO = i (i <= k = pormd), then i is the first -C integer I for which ABS( DCOEFF(I,1) ) is so small -C that the calculations would overflow (see SLICOT -C Library routine TD03AY); that is, the leading -C coefficient of a polynomial is nearly zero; no -C state-space representation or polynomial matrix -C representation is calculated; -C = k+1: if a singular matrix was encountered during the -C computation of V(s); -C = k+2: if a singular matrix was encountered during the -C computation of P(s). -C -C METHOD -C -C The method for transfer matrices factorized by rows will be -C described here; T(s) factorized by columns is dealt with by -C operating on the dual T'(s). The description for T(s) is actually -C the left polynomial matrix representation -C -C T(s) = inv(D(s))*U(s), -C -C where D(s) is diagonal with its (I,I)-th polynomial element of -C degree INDEXD(I). The first step is to check whether the leading -C coefficient of any polynomial element of D(s) is approximately -C zero, if so the routine returns with INFO > 0. Otherwise, -C Wolovich's Observable Structure Theorem is used to construct a -C state-space representation in observable companion form which is -C equivalent to the above polynomial matrix representation. The -C method is particularly easy here due to the diagonal form of D(s). -C This state-space representation is not necessarily controllable -C (as D(s) and U(s) are not necessarily relatively left prime), but -C it is in theory completely observable; however, its observability -C matrix may be poorly conditioned, so it is treated as a general -C state-space representation and SLICOT Library routine TB03AD is -C used to separate out a minimal realization for T(s) from it by -C means of orthogonal similarity transformations and then to -C calculate a relatively prime (left or right) polynomial matrix -C representation which is equivalent to this. -C -C REFERENCES -C -C [1] Patel, R.V. -C On Computing Matrix Fraction Descriptions and Canonical -C Forms of Linear Time-Invariant Systems. -C UMIST Control Systems Centre Report 489, 1980. -C -C [2] Wolovich, W.A. -C Linear Multivariable Systems, (Theorem 4.3.3). -C Springer-Verlag, 1974. -C -C NUMERICAL ASPECTS -C 3 -C The algorithm requires 0(N ) operations. -C -C CONTRIBUTOR -C -C V. Sima, Katholieke Univ. Leuven, Belgium, Apr. 1998. -C Supersedes Release 3.0 routine TD01ND. -C -C REVISIONS -C -C - -C -C KEYWORDS -C -C Coprime matrix fraction, elementary polynomial operations, -C polynomial matrix, state-space representation, transfer matrix. -C -C ****************************************************************** -C -C .. Parameters .. - DOUBLE PRECISION ZERO, ONE - PARAMETER ( ZERO = 0.0D0, ONE = 1.0D0 ) -C .. Scalar Arguments .. - CHARACTER EQUIL, LERI, ROWCOL - INTEGER INFO, LDA, LDB, LDC, LDD, LDDCOE, LDPCO1, - $ LDPCO2, LDQCO1, LDQCO2, LDUCO1, LDUCO2, LDVCO1, - $ LDVCO2, LDWORK, M, NR, P - DOUBLE PRECISION TOL -C .. Array Arguments .. - INTEGER INDEXD(*), INDEXP(*), IWORK(*) - DOUBLE PRECISION A(LDA,*), B(LDB,*), C(LDC,*), D(LDD,*), - $ DCOEFF(LDDCOE,*), DWORK(*), - $ PCOEFF(LDPCO1,LDPCO2,*), - $ QCOEFF(LDQCO1,LDQCO2,*), - $ UCOEFF(LDUCO1,LDUCO2,*), VCOEFF(LDVCO1,LDVCO2,*) -C .. Local Scalars .. - LOGICAL LEQUIL, LLERI, LROWCO - INTEGER I, IDUAL, ITEMP, J, JSTOP, K, KDCOEF, KPCOEF, - $ MAXMP, MPLIM, MWORK, N, PWORK -C .. External Functions .. - LOGICAL LSAME - EXTERNAL LSAME -C .. External Subroutines .. - EXTERNAL AB07MD, DLACPY, DSWAP, TB01XD, TB03AD, TC01OD, - $ TD03AY, XERBLA -C .. Intrinsic Functions .. - INTRINSIC MAX -C .. Executable Statements .. -C - INFO = 0 - LROWCO = LSAME( ROWCOL, 'R' ) - LLERI = LSAME( LERI, 'L' ) - LEQUIL = LSAME( EQUIL, 'S' ) -C -C Test the input scalar arguments. -C - MAXMP = MAX( M, P ) - MPLIM = MAX( 1, MAXMP ) - IF ( LROWCO ) THEN -C -C Initialization for T(s) given as rows over common denominators. -C - PWORK = P - MWORK = M - ELSE -C -C Initialization for T(s) given as columns over common -C denominators. -C - PWORK = M - MWORK = P - END IF -C - IF( .NOT.LROWCO .AND. .NOT.LSAME( ROWCOL, 'C' ) ) THEN - INFO = -1 - ELSE IF( .NOT.LLERI .AND. .NOT.LSAME( LERI, 'R' ) ) THEN - INFO = -2 - ELSE IF( .NOT.LEQUIL .AND. .NOT.LSAME( EQUIL, 'N' ) ) THEN - INFO = -3 - ELSE IF( M.LT.0 ) THEN - INFO = -4 - ELSE IF( P.LT.0 ) THEN - INFO = -5 - ELSE IF( LDDCOE.LT.MAX( 1, PWORK ) ) THEN - INFO = -8 - ELSE IF( LDUCO1.LT.MAX( 1, PWORK ) .OR. ( .NOT.LROWCO .AND. - $ LDUCO1.LT.MPLIM ) ) THEN - INFO = -10 - ELSE IF( LDUCO2.LT.MAX( 1, MWORK ) .OR. ( .NOT.LROWCO .AND. - $ LDUCO2.LT.MPLIM ) ) THEN - INFO = -11 - END IF -C - N = 0 - IF ( INFO.EQ.0 ) THEN -C -C Calculate N, the order of the resulting state-space -C representation, and the index kdcoef. -C - KDCOEF = 0 -C - DO 10 I = 1, PWORK - KDCOEF = MAX( KDCOEF, INDEXD(I) ) - N = N + INDEXD(I) - 10 CONTINUE -C - KDCOEF = KDCOEF + 1 -C - IF( LDA.LT.MAX( 1, N ) ) THEN - INFO = -14 - ELSE IF( LDB.LT.MAX( 1, N ) ) THEN - INFO = -16 - ELSE IF( LDC.LT.MPLIM ) THEN - INFO = -18 - ELSE IF( LDD.LT.MPLIM ) THEN - INFO = -20 - ELSE IF( LDPCO1.LT.PWORK ) THEN - INFO = -23 - ELSE IF( LDPCO2.LT.PWORK ) THEN - INFO = -24 - ELSE IF( LDQCO1.LT.MAX( 1, PWORK ) .OR. ( .NOT.LLERI .AND. - $ LDQCO1.LT.MPLIM ) ) THEN - INFO = -26 - ELSE IF( LDQCO2.LT.MAX( 1, MWORK ) .OR. ( .NOT.LLERI .AND. - $ LDQCO2.LT.MPLIM ) ) THEN - INFO = -27 - ELSE IF( LDVCO1.LT.MAX( 1, PWORK ) ) THEN - INFO = -29 - ELSE IF( LDVCO2.LT.MAX( 1, N ) ) THEN - INFO = -30 -C - ELSE IF( LDWORK.LT.MAX( 1, N + MAX( N, 3*MAXMP ), - $ PWORK*( PWORK + 2 ) ) ) THEN - INFO = -34 - END IF - END IF -C - IF ( INFO.NE.0 ) THEN -C -C Error return. -C - CALL XERBLA( 'TD03AD', -INFO ) - RETURN - END IF -C -C Quick return if possible. -C - IF ( MAX( N, M, P ).EQ.0 ) THEN - NR = 0 - DWORK(1) = ONE - RETURN - END IF -C -C IDUAL = 1 iff precisely ROWCOL = 'C' or (exclusively) LERI = 'R', -C i.e. iff AB07MD call is required before TB03AD. -C - IDUAL = 0 - IF ( .NOT.LROWCO ) IDUAL = 1 - IF ( .NOT.LLERI ) IDUAL = IDUAL + 1 -C - IF ( .NOT.LROWCO ) THEN -C -C Initialize the remainder of the leading -C MPLIM-by-MPLIM-by-KDCOEF part of U(s) to zero. -C - IF ( P.LT.M ) THEN -C - DO 20 K = 1, KDCOEF - CALL DLACPY( 'Full', M-P, MPLIM, ZERO, ZERO, - $ UCOEFF(P+1,1,K), LDUCO1 ) - 20 CONTINUE -C - ELSE IF ( P.GT.M ) THEN -C - DO 30 K = 1, KDCOEF - CALL DLACPY( 'Full', MPLIM, P-M, ZERO, ZERO, - $ UCOEFF(1,M+1,K), LDUCO1 ) - 30 CONTINUE -C - END IF -C - IF ( MPLIM.NE.1 ) THEN -C -C Non-scalar T(s) factorized by columns: transpose it -C (i.e. U(s)). -C - JSTOP = MPLIM - 1 -C - DO 50 K = 1, KDCOEF -C - DO 40 J = 1, JSTOP - CALL DSWAP( MPLIM-J, UCOEFF(J+1,J,K), 1, - $ UCOEFF(J,J+1,K), LDUCO1 ) - 40 CONTINUE -C - 50 CONTINUE -C - END IF - END IF -C -C Construct non-minimal state-space representation (by Wolovich's -C Structure Theorem) which has transfer matrix T(s) or T'(s) as -C appropriate, -C - CALL TD03AY( MWORK, PWORK, INDEXD, DCOEFF, LDDCOE, UCOEFF, LDUCO1, - $ LDUCO2, N, A, LDA, B, LDB, C, LDC, D, LDD, INFO ) - IF ( INFO.GT.0 ) - $ RETURN -C - IF ( IDUAL.EQ.1 ) THEN -C -C and then obtain (MWORK x PWORK) dual of this system if -C appropriate. -C - CALL AB07MD( 'D', N, MWORK, PWORK, A, LDA, B, LDB, C, LDC, D, - $ LDD, INFO ) - ITEMP = PWORK - PWORK = MWORK - MWORK = ITEMP - END IF -C -C Find left polynomial matrix representation (and minimal -C state-space representation en route) for the relevant state-space -C representation ... -C - CALL TB03AD( 'Left', EQUIL, N, MWORK, PWORK, A, LDA, B, LDB, C, - $ LDC, D, LDD, NR, INDEXP, PCOEFF, LDPCO1, LDPCO2, - $ QCOEFF, LDQCO1, LDQCO2, VCOEFF, LDVCO1, LDVCO2, TOL, - $ IWORK, DWORK, LDWORK, INFO ) -C - IF ( INFO.GT.0 ) THEN - INFO = PWORK + INFO - RETURN - END IF -C - IF ( .NOT.LLERI ) THEN -C -C and, if a right polynomial matrix representation is required, -C transpose and reorder (to get a block upper Hessenberg -C matrix A). -C - K = IWORK(1) - 1 - IF ( N.GE.2 ) - $ K = K + IWORK(2) - CALL TB01XD( 'D', NR, MWORK, PWORK, K, NR-1, A, LDA, B, LDB, C, - $ LDC, D, LDD, INFO ) -C - KPCOEF = 0 -C - DO 60 I = 1, PWORK - KPCOEF = MAX( KPCOEF, INDEXP(I) ) - 60 CONTINUE -C - KPCOEF = KPCOEF + 1 - CALL TC01OD( 'L', MWORK, PWORK, KPCOEF, PCOEFF, LDPCO1, LDPCO2, - $ QCOEFF, LDQCO1, LDQCO2, INFO ) - END IF -C - IF ( ( .NOT.LROWCO ) .AND. ( MPLIM.NE.1 ) ) THEN -C -C If non-scalar T(s) originally given by columns, -C retranspose U(s). -C - DO 80 K = 1, KDCOEF -C - DO 70 J = 1, JSTOP - CALL DSWAP( MPLIM-J, UCOEFF(J+1,J,K), 1, UCOEFF(J,J+1,K), - $ LDUCO1 ) - 70 CONTINUE -C - 80 CONTINUE -C - END IF - RETURN -C *** Last line of TD03AD *** - END diff --git a/mex/sources/libslicot/TD03AY.f b/mex/sources/libslicot/TD03AY.f deleted file mode 100644 index 90d53eee2..000000000 --- a/mex/sources/libslicot/TD03AY.f +++ /dev/null @@ -1,171 +0,0 @@ - SUBROUTINE TD03AY( MWORK, PWORK, INDEX, DCOEFF, LDDCOE, UCOEFF, - $ LDUCO1, LDUCO2, N, A, LDA, B, LDB, C, LDC, D, - $ LDD, INFO ) -C -C SLICOT RELEASE 5.0. -C -C Copyright (c) 2002-2009 NICONET e.V. -C -C This program is free software: you can redistribute it and/or -C modify it under the terms of the GNU General Public License as -C published by the Free Software Foundation, either version 2 of -C the License, or (at your option) any later version. -C -C This program is distributed in the hope that it will be useful, -C but WITHOUT ANY WARRANTY; without even the implied warranty of -C MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the -C GNU General Public License for more details. -C -C You should have received a copy of the GNU General Public License -C along with this program. If not, see -C . -C -C Calculates a state-space representation for a (PWORK x MWORK) -C transfer matrix given in the form of polynomial row vectors over -C common denominators (not necessarily lcd's). Such a description -C is simply the polynomial matrix representation -C -C T(s) = inv(D(s)) * U(s), -C -C where D(s) is diagonal with (I,I)-th element D:I(s) of degree -C INDEX(I); applying Wolovich's Observable Structure Theorem to -C this left matrix fraction then yields an equivalent state-space -C representation in observable companion form, of order -C N = sum(INDEX(I)). As D(s) is diagonal, the PWORK ordered -C 'non-trivial' columns of C and A are very simply calculated, these -C submatrices being diagonal and (INDEX(I) x 1) - block diagonal, -C respectively: finding B and D is also somewhat simpler than for -C general P(s) as dealt with in TC04AD. Finally, the state-space -C representation obtained here is not necessarily controllable -C (as D(s) and U(s) are not necessarily relatively left prime), but -C it is theoretically completely observable: however, its -C observability matrix may be poorly conditioned, so it is safer -C not to assume observability either. -C -C REVISIONS -C -C May 13, 1998. -C -C KEYWORDS -C -C Coprime matrix fraction, elementary polynomial operations, -C polynomial matrix, state-space representation, transfer matrix. -C -C ****************************************************************** -C - DOUBLE PRECISION ZERO, ONE - PARAMETER ( ZERO = 0.0D0, ONE = 1.0D0 ) -C .. Scalar Arguments .. - INTEGER INFO, LDA, LDB, LDC, LDD, LDDCOE, LDUCO1, - $ LDUCO2, MWORK, N, PWORK -C .. Array Arguments .. - INTEGER INDEX(*) - DOUBLE PRECISION A(LDA,*), B(LDB,*), C(LDC,*), D(LDD,*), - $ DCOEFF(LDDCOE,*), UCOEFF(LDUCO1,LDUCO2,*) -C .. Local Scalars .. - INTEGER I, IA, IBIAS, INDCUR, JA, JMAX1, K - DOUBLE PRECISION ABSDIA, ABSDMX, BIGNUM, DIAG, SMLNUM, UMAX1, - $ TEMP -C .. External Functions .. - INTEGER IDAMAX - DOUBLE PRECISION DLAMCH - EXTERNAL DLAMCH, IDAMAX -C .. External Subroutines .. - EXTERNAL DAXPY, DCOPY, DLASET, DSCAL -C .. Intrinsic Functions .. - INTRINSIC ABS -C .. Executable Statements .. -C - INFO = 0 -C -C Initialize A and C to be zero, apart from 1's on the subdiagonal -C of A. -C - CALL DLASET( 'Upper', N, N, ZERO, ZERO, A, LDA ) - IF ( N.GT.1 ) CALL DLASET( 'Lower', N-1, N-1, ZERO, ONE, A(2,1), - $ LDA ) -C - CALL DLASET( 'Full', PWORK, N, ZERO, ZERO, C, LDC ) -C -C Calculate B and D, as well as 'non-trivial' elements of A and C. -C Check if any leading coefficient of D(s) nearly zero: if so, exit. -C Caution is taken to avoid overflow. -C - SMLNUM = DLAMCH( 'Safe minimum' ) / DLAMCH( 'Precision' ) - BIGNUM = ONE / SMLNUM -C - IBIAS = 2 - JA = 0 -C - DO 20 I = 1, PWORK - ABSDIA = ABS( DCOEFF(I,1) ) - JMAX1 = IDAMAX( MWORK, UCOEFF(I,1,1), LDUCO1 ) - UMAX1 = ABS( UCOEFF(I,JMAX1,1) ) - IF ( ( ABSDIA.LT.SMLNUM ) .OR. - $ ( ABSDIA.LT.ONE .AND. UMAX1.GT.ABSDIA*BIGNUM ) ) THEN -C -C Error return. -C - INFO = I - RETURN - END IF - DIAG = ONE/DCOEFF(I,1) - INDCUR = INDEX(I) - IF ( INDCUR.NE.0 ) THEN - IBIAS = IBIAS + INDCUR - JA = JA + INDCUR - IF ( INDCUR.GE.1 ) THEN - JMAX1 = IDAMAX( INDCUR, DCOEFF(I,2), LDDCOE ) - ABSDMX = ABS( DCOEFF(I,JMAX1) ) - IF ( ABSDIA.GE.ONE ) THEN - IF ( UMAX1.GT.ONE ) THEN - IF ( ( ABSDMX/ABSDIA ).GT.( BIGNUM/UMAX1 ) ) THEN -C -C Error return. -C - INFO = I - RETURN - END IF - END IF - ELSE - IF ( UMAX1.GT.ONE ) THEN - IF ( ABSDMX.GT.( BIGNUM*ABSDIA )/UMAX1 ) THEN -C -C Error return. -C - INFO = I - RETURN - END IF - END IF - END IF - END IF -C -C I-th 'non-trivial' sub-vector of A given from coefficients -C of D:I(s), while I-th row block of B given from this and -C row I of U(s). -C - DO 10 K = 2, INDCUR + 1 - IA = IBIAS - K - TEMP = -DIAG*DCOEFF(I,K) - A(IA,JA) = TEMP -C - CALL DCOPY( MWORK, UCOEFF(I,1,K), LDUCO1, B(IA,1), LDB ) - CALL DAXPY( MWORK, TEMP, UCOEFF(I,1,1), LDUCO1, B(IA,1), - $ LDB ) - 10 CONTINUE -C - IF ( JA.LT.N ) A(JA+1,JA) = ZERO -C -C Finally, I-th 'non-trivial' entry of C and row of D obtained -C also. -C - C(I,JA) = DIAG - END IF -C - CALL DCOPY( MWORK, UCOEFF(I,1,1), LDUCO1, D(I,1), LDD ) - CALL DSCAL( MWORK, DIAG, D(I,1), LDD ) - 20 CONTINUE -C - RETURN -C *** Last line of TD03AY *** - END diff --git a/mex/sources/libslicot/TD04AD.f b/mex/sources/libslicot/TD04AD.f deleted file mode 100644 index 9297cee09..000000000 --- a/mex/sources/libslicot/TD04AD.f +++ /dev/null @@ -1,425 +0,0 @@ - SUBROUTINE TD04AD( ROWCOL, M, P, INDEX, DCOEFF, LDDCOE, UCOEFF, - $ LDUCO1, LDUCO2, NR, A, LDA, B, LDB, C, LDC, D, - $ LDD, TOL, IWORK, DWORK, LDWORK, INFO ) -C -C SLICOT RELEASE 5.0. -C -C Copyright (c) 2002-2009 NICONET e.V. -C -C This program is free software: you can redistribute it and/or -C modify it under the terms of the GNU General Public License as -C published by the Free Software Foundation, either version 2 of -C the License, or (at your option) any later version. -C -C This program is distributed in the hope that it will be useful, -C but WITHOUT ANY WARRANTY; without even the implied warranty of -C MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the -C GNU General Public License for more details. -C -C You should have received a copy of the GNU General Public License -C along with this program. If not, see -C . -C -C PURPOSE -C -C To find a minimal state-space representation (A,B,C,D) for a -C proper transfer matrix T(s) given as either row or column -C polynomial vectors over denominator polynomials, possibly with -C uncancelled common terms. -C -C ARGUMENTS -C -C Mode Parameters -C -C ROWCOL CHARACTER*1 -C Indicates whether the transfer matrix T(s) is given as -C rows or columns over common denominators as follows: -C = 'R': T(s) is given as rows over common denominators; -C = 'C': T(s) is given as columns over common denominators. -C -C Input/Output Parameters -C -C M (input) INTEGER -C The number of system inputs. M >= 0. -C -C P (input) INTEGER -C The number of system outputs. P >= 0. -C -C INDEX (input) INTEGER array, dimension (porm), where porm = P, -C if ROWCOL = 'R', and porm = M, if ROWCOL = 'C'. -C This array must contain the degrees of the denominator -C polynomials in D(s). -C -C DCOEFF (input) DOUBLE PRECISION array, dimension (LDDCOE,kdcoef), -C where kdcoef = MAX(INDEX(I)) + 1. -C The leading porm-by-kdcoef part of this array must contain -C the coefficients of each denominator polynomial. -C DCOEFF(I,K) is the coefficient in s**(INDEX(I)-K+1) of the -C I-th denominator polynomial in D(s), where -C K = 1,2,...,kdcoef. -C -C LDDCOE INTEGER -C The leading dimension of array DCOEFF. -C LDDCOE >= MAX(1,P) if ROWCOL = 'R'; -C LDDCOE >= MAX(1,M) if ROWCOL = 'C'. -C -C UCOEFF (input) DOUBLE PRECISION array, dimension -C (LDUCO1,LDUCO2,kdcoef) -C The leading P-by-M-by-kdcoef part of this array must -C contain the numerator matrix U(s); if ROWCOL = 'C', this -C array is modified internally but restored on exit, and the -C remainder of the leading MAX(M,P)-by-MAX(M,P)-by-kdcoef -C part is used as internal workspace. -C UCOEFF(I,J,K) is the coefficient in s**(INDEX(iorj)-K+1) -C of polynomial (I,J) of U(s), where K = 1,2,...,kdcoef; -C if ROWCOL = 'R' then iorj = I, otherwise iorj = J. -C Thus for ROWCOL = 'R', U(s) = -C diag(s**INDEX(I))*(UCOEFF(.,.,1)+UCOEFF(.,.,2)/s+...). -C -C LDUCO1 INTEGER -C The leading dimension of array UCOEFF. -C LDUCO1 >= MAX(1,P) if ROWCOL = 'R'; -C LDUCO1 >= MAX(1,M,P) if ROWCOL = 'C'. -C -C LDUCO2 INTEGER -C The second dimension of array UCOEFF. -C LDUCO2 >= MAX(1,M) if ROWCOL = 'R'; -C LDUCO2 >= MAX(1,M,P) if ROWCOL = 'C'. -C -C NR (output) INTEGER -C The order of the resulting minimal realization, i.e. the -C order of the state dynamics matrix A. -C -C A (output) DOUBLE PRECISION array, dimension (LDA,N), -C porm -C where N = SUM INDEX(I). -C I=1 -C The leading NR-by-NR part of this array contains the upper -C block Hessenberg state dynamics matrix A of a minimal -C realization. -C -C LDA INTEGER -C The leading dimension of array A. LDA >= MAX(1,N). -C -C B (output) DOUBLE PRECISION array, dimension (LDB,MAX(M,P)) -C The leading NR-by-M part of this array contains the -C input/state matrix B of a minimal realization; the -C remainder of the leading N-by-MAX(M,P) part is used as -C internal workspace. -C -C LDB INTEGER -C The leading dimension of array B. LDB >= MAX(1,N). -C -C C (output) DOUBLE PRECISION array, dimension (LDC,N) -C The leading P-by-NR part of this array contains the -C state/output matrix C of a minimal realization; the -C remainder of the leading MAX(M,P)-by-N part is used as -C internal workspace. -C -C LDC INTEGER -C The leading dimension of array C. LDC >= MAX(1,M,P). -C -C D (output) DOUBLE PRECISION array, dimension (LDD,M), -C if ROWCOL = 'R', and (LDD,MAX(M,P)) if ROWCOL = 'C'. -C The leading P-by-M part of this array contains the direct -C transmission matrix D; if ROWCOL = 'C', the remainder of -C the leading MAX(M,P)-by-MAX(M,P) part is used as internal -C workspace. -C -C LDD INTEGER -C The leading dimension of array D. -C LDD >= MAX(1,P) if ROWCOL = 'R'; -C LDD >= MAX(1,M,P) if ROWCOL = 'C'. -C -C Tolerances -C -C TOL DOUBLE PRECISION -C The tolerance to be used in rank determination when -C transforming (A, B, C). If the user sets TOL > 0, then -C the given value of TOL is used as a lower bound for the -C reciprocal condition number (see the description of the -C argument RCOND in the SLICOT routine MB03OD); a -C (sub)matrix whose estimated condition number is less than -C 1/TOL is considered to be of full rank. If the user sets -C TOL <= 0, then an implicitly computed, default tolerance -C (determined by the SLICOT routine TB01UD) is used instead. -C -C Workspace -C -C IWORK INTEGER array, dimension (N+MAX(M,P)) -C On exit, if INFO = 0, the first nonzero elements of -C IWORK(1:N) return the orders of the diagonal blocks of A. -C -C DWORK DOUBLE PRECISION array, dimension (LDWORK) -C On exit, if INFO = 0, DWORK(1) returns the optimal value -C of LDWORK. -C -C LDWORK INTEGER -C The length of the array DWORK. -C LDWORK >= MAX(1, N + MAX(N, 3*M, 3*P)). -C For optimum performance LDWORK should be larger. -C -C Error Indicator -C -C INFO INTEGER -C = 0: successful exit; -C < 0: if INFO = -i, the i-th argument had an illegal -C value; -C > 0: if INFO = i, then i is the first integer for which -C ABS( DCOEFF(I,1) ) is so small that the calculations -C would overflow (see SLICOT Library routine TD03AY); -C that is, the leading coefficient of a polynomial is -C nearly zero; no state-space representation is -C calculated. -C -C METHOD -C -C The method for transfer matrices factorized by rows will be -C described here: T(s) factorized by columns is dealt with by -C operating on the dual T'(s). This description for T(s) is -C actually the left polynomial matrix representation -C -C T(s) = inv(D(s))*U(s), -C -C where D(s) is diagonal with its (I,I)-th polynomial element of -C degree INDEX(I). The first step is to check whether the leading -C coefficient of any polynomial element of D(s) is approximately -C zero; if so the routine returns with INFO > 0. Otherwise, -C Wolovich's Observable Structure Theorem is used to construct a -C state-space representation in observable companion form which -C is equivalent to the above polynomial matrix representation. -C The method is particularly easy here due to the diagonal form -C of D(s). This state-space representation is not necessarily -C controllable (as D(s) and U(s) are not necessarily relatively -C left prime), but it is in theory completely observable; however, -C its observability matrix may be poorly conditioned, so it is -C treated as a general state-space representation and SLICOT -C Library routine TB01PD is then called to separate out a minimal -C realization from this general state-space representation by means -C of orthogonal similarity transformations. -C -C REFERENCES -C -C [1] Patel, R.V. -C Computation of Minimal-Order State-Space Realizations and -C Observability Indices using Orthogonal Transformations. -C Int. J. Control, 33, pp. 227-246, 1981. -C -C [2] Wolovich, W.A. -C Linear Multivariable Systems, (Theorem 4.3.3). -C Springer-Verlag, 1974. -C -C NUMERICAL ASPECTS -C 3 -C The algorithm requires 0(N ) operations. -C -C CONTRIBUTOR -C -C V. Sima, Katholieke Univ. Leuven, Belgium, March 1998. -C Supersedes Release 3.0 routine TD01OD. -C -C REVISIONS -C -C - -C -C KEYWORDS -C -C Controllability, elementary polynomial operations, minimal -C realization, polynomial matrix, state-space representation, -C transfer matrix. -C -C ****************************************************************** -C -C .. Parameters .. - DOUBLE PRECISION ZERO, ONE - PARAMETER ( ZERO = 0.0D0, ONE = 1.0D0 ) -C .. Scalar Arguments .. - CHARACTER ROWCOL - INTEGER INFO, LDA, LDB, LDC, LDD, LDDCOE, LDUCO1, - $ LDUCO2, LDWORK, M, NR, P - DOUBLE PRECISION TOL -C .. Array Arguments .. - INTEGER INDEX(*), IWORK(*) - DOUBLE PRECISION A(LDA,*), B(LDB,*), C(LDC,*), D(LDD,*), - $ DCOEFF(LDDCOE,*), DWORK(*), - $ UCOEFF(LDUCO1,LDUCO2,*) -C .. Local Scalars .. - LOGICAL LROCOC, LROCOR - INTEGER I, J, JSTOP, K, KDCOEF, MPLIM, MWORK, N, PWORK -C .. External Functions .. - LOGICAL LSAME - EXTERNAL LSAME -C .. External Subroutines .. - EXTERNAL DLASET, DSWAP, TB01PD, TB01XD, TD03AY, XERBLA -C .. Intrinsic Functions .. - INTRINSIC MAX -C .. Executable Statements .. -C - INFO = 0 - LROCOR = LSAME( ROWCOL, 'R' ) - LROCOC = LSAME( ROWCOL, 'C' ) - MPLIM = MAX( 1, M, P ) -C -C Test the input scalar arguments. -C - IF( .NOT.LROCOR .AND. .NOT.LROCOC ) THEN - INFO = -1 - ELSE IF( M.LT.0 ) THEN - INFO = -2 - ELSE IF( P.LT.0 ) THEN - INFO = -3 - ELSE IF( ( LROCOR .AND. LDDCOE.LT.MAX( 1, P ) ) .OR. - $ ( LROCOC .AND. LDDCOE.LT.MAX( 1, M ) ) ) THEN - INFO = -6 - ELSE IF( ( LROCOR .AND. LDUCO1.LT.MAX( 1, P ) ) .OR. - $ ( LROCOC .AND. LDUCO1.LT.MPLIM ) ) THEN - INFO = -8 - ELSE IF( ( LROCOR .AND. LDUCO2.LT.MAX( 1, M ) ) .OR. - $ ( LROCOC .AND. LDUCO2.LT.MPLIM ) ) THEN - INFO = -9 - END IF -C - N = 0 - IF ( INFO.EQ.0 ) THEN - IF ( LROCOR ) THEN -C -C Initialization for T(s) given as rows over common -C denominators. -C - PWORK = P - MWORK = M - ELSE -C -C Initialization for T(s) given as columns over common -C denominators. -C - PWORK = M - MWORK = P - END IF -C -C Calculate N, the order of the resulting state-space -C representation. -C - KDCOEF = 0 -C - DO 10 I = 1, PWORK - KDCOEF = MAX( KDCOEF, INDEX(I) ) - N = N + INDEX(I) - 10 CONTINUE -C - KDCOEF = KDCOEF + 1 -C - IF( LDA.LT.MAX( 1, N ) ) THEN - INFO = -12 - ELSE IF( LDB.LT.MAX( 1, N ) ) THEN - INFO = -14 - ELSE IF( LDC.LT.MPLIM ) THEN - INFO = -16 - ELSE IF( ( LROCOR .AND. LDD.LT.MAX( 1, P ) ) .OR. - $ ( LROCOC .AND. LDD.LT.MPLIM ) ) THEN - INFO = -18 - ELSE IF( LDWORK.LT.MAX( 1, N + MAX( N, 3*M, 3*P ) ) ) THEN - INFO = -22 - END IF - END IF -C - IF ( INFO.NE.0 ) THEN -C -C Error return. -C - CALL XERBLA( 'TD04AD', -INFO ) - RETURN - END IF -C -C Quick return if possible. -C - IF ( MAX( N, M, P ).EQ.0 ) THEN - NR = 0 - DWORK(1) = ONE - RETURN - END IF -C - IF ( LROCOC ) THEN -C -C Initialize the remainder of the leading -C MPLIM-by-MPLIM-by-KDCOEF part of U(s) to zero. -C - IF ( P.LT.M ) THEN -C - DO 20 K = 1, KDCOEF - CALL DLASET( 'Full', M-P, MPLIM, ZERO, ZERO, - $ UCOEFF(P+1,1,K), LDUCO1 ) - 20 CONTINUE -C - ELSE IF ( P.GT.M ) THEN -C - DO 30 K = 1, KDCOEF - CALL DLASET( 'Full', MPLIM, P-M, ZERO, ZERO, - $ UCOEFF(1,M+1,K), LDUCO1 ) - 30 CONTINUE -C - END IF -C - IF ( MPLIM.NE.1 ) THEN -C -C Non-scalar T(s) factorized by columns: transpose it (i.e. -C U(s)). -C - JSTOP = MPLIM - 1 -C - DO 50 K = 1, KDCOEF -C - DO 40 J = 1, JSTOP - CALL DSWAP( MPLIM-J, UCOEFF(J+1,J,K), 1, - $ UCOEFF(J,J+1,K), LDUCO1 ) - 40 CONTINUE -C - 50 CONTINUE -C - END IF - END IF -C -C Construct non-minimal state-space representation (by Wolovich's -C Structure Theorem) which has transfer matrix T(s) or T'(s) as -C appropriate ... -C - CALL TD03AY( MWORK, PWORK, INDEX, DCOEFF, LDDCOE, UCOEFF, LDUCO1, - $ LDUCO2, N, A, LDA, B, LDB, C, LDC, D, LDD, INFO ) - IF ( INFO.GT.0 ) - $ RETURN -C -C and then separate out a minimal realization from this. -C -C Workspace: need N + MAX(N, 3*MWORK, 3*PWORK). -C - CALL TB01PD( 'Minimal', 'Scale', N, MWORK, PWORK, A, LDA, B, LDB, - $ C, LDC, NR, TOL, IWORK, DWORK, LDWORK, INFO ) -C - IF ( LROCOC ) THEN -C -C If T(s) originally factorized by columns, find dual of minimal -C state-space representation, and reorder the rows and columns -C to get an upper block Hessenberg state dynamics matrix. -C - K = IWORK(1)+IWORK(2)-1 - CALL TB01XD( 'D', NR, MWORK, PWORK, K, NR-1, A, LDA, B, LDB, - $ C, LDC, D, LDD, INFO ) - IF ( MPLIM.NE.1 ) THEN -C -C Also, retranspose U(s) if this is non-scalar. -C - DO 70 K = 1, KDCOEF -C - DO 60 J = 1, JSTOP - CALL DSWAP( MPLIM-J, UCOEFF(J+1,J,K), 1, - $ UCOEFF(J,J+1,K), LDUCO1 ) - 60 CONTINUE -C - 70 CONTINUE -C - END IF - END IF -C - RETURN -C *** Last line of TD04AD *** - END diff --git a/mex/sources/libslicot/TD05AD.f b/mex/sources/libslicot/TD05AD.f deleted file mode 100644 index 0b527c4aa..000000000 --- a/mex/sources/libslicot/TD05AD.f +++ /dev/null @@ -1,314 +0,0 @@ - SUBROUTINE TD05AD( UNITF, OUTPUT, NP1, MP1, W, A, B, VALR, VALI, - $ INFO ) -C -C SLICOT RELEASE 5.0. -C -C Copyright (c) 2002-2009 NICONET e.V. -C -C This program is free software: you can redistribute it and/or -C modify it under the terms of the GNU General Public License as -C published by the Free Software Foundation, either version 2 of -C the License, or (at your option) any later version. -C -C This program is distributed in the hope that it will be useful, -C but WITHOUT ANY WARRANTY; without even the implied warranty of -C MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the -C GNU General Public License for more details. -C -C You should have received a copy of the GNU General Public License -C along with this program. If not, see -C . -C -C PURPOSE -C -C Given a complex valued rational function of frequency (transfer -C function) G(jW) this routine will calculate its complex value or -C its magnitude and phase for a specified frequency value. -C -C ARGUMENTS -C -C Mode Parameters -C -C UNITF CHARACTER*1 -C Indicates the choice of frequency unit as follows: -C = 'R': Input frequency W in radians/second; -C = 'H': Input frequency W in hertz. -C -C OUTPUT CHARACTER*1 -C Indicates the choice of co-ordinates for output as folows: -C = 'C': Cartesian co-ordinates (output real and imaginary -C parts of G(jW)); -C = 'P': Polar co-ordinates (output magnitude and phase -C of G(jW)). -C -C Input/Output Parameters -C -C NP1 (input) INTEGER -C The order of the denominator + 1, i.e. N + 1. NP1 >= 1. -C -C MP1 (input) INTEGER -C The order of the numerator + 1, i.e. M + 1. MP1 >= 1. -C -C W (input) DOUBLE PRECISION -C The frequency value W for which the transfer function is -C to be evaluated. -C -C A (input) DOUBLE PRECISION array, dimension (NP1) -C This array must contain the vector of denominator -C coefficients in ascending order of powers. That is, A(i) -C must contain the coefficient of (jW)**(i-1) for i = 1, -C 2,...,NP1. -C -C B (input) DOUBLE PRECISION array, dimension (MP1) -C This array must contain the vector of numerator -C coefficients in ascending order of powers. That is, B(i) -C must contain the coefficient of (jW)**(i-1) for i = 1, -C 2,...,MP1. -C -C VALR (output) DOUBLE PRECISION -C If OUTPUT = 'C', VALR contains the real part of G(jW). -C If OUTPUT = 'P', VALR contains the magnitude of G(jW) -C in dBs. -C -C VALI (output) DOUBLE PRECISION -C If OUTPUT = 'C', VALI contains the imaginary part of -C G(jW). -C If OUTPUT = 'P', VALI contains the phase of G(jW) in -C degrees. -C -C Error Indicator -C -C INFO INTEGER -C = 0: successful exit; -C < 0: if INFO = -i, the i-th argument had an illegal -C value; -C = 1: if the frequency value W is a pole of G(jW), or all -C the coefficients of the A polynomial are zero. -C -C METHOD -C -C By substituting the values of A, B and W in the following -C formula: -C -C B(1)+B(2)*(jW)+B(3)*(jW)**2+...+B(MP1)*(jW)**(MP1-1) -C G(jW) = ---------------------------------------------------. -C A(1)+A(2)*(jW)+A(3)*(jW)**2+...+A(NP1)*(jW)**(NP1-1) -C -C REFERENCES -C -C None. -C -C NUMERICAL ASPECTS -C -C The algorithm requires 0(N+M) operations. -C -C CONTRIBUTORS -C -C Release 3.0: V. Sima, Katholieke Univ. Leuven, Belgium, Dec. 1996. -C Supersedes Release 2.0 routine TD01AD by Control Systems Research -C Group, Kingston Polytechnic, United Kingdom, March 1981. -C -C REVISIONS -C -C February 1997. -C February 22, 1998 (changed the name of TD01MD). -C -C KEYWORDS -C -C Elementary polynomial operations, frequency response, matrix -C fraction, polynomial matrix, state-space representation, transfer -C matrix. -C -C ****************************************************************** -C -C .. Parameters .. - DOUBLE PRECISION ZERO, ONE, EIGHT, TWENTY, NINETY, ONE80, THRE60 - PARAMETER ( ZERO = 0.0D0, ONE = 1.0D0, EIGHT=8.0D0, - $ TWENTY=20.0D0, NINETY=90.0D0, ONE80 = 180.0D0, - $ THRE60=360.0D0 ) -C .. Scalar Arguments .. - CHARACTER OUTPUT, UNITF - INTEGER INFO, MP1, NP1 - DOUBLE PRECISION VALI, VALR, W -C .. Array Arguments .. - DOUBLE PRECISION A(*), B(*) -C .. Local Scalars .. - LOGICAL LOUTPU, LUNITF - INTEGER I, IPHASE, M, M2, N, N2, NPZERO, NZZERO - DOUBLE PRECISION BIMAG, BREAL, G, TIMAG, TREAL, TWOPI, W2, WC - COMPLEX*16 ZTEMP -C .. External Functions .. - LOGICAL LSAME - DOUBLE PRECISION DLAPY2 - COMPLEX*16 ZLADIV - EXTERNAL DLAPY2, LSAME, ZLADIV -C .. External Subroutines .. - EXTERNAL XERBLA -C .. Intrinsic Functions .. - INTRINSIC ABS, ATAN, DBLE, DCMPLX, DIMAG, LOG10, MAX, MOD, - $ SIGN -C .. Executable Statements .. -C - INFO = 0 - LUNITF = LSAME( UNITF, 'H' ) - LOUTPU = LSAME( OUTPUT, 'P' ) -C -C Test the input scalar arguments. -C - IF( .NOT.LUNITF .AND. .NOT.LSAME( UNITF, 'R' ) ) THEN - INFO = -1 - ELSE IF( .NOT.LOUTPU .AND. .NOT.LSAME( OUTPUT, 'C' ) ) THEN - INFO = -2 - ELSE IF( NP1.LT.1 ) THEN - INFO = -3 - ELSE IF( MP1.LT.1 ) THEN - INFO = -4 - END IF -C - IF ( INFO.NE.0 ) THEN -C -C Error return. -C - CALL XERBLA( 'TD05AD', -INFO ) - RETURN - END IF -C - M = MP1 - 1 - N = NP1 - 1 - WC = W - TWOPI = EIGHT*ATAN( ONE ) - IF ( LUNITF ) WC = WC*TWOPI - W2 = WC**2 -C -C Determine the orders z (NZZERO) and p (NPZERO) of the factors -C (jW)**k in the numerator and denominator polynomials, by counting -C the zero trailing coefficients. The value of G(jW) will then be -C computed as (jW)**(z-p)*m(jW)/n(jW), for appropriate m and n. -C - I = 0 -C - 10 CONTINUE - I = I + 1 - IF ( I.LE.M ) THEN - IF ( B(I).EQ.ZERO ) GO TO 10 - END IF -C - NZZERO = I - 1 - I = 0 -C - 20 CONTINUE - I = I + 1 - IF ( I.LE.N ) THEN - IF ( A(I).EQ.ZERO ) GO TO 20 - END IF -C - NPZERO = I - 1 - IPHASE = NZZERO - NPZERO -C - M2 = MOD( M - NZZERO, 2 ) -C -C Add real parts of the numerator m(jW). -C - TREAL = B(MP1-M2) -C - DO 30 I = M - 1 - M2, NZZERO + 1, -2 - TREAL = B(I) - W2*TREAL - 30 CONTINUE -C -C Add imaginary parts of the numerator m(jW). -C - IF ( M.EQ.0 ) THEN - TIMAG = ZERO - ELSE - TIMAG = B(M+M2) -C - DO 40 I = M + M2 - 2, NZZERO + 2, -2 - TIMAG = B(I) - W2*TIMAG - 40 CONTINUE -C - TIMAG = TIMAG*WC - END IF -C - N2 = MOD( N - NPZERO, 2 ) -C -C Add real parts of the denominator n(jW). -C - BREAL = A(NP1-N2) -C - DO 50 I = N - 1 - N2, NPZERO + 1, -2 - BREAL = A(I) - W2*BREAL - 50 CONTINUE -C -C Add imaginary parts of the denominator n(jW). -C - IF ( N.EQ.0 ) THEN - BIMAG = ZERO - ELSE - BIMAG = A(N+N2) -C - DO 60 I = N + N2 - 2, NPZERO + 2, -2 - BIMAG = A(I) - W2*BIMAG - 60 CONTINUE -C - BIMAG = BIMAG*WC - END IF -C - IF ( ( MAX( ABS( BREAL ), ABS( BIMAG ) ).EQ.ZERO ) .OR. - $ ( W.EQ.ZERO .AND. IPHASE.LT.0 ) ) THEN -C -C Error return: The specified frequency W is a pole of G(jW), -C or all the coefficients of the A polynomial are zero. -C - INFO = 1 - ELSE -C -C Evaluate the complex number W**(z-p)*m(jW)/n(jW). -C - ZTEMP = - $ ZLADIV( DCMPLX( TREAL, TIMAG ), DCMPLX( BREAL, BIMAG ) ) - VALR = DBLE( ZTEMP )*WC**IPHASE - VALI = DIMAG( ZTEMP )*WC**IPHASE -C - IF ( .NOT.LOUTPU ) THEN -C -C Cartesian co-ordinates: Update the result for j**(z-p). -C - I = MOD( ABS( IPHASE ), 4 ) - IF ( ( IPHASE.GT.0 .AND. I.GT.1 ) .OR. - $ ( IPHASE.LT.0 .AND. ( I.EQ.1 .OR. I.EQ.2) ) ) THEN - VALR = -VALR - VALI = -VALI - END IF -C - IF ( MOD( I, 2 ).NE.0 ) THEN - G = VALR - VALR = -VALI - VALI = G - END IF -C - ELSE -C -C Polar co-ordinates: Compute the magnitude and phase. -C - G = DLAPY2( VALR, VALI ) -C - IF ( VALR.EQ.ZERO ) THEN - VALI = SIGN( NINETY, VALI ) - ELSE - VALI = ( ATAN( VALI/VALR )/TWOPI )*THRE60 - IF ( VALI.EQ.ZERO .AND. NZZERO.EQ.M .AND. NPZERO.EQ.N - $ .AND. B(NZZERO+1)*A(NPZERO+1).LT.ZERO ) - $ VALI = ONE80 - END IF -C - VALR = TWENTY*LOG10( G ) -C - IF ( IPHASE.NE.0 ) - $ VALI = VALI + DBLE( NZZERO - NPZERO )*NINETY - END IF -C - END IF -C - RETURN -C *** Last line of TD05AD *** - END diff --git a/mex/sources/libslicot/TF01MD.f b/mex/sources/libslicot/TF01MD.f deleted file mode 100644 index 1b33b81ca..000000000 --- a/mex/sources/libslicot/TF01MD.f +++ /dev/null @@ -1,233 +0,0 @@ - SUBROUTINE TF01MD( N, M, P, NY, A, LDA, B, LDB, C, LDC, D, LDD, - $ U, LDU, X, Y, LDY, DWORK, INFO ) -C -C SLICOT RELEASE 5.0. -C -C Copyright (c) 2002-2009 NICONET e.V. -C -C This program is free software: you can redistribute it and/or -C modify it under the terms of the GNU General Public License as -C published by the Free Software Foundation, either version 2 of -C the License, or (at your option) any later version. -C -C This program is distributed in the hope that it will be useful, -C but WITHOUT ANY WARRANTY; without even the implied warranty of -C MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the -C GNU General Public License for more details. -C -C You should have received a copy of the GNU General Public License -C along with this program. If not, see -C . -C -C PURPOSE -C -C To compute the output sequence of a linear time-invariant -C open-loop system given by its discrete-time state-space model -C (A,B,C,D), where A is an N-by-N general matrix. -C -C The initial state vector x(1) must be supplied by the user. -C -C ARGUMENTS -C -C Input/Output Parameters -C -C N (input) INTEGER -C The order of the matrix A. N >= 0. -C -C M (input) INTEGER -C The number of system inputs. M >= 0. -C -C P (input) INTEGER -C The number of system outputs. P >= 0. -C -C NY (input) INTEGER -C The number of output vectors y(k) to be computed. -C NY >= 0. -C -C A (input) DOUBLE PRECISION array, dimension (LDA,N) -C The leading N-by-N part of this array must contain the -C state matrix A of the system. -C -C LDA INTEGER -C The leading dimension of array A. LDA >= MAX(1,N). -C -C B (input) DOUBLE PRECISION array, dimension (LDB,M) -C The leading N-by-M part of this array must contain the -C input matrix B of the system. -C -C LDB INTEGER -C The leading dimension of array B. LDB >= MAX(1,N). -C -C C (input) DOUBLE PRECISION array, dimension (LDC,N) -C The leading P-by-N part of this array must contain the -C output matrix C of the system. -C -C LDC INTEGER -C The leading dimension of array C. LDC >= MAX(1,P). -C -C D (input) DOUBLE PRECISION array, dimension (LDD,M) -C The leading P-by-M part of this array must contain the -C direct link matrix D of the system. -C -C LDD INTEGER -C The leading dimension of array D. LDD >= MAX(1,P). -C -C U (input) DOUBLE PRECISION array, dimension (LDU,NY) -C The leading M-by-NY part of this array must contain the -C input vector sequence u(k), for k = 1,2,...,NY. -C Specifically, the k-th column of U must contain u(k). -C -C LDU INTEGER -C The leading dimension of array U. LDU >= MAX(1,M). -C -C X (input/output) DOUBLE PRECISION array, dimension (N) -C On entry, this array must contain the initial state vector -C x(1) which consists of the N initial states of the system. -C On exit, this array contains the final state vector -C x(NY+1) of the N states of the system at instant NY. -C -C Y (output) DOUBLE PRECISION array, dimension (LDY,NY) -C The leading P-by-NY part of this array contains the output -C vector sequence y(1),y(2),...,y(NY) such that the k-th -C column of Y contains y(k) (the outputs at instant k), -C for k = 1,2,...,NY. -C -C LDY INTEGER -C The leading dimension of array Y. LDY >= MAX(1,P). -C -C Workspace -C -C DWORK DOUBLE PRECISION array, dimension (N) -C -C Error Indicator -C -C INFO INTEGER -C = 0: successful exit; -C < 0: if INFO = -i, the i-th argument had an illegal -C value. -C -C METHOD -C -C Given an initial state vector x(1), the output vector sequence -C y(1), y(2),..., y(NY) is obtained via the formulae -C -C x(k+1) = A x(k) + B u(k) -C y(k) = C x(k) + D u(k), -C -C where each element y(k) is a vector of length P containing the -C outputs at instant k and k = 1,2,...,NY. -C -C REFERENCES -C -C [1] Luenberger, D.G. -C Introduction to Dynamic Systems: Theory, Models and -C Applications. -C John Wiley & Sons, New York, 1979. -C -C NUMERICAL ASPECTS -C -C The algorithm requires approximately (N + M) x (N + P) x NY -C multiplications and additions. -C -C CONTRIBUTOR -C -C Release 3.0: V. Sima, Katholieke Univ. Leuven, Belgium, Dec. 1996. -C Supersedes Release 2.0 routine TF01AD by S. Van Huffel, Katholieke -C Univ. Leuven, Belgium. -C -C REVISIONS -C -C V. Sima, Research Institute for Informatics, Bucharest, Apr. 2003. -C -C KEYWORDS -C -C Discrete-time system, multivariable system, state-space model, -C state-space representation, time response. -C -C ****************************************************************** -C -C .. Parameters .. - DOUBLE PRECISION ZERO, ONE - PARAMETER ( ZERO = 0.0D0, ONE = 1.0D0 ) -C .. Scalar Arguments .. - INTEGER INFO, LDA, LDB, LDC, LDD, LDU, LDY, M, N, NY, P -C .. Array Arguments .. - DOUBLE PRECISION A(LDA,*), B(LDB,*), C(LDC,*), D(LDD,*), - $ DWORK(*), U(LDU,*), X(*), Y(LDY,*) -C .. Local Scalars .. - INTEGER IK -C .. External Subroutines .. - EXTERNAL DCOPY, DGEMM, DGEMV, DLASET, XERBLA -C .. Intrinsic Functions .. - INTRINSIC MAX, MIN -C .. Executable Statements .. -C - INFO = 0 -C -C Test the input scalar arguments. -C - IF( N.LT.0 ) THEN - INFO = -1 - ELSE IF( M.LT.0 ) THEN - INFO = -2 - ELSE IF( P.LT.0 ) THEN - INFO = -3 - ELSE IF( NY.LT.0 ) THEN - INFO = -4 - ELSE IF( LDA.LT.MAX( 1, N ) ) THEN - INFO = -6 - ELSE IF( LDB.LT.MAX( 1, N ) ) THEN - INFO = -8 - ELSE IF( LDC.LT.MAX( 1, P ) ) THEN - INFO = -10 - ELSE IF( LDD.LT.MAX( 1, P ) ) THEN - INFO = -12 - ELSE IF( LDU.LT.MAX( 1, M ) ) THEN - INFO = -14 - ELSE IF( LDY.LT.MAX( 1, P ) ) THEN - INFO = -17 - END IF -C - IF ( INFO.NE.0 ) THEN -C -C Error return. -C - CALL XERBLA( 'TF01MD', -INFO ) - RETURN - END IF -C -C Quick return if possible. -C - IF ( MIN( P, NY ).EQ.0 ) THEN - RETURN - ELSE IF ( N.EQ.0 ) THEN -C -C Non-dynamic system: compute the output vectors. -C - IF ( M.EQ.0 ) THEN - CALL DLASET( 'Full', P, NY, ZERO, ZERO, Y, LDY ) - ELSE - CALL DGEMM( 'No transpose', 'No transpose', P, NY, M, ONE, - $ D, LDD, U, LDU, ZERO, Y, LDY ) - END IF - RETURN - END IF -C - DO 10 IK = 1, NY - CALL DGEMV( 'No transpose', P, N, ONE, C, LDC, X, 1, ZERO, - $ Y(1,IK), 1 ) -C - CALL DGEMV( 'No transpose', N, N, ONE, A, LDA, X, 1, ZERO, - $ DWORK, 1 ) - CALL DGEMV( 'No transpose', N, M, ONE, B, LDB, U(1,IK), 1, ONE, - $ DWORK, 1 ) -C - CALL DCOPY( N, DWORK, 1, X, 1 ) - 10 CONTINUE -C - CALL DGEMM( 'No transpose', 'No transpose', P, NY, M, ONE, D, LDD, - $ U, LDU, ONE, Y, LDY ) -C - RETURN -C *** Last line of TF01MD *** - END diff --git a/mex/sources/libslicot/TF01MX.f b/mex/sources/libslicot/TF01MX.f deleted file mode 100644 index aaaf7aaff..000000000 --- a/mex/sources/libslicot/TF01MX.f +++ /dev/null @@ -1,457 +0,0 @@ - SUBROUTINE TF01MX( N, M, P, NY, S, LDS, U, LDU, X, Y, LDY, - $ DWORK, LDWORK, INFO ) -C -C SLICOT RELEASE 5.0. -C -C Copyright (c) 2002-2009 NICONET e.V. -C -C This program is free software: you can redistribute it and/or -C modify it under the terms of the GNU General Public License as -C published by the Free Software Foundation, either version 2 of -C the License, or (at your option) any later version. -C -C This program is distributed in the hope that it will be useful, -C but WITHOUT ANY WARRANTY; without even the implied warranty of -C MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the -C GNU General Public License for more details. -C -C You should have received a copy of the GNU General Public License -C along with this program. If not, see -C . -C -C PURPOSE -C -C To compute the output sequence of a linear time-invariant -C open-loop system given by its discrete-time state-space model -C with an (N+P)-by-(N+M) general system matrix S, -C -C ( A B ) -C S = ( ) . -C ( C D ) -C -C The initial state vector x(1) must be supplied by the user. -C -C The input and output trajectories are stored as in the SLICOT -C Library routine TF01MY. -C -C ARGUMENTS -C -C Input/Output Parameters -C -C N (input) INTEGER -C The order of the matrix A. N >= 0. -C -C M (input) INTEGER -C The number of system inputs. M >= 0. -C -C P (input) INTEGER -C The number of system outputs. P >= 0. -C -C NY (input) INTEGER -C The number of output vectors y(k) to be computed. -C NY >= 0. -C -C S (input) DOUBLE PRECISION array, dimension (LDS,N+M) -C The leading (N+P)-by-(N+M) part of this array must contain -C the system matrix S. -C -C LDS INTEGER -C The leading dimension of array S. LDS >= MAX(1,N+P). -C -C U (input) DOUBLE PRECISION array, dimension (LDU,M) -C The leading NY-by-M part of this array must contain the -C input vector sequence u(k), for k = 1,2,...,NY. -C Specifically, the k-th row of U must contain u(k)'. -C -C LDU INTEGER -C The leading dimension of array U. LDU >= MAX(1,NY). -C -C X (input/output) DOUBLE PRECISION array, dimension (N) -C On entry, this array must contain the initial state vector -C x(1) which consists of the N initial states of the system. -C On exit, this array contains the final state vector -C x(NY+1) of the N states of the system at instant NY+1. -C -C Y (output) DOUBLE PRECISION array, dimension (LDY,P) -C The leading NY-by-P part of this array contains the output -C vector sequence y(1),y(2),...,y(NY) such that the k-th -C row of Y contains y(k)' (the outputs at instant k), -C for k = 1,2,...,NY. -C -C LDY INTEGER -C The leading dimension of array Y. LDY >= MAX(1,NY). -C -C Workspace -C -C DWORK DOUBLE PRECISION array, dimension (LDWORK) -C -C LDWORK INTEGER -C The length of the array DWORK. -C LDWORK >= 0, if MIN(N,P,NY) = 0; otherwise, -C LDWORK >= N+P, if M = 0; -C LDWORK >= 2*N+M+P, if M > 0. -C For better performance, LDWORK should be larger. -C -C Error Indicator -C -C INFO INTEGER -C = 0: successful exit; -C < 0: if INFO = -i, the i-th argument had an illegal -C value. -C -C METHOD -C -C Given an initial state vector x(1), the output vector sequence -C y(1), y(2),..., y(NY) is obtained via the formulae -C -C ( x(k+1) ) ( x(k) ) -C ( ) = S ( ) , -C ( y(k) ) ( u(k) ) -C -C where each element y(k) is a vector of length P containing the -C outputs at instant k, and k = 1,2,...,NY. -C -C REFERENCES -C -C [1] Luenberger, D.G. -C Introduction to Dynamic Systems: Theory, Models and -C Applications. -C John Wiley & Sons, New York, 1979. -C -C NUMERICAL ASPECTS -C -C The algorithm requires approximately (N + M) x (N + P) x NY -C multiplications and additions. -C -C FURTHER COMMENTS -C -C The implementation exploits data locality as much as possible, -C given the workspace length. -C -C CONTRIBUTOR -C -C V. Sima, Katholieke Univ. Leuven, Belgium, Feb. 2002. -C -C REVISIONS -C -C - -C -C KEYWORDS -C -C Discrete-time system, multivariable system, state-space model, -C state-space representation, time response. -C -C ****************************************************************** -C -C .. Parameters .. - DOUBLE PRECISION ZERO, ONE - PARAMETER ( ZERO = 0.0D0, ONE = 1.0D0 ) -C .. Scalar Arguments .. - INTEGER INFO, LDS, LDU, LDWORK, LDY, M, N, NY, P -C .. Array Arguments .. - DOUBLE PRECISION DWORK(*), S(LDS,*), U(LDU,*), X(*), Y(LDY,*) -C .. Local Scalars .. - INTEGER I, IC, IU, IW, IY, J, JW, K, N2M, N2P, NB, NF, - $ NM, NP, NS -C .. External Functions .. - INTEGER ILAENV - EXTERNAL ILAENV -C .. External Subroutines .. - EXTERNAL DCOPY, DGEMM, DGEMV, DLASET, XERBLA -C .. Intrinsic Functions .. - INTRINSIC MAX, MIN -C .. Executable Statements .. -C - INFO = 0 -C -C Test the input scalar arguments. -C - NP = N + P - NM = N + M - IW = NM + NP - IF( N.LT.0 ) THEN - INFO = -1 - ELSE IF( M.LT.0 ) THEN - INFO = -2 - ELSE IF( P.LT.0 ) THEN - INFO = -3 - ELSE IF( NY.LT.0 ) THEN - INFO = -4 - ELSE IF( LDS.LT.MAX( 1, NP ) ) THEN - INFO = -6 - ELSE IF( LDU.LT.MAX( 1, NY ) ) THEN - INFO = -8 - ELSE IF( LDY.LT.MAX( 1, NY ) ) THEN - INFO = -11 - ELSE - IF( MIN( N, P, NY ).EQ.0 ) THEN - JW = 0 - ELSE IF( M.EQ.0 ) THEN - JW = NP - ELSE - JW = IW - END IF - IF( LDWORK.LT.JW ) - $ INFO = -13 - END IF -C - IF ( INFO.NE.0 ) THEN -C -C Error return. -C - CALL XERBLA( 'TF01MX', -INFO ) - RETURN - END IF -C -C Quick return if possible. -C - IF ( MIN( NY, P ).EQ.0 ) THEN - RETURN - ELSE IF ( N.EQ.0 ) THEN -C -C Non-dynamic system: compute the output vectors. -C - IF ( M.EQ.0 ) THEN - CALL DLASET( 'Full', NY, P, ZERO, ZERO, Y, LDY ) - ELSE - CALL DGEMM( 'No transpose', 'Transpose', NY, P, M, ONE, - $ U, LDU, S, LDS, ZERO, Y, LDY ) - END IF - RETURN - END IF -C -C Determine the block size (taken as for LAPACK routine DGETRF). -C - NB = ILAENV( 1, 'DGETRF', ' ', NY, MAX( M, P ), -1, -1 ) -C -C Find the number of state vectors, extended with inputs (if M > 0) -C and outputs, that can be accommodated in the provided workspace. -C - NS = MIN( LDWORK/JW, NB*NB/JW, NY ) - N2P = N + NP -C - IF ( M.EQ.0 ) THEN -C -C System with no inputs. -C Workspace: need N + P; -C prefer larger. -C - IF( NS.LE.1 .OR. NY*P.LE.NB*NB ) THEN - IY = N + 1 -C -C LDWORK < 2*(N+P), or small problem. -C One row of array Y is computed for each loop index value. -C - DO 10 I = 1, NY -C -C Compute -C -C /x(i+1)\ /A\ -C | | = | | * x(i). -C \ y(i) / \C/ -C - CALL DGEMV( 'NoTranspose', NP, N, ONE, S, LDS, X, 1, - $ ZERO, DWORK, 1 ) - CALL DCOPY( N, DWORK, 1, X, 1 ) - CALL DCOPY( P, DWORK(IY), 1, Y(I,1), LDY ) - 10 CONTINUE -C - ELSE -C -C LDWORK >= 2*(N+P), and large problem. -C NS rows of array Y are computed before being saved. -C - NF = ( NY/NS )*NS - CALL DCOPY( N, X, 1, DWORK, 1 ) -C - DO 40 I = 1, NF, NS -C -C Compute the current NS extended state vectors in the -C workspace: -C -C /x(i+1)\ /A\ -C | | = | | * x(i), i = 1 : ns - 1. -C \ y(i) / \C/ -C - DO 20 IC = 1, ( NS - 1 )*NP, NP - CALL DGEMV( 'No transpose', NP, N, ONE, S, LDS, - $ DWORK(IC), 1, ZERO, DWORK(IC+NP), 1 ) - 20 CONTINUE -C -C Prepare the next iteration. -C - CALL DGEMV( 'No transpose', NP, N, ONE, S, LDS, - $ DWORK((NS-1)*NP+1), 1, ZERO, DWORK, 1 ) -C -C Transpose the NS output vectors in the corresponding part -C of Y (column-wise). -C - DO 30 J = 1, P - CALL DCOPY( NS-1, DWORK(N2P+J), NP, Y(I,J), 1 ) - Y(I+NS-1,J) = DWORK(N+J) - 30 CONTINUE -C - 40 CONTINUE -C - NS = NY - NF -C - IF ( NS.GT.1 ) THEN -C -C Compute similarly the last NS output vectors. -C - DO 50 IC = 1, ( NS - 1 )*NP, NP - CALL DGEMV( 'No transpose', NP, N, ONE, S, LDS, - $ DWORK(IC), 1, ZERO, DWORK(IC+NP), 1 ) - 50 CONTINUE -C - CALL DGEMV( 'No transpose', NP, N, ONE, S, LDS, - $ DWORK((NS-1)*NP+1), 1, ZERO, DWORK, 1 ) -C - DO 60 J = 1, P - CALL DCOPY( NS-1, DWORK(N2P+J), NP, Y(NF+1,J), 1 ) - Y(NF+NS,J) = DWORK(N+J) - 60 CONTINUE -C - ELSE IF ( NS.EQ.1 ) THEN -C -C Compute similarly the last NS = 1 output vectors. -C - CALL DCOPY( N, DWORK, 1, DWORK(NP+1), 1 ) - CALL DGEMV( 'No transpose', NP, N, ONE, S, LDS, - $ DWORK(NP+1), 1, ZERO, DWORK, 1 ) - CALL DCOPY( P, DWORK(N+1), 1, Y(NF+1,1), LDY ) -C - END IF -C -C Set the final state vector. -C - CALL DCOPY( N, DWORK, 1, X, 1 ) -C - END IF -C - ELSE -C -C General case. -C Workspace: need 2*N + M + P; -C prefer larger. -C - CALL DCOPY( N, X, 1, DWORK, 1 ) -C - IF( NS.LE.1 .OR. NY*( M + P ).LE.NB*NB ) THEN - IU = N + 1 - JW = IU + M - IY = JW + N -C -C LDWORK < 2*(2*N+M+P), or small problem. -C One row of array Y is computed for each loop index value. -C - DO 70 I = 1, NY -C -C Compute -C -C /x(i+1)\ /A, B\ /x(i)\ -C | | = | | * | | . -C \ y(i) / \C, D/ \u(i)/ -C - CALL DCOPY( M, U(I,1), LDU, DWORK(IU), 1 ) - CALL DGEMV( 'NoTranspose', NP, NM, ONE, S, LDS, DWORK, 1, - $ ZERO, DWORK(JW), 1 ) - CALL DCOPY( N, DWORK(JW), 1, DWORK, 1 ) - CALL DCOPY( P, DWORK(IY), 1, Y(I,1), LDY ) - 70 CONTINUE -C - ELSE -C -C LDWORK >= 2*(2*N+M+P), and large problem. -C NS rows of array Y are computed before being saved. -C - NF = ( NY/NS )*NS - N2M = N + NM -C - DO 110 I = 1, NF, NS - JW = 1 -C -C Compute the current NS extended state vectors in the -C workspace: -C -C /x(i+1)\ /A, B\ /x(i)\ -C | | = | | * | | , i = 1 : ns - 1. -C \ y(i) / \C, D/ \u(i)/ -C - DO 80 J = 1, M - CALL DCOPY( NS, U(I,J), 1, DWORK(N+J), IW ) - 80 CONTINUE -C - DO 90 K = 1, NS - 1 - CALL DGEMV( 'No transpose', NP, NM, ONE, S, LDS, - $ DWORK(JW), 1, ZERO, DWORK(JW+NM), 1 ) - JW = JW + NM - CALL DCOPY( N, DWORK(JW), 1, DWORK(JW+NP), 1 ) - JW = JW + NP - 90 CONTINUE -C -C Prepare the next iteration. -C - CALL DGEMV( 'No transpose', NP, NM, ONE, S, LDS, - $ DWORK(JW), 1, ZERO, DWORK(JW+NM), 1 ) - CALL DCOPY( N, DWORK(JW+NM), 1, DWORK, 1 ) -C -C Transpose the NS output vectors in the corresponding part -C of Y (column-wise). -C - DO 100 J = 1, P - CALL DCOPY( NS, DWORK(N2M+J), IW, Y(I,J), 1 ) - 100 CONTINUE -C - 110 CONTINUE -C - NS = NY - NF -C - IF ( NS.GT.1 ) THEN - JW = 1 -C -C Compute similarly the last NS output vectors. -C - DO 120 J = 1, M - CALL DCOPY( NS, U(NF+1,J), 1, DWORK(N+J), IW ) - 120 CONTINUE -C - DO 130 K = 1, NS - 1 - CALL DGEMV( 'No transpose', NP, NM, ONE, S, LDS, - $ DWORK(JW), 1, ZERO, DWORK(JW+NM), 1 ) - JW = JW + NM - CALL DCOPY( N, DWORK(JW), 1, DWORK(JW+NP), 1 ) - JW = JW + NP - 130 CONTINUE -C - CALL DGEMV( 'No transpose', NP, NM, ONE, S, LDS, - $ DWORK(JW), 1, ZERO, DWORK(JW+NM), 1 ) - CALL DCOPY( N, DWORK(JW+NM), 1, DWORK, 1 ) -C - DO 140 J = 1, P - CALL DCOPY( NS, DWORK(N2M+J), IW, Y(NF+1,J), 1 ) - 140 CONTINUE -C - ELSE IF ( NS.EQ.1 ) THEN -C -C Compute similarly the last NS = 1 output vectors. -C - CALL DCOPY( N, DWORK, 1, DWORK(NP+1), 1 ) - CALL DCOPY( M, U(NF+1,1), LDU, DWORK(N2P+1), 1 ) - CALL DGEMV( 'No transpose', NP, NM, ONE, S, LDS, - $ DWORK(NP+1), 1, ZERO, DWORK, 1 ) - CALL DCOPY( P, DWORK(N+1), 1, Y(NF+1,1), LDY ) -C - END IF -C - END IF -C -C Set the final state vector. -C - CALL DCOPY( N, DWORK, 1, X, 1 ) -C - END IF -C - RETURN -C *** Last line of TF01MX *** - END diff --git a/mex/sources/libslicot/TF01MY.f b/mex/sources/libslicot/TF01MY.f deleted file mode 100644 index 85e31c05b..000000000 --- a/mex/sources/libslicot/TF01MY.f +++ /dev/null @@ -1,358 +0,0 @@ - SUBROUTINE TF01MY( N, M, P, NY, A, LDA, B, LDB, C, LDC, D, LDD, - $ U, LDU, X, Y, LDY, DWORK, LDWORK, INFO ) -C -C SLICOT RELEASE 5.0. -C -C Copyright (c) 2002-2009 NICONET e.V. -C -C This program is free software: you can redistribute it and/or -C modify it under the terms of the GNU General Public License as -C published by the Free Software Foundation, either version 2 of -C the License, or (at your option) any later version. -C -C This program is distributed in the hope that it will be useful, -C but WITHOUT ANY WARRANTY; without even the implied warranty of -C MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the -C GNU General Public License for more details. -C -C You should have received a copy of the GNU General Public License -C along with this program. If not, see -C . -C -C PURPOSE -C -C To compute the output sequence of a linear time-invariant -C open-loop system given by its discrete-time state-space model -C (A,B,C,D), where A is an N-by-N general matrix. -C -C The initial state vector x(1) must be supplied by the user. -C -C This routine differs from SLICOT Library routine TF01MD in the -C way the input and output trajectories are stored. -C -C ARGUMENTS -C -C Input/Output Parameters -C -C N (input) INTEGER -C The order of the matrix A. N >= 0. -C -C M (input) INTEGER -C The number of system inputs. M >= 0. -C -C P (input) INTEGER -C The number of system outputs. P >= 0. -C -C NY (input) INTEGER -C The number of output vectors y(k) to be computed. -C NY >= 0. -C -C A (input) DOUBLE PRECISION array, dimension (LDA,N) -C The leading N-by-N part of this array must contain the -C state matrix A of the system. -C -C LDA INTEGER -C The leading dimension of array A. LDA >= MAX(1,N). -C -C B (input) DOUBLE PRECISION array, dimension (LDB,M) -C The leading N-by-M part of this array must contain the -C input matrix B of the system. -C -C LDB INTEGER -C The leading dimension of array B. LDB >= MAX(1,N). -C -C C (input) DOUBLE PRECISION array, dimension (LDC,N) -C The leading P-by-N part of this array must contain the -C output matrix C of the system. -C -C LDC INTEGER -C The leading dimension of array C. LDC >= MAX(1,P). -C -C D (input) DOUBLE PRECISION array, dimension (LDD,M) -C The leading P-by-M part of this array must contain the -C direct link matrix D of the system. -C -C LDD INTEGER -C The leading dimension of array D. LDD >= MAX(1,P). -C -C U (input) DOUBLE PRECISION array, dimension (LDU,M) -C The leading NY-by-M part of this array must contain the -C input vector sequence u(k), for k = 1,2,...,NY. -C Specifically, the k-th row of U must contain u(k)'. -C -C LDU INTEGER -C The leading dimension of array U. LDU >= MAX(1,NY). -C -C X (input/output) DOUBLE PRECISION array, dimension (N) -C On entry, this array must contain the initial state vector -C x(1) which consists of the N initial states of the system. -C On exit, this array contains the final state vector -C x(NY+1) of the N states of the system at instant NY+1. -C -C Y (output) DOUBLE PRECISION array, dimension (LDY,P) -C The leading NY-by-P part of this array contains the output -C vector sequence y(1),y(2),...,y(NY) such that the k-th -C row of Y contains y(k)' (the outputs at instant k), -C for k = 1,2,...,NY. -C -C LDY INTEGER -C The leading dimension of array Y. LDY >= MAX(1,NY). -C -C Workspace -C -C DWORK DOUBLE PRECISION array, dimension (LDWORK) -C -C LDWORK INTEGER -C The length of the array DWORK. LDWORK >= N. -C For better performance, LDWORK should be larger. -C -C Error Indicator -C -C INFO INTEGER -C = 0: successful exit; -C < 0: if INFO = -i, the i-th argument had an illegal -C value. -C -C METHOD -C -C Given an initial state vector x(1), the output vector sequence -C y(1), y(2),..., y(NY) is obtained via the formulae -C -C x(k+1) = A x(k) + B u(k) -C y(k) = C x(k) + D u(k), -C -C where each element y(k) is a vector of length P containing the -C outputs at instant k and k = 1,2,...,NY. -C -C REFERENCES -C -C [1] Luenberger, D.G. -C Introduction to Dynamic Systems: Theory, Models and -C Applications. -C John Wiley & Sons, New York, 1979. -C -C NUMERICAL ASPECTS -C -C The algorithm requires approximately (N + M) x (N + P) x NY -C multiplications and additions. -C -C FURTHER COMMENTS -C -C The implementation exploits data locality and uses BLAS 3 -C operations as much as possible, given the workspace length. -C -C CONTRIBUTOR -C -C V. Sima, Research Institute for Informatics, Bucharest, Mar. 2001. -C -C REVISIONS -C -C - -C -C KEYWORDS -C -C Discrete-time system, multivariable system, state-space model, -C state-space representation, time response. -C -C ****************************************************************** -C -C .. Parameters .. - DOUBLE PRECISION ZERO, ONE - PARAMETER ( ZERO = 0.0D0, ONE = 1.0D0 ) -C .. Scalar Arguments .. - INTEGER INFO, LDA, LDB, LDC, LDD, LDU, LDWORK, LDY, M, - $ N, NY, P -C .. Array Arguments .. - DOUBLE PRECISION A(LDA,*), B(LDB,*), C(LDC,*), D(LDD,*), - $ DWORK(*), U(LDU,*), X(*), Y(LDY,*) -C .. Local Scalars .. - INTEGER IK, IREM, IS, IYL, MAXN, NB, NS - DOUBLE PRECISION UPD -C .. External Functions .. - INTEGER ILAENV - EXTERNAL ILAENV -C .. External Subroutines .. - EXTERNAL DCOPY, DGEMM, DGEMV, DLASET, XERBLA -C .. Intrinsic Functions .. - INTRINSIC MAX, MIN -C .. Executable Statements .. -C - INFO = 0 -C -C Test the input scalar arguments. -C - MAXN = MAX( 1, N ) - IF( N.LT.0 ) THEN - INFO = -1 - ELSE IF( M.LT.0 ) THEN - INFO = -2 - ELSE IF( P.LT.0 ) THEN - INFO = -3 - ELSE IF( NY.LT.0 ) THEN - INFO = -4 - ELSE IF( LDA.LT.MAXN ) THEN - INFO = -6 - ELSE IF( LDB.LT.MAXN ) THEN - INFO = -8 - ELSE IF( LDC.LT.MAX( 1, P ) ) THEN - INFO = -10 - ELSE IF( LDD.LT.MAX( 1, P ) ) THEN - INFO = -12 - ELSE IF( LDU.LT.MAX( 1, NY ) ) THEN - INFO = -14 - ELSE IF( LDY.LT.MAX( 1, NY ) ) THEN - INFO = -17 - ELSE IF( LDWORK.LT.N ) THEN - INFO = -19 - END IF -C - IF ( INFO.NE.0 ) THEN -C -C Error return. -C - CALL XERBLA( 'TF01MY', -INFO ) - RETURN - END IF -C -C Quick return if possible. -C - IF ( MIN( NY, P ).EQ.0 ) THEN - RETURN - ELSE IF ( N.EQ.0 ) THEN -C -C Non-dynamic system: compute the output vectors. -C - IF ( M.EQ.0 ) THEN - CALL DLASET( 'Full', NY, P, ZERO, ZERO, Y, LDY ) - ELSE - CALL DGEMM( 'No transpose', 'Transpose', NY, P, M, ONE, - $ U, LDU, D, LDD, ZERO, Y, LDY ) - END IF - RETURN - END IF -C -C Determine the block size (taken as for LAPACK routine DGETRF). -C - NB = ILAENV( 1, 'DGETRF', ' ', NY, MAX( M, P ), -1, -1 ) -C -C Find the number of state vectors that can be accommodated in -C the provided workspace and initialize. -C - NS = MIN( LDWORK/N, NB*NB/N, NY ) -C - IF ( NS.LE.1 .OR. NY*MAX( M, P ).LE.NB*NB ) THEN -C -C LDWORK < 2*N or small problem: -C only BLAS 2 calculations are used in the loop -C for computing the output corresponding to D = 0. -C One row of the array Y is computed for each loop index value. -C - DO 10 IK = 1, NY - CALL DGEMV( 'No transpose', P, N, ONE, C, LDC, X, 1, ZERO, - $ Y(IK,1), LDY ) -C - CALL DGEMV( 'No transpose', N, N, ONE, A, LDA, X, 1, ZERO, - $ DWORK, 1 ) - CALL DGEMV( 'No transpose', N, M, ONE, B, LDB, U(IK,1), LDU, - $ ONE, DWORK, 1 ) -C - CALL DCOPY( N, DWORK, 1, X, 1 ) - 10 CONTINUE -C - ELSE -C -C LDWORK >= 2*N and large problem: -C some BLAS 3 calculations can also be used. -C - IYL = ( NY/NS )*NS - IF ( M.EQ.0 ) THEN - UPD = ZERO - ELSE - UPD = ONE - END IF -C - CALL DCOPY( N, X, 1, DWORK, 1 ) -C - DO 30 IK = 1, IYL, NS -C -C Compute the current NS-1 state vectors in the workspace. -C - CALL DGEMM( 'No transpose', 'Transpose', N, NS-1, M, ONE, - $ B, LDB, U(IK,1), LDU, ZERO, DWORK(N+1), MAXN ) -C - DO 20 IS = 1, NS - 1 - CALL DGEMV( 'No transpose', N, N, ONE, A, LDA, - $ DWORK((IS-1)*N+1), 1, UPD, DWORK(IS*N+1), 1 ) - 20 CONTINUE -C -C Initialize the current NS output vectors. -C - CALL DGEMM( 'Transpose', 'Transpose', NS, P, N, ONE, DWORK, - $ MAXN, C, LDC, ZERO, Y(IK,1), LDY ) -C -C Prepare the next iteration. -C - CALL DGEMV( 'No transpose', N, M, ONE, B, LDB, - $ U(IK+NS-1,1), LDU, ZERO, DWORK, 1 ) - CALL DGEMV( 'No transpose', N, N, ONE, A, LDA, - $ DWORK((NS-1)*N+1), 1, UPD, DWORK, 1 ) - 30 CONTINUE -C - IREM = NY - IYL -C - IF ( IREM.GT.1 ) THEN -C -C Compute the last IREM output vectors. -C First, compute the current IREM-1 state vectors. -C - IK = IYL + 1 - CALL DGEMM( 'No transpose', 'Transpose', N, IREM-1, M, ONE, - $ B, LDB, U(IK,1), LDU, ZERO, DWORK(N+1), MAXN ) -C - DO 40 IS = 1, IREM - 1 - CALL DGEMV( 'No transpose', N, N, ONE, A, LDA, - $ DWORK((IS-1)*N+1), 1, UPD, DWORK(IS*N+1), 1 ) - 40 CONTINUE -C -C Initialize the last IREM output vectors. -C - CALL DGEMM( 'Transpose', 'Transpose', IREM, P, N, ONE, - $ DWORK, MAXN, C, LDC, ZERO, Y(IK,1), LDY ) -C -C Prepare the final state vector. -C - CALL DGEMV( 'No transpose', N, M, ONE, B, LDB, - $ U(IK+IREM-1,1), LDU, ZERO, DWORK, 1 ) - CALL DGEMV( 'No transpose', N, N, ONE, A, LDA, - $ DWORK((IREM-1)*N+1), 1, UPD, DWORK, 1 ) -C - ELSE IF ( IREM.EQ.1 ) THEN -C -C Compute the last 1 output vectors. -C - CALL DGEMV( 'No transpose', P, N, ONE, C, LDC, DWORK, 1, - $ ZERO, Y(IK,1), LDY ) -C -C Prepare the final state vector. -C - CALL DCOPY( N, DWORK, 1, DWORK(N+1), 1 ) - CALL DGEMV( 'No transpose', N, M, ONE, B, LDB, - $ U(IK,1), LDU, ZERO, DWORK, 1 ) - CALL DGEMV( 'No transpose', N, N, ONE, A, LDA, - $ DWORK(N+1), 1, UPD, DWORK, 1 ) - END IF -C -C Set the final state vector. -C - CALL DCOPY( N, DWORK, 1, X, 1 ) -C - END IF -C -C Add the direct contribution of the input to the output vectors. -C - CALL DGEMM( 'No transpose', 'Transpose', NY, P, M, ONE, U, LDU, - $ D, LDD, ONE, Y, LDY ) -C - RETURN -C *** Last line of TF01MY *** - END diff --git a/mex/sources/libslicot/TF01ND.f b/mex/sources/libslicot/TF01ND.f deleted file mode 100644 index 04676e7e5..000000000 --- a/mex/sources/libslicot/TF01ND.f +++ /dev/null @@ -1,278 +0,0 @@ - SUBROUTINE TF01ND( UPLO, N, M, P, NY, A, LDA, B, LDB, C, LDC, D, - $ LDD, U, LDU, X, Y, LDY, DWORK, INFO ) -C -C SLICOT RELEASE 5.0. -C -C Copyright (c) 2002-2009 NICONET e.V. -C -C This program is free software: you can redistribute it and/or -C modify it under the terms of the GNU General Public License as -C published by the Free Software Foundation, either version 2 of -C the License, or (at your option) any later version. -C -C This program is distributed in the hope that it will be useful, -C but WITHOUT ANY WARRANTY; without even the implied warranty of -C MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the -C GNU General Public License for more details. -C -C You should have received a copy of the GNU General Public License -C along with this program. If not, see -C . -C -C PURPOSE -C -C To compute the output sequence of a linear time-invariant -C open-loop system given by its discrete-time state-space model -C (A,B,C,D), where A is an N-by-N upper or lower Hessenberg matrix. -C -C The initial state vector x(1) must be supplied by the user. -C -C ARGUMENTS -C -C Mode Parameters -C -C UPLO CHARACTER*1 -C Indicates whether the user wishes to use an upper or lower -C Hessenberg matrix as follows: -C = 'U': Upper Hessenberg matrix; -C = 'L': Lower Hessenberg matrix. -C -C Input/Output Parameters -C -C N (input) INTEGER -C The order of the matrix A. N >= 0. -C -C M (input) INTEGER -C The number of system inputs. M >= 0. -C -C P (input) INTEGER -C The number of system outputs. P >= 0. -C -C NY (input) INTEGER -C The number of output vectors y(k) to be computed. -C NY >= 0. -C -C A (input) DOUBLE PRECISION array, dimension (LDA,N) -C If UPLO = 'U', the leading N-by-N upper Hessenberg part -C of this array must contain the state matrix A of the -C system. -C If UPLO = 'L', the leading N-by-N lower Hessenberg part -C of this array must contain the state matrix A of the -C system. -C The remainder of the leading N-by-N part is not -C referenced. -C -C LDA INTEGER -C The leading dimension of array A. LDA >= MAX(1,N). -C -C B (input) DOUBLE PRECISION array, dimension (LDB,M) -C The leading N-by-M part of this array must contain the -C input matrix B of the system. -C -C LDB INTEGER -C The leading dimension of array B. LDB >= MAX(1,N). -C -C C (input) DOUBLE PRECISION array, dimension (LDC,N) -C The leading P-by-N part of this array must contain the -C output matrix C of the system. -C -C LDC INTEGER -C The leading dimension of array C. LDC >= MAX(1,P). -C -C D (input) DOUBLE PRECISION array, dimension (LDD,M) -C The leading P-by-M part of this array must contain the -C direct link matrix D of the system. -C -C LDD INTEGER -C The leading dimension of array D. LDD >= MAX(1,P). -C -C U (input) DOUBLE PRECISION array, dimension (LDU,NY) -C The leading M-by-NY part of this array must contain the -C input vector sequence u(k), for k = 1,2,...,NY. -C Specifically, the k-th column of U must contain u(k). -C -C LDU INTEGER -C The leading dimension of array U. LDU >= MAX(1,M). -C -C X (input/output) DOUBLE PRECISION array, dimension (N) -C On entry, this array must contain the initial state vector -C x(1) which consists of the N initial states of the system. -C On exit, this array contains the final state vector -C x(NY+1) of the N states of the system at instant NY. -C -C Y (output) DOUBLE PRECISION array, dimension (LDY,NY) -C The leading P-by-NY part of this array contains the output -C vector sequence y(1),y(2),...,y(NY) such that the k-th -C column of Y contains y(k) (the outputs at instant k), -C for k = 1,2,...,NY. -C -C LDY INTEGER -C The leading dimension of array Y. LDY >= MAX(1,P). -C -C Workspace -C -C DWORK DOUBLE PRECISION array, dimension (N) -C -C Error Indicator -C -C INFO INTEGER -C = 0: successful exit; -C < 0: if INFO = -i, the i-th argument had an illegal -C value. -C -C METHOD -C -C Given an initial state vector x(1), the output vector sequence -C y(1), y(2),..., y(NY) is obtained via the formulae -C -C x(k+1) = A x(k) + B u(k) -C y(k) = C x(k) + D u(k), -C -C where each element y(k) is a vector of length P containing the -C outputs at instant k and k = 1,2,...,NY. -C -C REFERENCES -C -C [1] Luenberger, D.G. -C Introduction to Dynamic Systems: Theory, Models and -C Applications. -C John Wiley & Sons, New York, 1979. -C -C NUMERICAL ASPECTS -C -C The algorithm requires approximately ((N+M)xP + (N/2+M)xN) x NY -C multiplications and additions. -C -C FURTHER COMMENTS -C -C The processing time required by this routine will be approximately -C half that required by the SLICOT Library routine TF01MD, which -C treats A as a general matrix. -C -C CONTRIBUTOR -C -C Release 3.0: V. Sima, Katholieke Univ. Leuven, Belgium, Dec. 1996. -C Supersedes Release 2.0 routine TF01BD by S. Van Huffel, Katholieke -C Univ. Leuven, Belgium. -C -C REVISIONS -C -C V. Sima, Research Institute for Informatics, Bucharest, Apr. 2003. -C -C KEYWORDS -C -C Discrete-time system, Hessenberg form, multivariable system, -C state-space model, state-space representation, time response. -C -C ****************************************************************** -C -C .. Parameters .. - DOUBLE PRECISION ZERO, ONE - PARAMETER ( ZERO = 0.0D0, ONE = 1.0D0 ) -C .. Scalar Arguments .. - CHARACTER UPLO - INTEGER INFO, LDA, LDB, LDC, LDD, LDU, LDY, M, N, NY, P -C .. Array Arguments .. - DOUBLE PRECISION A(LDA,*), B(LDB,*), C(LDC,*), D(LDD,*), - $ DWORK(*), U(LDU,*), X(*), Y(LDY,*) -C .. Local Scalars .. - LOGICAL LUPLO - INTEGER I, IK -C .. External Functions .. - LOGICAL LSAME - EXTERNAL LSAME -C .. External Subroutines .. - EXTERNAL DCOPY, DGEMM, DGEMV, DLASET, DTRMV, XERBLA -C .. Intrinsic Functions .. - INTRINSIC MAX, MIN -C .. Executable Statements .. -C - INFO = 0 - LUPLO = LSAME( UPLO, 'U' ) -C -C Test the input scalar arguments. -C - IF( .NOT.LUPLO .AND. .NOT.LSAME( UPLO, 'L' ) ) THEN - INFO = -1 - ELSE IF( N.LT.0 ) THEN - INFO = -2 - ELSE IF( M.LT.0 ) THEN - INFO = -3 - ELSE IF( P.LT.0 ) THEN - INFO = -4 - ELSE IF( NY.LT.0 ) THEN - INFO = -5 - ELSE IF( LDA.LT.MAX( 1, N ) ) THEN - INFO = -7 - ELSE IF( LDB.LT.MAX( 1, N ) ) THEN - INFO = -9 - ELSE IF( LDC.LT.MAX( 1, P ) ) THEN - INFO = -11 - ELSE IF( LDD.LT.MAX( 1, P ) ) THEN - INFO = -13 - ELSE IF( LDU.LT.MAX( 1, M ) ) THEN - INFO = -15 - ELSE IF( LDY.LT.MAX( 1, P ) ) THEN - INFO = -18 - END IF -C - IF ( INFO.NE.0 ) THEN -C -C Error return. -C - CALL XERBLA( 'TF01ND', -INFO ) - RETURN - END IF -C -C Quick return if possible. -C - IF ( MIN( P, NY ).EQ.0 ) THEN - RETURN - ELSE IF ( N.EQ.0 ) THEN -C -C Non-dynamic system: compute the output vectors. -C - IF ( M.EQ.0 ) THEN - CALL DLASET( 'Full', P, NY, ZERO, ZERO, Y, LDY ) - ELSE - CALL DGEMM( 'No transpose', 'No transpose', P, NY, M, ONE, - $ D, LDD, U, LDU, ZERO, Y, LDY ) - END IF - RETURN - END IF -C - CALL DCOPY( N, X, 1, DWORK, 1 ) -C - DO 30 IK = 1, NY - CALL DGEMV( 'No transpose', P, N, ONE, C, LDC, DWORK, 1, ZERO, - $ Y(1,IK), 1 ) -C - CALL DTRMV( UPLO, 'No transpose', 'Non-unit', N, A, LDA, - $ DWORK, 1 ) -C - IF ( LUPLO ) THEN -C - DO 10 I = 2, N - DWORK(I) = DWORK(I) + A(I,I-1)*X(I-1) - 10 CONTINUE -C - ELSE -C - DO 20 I = 1, N - 1 - DWORK(I) = DWORK(I) + A(I,I+1)*X(I+1) - 20 CONTINUE -C - END IF -C - CALL DGEMV( 'No transpose', N, M, ONE, B, LDB, U(1,IK), 1, ONE, - $ DWORK, 1 ) -C - CALL DCOPY( N, DWORK, 1, X, 1 ) - 30 CONTINUE -C - CALL DGEMM( 'No transpose', 'No transpose', P, NY, M, ONE, D, LDD, - $ U, LDU, ONE, Y, LDY ) -C - RETURN -C *** Last line of TF01ND *** - END diff --git a/mex/sources/libslicot/TF01OD.f b/mex/sources/libslicot/TF01OD.f deleted file mode 100644 index 656d86c9d..000000000 --- a/mex/sources/libslicot/TF01OD.f +++ /dev/null @@ -1,179 +0,0 @@ - SUBROUTINE TF01OD( NH1, NH2, NR, NC, H, LDH, T, LDT, INFO ) -C -C SLICOT RELEASE 5.0. -C -C Copyright (c) 2002-2009 NICONET e.V. -C -C This program is free software: you can redistribute it and/or -C modify it under the terms of the GNU General Public License as -C published by the Free Software Foundation, either version 2 of -C the License, or (at your option) any later version. -C -C This program is distributed in the hope that it will be useful, -C but WITHOUT ANY WARRANTY; without even the implied warranty of -C MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the -C GNU General Public License for more details. -C -C You should have received a copy of the GNU General Public License -C along with this program. If not, see -C . -C -C PURPOSE -C -C To construct the block Hankel expansion T of a multivariable -C parameter sequence M(1),...,M(NR+NC-1), where each parameter M(k) -C is an NH1-by-NH2 block matrix and k = 1,2,...,(NR+NC-1). -C -C ARGUMENTS -C -C Input/Output Parameters -C -C NH1 (input) INTEGER -C The number of rows in each parameter M(k). NH1 >= 0. -C -C NH2 (input) INTEGER -C The number of columns in each parameter M(k). NH2 >= 0. -C -C NR (input) INTEGER -C The number of parameters required in each column of the -C block Hankel expansion matrix T. NR >= 0. -C -C NC (input) INTEGER -C The number of parameters required in each row of the -C block Hankel expansion matrix T. NC >= 0. -C -C H (input) DOUBLE PRECISION array, dimension -C (LDH,(NR+NC-1)*NH2) -C The leading NH1-by-(NR+NC-1)*NH2 part of this array must -C contain the multivariable sequence M(k), where k = 1,2, -C ...,(NR+NC-1). Specifically, each parameter M(k) is an -C NH1-by-NH2 matrix whose (i,j)-th element must be stored in -C H(i,(k-1)*NH2+j) for i = 1,2,...,NH1 and j = 1,2,...,NH2. -C -C LDH INTEGER -C The leading dimension of array H. LDH >= MAX(1,NH1). -C -C T (output) DOUBLE PRECISION array, dimension (LDT,NH2*NC) -C The leading NH1*NR-by-NH2*NC part of this array contains -C the block Hankel expansion of the multivariable sequence -C M(k). -C -C LDT INTEGER -C The leading dimension of array T. LDT >= MAX(1,NH1*NR). -C -C Error Indicator -C -C INFO INTEGER -C = 0: successful exit; -C < 0: if INFO = -i, the i-th argument had an illegal -C value. -C -C METHOD -C -C The NH1-by-NH2 dimensional parameters M(k) of a multivariable -C sequence are arranged into a matrix T in Hankel form such that -C -C -C | M(1) M(2) M(3) . . . M(NC) | -C | | -C | M(2) M(3) M(4) . . . M(NC+1) | -C T = | . . . . |. -C | . . . . | -C | . . . . | -C | | -C | M(NR) M(NR+1) M(NR+2) . . . M(NR+NC-1)| -C -C REFERENCES -C -C [1] Johvidov, J.S. -C Hankel and Toeplitz Matrices and Forms: Algebraic Theory, -C (translated by G.P.A. Thijsse, I. Gohberg, ed.). -C Birkhaeuser, Boston, 1982. -C -C NUMERICAL ASPECTS -C -C The time taken is approximately proportional to -C NH1 x NH2 x NR x NC. -C -C CONTRIBUTOR -C -C Release 3.0: V. Sima, Katholieke Univ. Leuven, Belgium, Dec. 1996. -C Supersedes Release 2.0 routine TF01CD by S. Van Huffel, Katholieke -C Univ. Leuven, Belgium. -C -C REVISIONS -C -C - -C -C KEYWORDS -C -C Hankel matrix, multivariable system. -C -C ****************************************************************** -C -C .. Scalar Arguments .. - INTEGER INFO, LDH, LDT, NC, NH1, NH2, NR -C .. Array Arguments .. - DOUBLE PRECISION H(LDH,*), T(LDT,*) -C .. Local Scalars .. - INTEGER IH, IT, JT, NROW -C .. External Subroutines .. - EXTERNAL DLACPY, XERBLA -C .. Intrinsic Functions .. - INTRINSIC MAX -C .. Executable Statements .. -C - INFO = 0 -C -C Test the input scalar arguments. -C - IF( NH1.LT.0 ) THEN - INFO = -1 - ELSE IF( NH2.LT.0 ) THEN - INFO = -2 - ELSE IF( NR.LT.0 ) THEN - INFO = -3 - ELSE IF( NC.LT.0 ) THEN - INFO = -4 - ELSE IF( LDH.LT.MAX( 1, NH1 ) ) THEN - INFO = -6 - ELSE IF( LDT.LT.MAX( 1, NH1*NR ) ) THEN - INFO = -8 - END IF -C - IF ( INFO.NE.0 ) THEN -C -C Error return. -C - CALL XERBLA( 'TF01OD', -INFO ) - RETURN - END IF -C -C Quick return if possible. -C - IF ( MAX( NH1, NH2, NR, NC ).EQ.0 ) - $ RETURN -C -C Construct the first block column of T. -C - IH = 1 - NROW = (NR-1)*NH1 -C - DO 10 IT = 1, NROW+NH1, NH1 - CALL DLACPY( 'Full', NH1, NH2, H(1,IH), LDH, T(IT,1), LDT ) - IH = IH + NH2 - 10 CONTINUE -C -C Construct the remaining block columns of T. -C - DO 20 JT = NH2+1, NC*NH2, NH2 - CALL DLACPY( 'Full', NROW, NH2, T(NH1+1,JT-NH2), LDT, T(1,JT), - $ LDT ) - CALL DLACPY( 'Full', NH1, NH2, H(1,IH), LDH, T(NROW+1,JT), - $ LDT ) - IH = IH + NH2 - 20 CONTINUE -C - RETURN -C *** Last line of TF01OD *** - END diff --git a/mex/sources/libslicot/TF01PD.f b/mex/sources/libslicot/TF01PD.f deleted file mode 100644 index e45f078b6..000000000 --- a/mex/sources/libslicot/TF01PD.f +++ /dev/null @@ -1,178 +0,0 @@ - SUBROUTINE TF01PD( NH1, NH2, NR, NC, H, LDH, T, LDT, INFO ) -C -C SLICOT RELEASE 5.0. -C -C Copyright (c) 2002-2009 NICONET e.V. -C -C This program is free software: you can redistribute it and/or -C modify it under the terms of the GNU General Public License as -C published by the Free Software Foundation, either version 2 of -C the License, or (at your option) any later version. -C -C This program is distributed in the hope that it will be useful, -C but WITHOUT ANY WARRANTY; without even the implied warranty of -C MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the -C GNU General Public License for more details. -C -C You should have received a copy of the GNU General Public License -C along with this program. If not, see -C . -C -C PURPOSE -C -C To construct the block Toeplitz expansion T of a multivariable -C parameter sequence M(1),...,M(NR+NC-1), where each parameter M(k) -C is an NH1-by-NH2 block matrix and k = 1,2,...,(NR+NC-1). -C -C ARGUMENTS -C -C Input/Output Parameters -C -C NH1 (input) INTEGER -C The number of rows in each parameter M(k). NH1 >= 0. -C -C NH2 (input) INTEGER -C The number of columns in each parameter M(k). NH2 >= 0. -C -C NR (input) INTEGER -C The number of parameters required in each column of the -C block Toeplitz expansion matrix T. NR >= 0. -C -C NC (input) INTEGER -C The number of parameters required in each row of the -C block Toeplitz expansion matrix T. NC >= 0. -C -C H (input) DOUBLE PRECISION array, dimension -C (LDH,(NR+NC-1)*NH2) -C The leading NH1-by-(NR+NC-1)*NH2 part of this array must -C contain the multivariable sequence M(k), where k = 1,2, -C ...,(NR+NC-1). Specifically, each parameter M(k) is an -C NH1-by-NH2 matrix whose (i,j)-th element must be stored in -C H(i,(k-1)*NH2+j) for i = 1,2,...,NH1 and j = 1,2,...,NH2. -C -C LDH INTEGER -C The leading dimension of array H. LDH >= MAX(1,NH1). -C -C T (output) DOUBLE PRECISION array, dimension (LDT,NH2*NC) -C The leading NH1*NR-by-NH2*NC part of this array contains -C the block Toeplitz expansion of the multivariable sequence -C M(k). -C -C LDT INTEGER -C The leading dimension of array T. LDT >= MAX(1,NH1*NR). -C -C Error Indicator -C -C INFO INTEGER -C = 0: successful exit; -C < 0: if INFO = -i, the i-th argument had an illegal -C value. -C -C METHOD -C -C The NH1-by-NH2 dimensional parameters M(k) of a multivariable -C sequence are arranged into a matrix T in Toeplitz form such that -C -C | M(NC) M(NC-1) M(NC-2) . . . M(1) | -C | | -C | M(NC+1) M(NC) M(NC-1) . . . M(2) | -C T = | . . . . |. -C | . . . . | -C | . . . . | -C | | -C | M(NR+NC-1) M(NR+NC-2) M(NR+NC-3) . . . M(NR) | -C -C REFERENCES -C -C [1] Johvidov, J.S. -C Hankel and Toeplitz Matrices and Forms: Algebraic Theory, -C (translated by G.P.A. Thijsse, I. Gohberg, ed.). -C Birkhaeuser, Boston, 1982. -C -C NUMERICAL ASPECTS -C -C The time taken is approximately proportional to -C NH1 x NH2 x NR x NC. -C -C CONTRIBUTOR -C -C Release 3.0: V. Sima, Katholieke Univ. Leuven, Belgium, Dec. 1996. -C Supersedes Release 2.0 routine TF01DD by S. Van Huffel, Katholieke -C Univ. Leuven, Belgium. -C -C REVISIONS -C -C - -C -C KEYWORDS -C -C Multivariable system, Toeplitz matrix. -C -C ****************************************************************** -C -C .. Scalar Arguments .. - INTEGER INFO, LDH, LDT, NC, NH1, NH2, NR -C .. Array Arguments .. - DOUBLE PRECISION H(LDH,*), T(LDT,*) -C .. Local Scalars .. - INTEGER IH, IT, JT, NCOL, NROW -C .. External Subroutines .. - EXTERNAL DLACPY, XERBLA -C .. Executable Statements .. -C - INFO = 0 -C -C Test the input scalar arguments. -C - IF( NH1.LT.0 ) THEN - INFO = -1 - ELSE IF( NH2.LT.0 ) THEN - INFO = -2 - ELSE IF( NR.LT.0 ) THEN - INFO = -3 - ELSE IF( NC.LT.0 ) THEN - INFO = -4 - ELSE IF( LDH.LT.MAX( 1, NH1 ) ) THEN - INFO = -6 - ELSE IF( LDT.LT.MAX( 1, NH1*NR ) ) THEN - INFO = -8 - END IF -C - IF ( INFO.NE.0 ) THEN -C -C Error return. -C - CALL XERBLA( 'TF01PD', -INFO ) - RETURN - END IF -C -C Quick return if possible. -C - IF ( MAX( NH1, NH2, NR, NC ).EQ.0 ) - $ RETURN -C -C Construct the last block column of T. -C - IH = 1 - NROW = (NR-1)*NH1 - NCOL = (NC-1)*NH2 + 1 -C - DO 10 IT = 1, NROW+NH1, NH1 - CALL DLACPY( 'Full', NH1, NH2, H(1,IH), LDH, T(IT,NCOL), - $ LDT ) - IH = IH + NH2 - 10 CONTINUE -C -C Construct the remaining block columns of T in backward order. -C - DO 20 JT = NCOL-NH2, 1, -NH2 - CALL DLACPY( 'Full', NROW, NH2, T(NH1+1,JT+NH2), LDT, T(1,JT), - $ LDT ) - CALL DLACPY( 'Full', NH1, NH2, H(1,IH), LDH, T(NROW+1,JT), - $ LDT ) - IH = IH + NH2 - 20 CONTINUE -C - RETURN -C *** Last line of TF01PD *** - END diff --git a/mex/sources/libslicot/TF01QD.f b/mex/sources/libslicot/TF01QD.f deleted file mode 100644 index a2d3696ce..000000000 --- a/mex/sources/libslicot/TF01QD.f +++ /dev/null @@ -1,234 +0,0 @@ - SUBROUTINE TF01QD( NC, NB, N, IORD, AR, MA, H, LDH, INFO ) -C -C SLICOT RELEASE 5.0. -C -C Copyright (c) 2002-2009 NICONET e.V. -C -C This program is free software: you can redistribute it and/or -C modify it under the terms of the GNU General Public License as -C published by the Free Software Foundation, either version 2 of -C the License, or (at your option) any later version. -C -C This program is distributed in the hope that it will be useful, -C but WITHOUT ANY WARRANTY; without even the implied warranty of -C MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the -C GNU General Public License for more details. -C -C You should have received a copy of the GNU General Public License -C along with this program. If not, see -C . -C -C PURPOSE -C -C To compute N Markov parameters M(1), M(2),..., M(N) from a -C multivariable system whose transfer function matrix G(z) is given. -C -C ARGUMENTS -C -C Input/Output Parameters -C -C NC (input) INTEGER -C The number of system outputs, i.e. the number of rows in -C the transfer function matrix G(z). NC >= 0. -C -C NB (input) INTEGER -C The number of system inputs, i.e. the number of columns in -C the transfer function matrix G(z). NB >= 0. -C -C N (input) INTEGER -C The number of Markov parameters M(k) to be computed. -C N >= 0. -C -C IORD (input) INTEGER array, dimension (NC*NB) -C This array must contain the order r of the elements of the -C transfer function matrix G(z), stored row by row. -C For example, the order of the (i,j)-th element of G(z) is -C given by IORD((i-1)xNB+j). -C -C AR (input) DOUBLE PRECISION array, dimension (NA), where -C NA = IORD(1) + IORD(2) + ... + IORD(NC*NB). -C The leading NA elements of this array must contain the -C denominator coefficients AR(1),...,AR(r) in equation (1) -C of the (i,j)-th element of the transfer function matrix -C G(z), stored row by row, i.e. in the order -C (1,1),(1,2),...,(1,NB), (2,1),(2,2),...,(2,NB), ..., -C (NC,1),(NC,2),...,(NC,NB). The coefficients must be given -C in decreasing order of powers of z; the coefficient of the -C highest order term is assumed to be equal to 1. -C -C MA (input) DOUBLE PRECISION array, dimension (NA) -C The leading NA elements of this array must contain the -C numerator coefficients MA(1),...,MA(r) in equation (1) -C of the (i,j)-th element of the transfer function matrix -C G(z), stored row by row, i.e. in the order -C (1,1),(1,2),...,(1,NB), (2,1),(2,2),...,(2,NB), ..., -C (NC,1),(NC,2),...,(NC,NB). The coefficients must be given -C in decreasing order of powers of z. -C -C H (output) DOUBLE PRECISION array, dimension (LDH,N*NB) -C The leading NC-by-N*NB part of this array contains the -C multivariable Markov parameter sequence M(k), where each -C parameter M(k) is an NC-by-NB matrix and k = 1,2,...,N. -C The Markov parameters are stored such that H(i,(k-1)xNB+j) -C contains the (i,j)-th element of M(k) for i = 1,2,...,NC -C and j = 1,2,...,NB. -C -C LDH INTEGER -C The leading dimension of array H. LDH >= MAX(1,NC). -C -C Error Indicator -C -C INFO INTEGER -C = 0: successful exit; -C < 0: if INFO = -i, the i-th argument had an illegal -C value. -C -C METHOD -C -C The (i,j)-th element of G(z), defining the particular I/O transfer -C between output i and input j, has the following form: -C -C -1 -2 -r -C MA(1)z + MA(2)z + ... + MA(r)z -C G (z) = ----------------------------------------. (1) -C ij -1 -2 -r -C 1 + AR(1)z + AR(2)z + ... + AR(r)z -C -C The (i,j)-th element of G(z) is defined by its order r, its r -C moving average coefficients (= numerator) MA(1),...,MA(r) and its -C r autoregressive coefficients (= denominator) AR(1),...,AR(r). The -C coefficient of the constant term in the denominator is assumed to -C be equal to 1. -C -C The relationship between the (i,j)-th element of the Markov -C parameters M(1),M(2),...,M(N) and the corresponding element of the -C transfer function matrix G(z) is given by: -C -C -1 -2 -k -C G (z) = M (0) + M (1)z + M (2)z + ... + M (k)z + ...(2) -C ij ij ij ij ij -C -C Equating (1) and (2), we find that the relationship between the -C (i,j)-th element of the Markov parameters M(k) and the ARMA -C parameters AR(1),...,AR(r) and MA(1),...,MA(r) of the (i,j)-th -C element of the transfer function matrix G(z) is as follows: -C -C M (1) = MA(1), -C ij -C k-1 -C M (k) = MA(k) - SUM AR(p) x M (k-p) for 1 < k <= r and -C ij p=1 ij -C r -C M (k+r) = - SUM AR(p) x M (k+r-p) for k > 0. -C ij p=1 ij -C -C From these expressions the Markov parameters M(k) are computed -C element by element. -C -C REFERENCES -C -C [1] Luenberger, D.G. -C Introduction to Dynamic Systems: Theory, Models and -C Applications. -C John Wiley & Sons, New York, 1979. -C -C NUMERICAL ASPECTS -C -C The computation of the (i,j)-th element of M(k) requires: -C (k-1) multiplications and k additions if k <= r; -C r multiplications and r additions if k > r. -C -C CONTRIBUTOR -C -C Release 3.0: V. Sima, Katholieke Univ. Leuven, Belgium, Dec. 1996. -C Supersedes Release 2.0 routine TF01ED by S. Van Huffel, Katholieke -C Univ. Leuven, Belgium. -C -C REVISIONS -C -C - -C -C KEYWORDS -C -C Markov parameters, multivariable system, transfer function, -C transfer matrix. -C -C ****************************************************************** -C -C .. Parameters .. - DOUBLE PRECISION ZERO - PARAMETER ( ZERO = 0.0D0 ) -C .. Scalar Arguments .. - INTEGER INFO, LDH, N, NB, NC -C .. Array Arguments .. - INTEGER IORD(*) - DOUBLE PRECISION AR(*), H(LDH,*), MA(*) -C .. Local Scalars .. - INTEGER I, J, JJ, JK, K, KI, LDHNB, NL, NORD -C .. External Functions .. - DOUBLE PRECISION DDOT - EXTERNAL DDOT -C .. External Subroutines .. - EXTERNAL XERBLA -C .. Intrinsic Functions .. - INTRINSIC MAX -C .. Executable Statements .. -C - INFO = 0 -C -C Test the input scalar arguments. -C - IF( NC.LT.0 ) THEN - INFO = -1 - ELSE IF( NB.LT.0 ) THEN - INFO = -2 - ELSE IF( N.LT.0 ) THEN - INFO = -3 - ELSE IF( LDH.LT.MAX( 1, NC ) ) THEN - INFO = -8 - END IF -C - IF ( INFO.NE.0 ) THEN -C -C Error return. -C - CALL XERBLA( 'TF01QD', -INFO ) - RETURN - END IF -C -C Quick return if possible. -C - IF ( MAX( NC, NB, N ).EQ.0 ) - $ RETURN -C - LDHNB = LDH*NB - NL = 1 - K = 1 -C - DO 60 I = 1, NC -C - DO 50 J = 1, NB - NORD = IORD(K) - H(I,J) = MA(NL) - JK = J -C - DO 20 KI = 1, NORD - 1 - JK = JK + NB - H(I,JK) = MA(NL+KI) - DDOT( KI, AR(NL), 1, H(I,J), - $ -LDHNB ) - 20 CONTINUE -C - DO 40 JJ = J, J + (N - NORD - 1)*NB, NB - JK = JK + NB - H(I,JK) = -DDOT( NORD, AR(NL), 1, H(I,JJ), -LDHNB ) - 40 CONTINUE -C - NL = NL + NORD - K = K + 1 - 50 CONTINUE -C - 60 CONTINUE -C - RETURN -C *** Last line of TF01QD *** - END diff --git a/mex/sources/libslicot/TF01RD.f b/mex/sources/libslicot/TF01RD.f deleted file mode 100644 index d28a6ed98..000000000 --- a/mex/sources/libslicot/TF01RD.f +++ /dev/null @@ -1,230 +0,0 @@ - SUBROUTINE TF01RD( NA, NB, NC, N, A, LDA, B, LDB, C, LDC, H, LDH, - $ DWORK, LDWORK, INFO ) -C -C SLICOT RELEASE 5.0. -C -C Copyright (c) 2002-2009 NICONET e.V. -C -C This program is free software: you can redistribute it and/or -C modify it under the terms of the GNU General Public License as -C published by the Free Software Foundation, either version 2 of -C the License, or (at your option) any later version. -C -C This program is distributed in the hope that it will be useful, -C but WITHOUT ANY WARRANTY; without even the implied warranty of -C MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the -C GNU General Public License for more details. -C -C You should have received a copy of the GNU General Public License -C along with this program. If not, see -C . -C -C PURPOSE -C -C To compute N Markov parameters M(1), M(2),..., M(N) from the -C parameters (A,B,C) of a linear time-invariant system, where each -C M(k) is an NC-by-NB matrix and k = 1,2,...,N. -C -C All matrices are treated as dense, and hence TF01RD is not -C intended for large sparse problems. -C -C ARGUMENTS -C -C Input/Output Parameters -C -C NA (input) INTEGER -C The order of the matrix A. NA >= 0. -C -C NB (input) INTEGER -C The number of system inputs. NB >= 0. -C -C NC (input) INTEGER -C The number of system outputs. NC >= 0. -C -C N (input) INTEGER -C The number of Markov parameters M(k) to be computed. -C N >= 0. -C -C A (input) DOUBLE PRECISION array, dimension (LDA,NA) -C The leading NA-by-NA part of this array must contain the -C state matrix A of the system. -C -C LDA INTEGER -C The leading dimension of array A. LDA >= MAX(1,NA). -C -C B (input) DOUBLE PRECISION array, dimension (LDB,NB) -C The leading NA-by-NB part of this array must contain the -C input matrix B of the system. -C -C LDB INTEGER -C The leading dimension of array B. LDB >= MAX(1,NA). -C -C C (input) DOUBLE PRECISION array, dimension (LDC,NA) -C The leading NC-by-NA part of this array must contain the -C output matrix C of the system. -C -C LDC INTEGER -C The leading dimension of array C. LDC >= MAX(1,NC). -C -C H (output) DOUBLE PRECISION array, dimension (LDH,N*NB) -C The leading NC-by-N*NB part of this array contains the -C multivariable parameters M(k), where each parameter M(k) -C is an NC-by-NB matrix and k = 1,2,...,N. The Markov -C parameters are stored such that H(i,(k-1)xNB+j) contains -C the (i,j)-th element of M(k) for i = 1,2,...,NC and -C j = 1,2,...,NB. -C -C LDH INTEGER -C The leading dimension of array H. LDH >= MAX(1,NC). -C -C Workspace -C -C DWORK DOUBLE PRECISION array, dimension (LDWORK) -C -C LDWORK INTEGER -C The length of the array DWORK. -C LDWORK >= MAX(1, 2*NA*NC). -C -C Error Indicator -C -C INFO INTEGER -C = 0: successful exit; -C < 0: if INFO = -i, the i-th argument had an illegal -C value. -C -C METHOD -C -C For the linear time-invariant discrete-time system -C -C x(k+1) = A x(k) + B u(k) -C y(k) = C x(k) + D u(k), -C -C the transfer function matrix G(z) is given by -C -1 -C G(z) = C(zI-A) B + D -C -1 -2 2 -3 -C = D + CB z + CAB z + CA B z + ... (1) -C -C Using Markov parameters, G(z) can also be written as -C -1 -2 -3 -C G(z) = M(0) + M(1)z + M(2)z + M(3)z + ... (2) -C -C k-1 -C Equating (1) and (2), we find that M(0) = D and M(k) = C A B -C for k > 0, from which the Markov parameters M(1),M(2)...,M(N) are -C computed. -C -C REFERENCES -C -C [1] Chen, C.T. -C Introduction to Linear System Theory. -C H.R.W. Series in Electrical Engineering, Electronics and -C Systems, Holt, Rinehart and Winston Inc., London, 1970. -C -C NUMERICAL ASPECTS -C -C The algorithm requires approximately (NA + NB) x NA x NC x N -C multiplications and additions. -C -C CONTRIBUTOR -C -C Release 3.0: V. Sima, Katholieke Univ. Leuven, Belgium, Dec. 1996. -C Supersedes Release 2.0 routine TF01FD by S. Van Huffel, Katholieke -C Univ. Leuven, Belgium. -C -C REVISIONS -C -C - -C -C KEYWORDS -C -C Markov parameters, multivariable system, time-invariant system, -C transfer function, transfer matrix. -C -C ****************************************************************** -C -C .. Parameters .. - DOUBLE PRECISION ZERO, ONE - PARAMETER ( ZERO = 0.0D0, ONE = 1.0D0 ) -C .. Scalar Arguments .. - INTEGER INFO, LDA, LDB, LDC, LDH, LDWORK, N, NA, NB, NC -C .. Array Arguments .. - DOUBLE PRECISION A(LDA,*), B(LDB,*), C(LDC,*), DWORK(*), H(LDH,*) -C .. Local Scalars .. - INTEGER I, JWORK, K, LDW -C .. External Subroutines .. - EXTERNAL DGEMM, DLACPY, XERBLA -C .. Intrinsic Functions .. - INTRINSIC MAX, MIN -C .. Executable Statements .. -C - INFO = 0 -C -C Test the input scalar arguments. -C - IF( NA.LT.0 ) THEN - INFO = -1 - ELSE IF( NB.LT.0 ) THEN - INFO = -2 - ELSE IF( NC.LT.0 ) THEN - INFO = -3 - ELSE IF( N.LT.0 ) THEN - INFO = -4 - ELSE IF( LDA.LT.MAX( 1, NA ) ) THEN - INFO = -6 - ELSE IF( LDB.LT.MAX( 1, NA ) ) THEN - INFO = -8 - ELSE IF( LDC.LT.MAX( 1, NC ) ) THEN - INFO = -10 - ELSE IF( LDH.LT.MAX( 1, NC ) ) THEN - INFO = -12 - ELSE IF( LDWORK.LT.MAX( 1, 2*NA*NC ) ) THEN - INFO = -14 - END IF -C - IF ( INFO.NE.0 ) THEN -C -C Error return. -C - CALL XERBLA( 'TF01RD', -INFO ) - RETURN - END IF -C -C Quick return if possible. -C - IF ( MIN( NA, NB, NC, N ).EQ.0 ) - $ RETURN -C - JWORK = 1 + NC*NA - LDW = MAX( 1, NC ) - I = 1 -C -C Copy C in the workspace beginning from the position JWORK. -C This workspace will contain the product C*A**(K-1), K = 1,2,...,N. -C - CALL DLACPY( 'Full', NC, NA, C, LDC, DWORK(JWORK), LDW ) -C -C Form M(1), M(2), ..., M(N). -C - DO 10 K = 1, N - CALL DLACPY( 'Full', NC, NA, DWORK(JWORK), LDW, DWORK, LDW ) -C -C Form (C * A**(K-1)) * B = M(K). -C - CALL DGEMM( 'No transpose', 'No transpose', NC, NB, NA, ONE, - $ DWORK, LDW, B, LDB, ZERO, H(1,I), LDH ) -C - IF ( K.NE.N ) THEN -C -C Form C * A**K. -C - CALL DGEMM( 'No transpose', 'No transpose', NC, NA, NA, ONE, - $ DWORK, LDW, A, LDA, ZERO, DWORK(JWORK), LDW ) -C - I = I + NB - END IF - 10 CONTINUE -C - RETURN -C *** Last line of TF01RD *** - END diff --git a/mex/sources/libslicot/TG01AD.f b/mex/sources/libslicot/TG01AD.f deleted file mode 100644 index 5bae2d7bf..000000000 --- a/mex/sources/libslicot/TG01AD.f +++ /dev/null @@ -1,513 +0,0 @@ - SUBROUTINE TG01AD( JOB, L, N, M, P, THRESH, A, LDA, E, LDE, - $ B, LDB, C, LDC, LSCALE, RSCALE, DWORK, INFO ) -C -C SLICOT RELEASE 5.0. -C -C Copyright (c) 2002-2009 NICONET e.V. -C -C This program is free software: you can redistribute it and/or -C modify it under the terms of the GNU General Public License as -C published by the Free Software Foundation, either version 2 of -C the License, or (at your option) any later version. -C -C This program is distributed in the hope that it will be useful, -C but WITHOUT ANY WARRANTY; without even the implied warranty of -C MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the -C GNU General Public License for more details. -C -C You should have received a copy of the GNU General Public License -C along with this program. If not, see -C . -C -C PURPOSE -C -C To balance the matrices of the system pencil -C -C S = ( A B ) - lambda ( E 0 ) := Q - lambda Z, -C ( C 0 ) ( 0 0 ) -C -C corresponding to the descriptor triple (A-lambda E,B,C), -C by balancing. This involves diagonal similarity transformations -C (Dl*A*Dr - lambda Dl*E*Dr, Dl*B, C*Dr) applied to the system -C (A-lambda E,B,C) to make the rows and columns of system pencil -C matrices -C -C diag(Dl,I) * S * diag(Dr,I) -C -C as close in norm as possible. Balancing may reduce the 1-norms -C of the matrices of the system pencil S. -C -C The balancing can be performed optionally on the following -C particular system pencils -C -C S = A-lambda E, -C -C S = ( A-lambda E B ), or -C -C S = ( A-lambda E ). -C ( C ) -C -C ARGUMENTS -C -C Mode Parameters -C -C JOB CHARACTER*1 -C Indicates which matrices are involved in balancing, as -C follows: -C = 'A': All matrices are involved in balancing; -C = 'B': B, A and E matrices are involved in balancing; -C = 'C': C, A and E matrices are involved in balancing; -C = 'N': B and C matrices are not involved in balancing. -C -C Input/Output Parameters -C -C L (input) INTEGER -C The number of rows of matrices A, B, and E. L >= 0. -C -C N (input) INTEGER -C The number of columns of matrices A, E, and C. N >= 0. -C -C M (input) INTEGER -C The number of columns of matrix B. M >= 0. -C -C P (input) INTEGER -C The number of rows of matrix C. P >= 0. -C -C THRESH (input) DOUBLE PRECISION -C Threshold value for magnitude of elements: -C elements with magnitude less than or equal to -C THRESH are ignored for balancing. THRESH >= 0. -C -C A (input/output) DOUBLE PRECISION array, dimension (LDA,N) -C On entry, the leading L-by-N part of this array must -C contain the state dynamics matrix A. -C On exit, the leading L-by-N part of this array contains -C the balanced matrix Dl*A*Dr. -C -C LDA INTEGER -C The leading dimension of array A. LDA >= MAX(1,L). -C -C E (input/output) DOUBLE PRECISION array, dimension (LDE,N) -C On entry, the leading L-by-N part of this array must -C contain the descriptor matrix E. -C On exit, the leading L-by-N part of this array contains -C the balanced matrix Dl*E*Dr. -C -C LDE INTEGER -C The leading dimension of array E. LDE >= MAX(1,L). -C -C B (input/output) DOUBLE PRECISION array, dimension (LDB,M) -C On entry, the leading L-by-M part of this array must -C contain the input/state matrix B. -C On exit, if M > 0, the leading L-by-M part of this array -C contains the balanced matrix Dl*B. -C The array B is not referenced if M = 0. -C -C LDB INTEGER -C The leading dimension of array B. -C LDB >= MAX(1,L) if M > 0 or LDB >= 1 if M = 0. -C -C C (input/output) DOUBLE PRECISION array, dimension (LDC,N) -C On entry, the leading P-by-N part of this array must -C contain the state/output matrix C. -C On exit, if P > 0, the leading P-by-N part of this array -C contains the balanced matrix C*Dr. -C The array C is not referenced if P = 0. -C -C LDC INTEGER -C The leading dimension of array C. LDC >= MAX(1,P). -C -C LSCALE (output) DOUBLE PRECISION array, dimension (L) -C The scaling factors applied to S from left. If Dl(j) is -C the scaling factor applied to row j, then -C SCALE(j) = Dl(j), for j = 1,...,L. -C -C RSCALE (output) DOUBLE PRECISION array, dimension (N) -C The scaling factors applied to S from right. If Dr(j) is -C the scaling factor applied to column j, then -C SCALE(j) = Dr(j), for j = 1,...,N. -C -C Workspace -C -C DWORK DOUBLE PRECISION array, dimension (3*(L+N)) -C -C Error Indicator -C -C INFO INTEGER -C = 0: successful exit. -C < 0: if INFO = -i, the i-th argument had an illegal -C value. -C -C METHOD -C -C Balancing consists of applying a diagonal similarity -C transformation -C -1 -C diag(Dl,I) * S * diag(Dr,I) -C -C to make the 1-norms of each row of the first L rows of S and its -C corresponding N columns nearly equal. -C -C Information about the diagonal matrices Dl and Dr are returned in -C the vectors LSCALE and RSCALE, respectively. -C -C REFERENCES -C -C [1] Anderson, E., Bai, Z., Bischof, C., Demmel, J., Dongarra, J., -C Du Croz, J., Greenbaum, A., Hammarling, S., McKenney, A., -C Ostrouchov, S., and Sorensen, D. -C LAPACK Users' Guide: Second Edition. -C SIAM, Philadelphia, 1995. -C -C [2] R.C. Ward, R. C. -C Balancing the generalized eigenvalue problem. -C SIAM J. Sci. Stat. Comp. 2 (1981), 141-152. -C -C NUMERICAL ASPECTS -C -C None. -C -C CONTRIBUTOR -C -C A. Varga, German Aerospace Center, DLR Oberpfaffenhofen. -C March 1999. Based on the LAPACK routine DGGBAL. -C -C REVISIONS -C -C V. Sima, Research Institute for Informatics, Bucharest, July 1999, -C May 2003, March 2004, Jan. 2009. -C -C KEYWORDS -C -C Balancing, eigenvalue, matrix algebra, matrix operations, -C similarity transformation. -C -C ********************************************************************* -C -C .. Parameters .. - DOUBLE PRECISION HALF, ONE, ZERO - PARAMETER ( HALF = 0.5D+0, ONE = 1.0D+0, ZERO = 0.0D+0 ) - DOUBLE PRECISION SCLFAC, THREE - PARAMETER ( SCLFAC = 1.0D+1, THREE = 3.0D+0 ) -C .. Scalar Arguments .. - CHARACTER JOB - INTEGER INFO, L, LDA, LDB, LDC, LDE, M, N, P - DOUBLE PRECISION THRESH -C .. Array Arguments .. - DOUBLE PRECISION A( LDA, * ), B( LDB, * ), C( LDC, * ), - $ DWORK( * ), E( LDE, * ), LSCALE( * ), - $ RSCALE( * ) -C .. Local Scalars .. - LOGICAL WITHB, WITHC - INTEGER I, ICAB, IR, IRAB, IT, J, JC, KOUNT, KW1, KW2, - $ KW3, KW4, KW5, LCAB, LRAB, LSFMAX, LSFMIN, - $ NRP2 - DOUBLE PRECISION ALPHA, BASL, BETA, CAB, CMAX, COEF, COEF2, - $ COEF5, COR, EW, EWC, GAMMA, PGAMMA, RAB, SFMAX, - $ SFMIN, SUM, T, TA, TB, TC, TE -C .. Local Arrays .. - DOUBLE PRECISION DUM( 1 ) -C .. External Functions .. - LOGICAL LSAME - INTEGER IDAMAX - DOUBLE PRECISION DDOT, DLAMCH - EXTERNAL DDOT, DLAMCH, IDAMAX, LSAME -C .. External Subroutines .. - EXTERNAL DAXPY, DCOPY, DSCAL, XERBLA -C .. Intrinsic Functions .. - INTRINSIC ABS, DBLE, INT, LOG10, MAX, MIN, SIGN -C -C .. Executable Statements .. -C -C Test the input parameters. -C - INFO = 0 - WITHB = LSAME( JOB, 'A' ) .OR. LSAME( JOB, 'B' ) - WITHC = LSAME( JOB, 'A' ) .OR. LSAME( JOB, 'C' ) -C - IF( .NOT.WITHB .AND. .NOT.WITHC .AND. .NOT.LSAME( JOB, 'N' ) ) - $ THEN - INFO = -1 - ELSE IF( L.LT.0 ) THEN - INFO = -2 - ELSE IF( N.LT.0 ) THEN - INFO = -3 - ELSE IF( M.LT.0 ) THEN - INFO = -4 - ELSE IF( P.LT.0 ) THEN - INFO = -5 - ELSE IF( THRESH.LT.ZERO ) THEN - INFO = -6 - ELSE IF( LDA.LT.MAX( 1, L ) ) THEN - INFO = -8 - ELSE IF( LDE.LT.MAX( 1, L ) ) THEN - INFO = -10 - ELSE IF( LDB.LT.1 .OR. ( M.GT.0 .AND. LDB.LT.L ) ) THEN - INFO = -12 - ELSE IF( LDC.LT.MAX( 1, P ) ) THEN - INFO = -14 - END IF - IF( INFO.NE.0 ) THEN - CALL XERBLA( 'TG01AD', -INFO ) - RETURN - END IF -C -C Quick return if possible. -C - IF( L.EQ.0 .OR. N.EQ.0 ) THEN - DUM( 1 ) = ONE - IF( L.GT.0 ) THEN - CALL DCOPY( L, DUM, 0, LSCALE, 1 ) - ELSE IF( N.GT.0 ) THEN - CALL DCOPY( N, DUM, 0, RSCALE, 1 ) - END IF - RETURN - END IF -C -C Initialize balancing and allocate work storage. -C - KW1 = N - KW2 = KW1 + L - KW3 = KW2 + L - KW4 = KW3 + N - KW5 = KW4 + L - DUM( 1 ) = ZERO - CALL DCOPY( L, DUM, 0, LSCALE, 1 ) - CALL DCOPY( N, DUM, 0, RSCALE, 1 ) - CALL DCOPY( 3*(L+N), DUM, 0, DWORK, 1 ) -C -C Compute right side vector in resulting linear equations. -C - BASL = LOG10( SCLFAC ) - DO 20 I = 1, L - DO 10 J = 1, N - TE = ABS( E( I, J ) ) - TA = ABS( A( I, J ) ) - IF( TA.GT.THRESH ) THEN - TA = LOG10( TA ) / BASL - ELSE - TA = ZERO - END IF - IF( TE.GT.THRESH ) THEN - TE = LOG10( TE ) / BASL - ELSE - TE = ZERO - END IF - DWORK( I+KW4 ) = DWORK( I+KW4 ) - TA - TE - DWORK( J+KW5 ) = DWORK( J+KW5 ) - TA - TE - 10 CONTINUE - 20 CONTINUE -C - IF( M.EQ.0 ) THEN - WITHB = .FALSE. - TB = ZERO - END IF - IF( P.EQ.0 ) THEN - WITHC = .FALSE. - TC = ZERO - END IF -C - IF( WITHB ) THEN - DO 30 I = 1, L - J = IDAMAX( M, B( I, 1 ), LDB ) - TB = ABS( B( I, J ) ) - IF( TB.GT.THRESH ) THEN - TB = LOG10( TB ) / BASL - DWORK( I+KW4 ) = DWORK( I+KW4 ) - TB - END IF - 30 CONTINUE - END IF -C - IF( WITHC ) THEN - DO 40 J = 1, N - I = IDAMAX( P, C( 1, J ), 1 ) - TC = ABS( C( I, J ) ) - IF( TC.GT.THRESH ) THEN - TC = LOG10( TC ) / BASL - DWORK( J+KW5 ) = DWORK( J+KW5 ) - TC - END IF - 40 CONTINUE - END IF -C - COEF = ONE / DBLE( L+N ) - COEF2 = COEF*COEF - COEF5 = HALF*COEF2 - NRP2 = MAX( L, N ) + 2 - BETA = ZERO - IT = 1 -C -C Start generalized conjugate gradient iteration. -C - 50 CONTINUE -C - GAMMA = DDOT( L, DWORK( 1+KW4 ), 1, DWORK( 1+KW4 ), 1 ) + - $ DDOT( N, DWORK( 1+KW5 ), 1, DWORK( 1+KW5 ), 1 ) -C - EW = ZERO - DO 60 I = 1, L - EW = EW + DWORK( I+KW4 ) - 60 CONTINUE -C - EWC = ZERO - DO 70 I = 1, N - EWC = EWC + DWORK( I+KW5 ) - 70 CONTINUE -C - GAMMA = COEF*GAMMA - COEF2*( EW**2 + EWC**2 ) - - $ COEF5*( EW - EWC )**2 - IF( GAMMA.EQ.ZERO ) - $ GO TO 160 - IF( IT.NE.1 ) - $ BETA = GAMMA / PGAMMA - T = COEF5*( EWC - THREE*EW ) - TC = COEF5*( EW - THREE*EWC ) -C - CALL DSCAL( N+L, BETA, DWORK, 1 ) -C - CALL DAXPY( L, COEF, DWORK( 1+KW4 ), 1, DWORK( 1+KW1 ), 1 ) - CALL DAXPY( N, COEF, DWORK( 1+KW5 ), 1, DWORK, 1 ) -C - DO 80 J = 1, N - DWORK( J ) = DWORK( J ) + TC - 80 CONTINUE -C - DO 90 I = 1, L - DWORK( I+KW1 ) = DWORK( I+KW1 ) + T - 90 CONTINUE -C -C Apply matrix to vector. -C - DO 110 I = 1, L - KOUNT = 0 - SUM = ZERO - DO 100 J = 1, N - IF( ABS( A( I, J ) ).GT.THRESH ) THEN - KOUNT = KOUNT + 1 - SUM = SUM + DWORK( J ) - END IF - IF( ABS( E( I, J ) ).GT.THRESH ) THEN - KOUNT = KOUNT + 1 - SUM = SUM + DWORK( J ) - END IF - 100 CONTINUE - IF( WITHB ) THEN - J = IDAMAX( M, B( I, 1 ), LDB ) - IF( ABS( B( I, J ) ).GT.THRESH ) KOUNT = KOUNT + 1 - END IF - DWORK( I+KW2 ) = DBLE( KOUNT )*DWORK( I+KW1 ) + SUM - 110 CONTINUE -C - DO 130 J = 1, N - KOUNT = 0 - SUM = ZERO - DO 120 I = 1, L - IF( ABS( A( I, J ) ).GT.THRESH ) THEN - KOUNT = KOUNT + 1 - SUM = SUM + DWORK( I+KW1 ) - END IF - IF( ABS( E( I, J ) ).GT.THRESH ) THEN - KOUNT = KOUNT + 1 - SUM = SUM + DWORK( I+KW1 ) - END IF - 120 CONTINUE - IF( WITHC ) THEN - I = IDAMAX( P, C( 1, J ), 1 ) - IF( ABS( C( I, J ) ).GT.THRESH ) KOUNT = KOUNT + 1 - END IF - DWORK( J+KW3 ) = DBLE( KOUNT )*DWORK( J ) + SUM - 130 CONTINUE -C - SUM = DDOT( L, DWORK( 1+KW1 ), 1, DWORK( 1+KW2 ), 1 ) + - $ DDOT( N, DWORK, 1, DWORK( 1+KW3 ), 1 ) - ALPHA = GAMMA / SUM -C -C Determine correction to current iteration. -C - CMAX = ZERO - DO 140 I = 1, L - COR = ALPHA*DWORK( I+KW1 ) - IF( ABS( COR ).GT.CMAX ) - $ CMAX = ABS( COR ) - LSCALE( I ) = LSCALE( I ) + COR - 140 CONTINUE -C - DO 150 J = 1, N - COR = ALPHA*DWORK( J ) - IF( ABS( COR ).GT.CMAX ) - $ CMAX = ABS( COR ) - RSCALE( J ) = RSCALE( J ) + COR - 150 CONTINUE - IF( CMAX.LT.HALF ) - $ GO TO 160 -C - CALL DAXPY( L, -ALPHA, DWORK( 1+KW2 ), 1, DWORK( 1+KW4 ), 1 ) - CALL DAXPY( N, -ALPHA, DWORK( 1+KW3 ), 1, DWORK( 1+KW5 ), 1 ) -C - PGAMMA = GAMMA - IT = IT + 1 - IF( IT.LE.NRP2 ) - $ GO TO 50 -C -C End generalized conjugate gradient iteration. -C - 160 CONTINUE - SFMIN = DLAMCH( 'Safe minimum' ) - SFMAX = ONE / SFMIN - LSFMIN = INT( LOG10( SFMIN ) / BASL + ONE ) - LSFMAX = INT( LOG10( SFMAX ) / BASL ) -C -C Compute left diagonal scaling matrix. -C - DO 170 I = 1, L - IRAB = IDAMAX( N, A( I, 1 ), LDA ) - RAB = ABS( A( I, IRAB ) ) - IRAB = IDAMAX( N, E( I, 1 ), LDE ) - RAB = MAX( RAB, ABS( E( I, IRAB ) ) ) - IF( WITHB ) THEN - IRAB = IDAMAX( M, B( I, 1 ), LDB ) - RAB = MAX( RAB, ABS( B( I, IRAB ) ) ) - END IF - LRAB = INT( LOG10( RAB+SFMIN ) / BASL + ONE ) - IR = LSCALE( I ) + SIGN( HALF, LSCALE( I ) ) - IR = MIN( MAX( IR, LSFMIN ), LSFMAX, LSFMAX-LRAB ) - LSCALE( I ) = SCLFAC**IR - 170 CONTINUE -C -C Compute right diagonal scaling matrix. -C - DO 180 J = 1, N - ICAB = IDAMAX( L, A( 1, J ), 1 ) - CAB = ABS( A( ICAB, J ) ) - ICAB = IDAMAX( L, E( 1, J ), 1 ) - CAB = MAX( CAB, ABS( E( ICAB, J ) ) ) - IF( WITHC ) THEN - ICAB = IDAMAX( P, C( 1, J ), 1 ) - CAB = MAX( CAB, ABS( C( ICAB, J ) ) ) - END IF - LCAB = INT( LOG10( CAB+SFMIN ) / BASL + ONE ) - JC = RSCALE( J ) + SIGN( HALF, RSCALE( J ) ) - JC = MIN( MAX( JC, LSFMIN ), LSFMAX, LSFMAX-LCAB ) - RSCALE( J ) = SCLFAC**JC - 180 CONTINUE -C -C Row scaling of matrices A, E and B. -C - DO 190 I = 1, L - CALL DSCAL( N, LSCALE( I ), A( I, 1 ), LDA ) - CALL DSCAL( N, LSCALE( I ), E( I, 1 ), LDE ) - IF( WITHB ) - $ CALL DSCAL( M, LSCALE( I ), B( I, 1 ), LDB ) - 190 CONTINUE -C -C Column scaling of matrices A, E and C. -C - DO 200 J = 1, N - CALL DSCAL( L, RSCALE( J ), A( 1, J ), 1 ) - CALL DSCAL( L, RSCALE( J ), E( 1, J ), 1 ) - IF( WITHC ) - $ CALL DSCAL( P, RSCALE( J ), C( 1, J ), 1 ) - 200 CONTINUE -C - RETURN -C *** Last line of TG01AD *** - END diff --git a/mex/sources/libslicot/TG01AZ.f b/mex/sources/libslicot/TG01AZ.f deleted file mode 100644 index 2c0bb3bcf..000000000 --- a/mex/sources/libslicot/TG01AZ.f +++ /dev/null @@ -1,523 +0,0 @@ - SUBROUTINE TG01AZ( JOB, L, N, M, P, THRESH, A, LDA, E, LDE, - $ B, LDB, C, LDC, LSCALE, RSCALE, DWORK, INFO ) -C -C SLICOT RELEASE 5.0. -C -C Copyright (c) 2002-2009 NICONET e.V. -C -C This program is free software: you can redistribute it and/or -C modify it under the terms of the GNU General Public License as -C published by the Free Software Foundation, either version 2 of -C the License, or (at your option) any later version. -C -C This program is distributed in the hope that it will be useful, -C but WITHOUT ANY WARRANTY; without even the implied warranty of -C MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the -C GNU General Public License for more details. -C -C You should have received a copy of the GNU General Public License -C along with this program. If not, see -C . -C -C PURPOSE -C -C To balance the matrices of the system pencil -C -C S = ( A B ) - lambda ( E 0 ) := Q - lambda Z, -C ( C 0 ) ( 0 0 ) -C -C corresponding to the descriptor triple (A-lambda E,B,C), -C by balancing. This involves diagonal similarity transformations -C (Dl*A*Dr - lambda Dl*E*Dr, Dl*B, C*Dr) applied to the system -C (A-lambda E,B,C) to make the rows and columns of system pencil -C matrices -C -C diag(Dl,I) * S * diag(Dr,I) -C -C as close in norm as possible. Balancing may reduce the 1-norms -C of the matrices of the system pencil S. -C -C The balancing can be performed optionally on the following -C particular system pencils -C -C S = A-lambda E, -C -C S = ( A-lambda E B ), or -C -C S = ( A-lambda E ). -C ( C ) -C -C ARGUMENTS -C -C Mode Parameters -C -C JOB CHARACTER*1 -C Indicates which matrices are involved in balancing, as -C follows: -C = 'A': All matrices are involved in balancing; -C = 'B': B, A and E matrices are involved in balancing; -C = 'C': C, A and E matrices are involved in balancing; -C = 'N': B and C matrices are not involved in balancing. -C -C Input/Output Parameters -C -C L (input) INTEGER -C The number of rows of matrices A, B, and E. L >= 0. -C -C N (input) INTEGER -C The number of columns of matrices A, E, and C. N >= 0. -C -C M (input) INTEGER -C The number of columns of matrix B. M >= 0. -C -C P (input) INTEGER -C The number of rows of matrix C. P >= 0. -C -C THRESH (input) DOUBLE PRECISION -C Threshold value for magnitude of elements: -C elements with magnitude less than or equal to -C THRESH are ignored for balancing. THRESH >= 0. -C The magnitude is computed as the sum of the absolute -C values of the real and imaginary parts. -C -C A (input/output) COMPLEX*16 array, dimension (LDA,N) -C On entry, the leading L-by-N part of this array must -C contain the state dynamics matrix A. -C On exit, the leading L-by-N part of this array contains -C the balanced matrix Dl*A*Dr. -C -C LDA INTEGER -C The leading dimension of array A. LDA >= MAX(1,L). -C -C E (input/output) COMPLEX*16 array, dimension (LDE,N) -C On entry, the leading L-by-N part of this array must -C contain the descriptor matrix E. -C On exit, the leading L-by-N part of this array contains -C the balanced matrix Dl*E*Dr. -C -C LDE INTEGER -C The leading dimension of array E. LDE >= MAX(1,L). -C -C B (input/output) COMPLEX*16 array, dimension (LDB,M) -C On entry, the leading L-by-M part of this array must -C contain the input/state matrix B. -C On exit, if M > 0, the leading L-by-M part of this array -C contains the balanced matrix Dl*B. -C The array B is not referenced if M = 0. -C -C LDB INTEGER -C The leading dimension of array B. -C LDB >= MAX(1,L) if M > 0 or LDB >= 1 if M = 0. -C -C C (input/output) COMPLEX*16 array, dimension (LDC,N) -C On entry, the leading P-by-N part of this array must -C contain the state/output matrix C. -C On exit, if P > 0, the leading P-by-N part of this array -C contains the balanced matrix C*Dr. -C The array C is not referenced if P = 0. -C -C LDC INTEGER -C The leading dimension of array C. LDC >= MAX(1,P). -C -C LSCALE (output) DOUBLE PRECISION array, dimension (L) -C The scaling factors applied to S from left. If Dl(j) is -C the scaling factor applied to row j, then -C SCALE(j) = Dl(j), for j = 1,...,L. -C -C RSCALE (output) DOUBLE PRECISION array, dimension (N) -C The scaling factors applied to S from right. If Dr(j) is -C the scaling factor applied to column j, then -C SCALE(j) = Dr(j), for j = 1,...,N. -C -C Workspace -C -C DWORK DOUBLE PRECISION array, dimension (3*(L+N)) -C -C Error Indicator -C -C INFO INTEGER -C = 0: successful exit. -C < 0: if INFO = -i, the i-th argument had an illegal -C value. -C -C METHOD -C -C Balancing consists of applying a diagonal similarity -C transformation -C -1 -C diag(Dl,I) * S * diag(Dr,I) -C -C to make the 1-norms of each row of the first L rows of S and its -C corresponding N columns nearly equal. -C -C Information about the diagonal matrices Dl and Dr are returned in -C the vectors LSCALE and RSCALE, respectively. -C -C REFERENCES -C -C [1] Anderson, E., Bai, Z., Bischof, C., Demmel, J., Dongarra, J., -C Du Croz, J., Greenbaum, A., Hammarling, S., McKenney, A., -C Ostrouchov, S., and Sorensen, D. -C LAPACK Users' Guide: Second Edition. -C SIAM, Philadelphia, 1995. -C -C [2] R.C. Ward, R. C. -C Balancing the generalized eigenvalue problem. -C SIAM J. Sci. Stat. Comp. 2 (1981), 141-152. -C -C NUMERICAL ASPECTS -C -C None. -C -C CONTRIBUTOR -C -C A. Varga, German Aerospace Center, DLR Oberpfaffenhofen. -C March 1999. -C Complex version: V. Sima, Research Institute for Informatics, -C Bucharest, Nov. 2008. -C -C REVISIONS -C -C - -C -C KEYWORDS -C -C Balancing, eigenvalue, matrix algebra, matrix operations, -C similarity transformation. -C -C ********************************************************************* -C -C .. Parameters .. - DOUBLE PRECISION HALF, ONE, ZERO - PARAMETER ( HALF = 0.5D+0, ONE = 1.0D+0, ZERO = 0.0D+0 ) - DOUBLE PRECISION SCLFAC, THREE - PARAMETER ( SCLFAC = 1.0D+1, THREE = 3.0D+0 ) -C .. Scalar Arguments .. - CHARACTER JOB - INTEGER INFO, L, LDA, LDB, LDC, LDE, M, N, P - DOUBLE PRECISION THRESH -C .. Array Arguments .. - COMPLEX*16 A( LDA, * ), B( LDB, * ), C( LDC, * ), - $ E( LDE, * ) - DOUBLE PRECISION DWORK( * ), LSCALE( * ), RSCALE( * ) -C .. Local Scalars .. - LOGICAL WITHB, WITHC - INTEGER I, ICAB, IR, IRAB, IT, J, JC, KOUNT, KW1, KW2, - $ KW3, KW4, KW5, LCAB, LRAB, LSFMAX, LSFMIN, - $ NRP2 - DOUBLE PRECISION ALPHA, BASL, BETA, CAB, CMAX, COEF, COEF2, - $ COEF5, COR, EW, EWC, GAMMA, PGAMMA, RAB, SFMAX, - $ SFMIN, SUM, T, TA, TB, TC, TE - COMPLEX*16 CDUM -C .. Local Arrays .. - DOUBLE PRECISION DUM( 1 ) -C .. External Functions .. - LOGICAL LSAME - INTEGER IZAMAX - DOUBLE PRECISION DDOT, DLAMCH - EXTERNAL DDOT, DLAMCH, IZAMAX, LSAME -C .. External Subroutines .. - EXTERNAL DAXPY, DCOPY, DSCAL, XERBLA, ZDSCAL -C .. Intrinsic Functions .. - INTRINSIC ABS, DBLE, DIMAG, INT, LOG10, MAX, MIN, SIGN -C .. -C .. Statement Functions .. - DOUBLE PRECISION CABS1 -C .. -C .. Statement Function definitions .. - CABS1( CDUM ) = ABS( DBLE( CDUM ) ) + ABS( DIMAG( CDUM ) ) -C -C .. Executable Statements .. -C -C Test the input parameters. -C - INFO = 0 - WITHB = LSAME( JOB, 'A' ) .OR. LSAME( JOB, 'B' ) - WITHC = LSAME( JOB, 'A' ) .OR. LSAME( JOB, 'C' ) -C - IF( .NOT.WITHB .AND. .NOT.WITHC .AND. .NOT.LSAME( JOB, 'N' ) ) - $ THEN - INFO = -1 - ELSE IF( L.LT.0 ) THEN - INFO = -2 - ELSE IF( N.LT.0 ) THEN - INFO = -3 - ELSE IF( M.LT.0 ) THEN - INFO = -4 - ELSE IF( P.LT.0 ) THEN - INFO = -5 - ELSE IF( THRESH.LT.ZERO ) THEN - INFO = -6 - ELSE IF( LDA.LT.MAX( 1, L ) ) THEN - INFO = -8 - ELSE IF( LDE.LT.MAX( 1, L ) ) THEN - INFO = -10 - ELSE IF( LDB.LT.1 .OR. ( M.GT.0 .AND. LDB.LT.L ) ) THEN - INFO = -12 - ELSE IF( LDC.LT.MAX( 1, P ) ) THEN - INFO = -14 - END IF - IF( INFO.NE.0 ) THEN - CALL XERBLA( 'TG01AZ', -INFO ) - RETURN - END IF -C -C Quick return if possible. -C - IF( L.EQ.0 .OR. N.EQ.0 ) THEN - DUM( 1 ) = ONE - IF( L.GT.0 ) THEN - CALL DCOPY( L, DUM, 0, LSCALE, 1 ) - ELSE IF( N.GT.0 ) THEN - CALL DCOPY( N, DUM, 0, RSCALE, 1 ) - END IF - RETURN - END IF -C -C Initialize balancing and allocate work storage. -C - KW1 = N - KW2 = KW1 + L - KW3 = KW2 + L - KW4 = KW3 + N - KW5 = KW4 + L - DUM( 1 ) = ZERO - CALL DCOPY( L, DUM, 0, LSCALE, 1 ) - CALL DCOPY( N, DUM, 0, RSCALE, 1 ) - CALL DCOPY( 3*(L+N), DUM, 0, DWORK, 1 ) -C -C Compute right side vector in resulting linear equations. -C - BASL = LOG10( SCLFAC ) - DO 20 I = 1, L - DO 10 J = 1, N - TE = CABS1( E( I, J ) ) - TA = CABS1( A( I, J ) ) - IF( TA.GT.THRESH ) THEN - TA = LOG10( TA ) / BASL - ELSE - TA = ZERO - END IF - IF( TE.GT.THRESH ) THEN - TE = LOG10( TE ) / BASL - ELSE - TE = ZERO - END IF - DWORK( I+KW4 ) = DWORK( I+KW4 ) - TA - TE - DWORK( J+KW5 ) = DWORK( J+KW5 ) - TA - TE - 10 CONTINUE - 20 CONTINUE -C - IF( M.EQ.0 ) THEN - WITHB = .FALSE. - TB = ZERO - END IF - IF( P.EQ.0 ) THEN - WITHC = .FALSE. - TC = ZERO - END IF -C - IF( WITHB ) THEN - DO 30 I = 1, L - J = IZAMAX( M, B( I, 1 ), LDB ) - TB = CABS1( B( I, J ) ) - IF( TB.GT.THRESH ) THEN - TB = LOG10( TB ) / BASL - DWORK( I+KW4 ) = DWORK( I+KW4 ) - TB - END IF - 30 CONTINUE - END IF -C - IF( WITHC ) THEN - DO 40 J = 1, N - I = IZAMAX( P, C( 1, J ), 1 ) - TC = CABS1( C( I, J ) ) - IF( TC.GT.THRESH ) THEN - TC = LOG10( TC ) / BASL - DWORK( J+KW5 ) = DWORK( J+KW5 ) - TC - END IF - 40 CONTINUE - END IF -C - COEF = ONE / DBLE( L+N ) - COEF2 = COEF*COEF - COEF5 = HALF*COEF2 - NRP2 = MAX( L, N ) + 2 - BETA = ZERO - IT = 1 -C -C Start generalized conjugate gradient iteration. -C - 50 CONTINUE -C - GAMMA = DDOT( L, DWORK( 1+KW4 ), 1, DWORK( 1+KW4 ), 1 ) + - $ DDOT( N, DWORK( 1+KW5 ), 1, DWORK( 1+KW5 ), 1 ) -C - EW = ZERO - DO 60 I = 1, L - EW = EW + DWORK( I+KW4 ) - 60 CONTINUE -C - EWC = ZERO - DO 70 I = 1, N - EWC = EWC + DWORK( I+KW5 ) - 70 CONTINUE -C - GAMMA = COEF*GAMMA - COEF2*( EW**2 + EWC**2 ) - - $ COEF5*( EW - EWC )**2 - IF( GAMMA.EQ.ZERO ) - $ GO TO 160 - IF( IT.NE.1 ) - $ BETA = GAMMA / PGAMMA - T = COEF5*( EWC - THREE*EW ) - TC = COEF5*( EW - THREE*EWC ) -C - CALL DSCAL( N+L, BETA, DWORK, 1 ) -C - CALL DAXPY( L, COEF, DWORK( 1+KW4 ), 1, DWORK( 1+KW1 ), 1 ) - CALL DAXPY( N, COEF, DWORK( 1+KW5 ), 1, DWORK, 1 ) -C - DO 80 J = 1, N - DWORK( J ) = DWORK( J ) + TC - 80 CONTINUE -C - DO 90 I = 1, L - DWORK( I+KW1 ) = DWORK( I+KW1 ) + T - 90 CONTINUE -C -C Apply matrix to vector. -C - DO 110 I = 1, L - KOUNT = 0 - SUM = ZERO - DO 100 J = 1, N - IF( CABS1( A( I, J ) ).GT.THRESH ) THEN - KOUNT = KOUNT + 1 - SUM = SUM + DWORK( J ) - END IF - IF( CABS1( E( I, J ) ).GT.THRESH ) THEN - KOUNT = KOUNT + 1 - SUM = SUM + DWORK( J ) - END IF - 100 CONTINUE - IF( WITHB ) THEN - J = IZAMAX( M, B( I, 1 ), LDB ) - IF( CABS1( B( I, J ) ).GT.THRESH ) KOUNT = KOUNT + 1 - END IF - DWORK( I+KW2 ) = DBLE( KOUNT )*DWORK( I+KW1 ) + SUM - 110 CONTINUE -C - DO 130 J = 1, N - KOUNT = 0 - SUM = ZERO - DO 120 I = 1, L - IF( CABS1( A( I, J ) ).GT.THRESH ) THEN - KOUNT = KOUNT + 1 - SUM = SUM + DWORK( I+KW1 ) - END IF - IF( CABS1( E( I, J ) ).GT.THRESH ) THEN - KOUNT = KOUNT + 1 - SUM = SUM + DWORK( I+KW1 ) - END IF - 120 CONTINUE - IF( WITHC ) THEN - I = IZAMAX( P, C( 1, J ), 1 ) - IF( CABS1( C( I, J ) ).GT.THRESH ) KOUNT = KOUNT + 1 - END IF - DWORK( J+KW3 ) = DBLE( KOUNT )*DWORK( J ) + SUM - 130 CONTINUE -C - SUM = DDOT( L, DWORK( 1+KW1 ), 1, DWORK( 1+KW2 ), 1 ) + - $ DDOT( N, DWORK, 1, DWORK( 1+KW3 ), 1 ) - ALPHA = GAMMA / SUM -C -C Determine correction to current iteration. -C - CMAX = ZERO - DO 140 I = 1, L - COR = ALPHA*DWORK( I+KW1 ) - IF( ABS( COR ).GT.CMAX ) - $ CMAX = ABS( COR ) - LSCALE( I ) = LSCALE( I ) + COR - 140 CONTINUE -C - DO 150 J = 1, N - COR = ALPHA*DWORK( J ) - IF( ABS( COR ).GT.CMAX ) - $ CMAX = ABS( COR ) - RSCALE( J ) = RSCALE( J ) + COR - 150 CONTINUE - IF( CMAX.LT.HALF ) - $ GO TO 160 -C - CALL DAXPY( L, -ALPHA, DWORK( 1+KW2 ), 1, DWORK( 1+KW4 ), 1 ) - CALL DAXPY( N, -ALPHA, DWORK( 1+KW3 ), 1, DWORK( 1+KW5 ), 1 ) -C - PGAMMA = GAMMA - IT = IT + 1 - IF( IT.LE.NRP2 ) - $ GO TO 50 -C -C End generalized conjugate gradient iteration. -C - 160 CONTINUE - SFMIN = DLAMCH( 'Safe minimum' ) - SFMAX = ONE / SFMIN - LSFMIN = INT( LOG10( SFMIN ) / BASL + ONE ) - LSFMAX = INT( LOG10( SFMAX ) / BASL ) -C -C Compute left diagonal scaling matrix. -C - DO 170 I = 1, L - IRAB = IZAMAX( N, A( I, 1 ), LDA ) - RAB = ABS( A( I, IRAB ) ) - IRAB = IZAMAX( N, E( I, 1 ), LDE ) - RAB = MAX( RAB, ABS( E( I, IRAB ) ) ) - IF( WITHB ) THEN - IRAB = IZAMAX( M, B( I, 1 ), LDB ) - RAB = MAX( RAB, ABS( B( I, IRAB ) ) ) - END IF - LRAB = INT( LOG10( RAB+SFMIN ) / BASL + ONE ) - IR = LSCALE( I ) + SIGN( HALF, LSCALE( I ) ) - IR = MIN( MAX( IR, LSFMIN ), LSFMAX, LSFMAX-LRAB ) - LSCALE( I ) = SCLFAC**IR - 170 CONTINUE -C -C Compute right diagonal scaling matrix. -C - DO 180 J = 1, N - ICAB = IZAMAX( L, A( 1, J ), 1 ) - CAB = ABS( A( ICAB, J ) ) - ICAB = IZAMAX( L, E( 1, J ), 1 ) - CAB = MAX( CAB, ABS( E( ICAB, J ) ) ) - IF( WITHC ) THEN - ICAB = IZAMAX( P, C( 1, J ), 1 ) - CAB = MAX( CAB, ABS( C( ICAB, J ) ) ) - END IF - LCAB = INT( LOG10( CAB+SFMIN ) / BASL + ONE ) - JC = RSCALE( J ) + SIGN( HALF, RSCALE( J ) ) - JC = MIN( MAX( JC, LSFMIN ), LSFMAX, LSFMAX-LCAB ) - RSCALE( J ) = SCLFAC**JC - 180 CONTINUE -C -C Row scaling of matrices A, E and B. -C - DO 190 I = 1, L - CALL ZDSCAL( N, LSCALE( I ), A( I, 1 ), LDA ) - CALL ZDSCAL( N, LSCALE( I ), E( I, 1 ), LDE ) - IF( WITHB ) - $ CALL ZDSCAL( M, LSCALE( I ), B( I, 1 ), LDB ) - 190 CONTINUE -C -C Column scaling of matrices A, E and C. -C - DO 200 J = 1, N - CALL ZDSCAL( L, RSCALE( J ), A( 1, J ), 1 ) - CALL ZDSCAL( L, RSCALE( J ), E( 1, J ), 1 ) - IF( WITHC ) - $ CALL ZDSCAL( P, RSCALE( J ), C( 1, J ), 1 ) - 200 CONTINUE -C - RETURN -C *** Last line of TG01AZ *** - END diff --git a/mex/sources/libslicot/TG01BD.f b/mex/sources/libslicot/TG01BD.f deleted file mode 100644 index 3a0681e5e..000000000 --- a/mex/sources/libslicot/TG01BD.f +++ /dev/null @@ -1,434 +0,0 @@ - SUBROUTINE TG01BD( JOBE, COMPQ, COMPZ, N, M, P, ILO, IHI, A, LDA, - $ E, LDE, B, LDB, C, LDC, Q, LDQ, Z, LDZ, DWORK, - $ LDWORK, INFO ) -C -C SLICOT RELEASE 5.0. -C -C Copyright (c) 2002-2009 NICONET e.V. -C -C This program is free software: you can redistribute it and/or -C modify it under the terms of the GNU General Public License as -C published by the Free Software Foundation, either version 2 of -C the License, or (at your option) any later version. -C -C This program is distributed in the hope that it will be useful, -C but WITHOUT ANY WARRANTY; without even the implied warranty of -C MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the -C GNU General Public License for more details. -C -C You should have received a copy of the GNU General Public License -C along with this program. If not, see -C . -C -C PURPOSE -C -C To reduce the matrices A and E of the system pencil -C -C S = ( A B ) - lambda ( E 0 ) , -C ( C 0 ) ( 0 0 ) -C -C corresponding to the descriptor triple (A-lambda E,B,C), -C to generalized upper Hessenberg form using orthogonal -C transformations, -C -C Q' * A * Z = H, Q' * E * Z = T, -C -C where H is upper Hessenberg, T is upper triangular, Q and Z -C are orthogonal, and ' means transpose. The corresponding -C transformations, written compactly as diag(Q',I) * S * diag(Z,I), -C are also applied to B and C, getting Q' * B and C * Z. -C -C The orthogonal matrices Q and Z are determined as products of -C Givens rotations. They may either be formed explicitly, or they -C may be postmultiplied into input matrices Q1 and Z1, so that -C -C Q1 * A * Z1' = (Q1*Q) * H * (Z1*Z)' -C Q1 * E * Z1' = (Q1*Q) * T * (Z1*Z)'. -C -C ARGUMENTS -C -C Mode Parameters -C -C JOBE CHARACTER*1 -C Specifies whether E is a general square or an upper -C triangular matrix, as follows: -C = 'G': E is a general square matrix; -C = 'U': E is an upper triangular matrix. -C -C COMPQ CHARACTER*1 -C Indicates what should be done with matrix Q, as follows: -C = 'N': do not compute Q; -C = 'I': Q is initialized to the unit matrix, and the -C orthogonal matrix Q is returned; -C = 'V': Q must contain an orthogonal matrix Q1 on entry, -C and the product Q1*Q is returned. -C -C COMPZ CHARACTER*1 -C Indicates what should be done with matrix Z, as follows: -C = 'N': do not compute Z; -C = 'I': Z is initialized to the unit matrix, and the -C orthogonal matrix Z is returned; -C = 'V': Z must contain an orthogonal matrix Z1 on entry, -C and the product Z1*Z is returned. -C -C Input/Output Parameters -C -C N (input) INTEGER -C The order of the matrices A, E, and the number of rows of -C the matrix B. N >= 0. -C -C M (input) INTEGER -C The number of columns of the matrix B. M >= 0. -C -C P (input) INTEGER -C The number of rows of the matrix C. P >= 0. -C -C ILO (input) INTEGER -C IHI (input) INTEGER -C It is assumed that A and E are already upper triangular in -C rows and columns 1:ILO-1 and IHI+1:N. ILO and IHI could -C normally be set by a previous call to LAPACK Library -C routine DGGBAL; otherwise they should be set to 1 and N, -C respectively. -C 1 <= ILO <= IHI <= N, if N > 0; ILO=1 and IHI=0, if N=0. -C If JOBE = 'U', the matrix E is assumed upper triangular. -C -C A (input/output) DOUBLE PRECISION array, dimension (LDA,N) -C On entry, the leading N-by-N part of this array must -C contain the state dynamics matrix A. -C On exit, the leading N-by-N part of this array contains -C the upper Hessenberg matrix H = Q' * A * Z. The elements -C below the first subdiagonal are set to zero. -C -C LDA INTEGER -C The leading dimension of array A. LDA >= MAX(1,N). -C -C E (input/output) DOUBLE PRECISION array, dimension (LDE,N) -C On entry, the leading N-by-N part of this array must -C contain the descriptor matrix E. If JOBE = 'U', this -C matrix is assumed upper triangular. -C On exit, the leading N-by-N part of this array contains -C the upper triangular matrix T = Q' * E * Z. The elements -C below the diagonal are set to zero. -C -C LDE INTEGER -C The leading dimension of array E. LDE >= MAX(1,N). -C -C B (input/output) DOUBLE PRECISION array, dimension (LDB,M) -C On entry, the leading N-by-M part of this array must -C contain the input/state matrix B. -C On exit, if M > 0, the leading N-by-M part of this array -C contains the transformed matrix Q' * B. -C The array B is not referenced if M = 0. -C -C LDB INTEGER -C The leading dimension of array B. -C LDB >= MAX(1,N) if M > 0; LDB >= 1 if M = 0. -C -C C (input/output) DOUBLE PRECISION array, dimension (LDC,N) -C On entry, the leading P-by-N part of this array must -C contain the state/output matrix C. -C On exit, if P > 0, the leading P-by-N part of this array -C contains the transformed matrix C * Z. -C The array C is not referenced if P = 0. -C -C LDC INTEGER -C The leading dimension of array C. LDC >= MAX(1,P). -C -C Q (input/output) DOUBLE PRECISION array, dimension (LDQ,N) -C If COMPQ = 'N': Q is not referenced; -C If COMPQ = 'I': on entry, Q need not be set, and on exit -C it contains the orthogonal matrix Q, -C where Q' is the product of the Givens -C transformations which are applied to A, -C E, and B on the left; -C If COMPQ = 'V': on entry, Q must contain an orthogonal -C matrix Q1, and on exit this is -C overwritten by Q1*Q. -C -C LDQ INTEGER -C The leading dimension of array Q. -C LDQ >= 1, if COMPQ = 'N'; -C LDQ >= MAX(1,N), if COMPQ = 'I' or 'V'. -C -C Z (input/output) DOUBLE PRECISION array, dimension (LDZ,N) -C If COMPZ = 'N': Z is not referenced; -C If COMPZ = 'I': on entry, Z need not be set, and on exit -C it contains the orthogonal matrix Z, -C which is the product of the Givens -C transformations applied to A, E, and C -C on the right; -C If COMPZ = 'V': on entry, Z must contain an orthogonal -C matrix Z1, and on exit this is -C overwritten by Z1*Z. -C -C LDZ INTEGER -C The leading dimension of array Z. -C LDZ >= 1, if COMPZ = 'N'; -C LDZ >= MAX(1,N), if COMPZ = 'I' or 'V'. -C -C Workspace -C -C DWORK DOUBLE PRECISION array, dimension (LDWORK) -C On exit, if INFO = 0, DWORK(1) contains the optimal value -C of LDWORK. -C -C LDWORK INTEGER -C The dimension of the array DWORK. -C LDWORK >= 1, if JOBE = 'U'; -C LDWORK >= MAX(1,IHI+1-ILO+MAX(NI,M)), if JOBE = 'G', where -C NI = N+1-ILO, if COMPQ = 'N', and NI = N, otherwise. -C For good performance, if JOBE = 'G', LDWORK must generally -C be larger, LDWORK >= MAX(1,IHI+1-ILO+MAX(NI,M)*NB), where -C NB is the optimal block size. -C -C Error Indicator -C -C INFO INTEGER -C = 0: successful exit. -C < 0: if INFO = -i, the i-th argument had an illegal -C value. -C -C METHOD -C -C First, this routine computes the QR factorization of E and applies -C the transformations to A, B, and possibly Q. Then, the routine -C reduces A to upper Hessenberg form, preserving E triangular, by -C an unblocked reduction [1], using two sequences of plane rotations -C applied alternately from the left and from the right. The -C corresponding transformations may be accumulated and/or applied -C to the matrices B and C. If JOBE = 'U', the initial reduction of E -C to upper triangular form is skipped. -C -C This routine is a modification and extension of the LAPACK Library -C routine DGGHRD [2]. -C -C REFERENCES -C -C [1] Golub, G.H. and van Loan, C.F. -C Matrix Computations. Third Edition. -C M. D. Johns Hopkins University Press, Baltimore, 1996. -C -C [2] Anderson, E., Bai, Z., Bischof, C., Demmel, J., Dongarra, J., -C Du Croz, J., Greenbaum, A., Hammarling, S., McKenney, A., -C Ostrouchov, S., and Sorensen, D. -C LAPACK Users' Guide: Second Edition. -C SIAM, Philadelphia, 1995. -C -C CONTRIBUTOR -C -C D. Sima, University of Bucharest, May 2001. -C V. Sima, Research Institute for Informatics, Bucharest, May 2001. -C -C REVISIONS -C -C - -C -C KEYWORDS -C -C Eigenvalue, matrix algebra, matrix operations, similarity -C transformation. -C -C ********************************************************************* -C -C .. Parameters .. - DOUBLE PRECISION ONE, ZERO - PARAMETER ( ONE = 1.0D+0, ZERO = 0.0D+0 ) -C .. Scalar Arguments .. - CHARACTER COMPQ, COMPZ, JOBE - INTEGER IHI, ILO, INFO, LDA, LDB, LDC, LDE, LDQ, - $ LDWORK, LDZ, M, N, P -C .. Array Arguments .. - DOUBLE PRECISION A( LDA, * ), B( LDB, * ), C( LDC, * ), - $ DWORK( * ), E( LDE, * ), Q( LDQ, * ), - $ Z( LDZ, * ) -C .. Local Scalars .. - LOGICAL ILQ, ILZ, INQ, INZ, UPPER, WITHB, WITHC - INTEGER IERR, ITAU, IWRK, JCOL, JROW, MAXWRK, MINWRK - DOUBLE PRECISION CS, S, TEMP -C .. External Functions .. - LOGICAL LSAME - EXTERNAL LSAME -C .. External Subroutines .. - EXTERNAL DGEQRF, DLARTG, DLASET, DORMQR, DROT, XERBLA -C .. Intrinsic Functions .. - INTRINSIC INT, MAX -C -C .. Executable Statements .. -C -C Test the input scalar parameters. -C - UPPER = LSAME( JOBE, 'U' ) - INQ = LSAME( COMPQ, 'I' ) - ILQ = LSAME( COMPQ, 'V' ) .OR. INQ - INZ = LSAME( COMPZ, 'I' ) - ILZ = LSAME( COMPZ, 'V' ) .OR. INZ - WITHB = M.GT.0 - WITHC = P.GT.0 -C - INFO = 0 - IF( .NOT.( UPPER .OR. LSAME( JOBE, 'G' ) ) ) THEN - INFO = -1 - ELSE IF( .NOT.( ILQ .OR. LSAME( COMPQ, 'N' ) ) ) THEN - INFO = -2 - ELSE IF( .NOT.( ILZ .OR. LSAME( COMPZ, 'N' ) ) ) THEN - INFO = -3 - ELSE IF( N.LT.0 ) THEN - INFO = -4 - ELSE IF( M.LT.0 ) THEN - INFO = -5 - ELSE IF( P.LT.0 ) THEN - INFO = -6 - ELSE IF( ILO.LT.1 ) THEN - INFO = -7 - ELSE IF( IHI.GT.N .OR. IHI.LT.ILO-1 ) THEN - INFO = -8 - ELSE IF( LDA.LT.MAX( 1, N ) ) THEN - INFO = -10 - ELSE IF( LDE.LT.MAX( 1, N ) ) THEN - INFO = -12 - ELSE IF( ( WITHB .AND. LDB.LT.N ) .OR. LDB.LT.1 ) THEN - INFO = -14 - ELSE IF( LDC.LT.MAX( 1, P ) ) THEN - INFO = -16 - ELSE IF( ( ILQ .AND. LDQ.LT.N ) .OR. LDQ.LT.1 ) THEN - INFO = -18 - ELSE IF( ( ILZ .AND. LDZ.LT.N ) .OR. LDZ.LT.1 ) THEN - INFO = -20 - ELSE - JROW = IHI + 1 - ILO - JCOL = N + 1 - ILO - IF( UPPER ) THEN - MINWRK = 1 - MAXWRK = 1 - ELSE - IF( ILQ ) THEN - MINWRK = N - ELSE - MINWRK = JCOL - END IF - MINWRK = MAX( 1, JROW + MAX( MINWRK, M ) ) - END IF - IF( LDWORK.LT.MINWRK ) - $ INFO = -22 - END IF -C - IF( INFO.NE.0 ) THEN - CALL XERBLA( 'TG01BD', -INFO ) - RETURN - END IF -C -C Initialize Q and Z if desired. -C - IF( INQ ) - $ CALL DLASET( 'Full', N, N, ZERO, ONE, Q, LDQ ) - IF( INZ ) - $ CALL DLASET( 'Full', N, N, ZERO, ONE, Z, LDZ ) -C -C Quick return if possible. -C - IF( N.LE.1 ) THEN - DWORK( 1 ) = ONE - RETURN - END IF -C - IF( .NOT.UPPER ) THEN -C -C Reduce E to triangular form (QR decomposition of E). -C -C (Note: Comments in the code beginning "Workspace:" describe the -C minimal amount of real workspace needed at that point in the -C code, as well as the preferred amount for good performance. -C NB refers to the optimal block size for the immediately -C following subroutine, as returned by ILAENV.) -C -C Workspace: need IHI+1-ILO+N+1-ILO; -C prefer IHI+1-ILO+(N+1-ILO)*NB. -C - ITAU = 1 - IWRK = ITAU + JROW - CALL DGEQRF( JROW, JCOL, E( ILO, ILO ), LDE, DWORK( ITAU ), - $ DWORK( IWRK ), LDWORK-IWRK+1, IERR ) - MAXWRK = MAX( INT( DWORK( IWRK ) ) + IWRK - 1, MINWRK ) -C -C Apply the orthogonal transformation to matrices A, B, and Q. -C Workspace: need IHI+1-ILO+N+1-ILO; -C prefer IHI+1-ILO+(N+1-ILO)*NB. -C - CALL DORMQR( 'Left', 'Transpose', JROW, JCOL, JROW, - $ E( ILO, ILO ), LDE, DWORK( ITAU ), A( ILO, ILO ), - $ LDA, DWORK( IWRK ), LDWORK-IWRK+1, IERR ) - MAXWRK = MAX( INT( DWORK( IWRK ) ) + IWRK - 1, MAXWRK ) -C - IF ( WITHB ) THEN -C -C Workspace: need IHI+1-ILO+M; -C prefer IHI+1-ILO+M*NB. -C - CALL DORMQR( 'Left', 'Transpose', JROW, M, JROW, - $ E( ILO, ILO ), LDE, DWORK( ITAU ), B( ILO, 1 ), - $ LDB, DWORK( IWRK ), LDWORK-IWRK+1, IERR ) - MAXWRK = MAX( INT( DWORK( IWRK ) ) + IWRK - 1, MAXWRK ) - END IF -C - IF( ILQ ) THEN -C -C Workspace: need IHI+1-ILO+N; -C prefer IHI+1-ILO+N*NB. -C - CALL DORMQR( 'Right', 'No Transpose', N, JROW, JROW, - $ E( ILO, ILO ), LDE, DWORK( ITAU ), Q( 1, ILO ), - $ LDQ, DWORK( IWRK ), LDWORK-IWRK+1, IERR ) - MAXWRK = MAX( INT( DWORK( IWRK ) ) + IWRK - 1, MAXWRK ) - END IF - END IF -C -C Zero out lower triangle of E. -C - IF( JROW.GT.1 ) - $ CALL DLASET( 'Lower', JROW-1, JROW-1, ZERO, ZERO, - $ E( ILO+1, ILO ), LDE ) -C -C Reduce A and E and apply the transformations to B, C, Q and Z. -C - DO 20 JCOL = ILO, IHI - 2 -C - DO 10 JROW = IHI, JCOL + 2, -1 -C -C Step 1: rotate rows JROW-1, JROW to kill A(JROW,JCOL). -C - TEMP = A( JROW-1, JCOL ) - CALL DLARTG( TEMP, A( JROW, JCOL ), CS, S, - $ A( JROW-1, JCOL ) ) - A( JROW, JCOL ) = ZERO - CALL DROT( N-JCOL, A( JROW-1, JCOL+1 ), LDA, - $ A( JROW, JCOL+1 ), LDA, CS, S ) - CALL DROT( N+2-JROW, E( JROW-1, JROW-1 ), LDE, - $ E( JROW, JROW-1 ), LDE, CS, S ) - IF( WITHB ) - $ CALL DROT( M, B( JROW-1, 1 ), LDB, B( JROW, 1 ), LDB, - $ CS, S ) - IF( ILQ ) - $ CALL DROT( N, Q( 1, JROW-1 ), 1, Q( 1, JROW ), 1, CS, S ) -C -C Step 2: rotate columns JROW, JROW-1 to kill E(JROW,JROW-1). -C - TEMP = E( JROW, JROW ) - CALL DLARTG( TEMP, E( JROW, JROW-1 ), CS, S, - $ E( JROW, JROW ) ) - E( JROW, JROW-1 ) = ZERO - CALL DROT( IHI, A( 1, JROW ), 1, A( 1, JROW-1 ), 1, CS, S ) - CALL DROT( JROW-1, E( 1, JROW ), 1, E( 1, JROW-1 ), 1, CS, - $ S ) - IF( WITHC ) - $ CALL DROT( P, C( 1, JROW ), 1, C( 1, JROW-1 ), 1, CS, S ) - IF( ILZ ) - $ CALL DROT( N, Z( 1, JROW ), 1, Z( 1, JROW-1 ), 1, CS, S ) - 10 CONTINUE -C - 20 CONTINUE -C - DWORK( 1 ) = MAXWRK - RETURN -C *** Last line of TG01BD *** - END diff --git a/mex/sources/libslicot/TG01CD.f b/mex/sources/libslicot/TG01CD.f deleted file mode 100644 index 1ce07b1e4..000000000 --- a/mex/sources/libslicot/TG01CD.f +++ /dev/null @@ -1,292 +0,0 @@ - SUBROUTINE TG01CD( COMPQ, L, N, M, A, LDA, E, LDE, B, LDB, Q, LDQ, - $ DWORK, LDWORK, INFO ) -C -C SLICOT RELEASE 5.0. -C -C Copyright (c) 2002-2009 NICONET e.V. -C -C This program is free software: you can redistribute it and/or -C modify it under the terms of the GNU General Public License as -C published by the Free Software Foundation, either version 2 of -C the License, or (at your option) any later version. -C -C This program is distributed in the hope that it will be useful, -C but WITHOUT ANY WARRANTY; without even the implied warranty of -C MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the -C GNU General Public License for more details. -C -C You should have received a copy of the GNU General Public License -C along with this program. If not, see -C . -C -C PURPOSE -C -C To reduce the descriptor system pair (A-lambda E,B) to the -C QR-coordinate form by computing an orthogonal transformation -C matrix Q such that the transformed descriptor system pair -C (Q'*A-lambda Q'*E, Q'*B) has the descriptor matrix Q'*E -C in an upper trapezoidal form. -C The left orthogonal transformations performed to reduce E -C can be optionally accumulated. -C -C ARGUMENTS -C -C Mode Parameters -C -C COMPQ CHARACTER*1 -C = 'N': do not compute Q; -C = 'I': Q is initialized to the unit matrix, and the -C orthogonal matrix Q is returned; -C = 'U': Q must contain an orthogonal matrix Q1 on entry, -C and the product Q1*Q is returned. -C -C Input/Output Parameters -C -C L (input) INTEGER -C The number of rows of matrices A, B, and E. L >= 0. -C -C N (input) INTEGER -C The number of columns of matrices A and E. N >= 0. -C -C M (input) INTEGER -C The number of columns of matrix B. M >= 0. -C -C A (input/output) DOUBLE PRECISION array, dimension (LDA,N) -C On entry, the leading L-by-N part of this array must -C contain the state dynamics matrix A. -C On exit, the leading L-by-N part of this array contains -C the transformed matrix Q'*A. -C -C LDA INTEGER -C The leading dimension of array A. LDA >= MAX(1,L). -C -C E (input/output) DOUBLE PRECISION array, dimension (LDE,N) -C On entry, the leading L-by-N part of this array must -C contain the descriptor matrix E. -C On exit, the leading L-by-N part of this array contains -C the transformed matrix Q'*E in upper trapezoidal form, -C i.e. -C -C ( E11 ) -C Q'*E = ( ) , if L >= N , -C ( 0 ) -C or -C -C Q'*E = ( E11 E12 ), if L < N , -C -C where E11 is an MIN(L,N)-by-MIN(L,N) upper triangular -C matrix. -C -C LDE INTEGER -C The leading dimension of array E. LDE >= MAX(1,L). -C -C B (input/output) DOUBLE PRECISION array, dimension (LDB,M) -C On entry, the leading L-by-M part of this array must -C contain the input/state matrix B. -C On exit, the leading L-by-M part of this array contains -C the transformed matrix Q'*B. -C -C LDB INTEGER -C The leading dimension of array B. -C LDB >= MAX(1,L) if M > 0 or LDB >= 1 if M = 0. -C -C Q (input/output) DOUBLE PRECISION array, dimension (LDQ,L) -C If COMPQ = 'N': Q is not referenced. -C If COMPQ = 'I': on entry, Q need not be set; -C on exit, the leading L-by-L part of this -C array contains the orthogonal matrix Q, -C where Q' is the product of Householder -C transformations which are applied to A, -C E, and B on the left. -C If COMPQ = 'U': on entry, the leading L-by-L part of this -C array must contain an orthogonal matrix -C Q1; -C on exit, the leading L-by-L part of this -C array contains the orthogonal matrix -C Q1*Q. -C -C LDQ INTEGER -C The leading dimension of array Q. -C LDQ >= 1, if COMPQ = 'N'; -C LDQ >= MAX(1,L), if COMPQ = 'U' or 'I'. -C -C Workspace -C -C DWORK DOUBLE PRECISION array, dimension (LDWORK) -C On exit, if INFO = 0, DWORK(1) returns the optimal value -C of LDWORK. -C -C LDWORK INTEGER -C The length of the array DWORK. -C LDWORK >= MAX(1, MIN(L,N) + MAX(L,N,M)). -C For optimum performance -C LWORK >= MAX(1, MIN(L,N) + MAX(L,N,M)*NB), -C where NB is the optimal blocksize. -C -C Error Indicator -C -C INFO INTEGER -C = 0: successful exit; -C < 0: if INFO = -i, the i-th argument had an illegal -C value. -C -C METHOD -C -C The routine computes the QR factorization of E to reduce it -C to the upper trapezoidal form. -C -C The transformations are also applied to the rest of system -C matrices -C -C A <- Q' * A , B <- Q' * B. -C -C NUMERICAL ASPECTS -C -C The algorithm is numerically backward stable and requires -C 0( L*L*N ) floating point operations. -C -C CONTRIBUTOR -C -C C. Oara, University "Politehnica" Bucharest. -C A. Varga, German Aerospace Center, DLR Oberpfaffenhofen. -C March 1999. Based on the RASP routine RPDSQR. -C -C REVISIONS -C -C V. Sima, Research Institute for Informatics, Bucharest, July 1999, -C May 2003. -C -C KEYWORDS -C -C Descriptor system, matrix algebra, matrix operations, -C orthogonal transformation. -C -C ****************************************************************** -C -C .. Parameters .. - DOUBLE PRECISION ONE, ZERO - PARAMETER ( ONE = 1.0D0, ZERO = 0.0D0 ) -C .. Scalar Arguments .. - CHARACTER COMPQ - INTEGER INFO, L, LDA, LDB, LDE, LDQ, LDWORK, M, N -C .. Array Arguments .. - DOUBLE PRECISION A( LDA, * ), B( LDB, * ), DWORK( * ), - $ E( LDE, * ), Q( LDQ, * ) -C .. Local Scalars .. - LOGICAL ILQ - INTEGER ICOMPQ, LN, WRKOPT -C .. External Functions .. - LOGICAL LSAME - EXTERNAL LSAME -C .. External Subroutines .. - EXTERNAL DGEQRF, DLASET, DORMQR, XERBLA -C .. Intrinsic Functions .. - INTRINSIC INT, MAX, MIN -C -C .. Executable Statements .. -C -C Decode COMPQ. -C - IF( LSAME( COMPQ, 'N' ) ) THEN - ILQ = .FALSE. - ICOMPQ = 1 - ELSE IF( LSAME( COMPQ, 'U' ) ) THEN - ILQ = .TRUE. - ICOMPQ = 2 - ELSE IF( LSAME( COMPQ, 'I' ) ) THEN - ILQ = .TRUE. - ICOMPQ = 3 - ELSE - ICOMPQ = 0 - END IF -C -C Test the input parameters. -C - INFO = 0 - WRKOPT = MAX( 1, MIN( L, N ) + MAX( L, N, M ) ) - IF( ICOMPQ.EQ.0 ) THEN - INFO = -1 - ELSE IF( L.LT.0 ) THEN - INFO = -2 - ELSE IF( N.LT.0 ) THEN - INFO = -3 - ELSE IF( M.LT.0 ) THEN - INFO = -4 - ELSE IF( LDA.LT.MAX( 1, L ) ) THEN - INFO = -6 - ELSE IF( LDE.LT.MAX( 1, L ) ) THEN - INFO = -8 - ELSE IF( LDB.LT.1 .OR. ( M.GT.0 .AND. LDB.LT.L ) ) THEN - INFO = -10 - ELSE IF( ( ILQ .AND. LDQ.LT.L ) .OR. LDQ.LT.1 ) THEN - INFO = -12 - ELSE IF( LDWORK.LT.WRKOPT ) THEN - INFO = -14 - END IF - IF( INFO.NE.0 ) THEN - CALL XERBLA( 'TG01CD', -INFO ) - RETURN - END IF -C -C Initialize Q if necessary. -C - IF( ICOMPQ.EQ.3 ) - $ CALL DLASET( 'Full', L, L, ZERO, ONE, Q, LDQ ) -C -C Quick return if possible. -C - IF( L.EQ.0 .OR. N.EQ.0 ) THEN - DWORK(1) = ONE - RETURN - END IF -C - LN = MIN( L, N ) -C -C Compute the QR decomposition of E. -C -C Workspace: need MIN(L,N) + N; -C prefer MIN(L,N) + N*NB. -C - CALL DGEQRF( L, N, E, LDE, DWORK, DWORK( LN+1 ), LDWORK-LN, INFO ) - WRKOPT = MAX( WRKOPT, INT( DWORK( LN+1 ) ) + LN ) -C -C Apply transformation on the rest of matrices. -C -C A <-- Q' * A. -C Workspace: need MIN(L,N) + N; -C prefer MIN(L,N) + N*NB. -C - CALL DORMQR( 'Left', 'Transpose', L, N, LN, E, LDE, DWORK, - $ A, LDA, DWORK( LN+1 ), LDWORK-LN, INFO ) - WRKOPT = MAX( WRKOPT, INT( DWORK( LN+1 ) ) + LN ) -C -C B <-- Q' * B. -C Workspace: need MIN(L,N) + M; -C prefer MIN(L,N) + M*NB. -C - IF ( M.GT.0 ) THEN - CALL DORMQR( 'Left', 'Transpose', L, M, LN, E, LDE, DWORK, - $ B, LDB, DWORK( LN+1 ), LDWORK-LN, INFO ) - WRKOPT = MAX( WRKOPT, INT( DWORK( LN+1 ) ) + LN ) - END IF -C -C Q <-- Q1 * Q. -C Workspace: need MIN(L,N) + L; -C prefer MIN(L,N) + L*NB. -C - IF( ILQ ) THEN - CALL DORMQR( 'Right', 'No Transpose', L, L, LN, E, LDE, DWORK, - $ Q, LDQ, DWORK( LN+1 ), LDWORK-LN, INFO ) - WRKOPT = MAX( WRKOPT, INT( DWORK( LN+1 ) ) + LN ) - END IF -C -C Set lower triangle of E to zero. -C - IF( L.GE.2 ) - $ CALL DLASET( 'Lower', L-1, LN, ZERO, ZERO, E( 2, 1 ), LDE ) -C - DWORK(1) = WRKOPT -C - RETURN -C *** Last line of TG01CD *** - END diff --git a/mex/sources/libslicot/TG01DD.f b/mex/sources/libslicot/TG01DD.f deleted file mode 100644 index cac8704d8..000000000 --- a/mex/sources/libslicot/TG01DD.f +++ /dev/null @@ -1,295 +0,0 @@ - SUBROUTINE TG01DD( COMPZ, L, N, P, A, LDA, E, LDE, C, LDC, Z, LDZ, - $ DWORK, LDWORK, INFO ) -C -C SLICOT RELEASE 5.0. -C -C Copyright (c) 2002-2009 NICONET e.V. -C -C This program is free software: you can redistribute it and/or -C modify it under the terms of the GNU General Public License as -C published by the Free Software Foundation, either version 2 of -C the License, or (at your option) any later version. -C -C This program is distributed in the hope that it will be useful, -C but WITHOUT ANY WARRANTY; without even the implied warranty of -C MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the -C GNU General Public License for more details. -C -C You should have received a copy of the GNU General Public License -C along with this program. If not, see -C . -C -C PURPOSE -C -C To reduce the descriptor system pair (C,A-lambda E) to the -C RQ-coordinate form by computing an orthogonal transformation -C matrix Z such that the transformed descriptor system pair -C (C*Z,A*Z-lambda E*Z) has the descriptor matrix E*Z in an upper -C trapezoidal form. -C The right orthogonal transformations performed to reduce E can -C be optionally accumulated. -C -C ARGUMENTS -C -C Mode Parameters -C -C COMPZ CHARACTER*1 -C = 'N': do not compute Z; -C = 'I': Z is initialized to the unit matrix, and the -C orthogonal matrix Z is returned; -C = 'U': Z must contain an orthogonal matrix Z1 on entry, -C and the product Z1*Z is returned. -C -C Input/Output Parameters -C -C L (input) INTEGER -C The number of rows of matrices A and E. L >= 0. -C -C N (input) INTEGER -C The number of columns of matrices A, E, and C. N >= 0. -C -C P (input) INTEGER -C The number of rows of matrix C. P >= 0. -C -C A (input/output) DOUBLE PRECISION array, dimension (LDA,N) -C On entry, the leading L-by-N part of this array must -C contain the state dynamics matrix A. -C On exit, the leading L-by-N part of this array contains -C the transformed matrix A*Z. -C -C LDA INTEGER -C The leading dimension of array A. LDA >= MAX(1,L). -C -C E (input/output) DOUBLE PRECISION array, dimension (LDE,N) -C On entry, the leading L-by-N part of this array must -C contain the descriptor matrix E. -C On exit, the leading L-by-N part of this array contains -C the transformed matrix E*Z in upper trapezoidal form, -C i.e. -C -C ( E11 ) -C E*Z = ( ) , if L >= N , -C ( R ) -C or -C -C E*Z = ( 0 R ), if L < N , -C -C where R is an MIN(L,N)-by-MIN(L,N) upper triangular -C matrix. -C -C LDE INTEGER -C The leading dimension of array E. LDE >= MAX(1,L). -C -C C (input/output) DOUBLE PRECISION array, dimension (LDC,N) -C On entry, the leading P-by-N part of this array must -C contain the state/output matrix C. -C On exit, the leading P-by-N part of this array contains -C the transformed matrix C*Z. -C -C LDC INTEGER -C The leading dimension of array C. LDC >= MAX(1,P). -C -C Z (input/output) DOUBLE PRECISION array, dimension (LDZ,N) -C If COMPZ = 'N': Z is not referenced. -C If COMPZ = 'I': on entry, Z need not be set; -C on exit, the leading N-by-N part of this -C array contains the orthogonal matrix Z, -C which is the product of Householder -C transformations applied to A, E, and C -C on the right. -C If COMPZ = 'U': on entry, the leading N-by-N part of this -C array must contain an orthogonal matrix -C Z1; -C on exit, the leading N-by-N part of this -C array contains the orthogonal matrix -C Z1*Z. -C -C LDZ INTEGER -C The leading dimension of array Z. -C LDZ >= 1, if COMPZ = 'N'; -C LDZ >= MAX(1,N), if COMPZ = 'U' or 'I'. -C -C Workspace -C -C DWORK DOUBLE PRECISION array, dimension (LDWORK) -C On exit, if INFO = 0, DWORK(1) returns the optimal value -C of LDWORK. -C -C LDWORK INTEGER -C The length of the array DWORK. -C LDWORK >= MAX(1, MIN(L,N) + MAX(L,N,P)). -C For optimum performance -C LWORK >= MAX(1, MIN(L,N) + MAX(L,N,P)*NB), -C where NB is the optimal blocksize. -C -C Error Indicator -C -C INFO INTEGER -C = 0: successful exit; -C < 0: if INFO = -i, the i-th argument had an illegal -C value. -C -C METHOD -C -C The routine computes the RQ factorization of E to reduce it -C the upper trapezoidal form. -C -C The transformations are also applied to the rest of system -C matrices -C -C A <- A * Z, C <- C * Z. -C -C NUMERICAL ASPECTS -C -C The algorithm is numerically backward stable and requires -C 0( L*N*N ) floating point operations. -C -C CONTRIBUTOR -C -C C. Oara, University "Politehnica" Bucharest. -C A. Varga, German Aerospace Center, DLR Oberpfaffenhofen. -C March 1999. Based on the RASP routine RPDSRQ. -C -C REVISIONS -C -C July 1999, V. Sima, Research Institute for Informatics, Bucharest. -C -C KEYWORDS -C -C Descriptor system, matrix algebra, matrix operations, -C orthogonal transformation. -C -C ****************************************************************** -C -C .. Parameters .. - DOUBLE PRECISION ONE, ZERO - PARAMETER ( ONE = 1.0D0, ZERO = 0.0D0 ) -C .. Scalar Arguments .. - CHARACTER COMPZ - INTEGER INFO, L, LDA, LDC, LDE, LDWORK, LDZ, N, P -C .. Array Arguments .. - DOUBLE PRECISION A( LDA, * ), C( LDC, * ), DWORK( * ), - $ E( LDE, * ), Z( LDZ, * ) -C .. Local Scalars .. - LOGICAL ILZ - INTEGER ICOMPZ, LN, WRKOPT -C .. External Functions .. - LOGICAL LSAME - EXTERNAL LSAME -C .. External Subroutines .. - EXTERNAL DGERQF, DLASET, DORMRQ, XERBLA -C .. Intrinsic Functions .. - INTRINSIC INT, MAX, MIN -C -C .. Executable Statements .. -C -C Decode COMPZ. -C - IF( LSAME( COMPZ, 'N' ) ) THEN - ILZ = .FALSE. - ICOMPZ = 1 - ELSE IF( LSAME( COMPZ, 'U' ) ) THEN - ILZ = .TRUE. - ICOMPZ = 2 - ELSE IF( LSAME( COMPZ, 'I' ) ) THEN - ILZ = .TRUE. - ICOMPZ = 3 - ELSE - ICOMPZ = 0 - END IF -C -C Test the input parameters. -C - INFO = 0 - WRKOPT = MAX( 1, MIN( L, N ) + MAX( L, N, P ) ) - IF( ICOMPZ.EQ.0 ) THEN - INFO = -1 - ELSE IF( L.LT.0 ) THEN - INFO = -2 - ELSE IF( N.LT.0 ) THEN - INFO = -3 - ELSE IF( P.LT.0 ) THEN - INFO = -4 - ELSE IF( LDA.LT.MAX( 1, L ) ) THEN - INFO = -6 - ELSE IF( LDE.LT.MAX( 1, L ) ) THEN - INFO = -8 - ELSE IF( LDC.LT.MAX( 1, P ) ) THEN - INFO = -10 - ELSE IF( ( ILZ .AND. LDZ.LT.N ) .OR. LDZ.LT.1 ) THEN - INFO = -12 - ELSE IF( LDWORK.LT.WRKOPT ) THEN - INFO = -14 - END IF - IF( INFO .NE. 0 ) THEN - CALL XERBLA( 'TG01DD', -INFO ) - RETURN - END IF -C -C Initialize Q if necessary. -C - IF( ICOMPZ.EQ.3 ) - $ CALL DLASET( 'Full', N, N, ZERO, ONE, Z, LDZ ) -C -C Quick return if possible. -C - IF( L.EQ.0 .OR. N.EQ.0 ) THEN - DWORK( 1 ) = ONE - RETURN - END IF -C - LN = MIN( L, N ) -C -C Compute the RQ decomposition of E, E = R*Z. -C -C Workspace: need MIN(L,N) + L; -C prefer MIN(L,N) + L*NB. -C - CALL DGERQF( L, N, E, LDE, DWORK, DWORK( LN+1 ), LDWORK-LN, INFO ) - WRKOPT = MAX( WRKOPT, INT( DWORK( LN+1 ) ) + LN ) -C -C Apply transformation on the rest of matrices. -C -C A <-- A * Z'. -C Workspace: need MIN(L,N) + L; -C prefer MIN(L,N) + L*NB. -C - CALL DORMRQ( 'Right', 'Transpose', L, N, LN, E( L-LN+1,1 ), LDE, - $ DWORK, A, LDA, DWORK( LN+1 ), LDWORK-LN, INFO ) - WRKOPT = MAX( WRKOPT, INT( DWORK( LN+1 ) ) + LN ) -C -C C <-- C * Z'. -C Workspace: need MIN(L,N) + P; -C prefer MIN(L,N) + P*NB. -C - CALL DORMRQ( 'Right', 'Transpose', P, N, LN, E( L-LN+1,1 ), LDE, - $ DWORK, C, LDC, DWORK( LN+1 ), LDWORK-LN, INFO ) - WRKOPT = MAX( WRKOPT, INT( DWORK( LN+1 ) ) + LN ) -C -C Z <-- Z1 * Z'. -C Workspace: need MIN(L,N) + N; -C prefer MIN(L,N) + N*NB. -C - IF( ILZ ) THEN - CALL DORMRQ( 'Right', 'Transpose', N, N, LN, E( L-LN+1,1 ), - $ LDE, DWORK, Z, LDZ, DWORK( LN+1 ), LDWORK-LN, - $ INFO ) - WRKOPT = MAX( WRKOPT, INT( DWORK( LN+1 ) ) + LN ) - END IF -C -C Set lower triangle of E to zero. -C - IF( L.LT.N ) THEN - CALL DLASET( 'Full', L, N-L, ZERO, ZERO, E, LDE ) - IF( L.GE.2 ) CALL DLASET( 'Lower', L-1, L, ZERO, ZERO, - $ E( 2, N-L+1 ), LDE ) - ELSE - IF( N.GE.2 ) CALL DLASET( 'Lower', N-1, N, ZERO, ZERO, - $ E( L-N+2, 1 ), LDE ) - END IF -C - DWORK(1) = WRKOPT -C - RETURN -C *** Last line of TG01DD *** - END diff --git a/mex/sources/libslicot/TG01ED.f b/mex/sources/libslicot/TG01ED.f deleted file mode 100644 index 1fe8e8bba..000000000 --- a/mex/sources/libslicot/TG01ED.f +++ /dev/null @@ -1,793 +0,0 @@ - SUBROUTINE TG01ED( JOBA, L, N, M, P, A, LDA, E, LDE, B, LDB, - $ C, LDC, Q, LDQ, Z, LDZ, RANKE, RNKA22, TOL, - $ DWORK, LDWORK, INFO ) -C -C SLICOT RELEASE 5.0. -C -C Copyright (c) 2002-2009 NICONET e.V. -C -C This program is free software: you can redistribute it and/or -C modify it under the terms of the GNU General Public License as -C published by the Free Software Foundation, either version 2 of -C the License, or (at your option) any later version. -C -C This program is distributed in the hope that it will be useful, -C but WITHOUT ANY WARRANTY; without even the implied warranty of -C MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the -C GNU General Public License for more details. -C -C You should have received a copy of the GNU General Public License -C along with this program. If not, see -C . -C -C PURPOSE -C -C To compute for the descriptor system (A-lambda E,B,C) -C the orthogonal transformation matrices Q and Z such that the -C transformed system (Q'*A*Z-lambda Q'*E*Z, Q'*B, C*Z) is in an -C SVD (singular value decomposition) coordinate form with -C the system matrices Q'*A*Z and Q'*E*Z in the form -C -C ( A11 A12 ) ( Er 0 ) -C Q'*A*Z = ( ) , Q'*E*Z = ( ) , -C ( A21 A22 ) ( 0 0 ) -C -C where Er is an invertible diagonal matrix having on the diagonal -C the decreasingly ordered nonzero singular values of E. -C Optionally, the A22 matrix can be further reduced to the -C SVD form -C -C ( Ar 0 ) -C A22 = ( ) , -C ( 0 0 ) -C -C where Ar is an invertible diagonal matrix having on the diagonal -C the decreasingly ordered nonzero singular values of A22. -C The left and/or right orthogonal transformations performed -C to reduce E and A22 are accumulated. -C -C ARGUMENTS -C -C Mode Parameters -C -C JOBA CHARACTER*1 -C = 'N': do not reduce A22; -C = 'R': reduce A22 to an SVD form. -C -C Input/Output Parameters -C -C L (input) INTEGER -C The number of rows of matrices A, B, and E. L >= 0. -C -C N (input) INTEGER -C The number of columns of matrices A, E, and C. N >= 0. -C -C M (input) INTEGER -C The number of columns of matrix B. M >= 0. -C -C P (input) INTEGER -C The number of rows of matrix C. P >= 0. -C -C A (input/output) DOUBLE PRECISION array, dimension (LDA,N) -C On entry, the leading L-by-N part of this array must -C contain the state dynamics matrix A. -C On exit, the leading L-by-N part of this array contains -C the transformed matrix Q'*A*Z. If JOBA = 'R', this matrix -C is in the form -C -C ( A11 * * ) -C Q'*A*Z = ( * Ar 0 ) , -C ( * 0 0 ) -C -C where A11 is a RANKE-by-RANKE matrix and Ar is a -C RNKA22-by-RNKA22 invertible diagonal matrix, with -C decresingly ordered positive diagonal elements. -C -C LDA INTEGER -C The leading dimension of array A. LDA >= MAX(1,L). -C -C E (input/output) DOUBLE PRECISION array, dimension (LDE,N) -C On entry, the leading L-by-N part of this array must -C contain the descriptor matrix E. -C On exit, the leading L-by-N part of this array contains -C the transformed matrix Q'*E*Z. -C -C ( Er 0 ) -C Q'*E*Z = ( ) , -C ( 0 0 ) -C -C where Er is a RANKE-by-RANKE invertible diagonal matrix -C having on the diagonal the decreasingly ordered positive -C singular values of E. -C -C LDE INTEGER -C The leading dimension of array E. LDE >= MAX(1,L). -C -C B (input/output) DOUBLE PRECISION array, dimension (LDB,M) -C On entry, the leading L-by-M part of this array must -C contain the input/state matrix B. -C On exit, the leading L-by-M part of this array contains -C the transformed matrix Q'*B. -C -C LDB INTEGER -C The leading dimension of array B. -C LDB >= MAX(1,L) if M > 0 or LDB >= 1 if M = 0. -C -C C (input/output) DOUBLE PRECISION array, dimension (LDC,N) -C On entry, the leading P-by-N part of this array must -C contain the state/output matrix C. -C On exit, the leading P-by-N part of this array contains -C the transformed matrix C*Z. -C -C LDC INTEGER -C The leading dimension of array C. LDC >= MAX(1,P). -C -C Q (output) DOUBLE PRECISION array, dimension (LDQ,L) -C The leading L-by-L part of this array contains the -C orthogonal matrix Q, which is the accumulated product of -C transformations applied to A, E, and B on the left. -C -C LDQ INTEGER -C The leading dimension of array Q. LDQ >= MAX(1,L). -C -C Z (output) DOUBLE PRECISION array, dimension (LDZ,N) -C The leading N-by-N part of this array contains the -C orthogonal matrix Z, which is the accumulated product of -C transformations applied to A, E, and C on the right. -C -C LDZ INTEGER -C The leading dimension of array Z. LDZ >= MAX(1,N). -C -C RANKE (output) INTEGER -C The effective rank of matrix E, and thus also the order -C of the invertible diagonal submatrix Er. -C RANKE is computed as the number of singular values of E -C greater than TOL*SVEMAX, where SVEMAX is the maximum -C singular value of E. -C -C RNKA22 (output) INTEGER -C If JOBA = 'R', then RNKA22 is the effective rank of -C matrix A22, and thus also the order of the invertible -C diagonal submatrix Ar. RNKA22 is computed as the number -C of singular values of A22 greater than TOL*SVAMAX, -C where SVAMAX is an estimate of the maximum singular value -C of A. -C If JOBA = 'N', then RNKA22 is not referenced. -C -C Tolerances -C -C TOL DOUBLE PRECISION -C The tolerance to be used in determining the rank of E -C and of A22. If TOL > 0, then singular values less than -C TOL*SVMAX are treated as zero, where SVMAX is the maximum -C singular value of E or an estimate of it for A and E. -C If TOL <= 0, the default tolerance TOLDEF = EPS*L*N is -C used instead, where EPS is the machine precision -C (see LAPACK Library routine DLAMCH). TOL < 1. -C -C Workspace -C -C DWORK DOUBLE PRECISION array, dimension (LDWORK) -C On exit, if INFO = 0, DWORK(1) returns the optimal value -C of LDWORK. -C -C LDWORK INTEGER -C The length of the array DWORK. -C LDWORK >= MAX(1,MIN(L,N) + -C MAX(3*MIN(L,N)+MAX(L,N), 5*MIN(L,N), M, P)). -C -C Error Indicator -C -C INFO INTEGER -C = 0: successful exit; -C < 0: if INFO = -i, the i-th argument had an illegal -C value; -C > 0: the QR algorithm has failed to converge when computing -C singular value decomposition. In this case INFO -C specifies how many superdiagonals did not converge. -C This failure is not likely to occur. -C -C METHOD -C -C The routine computes the singular value decomposition (SVD) of E, -C in the form -C -C ( Er 0 ) -C E = Q * ( ) * Z' -C ( 0 0 ) -C -C and finds the largest RANKE-by-RANKE leading diagonal submatrix -C Er whose condition number is less than 1/TOL. RANKE defines thus -C the effective rank of matrix E. -C If JOBA = 'R' the same reduction is performed on A22 in the -C partitioned matrix -C -C ( A11 A12 ) -C Q'*A*Z = ( ) , -C ( A21 A22 ) -C -C to obtain it in the form -C -C ( Ar 0 ) -C A22 = ( ) , -C ( 0 0 ) -C -C with Ar an invertible diagonal matrix. -C -C The accumulated transformations are also applied to the rest of -C matrices -C -C B <- Q' * B, C <- C * Z. -C -C NUMERICAL ASPECTS -C -C The algorithm is numerically backward stable and requires -C 0( L*L*N ) floating point operations. -C -C CONTRIBUTOR -C -C A. Varga, German Aerospace Center, DLR Oberpfaffenhofen. -C March 1999. Based on the RASP routine RPDSSV. -C -C REVISIONS -C -C V. Sima, Research Institute for Informatics, Bucharest, July 1999, -C Feb. 2000, Oct. 2001, May 2003. -C -C KEYWORDS -C -C Descriptor system, matrix algebra, matrix operations, -C orthogonal transformation. -C -C ****************************************************************** -C -C .. Parameters .. - DOUBLE PRECISION ONE, ZERO - PARAMETER ( ONE = 1.0D0, ZERO = 0.0D0 ) -C .. Scalar Arguments .. - CHARACTER JOBA - INTEGER INFO, L, LDA, LDB, LDC, LDE, LDQ, LDWORK, - $ LDZ, M, N, P, RNKA22, RANKE - DOUBLE PRECISION TOL -C .. Array Arguments .. - DOUBLE PRECISION A( LDA, * ), B( LDB, * ), C( LDC, * ), - $ DWORK( * ), E( LDE, * ), Q( LDQ, * ), - $ Z( LDZ, * ) -C .. Local Scalars .. - LOGICAL REDA - INTEGER I, IR1, J, KW, LA22, LN, LN2, LWR, NA22, WRKOPT - DOUBLE PRECISION EPSM, SVEMAX, SVLMAX, TOLDEF -C .. External Functions .. - LOGICAL LSAME - DOUBLE PRECISION DLAMCH, DLANGE - EXTERNAL DLAMCH, DLANGE, LSAME -C .. External Subroutines .. - EXTERNAL DCOPY, DGEMM, DGEMV, DGEQRF, DGELQF, DGESVD, - $ DLACPY, DLASET, DORMQR, DORMLQ, DSWAP, MA02AD, - $ MB03UD, XERBLA -C .. Intrinsic Functions .. - INTRINSIC DBLE, INT, MAX, MIN -C -C .. Executable Statements .. -C - REDA = LSAME( JOBA, 'R' ) -C -C Test the input parameters. -C - INFO = 0 - WRKOPT = MIN( L, N ) + - $ MAX( M, P, 3*MIN( L, N ) + MAX( L, N ), 5*MIN( L, N ) ) - IF( .NOT.LSAME( JOBA, 'N' ) .AND. .NOT.REDA ) THEN - INFO = -1 - ELSE IF( L.LT.0 ) THEN - INFO = -2 - ELSE IF( N.LT.0 ) THEN - INFO = -3 - ELSE IF( M.LT.0 ) THEN - INFO = -4 - ELSE IF( P.LT.0 ) THEN - INFO = -5 - ELSE IF( LDA.LT.MAX( 1, L ) ) THEN - INFO = -7 - ELSE IF( LDE.LT.MAX( 1, L ) ) THEN - INFO = -9 - ELSE IF( LDB.LT.1 .OR. ( M.GT.0 .AND. LDB.LT.L ) ) THEN - INFO = -11 - ELSE IF( LDC.LT.MAX( 1, P ) ) THEN - INFO = -13 - ELSE IF( LDQ.LT.MAX( 1, L ) ) THEN - INFO = -15 - ELSE IF( LDZ.LT.MAX( 1, N ) ) THEN - INFO = -17 - ELSE IF( TOL.GE.ONE ) THEN - INFO = -20 - ELSE IF( LDWORK.LT.MAX( 1, WRKOPT ) ) THEN - INFO = -22 - END IF - IF( INFO.NE.0 ) THEN - CALL XERBLA( 'TG01ED', -INFO ) - RETURN - END IF -C -C Quick return if possible. -C - IF( L.EQ.0 .OR. N.EQ.0 ) THEN - IF( L.GT.0 ) - $ CALL DLASET( 'Full', L, L, ZERO, ONE, Q, LDQ ) - IF( N.GT.0 ) - $ CALL DLASET( 'Full', N, N, ZERO, ONE, Z, LDZ ) - DWORK(1) = ONE - RANKE = 0 - IF( REDA ) RNKA22 = 0 - RETURN - END IF -C - LN = MIN( L, N ) - EPSM = DLAMCH( 'EPSILON' ) -C - TOLDEF = TOL - IF( TOLDEF.LE.ZERO ) THEN -C -C Use the default tolerance for rank determination. -C - TOLDEF = EPSM * DBLE( L*N ) - END IF -C -C Set the estimate of the maximum singular value of E to -C max(||E||,||A||) to detect negligible A or E matrices. -C - SVLMAX = MAX( DLANGE( 'F', L, N, E, LDE, DWORK ) , - $ DLANGE( 'F', L, N, A, LDA, DWORK ) ) -C -C Compute the SVD of E -C -C ( Er 0 ) -C E = Qr * ( ) * Zr' -C ( 0 0 ) -C -C Workspace: needed MIN(L,N) + MAX(3*MIN(L,N)+MAX(L,N),5*MIN(L,N)); -C prefer larger. -C - LWR = LDWORK - LN - KW = LN + 1 -C - CALL DGESVD( 'A', 'A', L, N, E, LDE, DWORK, Q, LDQ, Z, LDZ, - $ DWORK(KW), LWR, INFO ) - IF( INFO.GT.0 ) - $ RETURN - WRKOPT = MAX( WRKOPT, LN + INT( DWORK(KW) ) ) -C -C Determine the rank of E. -C - RANKE = 0 - IF( DWORK(1).GT.SVLMAX*EPSM ) THEN - RANKE = 1 - SVEMAX = DWORK(1) - DO 10 I = 2, LN - IF( DWORK(I).LT.SVEMAX*TOLDEF ) GO TO 20 - RANKE = RANKE + 1 - 10 CONTINUE -C - 20 CONTINUE - END IF -C -C Apply transformation on the rest of matrices. -C - IF( RANKE.GT.0 ) THEN -C -C A <-- Qr' * A * Zr. -C - CALL DGEMM( 'Transpose', 'No transpose', L, N, L, ONE, - $ Q, LDQ, A, LDA, ZERO, E, LDE ) - CALL DGEMM( 'No transpose', 'Transpose', L, N, N, ONE, - $ E, LDE, Z, LDZ, ZERO, A, LDA ) -C -C B <-- Qr' * B. -C Workspace: need L; -C prefer L*M. -C - IF( LWR.GT.L*M .AND. M.GT.0 ) THEN -C - CALL DGEMM( 'Transpose', 'No transpose', L, M, L, ONE, - $ Q, LDQ, B, LDB, ZERO, DWORK(KW), L ) - CALL DLACPY( 'Full', L, M, DWORK(KW), L, B, LDB ) - ELSE - DO 30 J = 1, M - CALL DGEMV( 'Transpose', L, L, ONE, Q, LDQ, B(1,J), 1, - $ ZERO, DWORK(KW), 1 ) - CALL DCOPY( L, DWORK(KW), 1, B(1,J), 1 ) - 30 CONTINUE - END IF -C -C C <-- C * Zr. -C Workspace: need N; -C prefer P*N. -C - IF( LWR.GT.P*N ) THEN -C - CALL DGEMM( 'No transpose', 'Transpose', P, N, N, ONE, - $ C, LDC, Z, LDZ, ZERO, DWORK(KW), MAX( 1, P ) ) - CALL DLACPY( 'Full', P, N, DWORK(KW), MAX( 1, P ), C, LDC ) - ELSE - DO 40 I = 1, P - CALL DGEMV( 'No transpose', N, N, ONE, Z, LDZ, - $ C(I,1), LDC, ZERO, DWORK(KW), 1 ) - CALL DCOPY( N, DWORK(KW), 1, C(I,1), LDC ) - 40 CONTINUE - END IF - WRKOPT = MAX( WRKOPT, L*M, P*N ) - END IF -C -C Reduce A22 if necessary. -C - IF( REDA ) THEN - LA22 = L - RANKE - NA22 = N - RANKE - LN2 = MIN( LA22, NA22 ) - IF( LN2.EQ.0 ) THEN - IR1 = 1 - RNKA22 = 0 - ELSE -C -C Compute the SVD of A22 using a storage saving approach. -C - IR1 = RANKE + 1 - IF( LA22.GE.NA22 ) THEN -C -C Compute the QR decomposition of A22 in the form -C -C A22 = Q2 * ( R2 ) , -C ( 0 ) -C -C where R2 is upper triangular. -C Workspace: need MIN(L,N) + N; -C prefer MIN(L,N) + N*NB. -C - CALL DGEQRF( LA22, NA22, A(IR1,IR1), LDA, DWORK(IR1), - $ DWORK(KW), LWR, INFO ) - WRKOPT = MAX( WRKOPT, LN + INT( DWORK(KW) ) ) -C -C Apply transformation Q2 to A, B, and Q. -C -C A <--diag(I, Q2') * A -C Workspace: need MIN(L,N) + N; -C prefer MIN(L,N) + N*NB. -C - CALL DORMQR( 'Left', 'Transpose', LA22, RANKE, LN2, - $ A(IR1,IR1), LDA, DWORK(IR1), A(IR1,1), LDA, - $ DWORK(KW), LWR, INFO ) - WRKOPT = MAX( WRKOPT, LN + INT( DWORK(KW) ) ) -C -C B <-- diag(I, Q2') * B -C Workspace: need MIN(L,N) + M; -C prefer MIN(L,N) + M*NB. -C - IF ( M.GT.0 ) THEN - CALL DORMQR( 'Left', 'Transpose', LA22, M, LN2, - $ A(IR1,IR1), LDA, DWORK(IR1), B(IR1,1), - $ LDB, DWORK(KW), LWR, INFO ) - WRKOPT = MAX( WRKOPT, LN + INT( DWORK(KW) ) ) - END IF -C -C Q <-- Q * diag(I, Q2) -C Workspace: need MIN(L,N) + L; -C prefer MIN(L,N) + L*NB. -C - CALL DORMQR( 'Right', 'No transpose', L, LA22, LN2, - $ A(IR1,IR1), LDA, DWORK(IR1), Q(1,IR1), LDQ, - $ DWORK(KW), LWR, INFO ) - WRKOPT = MAX( WRKOPT, LN + INT( DWORK(KW) ) ) -C -C Compute the SVD of the upper triangular submatrix R2 as -C -C ( Ar 0 ) -C R2 = Q2r * ( ) * Z2r' , -C ( 0 0 ) -C -C where Q2r is stored in E and Z2r' is stored in A22. -C Workspace: need MAX(1,5*MIN(L,N)); -C prefer larger. -C - CALL MB03UD( 'Vectors', 'Vectors', LN2, A(IR1,IR1), LDA, - $ E(IR1,IR1), LDE, DWORK(IR1), DWORK(KW), LWR, - $ INFO ) - IF( INFO.GT.0 ) - $ RETURN - WRKOPT = MAX( WRKOPT, LN + INT( DWORK(KW) ) ) -C -C Determine the rank of A22. -C - RNKA22 = 0 - IF( DWORK(IR1).GT.SVLMAX*EPSM ) THEN - RNKA22 = 1 - DO 50 I = IR1+1, LN - IF( DWORK(I).LE.SVLMAX*TOLDEF ) GO TO 60 - RNKA22 = RNKA22 + 1 - 50 CONTINUE -C - 60 CONTINUE - END IF -C -C Apply transformation on the rest of matrices. -C - IF( RNKA22.GT.0 ) THEN -C -C A <-- diag(I,Q2r') * A * diag(I,Zr2) -C - CALL DGEMM( 'Transpose', 'No transpose', LN2, RANKE, - $ LN2, ONE, E(IR1,IR1), LDE, A(IR1,1), LDA, - $ ZERO, E(IR1,1), LDE ) - CALL DLACPY( 'Full', LN2, RANKE, E(IR1,1), LDE, - $ A(IR1,1), LDA ) - CALL DGEMM( 'No transpose', 'Transpose', RANKE, LN2, - $ LN2, ONE, A(1,IR1), LDA, A(IR1,IR1), LDA, - $ ZERO, E(1,IR1), LDE ) - CALL DLACPY( 'Full', RANKE, LN2, E(1,IR1), LDE, - $ A(1,IR1), LDA ) -C -C B <-- diag(I,Q2r') * B -C - IF( LWR.GT.LN2*M .AND. M.GT.0 ) THEN -C - CALL DGEMM( 'Transpose', 'No transpose', LN2, M, - $ LN2, ONE, E(IR1,IR1), LDE, B(IR1,1), - $ LDB, ZERO, DWORK(KW), LN2 ) - CALL DLACPY( 'Full', LN2, M, DWORK(KW), LN2, - $ B(IR1,1), LDB ) - ELSE - DO 70 J = 1, M - CALL DGEMV( 'Transpose', LN2, LN2, ONE, - $ E(IR1,IR1), LDE, B( IR1,J), 1, - $ ZERO, DWORK(KW), 1 ) - CALL DCOPY( LN2, DWORK(KW), 1, B(IR1,J), 1 ) - 70 CONTINUE - END IF -C -C C <-- C * diag(I,Zr2) -C - IF( LWR.GT.P*LN2 .AND. P.GT.0 ) THEN -C - CALL DGEMM( 'No transpose', 'Transpose', P, LN2, - $ LN2, ONE, C(1,IR1), LDC, A(IR1,IR1), - $ LDA, ZERO, DWORK(KW), P ) - CALL DLACPY( 'Full', P, LN2, DWORK( KW ), P, - $ C(1,IR1), LDC ) - ELSE - DO 80 I = 1, P - CALL DGEMV( 'No transpose', LN2, LN2, ONE, - $ A(IR1,IR1), LDA, C(I,IR1), LDC, - $ ZERO, DWORK(KW), 1 ) - CALL DCOPY( LN2, DWORK(KW), 1, C(I,IR1), LDC ) - 80 CONTINUE - END IF -C -C Q <-- Q * diag(I, Qr2) -C - IF( LWR.GT.L*LN2 ) THEN -C - CALL DGEMM( 'No transpose', 'No transpose', L, LN2, - $ LN2, ONE, Q(1,IR1), LDQ, E(IR1,IR1), - $ LDE, ZERO, DWORK(KW), L ) - CALL DLACPY( 'Full', L, LN2, DWORK(KW), L, - $ Q(1,IR1), LDQ ) - ELSE - DO 90 I = 1, L - CALL DGEMV( 'Transpose', LN2, LN2, ONE, - $ E(IR1,IR1), LDE, Q(I,IR1), LDQ, - $ ZERO, DWORK(KW), 1 ) - CALL DCOPY( LN2, DWORK(KW), 1, Q(I,IR1), LDQ ) - 90 CONTINUE - END IF -C -C Z' <-- diag(I, Zr2') * Z' -C - IF( LWR.GT.N*LN2 ) THEN -C - CALL DGEMM( 'No transpose', 'No transpose', LN2, N, - $ LN2, ONE, A(IR1,IR1), LDA, Z(IR1,1), - $ LDZ, ZERO, DWORK(KW), LN2 ) - CALL DLACPY( 'Full', LN2, N, DWORK(KW), LN2, - $ Z(IR1,1), LDZ ) - ELSE - DO 100 J = 1, N - CALL DGEMV( 'No transpose', LN2, LN2, ONE, - $ A(IR1,IR1), LDA, Z(IR1,J), 1, - $ ZERO, DWORK(KW), 1 ) - CALL DCOPY( LN2, DWORK(KW), 1, Z(IR1,J), 1 ) - 100 CONTINUE - END IF - END IF - ELSE -C -C Compute the LQ decomposition of A22 in the form -C -C A22 = ( L2 0 )* Z2 -C -C where L2 is lower triangular. -C Workspace: need MIN(L,N) + L; -C prefer MIN(L,N) + L*NB. -C - CALL DGELQF( LA22, NA22, A(IR1,IR1), LDA, DWORK(IR1), - $ DWORK(KW), LWR, INFO ) - WRKOPT = MAX( WRKOPT, LN + INT( DWORK(KW) ) ) -C -C Apply transformation Z2 to A, C, and Z. -C -C A <-- A * diag(I, Z2') -C Workspace: need 2*MIN(L,N); -C prefer MIN(L,N) + MIN(L,N)*NB. -C - CALL DORMLQ( 'Right', 'Transpose', RANKE, NA22, LN2, - $ A(IR1,IR1), LDA, DWORK(IR1), A(1,IR1), LDA, - $ DWORK(KW), LWR, INFO ) - WRKOPT = MAX( WRKOPT, LN + INT( DWORK(KW) ) ) -C -C C <-- C * diag(I, Z2') -C Workspace: need MIN(L,N) + P; -C prefer MIN(L,N) + P*NB. -C - IF ( P.GT.0 ) THEN - CALL DORMLQ( 'Right', 'Transpose', P, NA22, LN2, - $ A(IR1,IR1), LDA, DWORK(IR1), C(1,IR1), - $ LDC, DWORK(KW), LWR, INFO ) - WRKOPT = MAX( WRKOPT, LN + INT( DWORK(KW) ) ) - END IF -C -C Z' <- diag(I, Z2) * Z' -C Workspace: need MIN(L,N) + N; -C prefer MIN(L,N) + N*NB. -C - CALL DORMLQ( 'Left', 'No transpose', NA22, N, LN2, - $ A(IR1,IR1), LDA, DWORK(IR1), Z(IR1,1), LDZ, - $ DWORK(KW), LWR, INFO ) - WRKOPT = MAX( WRKOPT, LN + INT( DWORK(KW) ) ) -C -C Compute the SVD of the lower triangular submatrix L2 as -C -C ( Ar 0 ) -C L2' = Z2r * ( ) * Q2r' -C ( 0 0 ) -C -C where Q2r' is stored in E and Z2r is stored in A22. -C Workspace: need MAX(1,5*MIN(L,N)); -C prefer larger. -C - CALL MA02AD( 'Lower', LN2, LN2, A(IR1,IR1), LDA, - $ E(IR1,IR1), LDE ) - CALL MB03UD( 'Vectors', 'Vectors', LN2, E(IR1,IR1), LDE, - $ A(IR1,IR1), LDA, DWORK(IR1), DWORK(KW), - $ LWR, INFO ) - IF( INFO.GT.0 ) - $ RETURN - WRKOPT = MAX( WRKOPT, LN + INT( DWORK(KW) ) ) -C -C Determine the rank of A22. -C - RNKA22 = 0 - IF( DWORK(IR1).GT.SVLMAX*EPSM ) THEN - RNKA22 = 1 - DO 110 I = IR1+1, LN - IF( DWORK(I).LE.SVLMAX*TOLDEF ) GO TO 120 - RNKA22 = RNKA22 + 1 - 110 CONTINUE -C - 120 CONTINUE - END IF -C -C Apply transformation on the rest of matrices. -C - IF( RNKA22.GT.0 ) THEN -C -C A <-- diag(I,Q2r') * A * diag(I,Zr2) -C - CALL DGEMM( 'No transpose', 'No transpose', LN2, - $ RANKE, LN2, ONE, E(IR1,IR1), LDE, - $ A(IR1,1), LDA, ZERO, E(IR1,1), LDE ) - CALL DLACPY( 'Full', LN2, RANKE, E(IR1,1), LDE, - $ A(IR1,1), LDA ) - CALL DGEMM( 'No transpose', 'No transpose', RANKE, - $ LN2, LN2, ONE, A(1,IR1), LDA, - $ A(IR1,IR1), LDA, ZERO, E(1,IR1), LDE ) - CALL DLACPY( 'Full', RANKE, LN2, E(1,IR1), LDE, - $ A(1,IR1), LDA ) -C -C B <-- diag(I,Q2r') * B -C - IF( LWR.GT.LN2*M .AND. M.GT.0 ) THEN -C - CALL DGEMM( 'No transpose', 'No transpose', LN2, M, - $ LN2, ONE, E(IR1,IR1), LDE, B(IR1,1), - $ LDB, ZERO, DWORK(KW), LN2 ) - CALL DLACPY( 'Full', LN2, M, DWORK(KW), LN2, - $ B(IR1,1), LDB ) - ELSE - DO 130 J = 1, M - CALL DGEMV( 'No transpose', LN2, LN2, ONE, - $ E(IR1,IR1), LDE, B( IR1,J), 1, - $ ZERO, DWORK(KW), 1 ) - CALL DCOPY( LN2, DWORK(KW), 1, B(IR1,J), 1 ) - 130 CONTINUE - END IF -C -C C <-- C * diag(I,Zr2) -C - IF( LWR.GT.P*LN2 .AND. P.GT.0 ) THEN -C - CALL DGEMM( 'No transpose', 'No transpose', P, LN2, - $ LN2, ONE, C(1,IR1), LDC, A(IR1,IR1), - $ LDA, ZERO, DWORK(KW), P ) - CALL DLACPY( 'Full', P, LN2, DWORK( KW ), P, - $ C(1,IR1), LDC ) - ELSE - DO 140 I = 1, P - CALL DGEMV( 'Transpose', LN2, LN2, ONE, - $ A(IR1,IR1), LDA, C(I,IR1), LDC, - $ ZERO, DWORK(KW), 1 ) - CALL DCOPY( LN2, DWORK(KW), 1, C(I,IR1), LDC ) - 140 CONTINUE - END IF -C -C Q <-- Q * diag(I, Qr2) -C - IF( LWR.GT.L*LN2 ) THEN -C - CALL DGEMM( 'No transpose', 'Transpose', L, LN2, - $ LN2, ONE, Q(1,IR1), LDQ, E(IR1,IR1), - $ LDE, ZERO, DWORK(KW), L ) - CALL DLACPY( 'Full', L, LN2, DWORK(KW), L, - $ Q(1,IR1), LDQ ) - ELSE - DO 150 I = 1, L - CALL DGEMV( 'No transpose', LN2, LN2, ONE, - $ E(IR1,IR1), LDE, Q(I,IR1), LDQ, - $ ZERO, DWORK(KW), 1 ) - CALL DCOPY( LN2, DWORK(KW), 1, Q(I,IR1), LDQ ) - 150 CONTINUE - END IF -C -C Z' <-- diag(I, Zr2') * Z' -C - IF( LWR.GT.N*LN2 ) THEN -C - CALL DGEMM( 'Transpose', 'No transpose', LN2, N, - $ LN2, ONE, A(IR1,IR1), LDA, Z(IR1,1), - $ LDZ, ZERO, DWORK(KW), LN2 ) - CALL DLACPY( 'Full', LN2, N, DWORK(KW), LN2, - $ Z(IR1,1), LDZ ) - ELSE - DO 160 J = 1, N - CALL DGEMV( 'Transpose', LN2, LN2, ONE, - $ A(IR1,IR1), LDA, Z(IR1,J), 1, - $ ZERO, DWORK(KW), 1 ) - CALL DCOPY( LN2, DWORK(KW), 1, Z(IR1,J), 1 ) - 160 CONTINUE - END IF - END IF - END IF - END IF - END IF -C -C Set E. -C - CALL DLASET( 'Full', L, N, ZERO, ZERO, E, LDE ) - CALL DCOPY( RANKE, DWORK, 1, E, LDE+1 ) -C - IF( REDA ) THEN -C -C Set A22. -C - CALL DLASET( 'Full', LA22, NA22, ZERO, ZERO, A(IR1,IR1), LDA ) - CALL DCOPY( RNKA22, DWORK(IR1), 1, A(IR1,IR1), LDA+1 ) - END IF -C -C Transpose Z. -C - DO 170 I = 2, N - CALL DSWAP( I-1, Z(1,I), 1, Z(I,1), LDZ ) - 170 CONTINUE -C - DWORK(1) = WRKOPT -C - RETURN -C *** Last line of TG01ED *** - END diff --git a/mex/sources/libslicot/TG01FD.f b/mex/sources/libslicot/TG01FD.f deleted file mode 100644 index c50d5fc95..000000000 --- a/mex/sources/libslicot/TG01FD.f +++ /dev/null @@ -1,725 +0,0 @@ - SUBROUTINE TG01FD( COMPQ, COMPZ, JOBA, L, N, M, P, A, LDA, E, LDE, - $ B, LDB, C, LDC, Q, LDQ, Z, LDZ, RANKE, RNKA22, - $ TOL, IWORK, DWORK, LDWORK, INFO ) -C -C SLICOT RELEASE 5.0. -C -C Copyright (c) 2002-2009 NICONET e.V. -C -C This program is free software: you can redistribute it and/or -C modify it under the terms of the GNU General Public License as -C published by the Free Software Foundation, either version 2 of -C the License, or (at your option) any later version. -C -C This program is distributed in the hope that it will be useful, -C but WITHOUT ANY WARRANTY; without even the implied warranty of -C MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the -C GNU General Public License for more details. -C -C You should have received a copy of the GNU General Public License -C along with this program. If not, see -C . -C -C PURPOSE -C -C To compute for the descriptor system (A-lambda E,B,C) -C the orthogonal transformation matrices Q and Z such that the -C transformed system (Q'*A*Z-lambda Q'*E*Z, Q'*B, C*Z) is -C in a SVD-like coordinate form with -C -C ( A11 A12 ) ( Er 0 ) -C Q'*A*Z = ( ) , Q'*E*Z = ( ) , -C ( A21 A22 ) ( 0 0 ) -C -C where Er is an upper triangular invertible matrix. -C Optionally, the A22 matrix can be further reduced to the form -C -C ( Ar X ) -C A22 = ( ) , -C ( 0 0 ) -C -C with Ar an upper triangular invertible matrix, and X either a full -C or a zero matrix. -C The left and/or right orthogonal transformations performed -C to reduce E and A22 can be optionally accumulated. -C -C ARGUMENTS -C -C Mode Parameters -C -C COMPQ CHARACTER*1 -C = 'N': do not compute Q; -C = 'I': Q is initialized to the unit matrix, and the -C orthogonal matrix Q is returned; -C = 'U': Q must contain an orthogonal matrix Q1 on entry, -C and the product Q1*Q is returned. -C -C COMPZ CHARACTER*1 -C = 'N': do not compute Z; -C = 'I': Z is initialized to the unit matrix, and the -C orthogonal matrix Z is returned; -C = 'U': Z must contain an orthogonal matrix Z1 on entry, -C and the product Z1*Z is returned. -C -C JOBA CHARACTER*1 -C = 'N': do not reduce A22; -C = 'R': reduce A22 to a SVD-like upper triangular form. -C = 'T': reduce A22 to an upper trapezoidal form. -C -C Input/Output Parameters -C -C L (input) INTEGER -C The number of rows of matrices A, B, and E. L >= 0. -C -C N (input) INTEGER -C The number of columns of matrices A, E, and C. N >= 0. -C -C M (input) INTEGER -C The number of columns of matrix B. M >= 0. -C -C P (input) INTEGER -C The number of rows of matrix C. P >= 0. -C -C A (input/output) DOUBLE PRECISION array, dimension (LDA,N) -C On entry, the leading L-by-N part of this array must -C contain the state dynamics matrix A. -C On exit, the leading L-by-N part of this array contains -C the transformed matrix Q'*A*Z. If JOBA = 'T', this matrix -C is in the form -C -C ( A11 * * ) -C Q'*A*Z = ( * Ar X ) , -C ( * 0 0 ) -C -C where A11 is a RANKE-by-RANKE matrix and Ar is a -C RNKA22-by-RNKA22 invertible upper triangular matrix. -C If JOBA = 'R' then A has the above form with X = 0. -C -C LDA INTEGER -C The leading dimension of array A. LDA >= MAX(1,L). -C -C E (input/output) DOUBLE PRECISION array, dimension (LDE,N) -C On entry, the leading L-by-N part of this array must -C contain the descriptor matrix E. -C On exit, the leading L-by-N part of this array contains -C the transformed matrix Q'*E*Z. -C -C ( Er 0 ) -C Q'*E*Z = ( ) , -C ( 0 0 ) -C -C where Er is a RANKE-by-RANKE upper triangular invertible -C matrix. -C -C LDE INTEGER -C The leading dimension of array E. LDE >= MAX(1,L). -C -C B (input/output) DOUBLE PRECISION array, dimension (LDB,M) -C On entry, the leading L-by-M part of this array must -C contain the input/state matrix B. -C On exit, the leading L-by-M part of this array contains -C the transformed matrix Q'*B. -C -C LDB INTEGER -C The leading dimension of array B. -C LDB >= MAX(1,L) if M > 0 or LDB >= 1 if M = 0. -C -C C (input/output) DOUBLE PRECISION array, dimension (LDC,N) -C On entry, the leading P-by-N part of this array must -C contain the state/output matrix C. -C On exit, the leading P-by-N part of this array contains -C the transformed matrix C*Z. -C -C LDC INTEGER -C The leading dimension of array C. LDC >= MAX(1,P). -C -C Q (input/output) DOUBLE PRECISION array, dimension (LDQ,L) -C If COMPQ = 'N': Q is not referenced. -C If COMPQ = 'I': on entry, Q need not be set; -C on exit, the leading L-by-L part of this -C array contains the orthogonal matrix Q, -C where Q' is the product of Householder -C transformations which are applied to A, -C E, and B on the left. -C If COMPQ = 'U': on entry, the leading L-by-L part of this -C array must contain an orthogonal matrix -C Q1; -C on exit, the leading L-by-L part of this -C array contains the orthogonal matrix -C Q1*Q. -C -C LDQ INTEGER -C The leading dimension of array Q. -C LDQ >= 1, if COMPQ = 'N'; -C LDQ >= MAX(1,L), if COMPQ = 'U' or 'I'. -C -C Z (input/output) DOUBLE PRECISION array, dimension (LDZ,N) -C If COMPZ = 'N': Z is not referenced. -C If COMPZ = 'I': on entry, Z need not be set; -C on exit, the leading N-by-N part of this -C array contains the orthogonal matrix Z, -C which is the product of Householder -C transformations applied to A, E, and C -C on the right. -C If COMPZ = 'U': on entry, the leading N-by-N part of this -C array must contain an orthogonal matrix -C Z1; -C on exit, the leading N-by-N part of this -C array contains the orthogonal matrix -C Z1*Z. -C -C LDZ INTEGER -C The leading dimension of array Z. -C LDZ >= 1, if COMPZ = 'N'; -C LDZ >= MAX(1,N), if COMPZ = 'U' or 'I'. -C -C RANKE (output) INTEGER -C The estimated rank of matrix E, and thus also the order -C of the invertible upper triangular submatrix Er. -C -C RNKA22 (output) INTEGER -C If JOBA = 'R' or 'T', then RNKA22 is the estimated rank of -C matrix A22, and thus also the order of the invertible -C upper triangular submatrix Ar. -C If JOBA = 'N', then RNKA22 is not referenced. -C -C Tolerances -C -C TOL DOUBLE PRECISION -C The tolerance to be used in determining the rank of E -C and of A22. If the user sets TOL > 0, then the given -C value of TOL is used as a lower bound for the -C reciprocal condition numbers of leading submatrices -C of R or R22 in the QR decompositions E * P = Q * R of E -C or A22 * P22 = Q22 * R22 of A22. -C A submatrix whose estimated condition number is less than -C 1/TOL is considered to be of full rank. If the user sets -C TOL <= 0, then an implicitly computed, default tolerance, -C defined by TOLDEF = L*N*EPS, is used instead, where -C EPS is the machine precision (see LAPACK Library routine -C DLAMCH). TOL < 1. -C -C Workspace -C -C IWORK INTEGER array, dimension (N) -C -C DWORK DOUBLE PRECISION array, dimension (LDWORK) -C On exit, if INFO = 0, DWORK(1) returns the optimal value -C of LDWORK. -C -C LDWORK INTEGER -C The length of the array DWORK. -C LDWORK >= MAX( 1, N+P, MIN(L,N)+MAX(3*N-1,M,L) ). -C For optimal performance, LDWORK should be larger. -C -C If LDWORK = -1, then a workspace query is assumed; -C the routine only calculates the optimal size of the -C DWORK array, returns this value as the first entry of -C the DWORK array, and no error message related to LDWORK -C is issued by XERBLA. -C -C Error Indicator -C -C INFO INTEGER -C = 0: successful exit; -C < 0: if INFO = -i, the i-th argument had an illegal -C value. -C -C METHOD -C -C The routine computes a truncated QR factorization with column -C pivoting of E, in the form -C -C ( E11 E12 ) -C E * P = Q * ( ) -C ( 0 E22 ) -C -C and finds the largest RANKE-by-RANKE leading submatrix E11 whose -C estimated condition number is less than 1/TOL. RANKE defines thus -C the rank of matrix E. Further E22, being negligible, is set to -C zero, and an orthogonal matrix Y is determined such that -C -C ( E11 E12 ) = ( Er 0 ) * Y . -C -C The overal transformation matrix Z results as Z = P * Y' and the -C resulting transformed matrices Q'*A*Z and Q'*E*Z have the form -C -C ( Er 0 ) ( A11 A12 ) -C E <- Q'* E * Z = ( ) , A <- Q' * A * Z = ( ) , -C ( 0 0 ) ( A21 A22 ) -C -C where Er is an upper triangular invertible matrix. -C If JOBA = 'R' the same reduction is performed on A22 to obtain it -C in the form -C -C ( Ar 0 ) -C A22 = ( ) , -C ( 0 0 ) -C -C with Ar an upper triangular invertible matrix. -C If JOBA = 'T' then A22 is row compressed using the QR -C factorization with column pivoting to the form -C -C ( Ar X ) -C A22 = ( ) -C ( 0 0 ) -C -C with Ar an upper triangular invertible matrix. -C -C The transformations are also applied to the rest of system -C matrices -C -C B <- Q' * B, C <- C * Z. -C -C NUMERICAL ASPECTS -C -C The algorithm is numerically backward stable and requires -C 0( L*L*N ) floating point operations. -C -C CONTRIBUTOR -C -C A. Varga, German Aerospace Center, DLR Oberpfaffenhofen. -C March 1999. Based on the RASP routine RPDSSV. -C -C REVISIONS -C -C V. Sima, Research Institute for Informatics, Bucharest, July 1999, -C May 2003, Jan. 2009. -C -C KEYWORDS -C -C Descriptor system, matrix algebra, matrix operations, -C orthogonal transformation. -C -C ****************************************************************** -C -C .. Parameters .. - DOUBLE PRECISION ONE, ZERO - PARAMETER ( ONE = 1.0D0, ZERO = 0.0D0 ) -C .. Scalar Arguments .. - CHARACTER COMPQ, COMPZ, JOBA - INTEGER INFO, L, LDA, LDB, LDC, LDE, LDQ, LDWORK, - $ LDZ, M, N, P, RANKE, RNKA22 - DOUBLE PRECISION TOL -C .. Array Arguments .. - INTEGER IWORK( * ) - DOUBLE PRECISION A( LDA, * ), B( LDB, * ), C( LDC, * ), - $ DWORK( * ), E( LDE, * ), Q( LDQ, * ), - $ Z( LDZ, * ) -C .. Local Scalars .. - LOGICAL ILQ, ILZ, LQUERY, REDA, REDTR, WITHB, WITHC - INTEGER I, ICOMPQ, ICOMPZ, IR1, IRE1, J, K, KW, LA22, - $ LH, LN, LWR, NA22, NB, WRKOPT - DOUBLE PRECISION SVLMAX, TOLDEF -C .. Local Arrays .. - DOUBLE PRECISION SVAL(3) -C .. External Functions .. - LOGICAL LSAME - INTEGER ILAENV - DOUBLE PRECISION DLAMCH, DLANGE - EXTERNAL DLAMCH, DLANGE, ILAENV, LSAME -C .. External Subroutines .. - EXTERNAL DLASET, DORMQR, DORMRZ, DSWAP, DTZRZF, MB03OY, - $ XERBLA -C .. Intrinsic Functions .. - INTRINSIC DBLE, INT, MAX, MIN -C -C .. Executable Statements .. -C -C Decode COMPQ. -C - IF( LSAME( COMPQ, 'N' ) ) THEN - ILQ = .FALSE. - ICOMPQ = 1 - ELSE IF( LSAME( COMPQ, 'U' ) ) THEN - ILQ = .TRUE. - ICOMPQ = 2 - ELSE IF( LSAME( COMPQ, 'I' ) ) THEN - ILQ = .TRUE. - ICOMPQ = 3 - ELSE - ICOMPQ = 0 - END IF -C -C Decode COMPZ. -C - IF( LSAME( COMPZ, 'N' ) ) THEN - ILZ = .FALSE. - ICOMPZ = 1 - ELSE IF( LSAME( COMPZ, 'U' ) ) THEN - ILZ = .TRUE. - ICOMPZ = 2 - ELSE IF( LSAME( COMPZ, 'I' ) ) THEN - ILZ = .TRUE. - ICOMPZ = 3 - ELSE - ICOMPZ = 0 - END IF - REDA = LSAME( JOBA, 'R' ) - REDTR = LSAME( JOBA, 'T' ) - WITHB = M.GT.0 - WITHC = P.GT.0 - LQUERY = ( LDWORK.EQ.-1 ) -C -C Test the input parameters. -C - LN = MIN( L, N ) - INFO = 0 - WRKOPT = MAX( 1, N+P, LN + MAX( 3*N-1, M, L ) ) - IF( ICOMPQ.LE.0 ) THEN - INFO = -1 - ELSE IF( ICOMPZ.LE.0 ) THEN - INFO = -2 - ELSE IF( .NOT.LSAME( JOBA, 'N' ) .AND. .NOT.REDA .AND. - $ .NOT.REDTR ) THEN - INFO = -3 - ELSE IF( L.LT.0 ) THEN - INFO = -4 - ELSE IF( N.LT.0 ) THEN - INFO = -5 - ELSE IF( M.LT.0 ) THEN - INFO = -6 - ELSE IF( P.LT.0 ) THEN - INFO = -7 - ELSE IF( LDA.LT.MAX( 1, L ) ) THEN - INFO = -9 - ELSE IF( LDE.LT.MAX( 1, L ) ) THEN - INFO = -11 - ELSE IF( LDB.LT.1 .OR. ( WITHB .AND. LDB.LT.L ) ) THEN - INFO = -13 - ELSE IF( LDC.LT.MAX( 1, P ) ) THEN - INFO = -15 - ELSE IF( ( ILQ .AND. LDQ.LT.L ) .OR. LDQ.LT.1 ) THEN - INFO = -17 - ELSE IF( ( ILZ .AND. LDZ.LT.N ) .OR. LDZ.LT.1 ) THEN - INFO = -19 - ELSE IF( TOL.GE.ONE ) THEN - INFO = -22 - ELSE - IF( LQUERY ) THEN - NB = MIN( 64, ILAENV( 1, 'DORMQR', 'LC', L, N, LN, -1 ) ) - WRKOPT = MAX( WRKOPT, LN + N*NB ) - IF( WITHB ) THEN - NB = MIN( 64, ILAENV( 1, 'DORMQR', 'LC', L, M, LN, -1 ) ) - WRKOPT = MAX( WRKOPT, LN + M*NB ) - END IF - IF( ILQ ) THEN - NB = MIN( 64, ILAENV( 1, 'DORMQR', 'RN', L, L, LN, -1 ) ) - WRKOPT = MAX( WRKOPT, LN + L*NB ) - END IF - NB = ILAENV( 1, 'DGERQF', ' ', L, N, -1, -1 ) - WRKOPT = MAX( WRKOPT, LN + N*NB ) - NB = MIN( 64, ILAENV( 1, 'DORMRQ', 'RC', L, N, N, -1 ) ) - WRKOPT = MAX( WRKOPT, N + MAX( 1, L )*NB ) - IF( WITHC ) THEN - NB = MIN( 64, ILAENV( 1, 'DORMRQ', 'RC', P, N, N, -1 ) ) - WRKOPT = MAX( WRKOPT, N + MAX( 1, P )*NB ) - END IF - IF( ILZ ) THEN - NB = MIN( 64, ILAENV( 1, 'DORMRQ', 'RC', N, N, N, -1 ) ) - WRKOPT = MAX( WRKOPT, N + MAX( 1, N )*NB ) - END IF - ELSE IF( LDWORK.LT.WRKOPT ) THEN - INFO = -25 - END IF - END IF - IF( INFO.NE.0 ) THEN - CALL XERBLA( 'TG01FD', -INFO ) - RETURN - ELSE IF( LQUERY ) THEN - DWORK(1) = WRKOPT - RETURN - END IF -C -C Initialize Q and Z if necessary. -C - IF( ICOMPQ.EQ.3 ) - $ CALL DLASET( 'Full', L, L, ZERO, ONE, Q, LDQ ) - IF( ICOMPZ.EQ.3 ) - $ CALL DLASET( 'Full', N, N, ZERO, ONE, Z, LDZ ) -C -C Quick return if possible. -C - IF( L.EQ.0 .OR. N.EQ.0 ) THEN - DWORK(1) = ONE - RANKE = 0 - IF( REDA .OR. REDTR ) RNKA22 = 0 - RETURN - END IF -C - TOLDEF = TOL - IF( TOLDEF.LE.ZERO ) THEN -C -C Use the default tolerance for rank determination. -C - TOLDEF = DBLE( L*N )*DLAMCH( 'EPSILON' ) - END IF -C -C Set the estimate of maximum singular value of E to -C max(||E||,||A||) to detect negligible A or E matrices. -C - SVLMAX = MAX( DLANGE( 'F', L, N, E, LDE, DWORK ), - $ DLANGE( 'F', L, N, A, LDA, DWORK ) ) -C -C Compute the rank-revealing QR decomposition of E, -C -C ( E11 E12 ) -C E * P = Qr * ( ) , -C ( 0 E22 ) -C -C and determine the rank of E using incremental condition -C estimation. -C Workspace: MIN(L,N) + 3*N - 1. -C - LWR = LDWORK - LN - KW = LN + 1 -C - CALL MB03OY( L, N, E, LDE, TOLDEF, SVLMAX, RANKE, SVAL, IWORK, - $ DWORK, DWORK(KW), INFO ) -C -C Apply transformation on the rest of matrices. -C - IF( RANKE.GT.0 ) THEN -C -C A <-- Qr' * A. -C Workspace: need MIN(L,N) + N; -C prefer MIN(L,N) + N*NB. -C - CALL DORMQR( 'Left', 'Transpose', L, N, RANKE, E, LDE, DWORK, - $ A, LDA, DWORK(KW), LWR, INFO ) - WRKOPT = MAX( WRKOPT, LN + INT( DWORK(KW) ) ) -C -C B <-- Qr' * B. -C Workspace: need MIN(L,N) + M; -C prefer MIN(L,N) + M*NB. -C - IF( WITHB ) THEN - CALL DORMQR( 'Left', 'Transpose', L, M, RANKE, E, LDE, - $ DWORK, B, LDB, DWORK(KW), LWR, INFO ) - WRKOPT = MAX( WRKOPT, LN + INT( DWORK(KW) ) ) - END IF -C -C Q <-- Q * Qr. -C Workspace: need MIN(L,N) + L; -C prefer MIN(L,N) + L*NB. -C - IF( ILQ ) THEN - CALL DORMQR( 'Right', 'No Transpose', L, L, RANKE, E, LDE, - $ DWORK, Q, LDQ, DWORK(KW), LWR, INFO ) - WRKOPT = MAX( WRKOPT, LN + INT( DWORK(KW) ) ) - END IF -C -C Set lower triangle of E to zero. -C - IF( L.GE.2 ) - $ CALL DLASET( 'Lower', L-1, RANKE, ZERO, ZERO, E(2,1), LDE ) -C -C Compute A*P, C*P and Z*P by forward permuting the columns of -C A, C and Z based on information in IWORK. -C - DO 10 J = 1, N - IWORK(J) = -IWORK(J) - 10 CONTINUE - DO 30 I = 1, N - IF( IWORK(I).LT.0 ) THEN - J = I - IWORK(J) = -IWORK(J) - 20 CONTINUE - K = IWORK(J) - IF( IWORK(K).LT.0 ) THEN - CALL DSWAP( L, A(1,J), 1, A(1,K), 1 ) - IF( WITHC ) - $ CALL DSWAP( P, C(1,J), 1, C(1,K), 1 ) - IF( ILZ ) - $ CALL DSWAP( N, Z(1,J), 1, Z(1,K), 1 ) - IWORK(K) = -IWORK(K) - J = K - GO TO 20 - END IF - END IF - 30 CONTINUE -C -C Determine an orthogonal matrix Y such that -C -C ( E11 E12 ) = ( Er 0 ) * Y . -C -C Compute E <-- E*Y', A <-- A*Y', C <-- C*Y', Z <-- Z*Y'. -C - IF( RANKE.LT.N ) THEN -C -C Workspace: need 2*N; -C prefer N + N*NB. -C - KW = RANKE + 1 - CALL DTZRZF( RANKE, N, E, LDE, DWORK, DWORK(KW), - $ LDWORK-KW+1, INFO ) - WRKOPT = MAX( WRKOPT, INT( DWORK(KW) ) + KW - 1 ) -C -C Workspace: need N + MAX(L,P,N); -C prefer N + MAX(L,P,N)*NB. -C - LH = N - RANKE - CALL DORMRZ( 'Right', 'Transpose', L, N, RANKE, LH, E, LDE, - $ DWORK, A, LDA, DWORK(KW), LDWORK-KW+1, INFO ) - WRKOPT = MAX( WRKOPT, INT( DWORK(KW) ) + KW - 1 ) - IF( WITHC ) THEN - CALL DORMRZ( 'Right', 'Transpose', P, N, RANKE, LH, E, - $ LDE, DWORK, C, LDC, DWORK(KW), LDWORK-KW+1, - $ INFO ) - WRKOPT = MAX( WRKOPT, INT( DWORK(KW) ) + KW - 1 ) - END IF - IF( ILZ ) THEN - CALL DORMRZ( 'Right', 'Transpose', N, N, RANKE, LH, E, - $ LDE, DWORK, Z, LDZ, DWORK(KW), LDWORK-KW+1, - $ INFO ) - WRKOPT = MAX( WRKOPT, INT( DWORK(KW) ) + KW - 1 ) - END IF -C -C Set E12 and E22 to zero. -C - CALL DLASET( 'Full', L, LH, ZERO, ZERO, E(1,KW), LDE ) - END IF - ELSE - CALL DLASET( 'Full', L, N, ZERO, ZERO, E, LDE ) - END IF -C -C Reduce A22 if necessary. -C - IF( REDA .OR. REDTR ) THEN - LA22 = L - RANKE - NA22 = N - RANKE - IF( MIN( LA22, NA22 ).EQ.0 ) THEN - RNKA22 = 0 - ELSE -C -C Compute the rank-revealing QR decomposition of A22, -C -C ( R11 R12 ) -C A22 * P2 = Q2 * ( ) , -C ( 0 R22 ) -C -C and determine the rank of A22 using incremental -C condition estimation. -C Workspace: MIN(L,N) + 3*N - 1. -C - IR1 = RANKE + 1 - CALL MB03OY( LA22, NA22, A(IR1,IR1), LDA, TOLDEF, - $ SVLMAX, RNKA22, SVAL, IWORK, DWORK, - $ DWORK(KW), INFO ) -C -C Apply transformation on the rest of matrices. -C - IF( RNKA22.GT.0 ) THEN -C -C A <-- diag(I, Q2') * A -C Workspace: need MIN(L,N) + N; -C prefer MIN(L,N) + N*NB. -C - CALL DORMQR( 'Left', 'Transpose', LA22, RANKE, RNKA22, - $ A(IR1,IR1), LDA, DWORK, A(IR1,1), LDA, - $ DWORK(KW), LWR, INFO ) -C -C B <-- diag(I, Q2') * B -C Workspace: need MIN(L,N) + M; -C prefer MIN(L,N) + M*NB. -C - IF ( WITHB ) - $ CALL DORMQR( 'Left', 'Transpose', LA22, M, RNKA22, - $ A(IR1,IR1), LDA, DWORK, B(IR1,1), LDB, - $ DWORK(KW), LWR, INFO ) -C -C Q <-- Q * diag(I, Q2) -C Workspace: need MIN(L,N) + L; -C prefer MIN(L,N) + L*NB. -C - IF( ILQ ) - $ CALL DORMQR( 'Right', 'No transpose', L, LA22, RNKA22, - $ A(IR1,IR1), LDA, DWORK, Q(1,IR1), LDQ, - $ DWORK(KW), LWR, INFO ) -C -C Set lower triangle of A22 to zero. -C - IF( LA22.GE.2 ) - $ CALL DLASET( 'Lower', LA22-1, RNKA22, ZERO, ZERO, - $ A(IR1+1,IR1), LDA ) -C -C Compute A*diag(I,P2), C*diag(I,P2) and Z*diag(I,P2) -C by forward permuting the columns of A, C and Z based -C on information in IWORK. -C - DO 40 J = 1, NA22 - IWORK(J) = -IWORK(J) - 40 CONTINUE - DO 60 I = 1, NA22 - IF( IWORK(I).LT.0 ) THEN - J = I - IWORK(J) = -IWORK(J) - 50 CONTINUE - K = IWORK(J) - IF( IWORK(K).LT.0 ) THEN - CALL DSWAP( RANKE, A(1,RANKE+J), 1, - $ A(1,RANKE+K), 1 ) - IF( WITHC ) - $ CALL DSWAP( P, C(1,RANKE+J), 1, - $ C(1,RANKE+K), 1 ) - IF( ILZ ) - $ CALL DSWAP( N, Z(1,RANKE+J), 1, - $ Z(1,RANKE+K), 1 ) - IWORK(K) = -IWORK(K) - J = K - GO TO 50 - END IF - END IF - 60 CONTINUE -C - IF( REDA .AND. RNKA22.LT.NA22 ) THEN -C -C Determine an orthogonal matrix Y2 such that -C -C ( R11 R12 ) = ( Ar 0 ) * Y2 . -C -C Compute A <-- A*diag(I, Y2'), C <-- C*diag(I, Y2'), -C Z <-- Z*diag(I, Y2'). -C Workspace: need 2*N. -C prefer N + N*NB. -C - KW = RANKE + 1 - CALL DTZRZF( RNKA22, NA22, A(IR1,IR1), LDA, DWORK, - $ DWORK(KW), LDWORK-KW+1, INFO ) - WRKOPT = MAX( WRKOPT, INT( DWORK(KW) ) + KW - 1 ) -C -C Workspace: need N + MAX(P,N); -C prefer N + MAX(P,N)*NB. -C - LH = NA22 - RNKA22 - IF( WITHC ) THEN - CALL DORMRZ( 'Right', 'Transpose', P, N, RNKA22, - $ LH, A(IR1,IR1), LDA, DWORK, C, LDC, - $ DWORK(KW), LDWORK-KW+1, INFO ) - WRKOPT = MAX( WRKOPT, INT( DWORK(KW) ) + KW - 1 ) - END IF - IF( ILZ ) THEN - CALL DORMRZ( 'Right', 'Transpose', N, N, RNKA22, - $ LH, A(IR1,IR1), LDA, DWORK, Z, LDZ, - $ DWORK(KW), LDWORK-KW+1, INFO ) - WRKOPT = MAX( WRKOPT, INT( DWORK(KW) ) + KW - 1 ) - END IF - IRE1 = RANKE + RNKA22 + 1 -C -C Set R12 and R22 to zero. -C - CALL DLASET( 'Full', LA22, LH, ZERO, ZERO, - $ A(IR1,IRE1), LDA ) - END IF - ELSE - CALL DLASET( 'Full', LA22, NA22, ZERO, ZERO, - $ A(IR1,IR1), LDA) - END IF - END IF - END IF -C - DWORK(1) = WRKOPT -C - RETURN -C *** Last line of TG01FD *** - END diff --git a/mex/sources/libslicot/TG01FZ.f b/mex/sources/libslicot/TG01FZ.f deleted file mode 100644 index 5d8f59509..000000000 --- a/mex/sources/libslicot/TG01FZ.f +++ /dev/null @@ -1,733 +0,0 @@ - SUBROUTINE TG01FZ( COMPQ, COMPZ, JOBA, L, N, M, P, A, LDA, E, LDE, - $ B, LDB, C, LDC, Q, LDQ, Z, LDZ, RANKE, RNKA22, - $ TOL, IWORK, DWORK, ZWORK, LZWORK, INFO ) -C -C SLICOT RELEASE 5.0. -C -C Copyright (c) 2002-2009 NICONET e.V. -C -C This program is free software: you can redistribute it and/or -C modify it under the terms of the GNU General Public License as -C published by the Free Software Foundation, either version 2 of -C the License, or (at your option) any later version. -C -C This program is distributed in the hope that it will be useful, -C but WITHOUT ANY WARRANTY; without even the implied warranty of -C MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the -C GNU General Public License for more details. -C -C You should have received a copy of the GNU General Public License -C along with this program. If not, see -C . -C -C PURPOSE -C -C To compute for the descriptor system (A-lambda E,B,C) -C the unitary transformation matrices Q and Z such that the -C transformed system (Q'*A*Z-lambda Q'*E*Z, Q'*B, C*Z) is -C in a SVD-like coordinate form with -C -C ( A11 A12 ) ( Er 0 ) -C Q'*A*Z = ( ) , Q'*E*Z = ( ) , -C ( A21 A22 ) ( 0 0 ) -C -C where Er is an upper triangular invertible matrix, and ' denotes -C the conjugate transpose. Optionally, the A22 matrix can be further -C reduced to the form -C -C ( Ar X ) -C A22 = ( ) , -C ( 0 0 ) -C -C with Ar an upper triangular invertible matrix, and X either a full -C or a zero matrix. -C The left and/or right unitary transformations performed -C to reduce E and A22 can be optionally accumulated. -C -C ARGUMENTS -C -C Mode Parameters -C -C COMPQ CHARACTER*1 -C = 'N': do not compute Q; -C = 'I': Q is initialized to the unit matrix, and the -C unitary matrix Q is returned; -C = 'U': Q must contain a unitary matrix Q1 on entry, -C and the product Q1*Q is returned. -C -C COMPZ CHARACTER*1 -C = 'N': do not compute Z; -C = 'I': Z is initialized to the unit matrix, and the -C unitary matrix Z is returned; -C = 'U': Z must contain a unitary matrix Z1 on entry, -C and the product Z1*Z is returned. -C -C JOBA CHARACTER*1 -C = 'N': do not reduce A22; -C = 'R': reduce A22 to a SVD-like upper triangular form. -C = 'T': reduce A22 to an upper trapezoidal form. -C -C Input/Output Parameters -C -C L (input) INTEGER -C The number of rows of matrices A, B, and E. L >= 0. -C -C N (input) INTEGER -C The number of columns of matrices A, E, and C. N >= 0. -C -C M (input) INTEGER -C The number of columns of matrix B. M >= 0. -C -C P (input) INTEGER -C The number of rows of matrix C. P >= 0. -C -C A (input/output) COMPLEX*16 array, dimension (LDA,N) -C On entry, the leading L-by-N part of this array must -C contain the state dynamics matrix A. -C On exit, the leading L-by-N part of this array contains -C the transformed matrix Q'*A*Z. If JOBA = 'T', this matrix -C is in the form -C -C ( A11 * * ) -C Q'*A*Z = ( * Ar X ) , -C ( * 0 0 ) -C -C where A11 is a RANKE-by-RANKE matrix and Ar is a -C RNKA22-by-RNKA22 invertible upper triangular matrix. -C If JOBA = 'R' then A has the above form with X = 0. -C -C LDA INTEGER -C The leading dimension of array A. LDA >= MAX(1,L). -C -C E (input/output) COMPLEX*16 array, dimension (LDE,N) -C On entry, the leading L-by-N part of this array must -C contain the descriptor matrix E. -C On exit, the leading L-by-N part of this array contains -C the transformed matrix Q'*E*Z. -C -C ( Er 0 ) -C Q'*E*Z = ( ) , -C ( 0 0 ) -C -C where Er is a RANKE-by-RANKE upper triangular invertible -C matrix. -C -C LDE INTEGER -C The leading dimension of array E. LDE >= MAX(1,L). -C -C B (input/output) COMPLEX*16 array, dimension (LDB,M) -C On entry, the leading L-by-M part of this array must -C contain the input/state matrix B. -C On exit, the leading L-by-M part of this array contains -C the transformed matrix Q'*B. -C -C LDB INTEGER -C The leading dimension of array B. -C LDB >= MAX(1,L) if M > 0 or LDB >= 1 if M = 0. -C -C C (input/output) COMPLEX*16 array, dimension (LDC,N) -C On entry, the leading P-by-N part of this array must -C contain the state/output matrix C. -C On exit, the leading P-by-N part of this array contains -C the transformed matrix C*Z. -C -C LDC INTEGER -C The leading dimension of array C. LDC >= MAX(1,P). -C -C Q (input/output) COMPLEX*16 array, dimension (LDQ,L) -C If COMPQ = 'N': Q is not referenced. -C If COMPQ = 'I': on entry, Q need not be set; -C on exit, the leading L-by-L part of this -C array contains the unitary matrix Q, -C where Q' is the product of Householder -C transformations which are applied to A, -C E, and B on the left. -C If COMPQ = 'U': on entry, the leading L-by-L part of this -C array must contain a unitary matrix Q1; -C on exit, the leading L-by-L part of this -C array contains the unitary matrix Q1*Q. -C -C LDQ INTEGER -C The leading dimension of array Q. -C LDQ >= 1, if COMPQ = 'N'; -C LDQ >= MAX(1,L), if COMPQ = 'U' or 'I'. -C -C Z (input/output) COMPLEX*16 array, dimension (LDZ,N) -C If COMPZ = 'N': Z is not referenced. -C If COMPZ = 'I': on entry, Z need not be set; -C on exit, the leading N-by-N part of this -C array contains the unitary matrix Z, -C which is the product of Householder -C transformations applied to A, E, and C -C on the right. -C If COMPZ = 'U': on entry, the leading N-by-N part of this -C array must contain a unitary matrix Z1; -C on exit, the leading N-by-N part of this -C array contains the unitary matrix Z1*Z. -C -C LDZ INTEGER -C The leading dimension of array Z. -C LDZ >= 1, if COMPZ = 'N'; -C LDZ >= MAX(1,N), if COMPZ = 'U' or 'I'. -C -C RANKE (output) INTEGER -C The estimated rank of matrix E, and thus also the order -C of the invertible upper triangular submatrix Er. -C -C RNKA22 (output) INTEGER -C If JOBA = 'R' or 'T', then RNKA22 is the estimated rank of -C matrix A22, and thus also the order of the invertible -C upper triangular submatrix Ar. -C If JOBA = 'N', then RNKA22 is not referenced. -C -C Tolerances -C -C TOL DOUBLE PRECISION -C The tolerance to be used in determining the rank of E -C and of A22. If the user sets TOL > 0, then the given -C value of TOL is used as a lower bound for the -C reciprocal condition numbers of leading submatrices -C of R or R22 in the QR decompositions E * P = Q * R of E -C or A22 * P22 = Q22 * R22 of A22. -C A submatrix whose estimated condition number is less than -C 1/TOL is considered to be of full rank. If the user sets -C TOL <= 0, then an implicitly computed, default tolerance, -C defined by TOLDEF = L*N*EPS, is used instead, where -C EPS is the machine precision (see LAPACK Library routine -C DLAMCH). TOL < 1. -C -C Workspace -C -C IWORK INTEGER array, dimension (N) -C -C DWORK DOUBLE PRECISION array, dimension (2*N) -C -C ZWORK DOUBLE PRECISION array, dimension (LZWORK) -C On exit, if INFO = 0, ZWORK(1) returns the optimal value -C of LZWORK. -C -C LZWORK INTEGER -C The length of the array ZWORK. -C LZWORK >= MAX( 1, N+P, MIN(L,N)+MAX(3*N-1,M,L) ). -C For optimal performance, LZWORK should be larger. -C -C If LZWORK = -1, then a workspace query is assumed; -C the routine only calculates the optimal size of the -C ZWORK array, returns this value as the first entry of -C the ZWORK array, and no error message related to LZWORK -C is issued by XERBLA. -C -C Error Indicator -C -C INFO INTEGER -C = 0: successful exit; -C < 0: if INFO = -i, the i-th argument had an illegal -C value. -C -C METHOD -C -C The routine computes a truncated QR factorization with column -C pivoting of E, in the form -C -C ( E11 E12 ) -C E * P = Q * ( ) -C ( 0 E22 ) -C -C and finds the largest RANKE-by-RANKE leading submatrix E11 whose -C estimated condition number is less than 1/TOL. RANKE defines thus -C the rank of matrix E. Further E22, being negligible, is set to -C zero, and a unitary matrix Y is determined such that -C -C ( E11 E12 ) = ( Er 0 ) * Y . -C -C The overal transformation matrix Z results as Z = P * Y' and the -C resulting transformed matrices Q'*A*Z and Q'*E*Z have the form -C -C ( Er 0 ) ( A11 A12 ) -C E <- Q'* E * Z = ( ) , A <- Q' * A * Z = ( ) , -C ( 0 0 ) ( A21 A22 ) -C -C where Er is an upper triangular invertible matrix. -C If JOBA = 'R' the same reduction is performed on A22 to obtain it -C in the form -C -C ( Ar 0 ) -C A22 = ( ) , -C ( 0 0 ) -C -C with Ar an upper triangular invertible matrix. -C If JOBA = 'T' then A22 is row compressed using the QR -C factorization with column pivoting to the form -C -C ( Ar X ) -C A22 = ( ) -C ( 0 0 ) -C -C with Ar an upper triangular invertible matrix. -C -C The transformations are also applied to the rest of system -C matrices -C -C B <- Q' * B, C <- C * Z. -C -C NUMERICAL ASPECTS -C -C The algorithm is numerically backward stable and requires -C 0( L*L*N ) floating point operations. -C -C CONTRIBUTOR -C -C A. Varga, German Aerospace Center, DLR Oberpfaffenhofen. -C March 1999. -C Complex version: V. Sima, Research Institute for Informatics, -C Bucharest, Nov. 2008. -C -C REVISIONS -C -C - -C -C KEYWORDS -C -C Descriptor system, matrix algebra, matrix operations, unitary -C transformation. -C -C ****************************************************************** -C -C .. Parameters .. - COMPLEX*16 ONE, ZERO - PARAMETER ( ONE = ( 1.0D+0, 0.0D+0 ), - $ ZERO = ( 0.0D+0, 0.0D+0 ) ) - DOUBLE PRECISION DONE, DZERO - PARAMETER ( DONE = 1.0D+0, DZERO = 0.0D+0 ) -C .. Scalar Arguments .. - CHARACTER COMPQ, COMPZ, JOBA - INTEGER INFO, L, LDA, LDB, LDC, LDE, LDQ, LDZ, LZWORK, - $ M, N, P, RANKE, RNKA22 - DOUBLE PRECISION TOL -C .. Array Arguments .. - INTEGER IWORK( * ) - COMPLEX*16 A( LDA, * ), B( LDB, * ), C( LDC, * ), - $ E( LDE, * ), Q( LDQ, * ), Z( LDZ, * ), - $ ZWORK( * ) - DOUBLE PRECISION DWORK( * ) -C .. Local Scalars .. - LOGICAL ILQ, ILZ, LQUERY, REDA, REDTR, WITHB, WITHC - INTEGER I, ICOMPQ, ICOMPZ, IR1, IRE1, J, K, KW, LA22, - $ LH, LN, LWR, NA22, NB, WRKOPT - DOUBLE PRECISION SVLMAX, TOLDEF -C .. Local Arrays .. - DOUBLE PRECISION SVAL(3) -C .. External Functions .. - LOGICAL LSAME - INTEGER ILAENV - DOUBLE PRECISION DLAMCH, ZLANGE - EXTERNAL DLAMCH, ILAENV, LSAME, ZLANGE -C .. External Subroutines .. - EXTERNAL MB3OYZ, XERBLA, ZLASET, ZSWAP, ZTZRZF, ZUNMQR, - $ ZUNMRZ -C .. Intrinsic Functions .. - INTRINSIC DBLE, INT, MAX, MIN -C -C .. Executable Statements .. -C -C Decode COMPQ. -C - IF( LSAME( COMPQ, 'N' ) ) THEN - ILQ = .FALSE. - ICOMPQ = 1 - ELSE IF( LSAME( COMPQ, 'U' ) ) THEN - ILQ = .TRUE. - ICOMPQ = 2 - ELSE IF( LSAME( COMPQ, 'I' ) ) THEN - ILQ = .TRUE. - ICOMPQ = 3 - ELSE - ICOMPQ = 0 - END IF -C -C Decode COMPZ. -C - IF( LSAME( COMPZ, 'N' ) ) THEN - ILZ = .FALSE. - ICOMPZ = 1 - ELSE IF( LSAME( COMPZ, 'U' ) ) THEN - ILZ = .TRUE. - ICOMPZ = 2 - ELSE IF( LSAME( COMPZ, 'I' ) ) THEN - ILZ = .TRUE. - ICOMPZ = 3 - ELSE - ICOMPZ = 0 - END IF - REDA = LSAME( JOBA, 'R' ) - REDTR = LSAME( JOBA, 'T' ) - WITHB = M.GT.0 - WITHC = P.GT.0 - LQUERY = ( LZWORK.EQ.-1 ) -C -C Test the input parameters. -C - LN = MIN( L, N ) - INFO = 0 - WRKOPT = MAX( 1, N+P, LN + MAX( 3*N-1, M, L ) ) - IF( ICOMPQ.LE.0 ) THEN - INFO = -1 - ELSE IF( ICOMPZ.LE.0 ) THEN - INFO = -2 - ELSE IF( .NOT.LSAME( JOBA, 'N' ) .AND. .NOT.REDA .AND. - $ .NOT.REDTR ) THEN - INFO = -3 - ELSE IF( L.LT.0 ) THEN - INFO = -4 - ELSE IF( N.LT.0 ) THEN - INFO = -5 - ELSE IF( M.LT.0 ) THEN - INFO = -6 - ELSE IF( P.LT.0 ) THEN - INFO = -7 - ELSE IF( LDA.LT.MAX( 1, L ) ) THEN - INFO = -9 - ELSE IF( LDE.LT.MAX( 1, L ) ) THEN - INFO = -11 - ELSE IF( LDB.LT.1 .OR. ( WITHB .AND. LDB.LT.L ) ) THEN - INFO = -13 - ELSE IF( LDC.LT.MAX( 1, P ) ) THEN - INFO = -15 - ELSE IF( ( ILQ .AND. LDQ.LT.L ) .OR. LDQ.LT.1 ) THEN - INFO = -17 - ELSE IF( ( ILZ .AND. LDZ.LT.N ) .OR. LDZ.LT.1 ) THEN - INFO = -19 - ELSE IF( TOL.GE.DONE ) THEN - INFO = -22 - ELSE - IF( LQUERY ) THEN - NB = MIN( 64, ILAENV( 1, 'ZUNMQR', 'LC', L, N, LN, -1 ) ) - WRKOPT = MAX( WRKOPT, LN + N*NB ) - IF( WITHB ) THEN - NB = MIN( 64, ILAENV( 1, 'ZUNMQR', 'LC', L, M, LN, -1 ) ) - WRKOPT = MAX( WRKOPT, LN + M*NB ) - END IF - IF( ILQ ) THEN - NB = MIN( 64, ILAENV( 1, 'ZUNMQR', 'RN', L, L, LN, -1 ) ) - WRKOPT = MAX( WRKOPT, LN + L*NB ) - END IF - NB = ILAENV( 1, 'ZGERQF', ' ', L, N, -1, -1 ) - WRKOPT = MAX( WRKOPT, LN + N*NB ) - NB = MIN( 64, ILAENV( 1, 'ZUNMRQ', 'RC', L, N, N, -1 ) ) - WRKOPT = MAX( WRKOPT, N + MAX( 1, L )*NB ) - IF( WITHC ) THEN - NB = MIN( 64, ILAENV( 1, 'ZUNMRQ', 'RC', P, N, N, -1 ) ) - WRKOPT = MAX( WRKOPT, N + MAX( 1, P )*NB ) - END IF - IF( ILZ ) THEN - NB = MIN( 64, ILAENV( 1, 'ZUNMRQ', 'RC', N, N, N, -1 ) ) - WRKOPT = MAX( WRKOPT, N + MAX( 1, N )*NB ) - END IF - ELSE IF( LZWORK.LT.WRKOPT ) THEN - INFO = -26 - END IF - END IF - IF( INFO.NE.0 ) THEN - CALL XERBLA( 'TG01FZ', -INFO ) - RETURN - ELSE IF( LQUERY ) THEN - ZWORK(1) = WRKOPT - RETURN - END IF -C -C Initialize Q and Z if necessary. -C - IF( ICOMPQ.EQ.3 ) - $ CALL ZLASET( 'Full', L, L, ZERO, ONE, Q, LDQ ) - IF( ICOMPZ.EQ.3 ) - $ CALL ZLASET( 'Full', N, N, ZERO, ONE, Z, LDZ ) -C -C Quick return if possible. -C - IF( L.EQ.0 .OR. N.EQ.0 ) THEN - ZWORK(1) = ONE - RANKE = 0 - IF( REDA .OR. REDTR ) RNKA22 = 0 - RETURN - END IF -C - TOLDEF = TOL - IF( TOLDEF.LE.DZERO ) THEN -C -C Use the default tolerance for rank determination. -C - TOLDEF = DBLE( L*N )*DLAMCH( 'EPSILON' ) - END IF -C -C Set the estimate of maximum singular value of E to -C max(||E||,||A||) to detect negligible A or E matrices. -C - SVLMAX = MAX( ZLANGE( 'F', L, N, E, LDE, DWORK ), - $ ZLANGE( 'F', L, N, A, LDA, DWORK ) ) -C -C Compute the rank-revealing QR decomposition of E, -C -C ( E11 E12 ) -C E * P = Qr * ( ) , -C ( 0 E22 ) -C -C and determine the rank of E using incremental condition -C estimation. -C Complex Workspace: MIN(L,N) + 3*N - 1. -C Real Workspace: 2*N. -C - LWR = LZWORK - LN - KW = LN + 1 -C - CALL MB3OYZ( L, N, E, LDE, TOLDEF, SVLMAX, RANKE, SVAL, IWORK, - $ ZWORK, DWORK, ZWORK(KW), INFO ) -C -C Apply transformation on the rest of matrices. -C - IF( RANKE.GT.0 ) THEN -C -C A <-- Qr' * A. -C Complex Workspace: need MIN(L,N) + N; -C prefer MIN(L,N) + N*NB. -C - CALL ZUNMQR( 'Left', 'ConjTranspose', L, N, RANKE, E, LDE, - $ ZWORK, A, LDA, ZWORK(KW), LWR, INFO ) - WRKOPT = MAX( WRKOPT, LN + INT( ZWORK(KW) ) ) -C -C B <-- Qr' * B. -C Complex Workspace: need MIN(L,N) + M; -C prefer MIN(L,N) + M*NB. -C - IF( WITHB ) THEN - CALL ZUNMQR( 'Left', 'ConjTranspose', L, M, RANKE, E, LDE, - $ ZWORK, B, LDB, ZWORK(KW), LWR, INFO ) - WRKOPT = MAX( WRKOPT, LN + INT( ZWORK(KW) ) ) - END IF -C -C Q <-- Q * Qr. -C Complex Workspace: need MIN(L,N) + L; -C prefer MIN(L,N) + L*NB. -C - IF( ILQ ) THEN - CALL ZUNMQR( 'Right', 'No Transpose', L, L, RANKE, E, LDE, - $ ZWORK, Q, LDQ, ZWORK(KW), LWR, INFO ) - WRKOPT = MAX( WRKOPT, LN + INT( ZWORK(KW) ) ) - END IF -C -C Set lower triangle of E to zero. -C - IF( L.GE.2 ) - $ CALL ZLASET( 'Lower', L-1, RANKE, ZERO, ZERO, E(2,1), LDE ) -C -C Compute A*P, C*P and Z*P by forward permuting the columns of -C A, C and Z based on information in IWORK. -C - DO 10 J = 1, N - IWORK(J) = -IWORK(J) - 10 CONTINUE - DO 30 I = 1, N - IF( IWORK(I).LT.0 ) THEN - J = I - IWORK(J) = -IWORK(J) - 20 CONTINUE - K = IWORK(J) - IF( IWORK(K).LT.0 ) THEN - CALL ZSWAP( L, A(1,J), 1, A(1,K), 1 ) - IF( WITHC ) - $ CALL ZSWAP( P, C(1,J), 1, C(1,K), 1 ) - IF( ILZ ) - $ CALL ZSWAP( N, Z(1,J), 1, Z(1,K), 1 ) - IWORK(K) = -IWORK(K) - J = K - GO TO 20 - END IF - END IF - 30 CONTINUE -C -C Determine a unitary matrix Y such that -C -C ( E11 E12 ) = ( Er 0 ) * Y . -C -C Compute E <-- E*Y', A <-- A*Y', C <-- C*Y', Z <-- Z*Y'. -C - IF( RANKE.LT.N ) THEN -C -C Complex Workspace: need 2*N; -C prefer N + N*NB. -C - KW = RANKE + 1 - CALL ZTZRZF( RANKE, N, E, LDE, ZWORK, ZWORK(KW), - $ LZWORK-KW+1, INFO ) - WRKOPT = MAX( WRKOPT, INT( ZWORK(KW) ) + KW - 1 ) -C -C Complex Workspace: need N + MAX(L,P,N); -C prefer N + MAX(L,P,N)*NB. -C - LH = N - RANKE - CALL ZUNMRZ( 'Right', 'Conjugate transpose', L, N, RANKE, - $ LH, E, LDE, ZWORK, A, LDA, ZWORK(KW), - $ LZWORK-KW+1, INFO ) - WRKOPT = MAX( WRKOPT, INT( ZWORK(KW) ) + KW - 1 ) - IF( WITHC ) THEN - CALL ZUNMRZ( 'Right', 'Conjugate transpose', P, N, RANKE, - $ LH, E, LDE, ZWORK, C, LDC, ZWORK(KW), - $ LZWORK-KW+1, INFO ) - WRKOPT = MAX( WRKOPT, INT( ZWORK(KW) ) + KW - 1 ) - END IF - IF( ILZ ) THEN - CALL ZUNMRZ( 'Right', 'Conjugate transpose', N, N, RANKE, - $ LH, E, LDE, ZWORK, Z, LDZ, ZWORK(KW), - $ LZWORK-KW+1, INFO ) - WRKOPT = MAX( WRKOPT, INT( ZWORK(KW) ) + KW - 1 ) - END IF -C -C Set E12 and E22 to zero. -C - CALL ZLASET( 'Full', L, LH, ZERO, ZERO, E(1,KW), LDE ) - END IF - ELSE - CALL ZLASET( 'Full', L, N, ZERO, ZERO, E, LDE ) - END IF -C -C Reduce A22 if necessary. -C - IF( REDA .OR. REDTR ) THEN - LA22 = L - RANKE - NA22 = N - RANKE - IF( MIN( LA22, NA22 ).EQ.0 ) THEN - RNKA22 = 0 - ELSE -C -C Compute the rank-revealing QR decomposition of A22, -C -C ( R11 R12 ) -C A22 * P2 = Q2 * ( ) , -C ( 0 R22 ) -C -C and determine the rank of A22 using incremental -C condition estimation. -C Complex Workspace: MIN(L,N) + 3*N - 1. -C Real Workspace: 2*N. -C - IR1 = RANKE + 1 - CALL MB3OYZ( LA22, NA22, A(IR1,IR1), LDA, TOLDEF, - $ SVLMAX, RNKA22, SVAL, IWORK, ZWORK, - $ DWORK, ZWORK(KW), INFO ) -C -C Apply transformation on the rest of matrices. -C - IF( RNKA22.GT.0 ) THEN -C -C A <-- diag(I, Q2') * A -C Complex Workspace: need MIN(L,N) + N; -C prefer MIN(L,N) + N*NB. -C - CALL ZUNMQR( 'Left', 'ConjTranspose', LA22, RANKE, - $ RNKA22, A(IR1,IR1), LDA, ZWORK, A(IR1,1), - $ LDA, ZWORK(KW), LWR, INFO ) -C -C B <-- diag(I, Q2') * B -C Complex Workspace: need MIN(L,N) + M; -C prefer MIN(L,N) + M*NB. -C - IF ( WITHB ) - $ CALL ZUNMQR( 'Left', 'ConjTranspose', LA22, M, RNKA22, - $ A(IR1,IR1), LDA, ZWORK, B(IR1,1), LDB, - $ ZWORK(KW), LWR, INFO ) -C -C Q <-- Q * diag(I, Q2) -C Complex Workspace: need MIN(L,N) + L; -C prefer MIN(L,N) + L*NB. -C - IF( ILQ ) - $ CALL ZUNMQR( 'Right', 'No transpose', L, LA22, RNKA22, - $ A(IR1,IR1), LDA, ZWORK, Q(1,IR1), LDQ, - $ ZWORK(KW), LWR, INFO ) -C -C Set lower triangle of A22 to zero. -C - IF( LA22.GE.2 ) - $ CALL ZLASET( 'Lower', LA22-1, RNKA22, ZERO, ZERO, - $ A(IR1+1,IR1), LDA ) -C -C Compute A*diag(I,P2), C*diag(I,P2) and Z*diag(I,P2) -C by forward permuting the columns of A, C and Z based -C on information in IWORK. -C - DO 40 J = 1, NA22 - IWORK(J) = -IWORK(J) - 40 CONTINUE - DO 60 I = 1, NA22 - IF( IWORK(I).LT.0 ) THEN - J = I - IWORK(J) = -IWORK(J) - 50 CONTINUE - K = IWORK(J) - IF( IWORK(K).LT.0 ) THEN - CALL ZSWAP( RANKE, A(1,RANKE+J), 1, - $ A(1,RANKE+K), 1 ) - IF( WITHC ) - $ CALL ZSWAP( P, C(1,RANKE+J), 1, - $ C(1,RANKE+K), 1 ) - IF( ILZ ) - $ CALL ZSWAP( N, Z(1,RANKE+J), 1, - $ Z(1,RANKE+K), 1 ) - IWORK(K) = -IWORK(K) - J = K - GO TO 50 - END IF - END IF - 60 CONTINUE -C - IF( REDA .AND. RNKA22.LT.NA22 ) THEN -C -C Determine a unitary matrix Y2 such that -C -C ( R11 R12 ) = ( Ar 0 ) * Y2 . -C -C Compute A <-- A*diag(I, Y2'), C <-- C*diag(I, Y2'), -C Z <-- Z*diag(I, Y2'). -C -C Complex Workspace: need 2*N; -C prefer N + N*NB. -C - KW = RANKE + 1 - CALL ZTZRZF( RNKA22, NA22, A(IR1,IR1), LDA, ZWORK, - $ ZWORK(KW), LZWORK-KW+1, INFO ) - WRKOPT = MAX( WRKOPT, INT( ZWORK(KW) ) + KW - 1 ) -C -C Complex Workspace: need N + MAX(P,N); -C prefer N + MAX(P,N)*NB. -C - LH = NA22 - RNKA22 - IF( WITHC ) THEN - CALL ZUNMRZ( 'Right', 'Conjugate transpose', P, N, - $ RNKA22, LH, A(IR1,IR1), LDA, ZWORK, C, - $ LDC, ZWORK(KW), LZWORK-KW+1, INFO ) - WRKOPT = MAX( WRKOPT, INT( ZWORK(KW) ) + KW - 1 ) - END IF - IF( ILZ ) THEN - CALL ZUNMRZ( 'Right', 'Conjugate transpose', N, N, - $ RNKA22, LH, A(IR1,IR1), LDA, ZWORK, Z, - $ LDZ, ZWORK(KW), LZWORK-KW+1, INFO ) - WRKOPT = MAX( WRKOPT, INT( ZWORK(KW) ) + KW - 1 ) - END IF - IRE1 = RANKE + RNKA22 + 1 -C -C Set R12 and R22 to zero. -C - CALL ZLASET( 'Full', LA22, LH, ZERO, ZERO, - $ A(IR1,IRE1), LDA ) - END IF - ELSE - CALL ZLASET( 'Full', LA22, NA22, ZERO, ZERO, - $ A(IR1,IR1), LDA) - END IF - END IF - END IF -C - ZWORK(1) = WRKOPT -C - RETURN -C *** Last line of TG01FZ *** - END diff --git a/mex/sources/libslicot/TG01HD.f b/mex/sources/libslicot/TG01HD.f deleted file mode 100644 index 318f1f353..000000000 --- a/mex/sources/libslicot/TG01HD.f +++ /dev/null @@ -1,545 +0,0 @@ - SUBROUTINE TG01HD( JOBCON, COMPQ, COMPZ, N, M, P, A, LDA, E, LDE, - $ B, LDB, C, LDC, Q, LDQ, Z, LDZ, NCONT, NIUCON, - $ NRBLCK, RTAU, TOL, IWORK, DWORK, INFO ) -C -C SLICOT RELEASE 5.0. -C -C Copyright (c) 2002-2009 NICONET e.V. -C -C This program is free software: you can redistribute it and/or -C modify it under the terms of the GNU General Public License as -C published by the Free Software Foundation, either version 2 of -C the License, or (at your option) any later version. -C -C This program is distributed in the hope that it will be useful, -C but WITHOUT ANY WARRANTY; without even the implied warranty of -C MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the -C GNU General Public License for more details. -C -C You should have received a copy of the GNU General Public License -C along with this program. If not, see -C . -C -C PURPOSE -C -C To compute orthogonal transformation matrices Q and Z which -C reduce the N-th order descriptor system (A-lambda*E,B,C) -C to the form -C -C ( Ac * ) ( Ec * ) ( Bc ) -C Q'*A*Z = ( ) , Q'*E*Z = ( ) , Q'*B = ( ) , -C ( 0 Anc ) ( 0 Enc ) ( 0 ) -C -C C*Z = ( Cc Cnc ) , -C -C where the NCONT-th order descriptor system (Ac-lambda*Ec,Bc,Cc) -C is a finite and/or infinite controllable. The pencil -C Anc - lambda*Enc is regular of order N-NCONT and contains the -C uncontrollable finite and/or infinite eigenvalues of the pencil -C A-lambda*E. -C -C For JOBCON = 'C' or 'I', the pencil ( Bc Ec-lambda*Ac ) has full -C row rank NCONT for all finite lambda and is in a staircase form -C with -C _ _ _ _ -C ( E1,0 E1,1 ... E1,k-1 E1,k ) -C ( _ _ _ ) -C ( Bc Ec ) = ( 0 E2,1 ... E2,k-1 E2,k ) , (1) -C ( ... _ _ ) -C ( 0 0 ... Ek,k-1 Ek,k ) -C -C _ _ _ -C ( A1,1 ... A1,k-1 A1,k ) -C ( _ _ ) -C Ac = ( 0 ... A2,k-1 A2,k ) , (2) -C ( ... _ ) -C ( 0 ... 0 Ak,k ) -C _ -C where Ei,i-1 is an rtau(i)-by-rtau(i-1) full row rank matrix -C _ -C (with rtau(0) = M) and Ai,i is an rtau(i)-by-rtau(i) -C upper triangular matrix. -C -C For JOBCON = 'F', the pencil ( Bc Ac-lambda*Ec ) has full -C row rank NCONT for all finite lambda and is in a staircase form -C with -C _ _ _ _ -C ( A1,0 A1,1 ... A1,k-1 A1,k ) -C ( _ _ _ ) -C ( Bc Ac ) = ( 0 A2,1 ... A2,k-1 A2,k ) , (3) -C ( ... _ _ ) -C ( 0 0 ... Ak,k-1 Ak,k ) -C -C _ _ _ -C ( E1,1 ... E1,k-1 E1,k ) -C ( _ _ ) -C Ec = ( 0 ... E2,k-1 E2,k ) , (4) -C ( ... _ ) -C ( 0 ... 0 Ek,k ) -C _ -C where Ai,i-1 is an rtau(i)-by-rtau(i-1) full row rank matrix -C _ -C (with rtau(0) = M) and Ei,i is an rtau(i)-by-rtau(i) -C upper triangular matrix. -C -C For JOBCON = 'C', the (N-NCONT)-by-(N-NCONT) regular pencil -C Anc - lambda*Enc has the form -C -C ( Ainc - lambda*Einc * ) -C Anc - lambda*Enc = ( ) , -C ( 0 Afnc - lambda*Efnc ) -C -C where: -C 1) the NIUCON-by-NIUCON regular pencil Ainc - lambda*Einc, -C with Ainc upper triangular and nonsingular, contains the -C uncontrollable infinite eigenvalues of A - lambda*E; -C 2) the (N-NCONT-NIUCON)-by-(N-NCONT-NIUCON) regular pencil -C Afnc - lambda*Efnc, with Efnc upper triangular and -C nonsingular, contains the uncontrollable finite -C eigenvalues of A - lambda*E. -C -C Note: The significance of the two diagonal blocks can be -C interchanged by calling the routine with the -C arguments A and E interchanged. In this case, -C Ainc - lambda*Einc contains the uncontrollable zero -C eigenvalues of A - lambda*E, while Afnc - lambda*Efnc -C contains the uncontrollable nonzero finite and infinite -C eigenvalues of A - lambda*E. -C -C For JOBCON = 'F', the pencil Anc - lambda*Enc has the form -C -C Anc - lambda*Enc = Afnc - lambda*Efnc , -C -C where the regular pencil Afnc - lambda*Efnc, with Efnc -C upper triangular and nonsingular, contains the uncontrollable -C finite eigenvalues of A - lambda*E. -C -C For JOBCON = 'I', the pencil Anc - lambda*Enc has the form -C -C Anc - lambda*Enc = Ainc - lambda*Einc , -C -C where the regular pencil Ainc - lambda*Einc, with Ainc -C upper triangular and nonsingular, contains the uncontrollable -C nonzero finite and infinite eigenvalues of A - lambda*E. -C -C The left and/or right orthogonal transformations Q and Z -C performed to reduce the system matrices can be optionally -C accumulated. -C -C The reduced order descriptor system (Ac-lambda*Ec,Bc,Cc) has -C the same transfer-function matrix as the original system -C (A-lambda*E,B,C). -C -C ARGUMENTS -C -C Mode Parameters -C -C JOBCON CHARACTER*1 -C = 'C': separate both finite and infinite uncontrollable -C eigenvalues; -C = 'F': separate only finite uncontrollable eigenvalues: -C = 'I': separate only nonzero finite and infinite -C uncontrollable eigenvalues. -C -C COMPQ CHARACTER*1 -C = 'N': do not compute Q; -C = 'I': Q is initialized to the unit matrix, and the -C orthogonal matrix Q is returned; -C = 'U': Q must contain an orthogonal matrix Q1 on entry, -C and the product Q1*Q is returned. -C -C COMPZ CHARACTER*1 -C = 'N': do not compute Z; -C = 'I': Z is initialized to the unit matrix, and the -C orthogonal matrix Z is returned; -C = 'U': Z must contain an orthogonal matrix Z1 on entry, -C and the product Z1*Z is returned. -C -C Input/Output Parameters -C -C N (input) INTEGER -C The dimension of the descriptor state vector; also the -C order of square matrices A and E, the number of rows of -C matrix B, and the number of columns of matrix C. N >= 0. -C -C M (input) INTEGER -C The dimension of descriptor system input vector; also the -C number of columns of matrix B. M >= 0. -C -C P (input) INTEGER -C The dimension of descriptor system output vector; also the -C number of rows of matrix C. P >= 0. -C -C A (input/output) DOUBLE PRECISION array, dimension (LDA,N) -C On entry, the leading N-by-N part of this array must -C contain the N-by-N state matrix A. -C On exit, the leading N-by-N part of this array contains -C the transformed state matrix Q'*A*Z, -C -C ( Ac * ) -C Q'*A*Z = ( ) , -C ( 0 Anc ) -C -C where Ac is NCONT-by-NCONT and Anc is -C (N-NCONT)-by-(N-NCONT). -C If JOBCON = 'F', the matrix ( Bc Ac ) is in the -C controllability staircase form (3). -C If JOBCON = 'C' or 'I', the submatrix Ac is upper -C triangular. -C If JOBCON = 'C', the Anc matrix has the form -C -C ( Ainc * ) -C Anc = ( ) , -C ( 0 Afnc ) -C -C where the NIUCON-by-NIUCON matrix Ainc is nonsingular and -C upper triangular. -C If JOBCON = 'I', Anc is nonsingular and upper triangular. -C -C LDA INTEGER -C The leading dimension of array A. LDA >= MAX(1,N). -C -C E (input/output) DOUBLE PRECISION array, dimension (LDE,N) -C On entry, the leading N-by-N part of this array must -C contain the N-by-N descriptor matrix E. -C On exit, the leading N-by-N part of this array contains -C the transformed descriptor matrix Q'*E*Z, -C -C ( Ec * ) -C Q'*E*Z = ( ) , -C ( 0 Enc ) -C -C where Ec is NCONT-by-NCONT and Enc is -C (N-NCONT)-by-(N-NCONT). -C If JOBCON = 'C' or 'I', the matrix ( Bc Ec ) is in the -C controllability staircase form (1). -C If JOBCON = 'F', the submatrix Ec is upper triangular. -C If JOBCON = 'C', the Enc matrix has the form -C -C ( Einc * ) -C Enc = ( ) , -C ( 0 Efnc ) -C -C where the NIUCON-by-NIUCON matrix Einc is nilpotent -C and the (N-NCONT-NIUCON)-by-(N-NCONT-NIUCON) matrix Efnc -C is nonsingular and upper triangular. -C If JOBCON = 'F', Enc is nonsingular and upper triangular. -C -C LDE INTEGER -C The leading dimension of array E. LDE >= MAX(1,N). -C -C B (input/output) DOUBLE PRECISION array, dimension (LDB,M) -C On entry, the leading N-by-M part of this array must -C contain the N-by-M input matrix B. -C On exit, the leading N-by-M part of this array contains -C the transformed input matrix -C -C ( Bc ) -C Q'*B = ( ) , -C ( 0 ) -C -C where Bc is NCONT-by-M. -C For JOBCON = 'C' or 'I', the matrix ( Bc Ec ) is in the -C controllability staircase form (1). -C For JOBCON = 'F', the matrix ( Bc Ac ) is in the -C controllability staircase form (3). -C -C LDB INTEGER -C The leading dimension of array B. LDB >= MAX(1,N). -C -C C (input/output) DOUBLE PRECISION array, dimension (LDC,N) -C On entry, the leading P-by-N part of this array must -C contain the state/output matrix C. -C On exit, the leading P-by-N part of this array contains -C the transformed matrix C*Z. -C -C LDC INTEGER -C The leading dimension of array C. LDC >= MAX(1,P). -C -C Q (input/output) DOUBLE PRECISION array, dimension (LDQ,N) -C If COMPQ = 'N': Q is not referenced. -C If COMPQ = 'I': on entry, Q need not be set; -C on exit, the leading N-by-N part of this -C array contains the orthogonal matrix Q, -C where Q' is the product of transformations -C which are applied to A, E, and B on -C the left. -C If COMPQ = 'U': on entry, the leading N-by-N part of this -C array must contain an orthogonal matrix -C Qc; -C on exit, the leading N-by-N part of this -C array contains the orthogonal matrix -C Qc*Q. -C -C LDQ INTEGER -C The leading dimension of array Q. -C LDQ >= 1, if COMPQ = 'N'; -C LDQ >= MAX(1,N), if COMPQ = 'U' or 'I'. -C -C Z (input/output) DOUBLE PRECISION array, dimension (LDZ,N) -C If COMPZ = 'N': Z is not referenced. -C If COMPZ = 'I': on entry, Z need not be set; -C on exit, the leading N-by-N part of this -C array contains the orthogonal matrix Z, -C which is the product of transformations -C applied to A, E, and C on the right. -C If COMPZ = 'U': on entry, the leading N-by-N part of this -C array must contain an orthogonal matrix -C Zc; -C on exit, the leading N-by-N part of this -C array contains the orthogonal matrix -C Zc*Z. -C -C LDZ INTEGER -C The leading dimension of array Z. -C LDZ >= 1, if COMPZ = 'N'; -C LDZ >= MAX(1,N), if COMPZ = 'U' or 'I'. -C -C NCONT (output) INTEGER -C The order of the reduced matrices Ac and Ec, and the -C number of rows of reduced matrix Bc; also the order of -C the controllable part of the pair (A-lambda*E,B). -C -C NIUCON (output) INTEGER -C For JOBCON = 'C', the order of the reduced matrices -C Ainc and Einc; also the number of uncontrollable -C infinite eigenvalues of the pencil A - lambda*E. -C For JOBCON = 'F' or 'I', NIUCON has no significance -C and is set to zero. -C -C NRBLCK (output) INTEGER -C For JOBCON = 'C' or 'I', the number k, of full row rank -C _ -C blocks Ei,i in the staircase form of the pencil -C (Bc Ec-lambda*Ac) (see (1) and (2)). -C For JOBCON = 'F', the number k, of full row rank blocks -C _ -C Ai,i in the staircase form of the pencil (Bc Ac-lambda*Ec) -C (see (3) and (4)). -C -C RTAU (output) INTEGER array, dimension (N) -C RTAU(i), for i = 1, ..., NRBLCK, is the row dimension of -C _ _ -C the full row rank block Ei,i-1 or Ai,i-1 in the staircase -C form (1) or (3) for JOBCON = 'C' or 'I', or -C for JOBCON = 'F', respectively. -C -C Tolerances -C -C TOL DOUBLE PRECISION -C The tolerance to be used in rank determinations when -C transforming (A-lambda*E, B). If the user sets TOL > 0, -C then the given value of TOL is used as a lower bound for -C reciprocal condition numbers in rank determinations; a -C (sub)matrix whose estimated condition number is less than -C 1/TOL is considered to be of full rank. If the user sets -C TOL <= 0, then an implicitly computed, default tolerance, -C defined by TOLDEF = N*N*EPS, is used instead, where EPS -C is the machine precision (see LAPACK Library routine -C DLAMCH). TOL < 1. -C -C Workspace -C -C IWORK INTEGER array, dimension (M) -C -C DWORK DOUBLE PRECISION array, dimension MAX(N,2*M) -C -C Error Indicator -C -C INFO INTEGER -C = 0: successful exit; -C < 0: if INFO = -i, the i-th argument had an illegal -C value. -C -C METHOD -C -C The subroutine is based on the reduction algorithms of [1]. -C -C REFERENCES -C -C [1] A. Varga -C Computation of Irreducible Generalized State-Space -C Realizations. -C Kybernetika, vol. 26, pp. 89-106, 1990. -C -C NUMERICAL ASPECTS -C -C The algorithm is numerically backward stable and requires -C 0( N**3 ) floating point operations. -C -C FURTHER COMMENTS -C -C If the system matrices A, E and B are badly scaled, it is -C generally recommendable to scale them with the SLICOT routine -C TG01AD, before calling TG01HD. -C -C CONTRIBUTOR -C -C C. Oara, University "Politehnica" Bucharest. -C A. Varga, German Aerospace Center, DLR Oberpfaffenhofen. -C March 1999. Based on the RASP routine RPDSCF. -C -C REVISIONS -C -C July 1999, V. Sima, Research Institute for Informatics, Bucharest. -C -C KEYWORDS -C -C Controllability, minimal realization, orthogonal canonical form, -C orthogonal transformation. -C -C ****************************************************************** -C -C .. Parameters .. - DOUBLE PRECISION ONE - PARAMETER ( ONE = 1.0D0 ) -C .. Scalar Arguments .. - CHARACTER COMPQ, COMPZ, JOBCON - INTEGER INFO, LDA, LDB, LDC, LDE, LDQ, LDZ, - $ M, N, NCONT, NIUCON, NRBLCK, P - DOUBLE PRECISION TOL -C .. Array Arguments .. - INTEGER IWORK( * ), RTAU( * ) - DOUBLE PRECISION A( LDA, * ), B( LDB, * ), C( LDC, * ), - $ DWORK( * ), E( LDE, * ), Q( LDQ, * ), - $ Z( LDZ, * ) -C .. Local Scalars .. - CHARACTER JOBQ, JOBZ - LOGICAL FINCON, ILQ, ILZ, INFCON - INTEGER ICOMPQ, ICOMPZ, LBA, NR -C .. External Functions .. - LOGICAL LSAME - EXTERNAL LSAME -C .. External Subroutines .. - EXTERNAL TG01HX, XERBLA -C .. Intrinsic Functions .. - INTRINSIC MAX -C -C .. Executable Statements .. -C -C Decode JOBCON. -C - IF( LSAME( JOBCON, 'C' ) ) THEN - FINCON = .TRUE. - INFCON = .TRUE. - ELSE IF( LSAME( JOBCON, 'F' ) ) THEN - FINCON = .TRUE. - INFCON = .FALSE. - ELSE IF( LSAME( JOBCON, 'I' ) ) THEN - FINCON = .FALSE. - INFCON = .TRUE. - ELSE - FINCON = .FALSE. - INFCON = .FALSE. - END IF -C -C Decode COMPQ. -C - IF( LSAME( COMPQ, 'N' ) ) THEN - ILQ = .FALSE. - ICOMPQ = 1 - ELSE IF( LSAME( COMPQ, 'U' ) ) THEN - ILQ = .TRUE. - ICOMPQ = 2 - ELSE IF( LSAME( COMPQ, 'I' ) ) THEN - ILQ = .TRUE. - ICOMPQ = 3 - ELSE - ICOMPQ = 0 - END IF -C -C Decode COMPZ. -C - IF( LSAME( COMPZ, 'N' ) ) THEN - ILZ = .FALSE. - ICOMPZ = 1 - ELSE IF( LSAME( COMPZ, 'U' ) ) THEN - ILZ = .TRUE. - ICOMPZ = 2 - ELSE IF( LSAME( COMPZ, 'I' ) ) THEN - ILZ = .TRUE. - ICOMPZ = 3 - ELSE - ICOMPZ = 0 - END IF -C -C Test the input scalar parameters. -C - INFO = 0 - IF( .NOT.FINCON .AND. .NOT.INFCON ) THEN - INFO = -1 - ELSE IF( ICOMPQ.LE.0 ) THEN - INFO = -2 - ELSE IF( ICOMPZ.LE.0 ) THEN - INFO = -3 - ELSE IF( N.LT.0 ) THEN - INFO = -4 - ELSE IF( M.LT.0 ) THEN - INFO = -5 - ELSE IF( P.LT.0 ) THEN - INFO = -6 - ELSE IF( LDA.LT.MAX( 1, N ) ) THEN - INFO = -8 - ELSE IF( LDE.LT.MAX( 1, N ) ) THEN - INFO = -10 - ELSE IF( LDB.LT.MAX( 1, N ) ) THEN - INFO = -12 - ELSE IF( LDC.LT.MAX( 1, P ) ) THEN - INFO = -14 - ELSE IF( ( ILQ .AND. LDQ.LT.N ) .OR. LDQ.LT.1 ) THEN - INFO = -16 - ELSE IF( ( ILZ .AND. LDZ.LT.N ) .OR. LDZ.LT.1 ) THEN - INFO = -18 - ELSE IF( TOL.GE.ONE ) THEN - INFO = -23 - END IF - IF( INFO.NE.0 ) THEN - CALL XERBLA( 'TG01HD', -INFO ) - RETURN - END IF -C - JOBQ = COMPQ - JOBZ = COMPZ -C - IF( FINCON ) THEN -C -C Perform finite controllability form reduction. -C - CALL TG01HX( JOBQ, JOBZ, N, N, M, P, N, MAX( 0, N-1 ), A, LDA, - $ E, LDE, B, LDB, C, LDC, Q, LDQ, Z, LDZ, NR, - $ NRBLCK, RTAU, TOL, IWORK, DWORK, INFO ) - IF( NRBLCK.GT.1 ) THEN - LBA = RTAU(1) + RTAU(2) - 1 - ELSE IF( NRBLCK.EQ.1 ) THEN - LBA = RTAU(1) - 1 - ELSE - LBA = 0 - END IF - IF( ILQ ) JOBQ = 'U' - IF( ILZ ) JOBZ = 'U' - ELSE - NR = N - LBA = MAX( 0, N-1 ) - END IF -C - IF( INFCON ) THEN -C -C Perform infinite controllability form reduction. -C - CALL TG01HX( JOBQ, JOBZ, N, N, M, P, NR, LBA, E, LDE, - $ A, LDA, B, LDB, C, LDC, Q, LDQ, Z, LDZ, NCONT, - $ NRBLCK, RTAU, TOL, IWORK, DWORK, INFO ) - IF( FINCON ) THEN - NIUCON = NR - NCONT - ELSE - NIUCON = 0 - END IF - ELSE - NCONT = NR - NIUCON = 0 - END IF -C - RETURN -C -C *** Last line of TG01HD *** - END diff --git a/mex/sources/libslicot/TG01HX.f b/mex/sources/libslicot/TG01HX.f deleted file mode 100644 index c0717f81a..000000000 --- a/mex/sources/libslicot/TG01HX.f +++ /dev/null @@ -1,694 +0,0 @@ - SUBROUTINE TG01HX( COMPQ, COMPZ, L, N, M, P, N1, LBE, A, LDA, - $ E, LDE, B, LDB, C, LDC, Q, LDQ, Z, LDZ, NR, - $ NRBLCK, RTAU, TOL, IWORK, DWORK, INFO ) -C -C SLICOT RELEASE 5.0. -C -C Copyright (c) 2002-2009 NICONET e.V. -C -C This program is free software: you can redistribute it and/or -C modify it under the terms of the GNU General Public License as -C published by the Free Software Foundation, either version 2 of -C the License, or (at your option) any later version. -C -C This program is distributed in the hope that it will be useful, -C but WITHOUT ANY WARRANTY; without even the implied warranty of -C MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the -C GNU General Public License for more details. -C -C You should have received a copy of the GNU General Public License -C along with this program. If not, see -C . -C -C PURPOSE -C -C Given the descriptor system (A-lambda*E,B,C) with the system -C matrices A, E and B of the form -C -C ( A1 X1 ) ( E1 Y1 ) ( B1 ) -C A = ( ) , E = ( ) , B = ( ) , -C ( 0 X2 ) ( 0 Y2 ) ( 0 ) -C -C where -C - B is an L-by-M matrix, with B1 an N1-by-M submatrix -C - A is an L-by-N matrix, with A1 an N1-by-N1 submatrix -C - E is an L-by-N matrix, with E1 an N1-by-N1 submatrix -C with LBE nonzero sub-diagonals, -C this routine reduces the pair (A1-lambda*E1,B1) to the form -C -C Qc'*[A1-lambda*E1 B1]*diag(Zc,I) = -C -C ( Bc Ac-lambda*Ec * ) -C ( ) , -C ( 0 0 Anc-lambda*Enc ) -C -C where: -C 1) the pencil ( Bc Ac-lambda*Ec ) has full row rank NR for -C all finite lambda and is in a staircase form with -C _ _ _ _ -C ( A1,0 A1,1 ... A1,k-1 A1,k ) -C ( _ _ _ ) -C ( Bc Ac ) = ( 0 A2,1 ... A2,k-1 A2,k ) , (1) -C ( ... _ _ ) -C ( 0 0 ... Ak,k-1 Ak,k ) -C -C _ _ _ -C ( E1,1 ... E1,k-1 E1,k ) -C ( _ _ ) -C Ec = ( 0 ... E2,k-1 E2,k ) , (2) -C ( ... _ ) -C ( 0 ... 0 Ek,k ) -C _ -C where Ai,i-1 is an rtau(i)-by-rtau(i-1) full row rank -C _ -C matrix (with rtau(0) = M) and Ei,i is an rtau(i)-by-rtau(i) -C upper triangular matrix. -C -C 2) the pencil Anc-lambda*Enc is regular of order N1-NR with Enc -C upper triangular; this pencil contains the uncontrollable -C finite eigenvalues of the pencil (A1-lambda*E1). -C -C The transformations are applied to the whole matrices A, E, B -C and C. The left and/or right orthogonal transformations Qc and Zc -C performed to reduce the pencil S(lambda) can be optionally -C accumulated in the matrices Q and Z, respectivelly. -C -C The reduced order descriptor system (Ac-lambda*Ec,Bc,Cc) has no -C uncontrollable finite eigenvalues and has the same -C transfer-function matrix as the original system (A-lambda*E,B,C). -C -C ARGUMENTS -C -C Mode Parameters -C -C COMPQ CHARACTER*1 -C = 'N': do not compute Q; -C = 'I': Q is initialized to the unit matrix, and the -C orthogonal matrix Q is returned; -C = 'U': Q must contain an orthogonal matrix Q1 on entry, -C and the product Q1*Q is returned. -C -C COMPZ CHARACTER*1 -C = 'N': do not compute Z; -C = 'I': Z is initialized to the unit matrix, and the -C orthogonal matrix Z is returned; -C = 'U': Z must contain an orthogonal matrix Z1 on entry, -C and the product Z1*Z is returned. -C -C Input/Output Parameters -C -C L (input) INTEGER -C The number of descriptor state equations; also the number -C of rows of matrices A, E and B. L >= 0. -C -C N (input) INTEGER -C The dimension of the descriptor state vector; also the -C number of columns of matrices A, E and C. N >= 0. -C -C M (input) INTEGER -C The dimension of descriptor system input vector; also the -C number of columns of matrix B. M >= 0. -C -C P (input) INTEGER -C The dimension of descriptor system output; also the -C number of rows of matrix C. P >= 0. -C -C N1 (input) INTEGER -C The order of subsystem (A1-lambda*E1,B1,C1) to be reduced. -C MIN(L,N) >= N1 >= 0. -C -C LBE (input) INTEGER -C The number of nonzero sub-diagonals of submatrix E1. -C MAX(0,N1-1) >= LBE >= 0. -C -C A (input/output) DOUBLE PRECISION array, dimension (LDA,N) -C On entry, the leading L-by-N part of this array must -C contain the L-by-N state matrix A in the partitioned -C form -C ( A1 X1 ) -C A = ( ) , -C ( 0 X2 ) -C -C where A1 is N1-by-N1. -C On exit, the leading L-by-N part of this array contains -C the transformed state matrix, -C -C ( Ac * * ) -C Qc'*A*Zc = ( 0 Anc * ) , -C ( 0 0 * ) -C -C where Ac is NR-by-NR and Anc is (N1-NR)-by-(N1-NR). -C The matrix ( Bc Ac ) is in the controlability -C staircase form (1). -C -C LDA INTEGER -C The leading dimension of array A. LDA >= MAX(1,L). -C -C E (input/output) DOUBLE PRECISION array, dimension (LDE,N) -C On entry, the leading L-by-N part of this array must -C contain the L-by-N descriptor matrix E in the partitioned -C form -C ( E1 Y1 ) -C E = ( ) , -C ( 0 Y2 ) -C -C where E1 is N1-by-N1 matrix with LBE nonzero -C sub-diagonals. -C On exit, the leading L-by-N part of this array contains -C the transformed descriptor matrix -C -C ( Ec * * ) -C Qc'*E*Zc = ( 0 Enc * ) , -C ( 0 0 * ) -C -C where Ec is NR-by-NR and Enc is (N1-NR)-by-(N1-NR). -C Both Ec and Enc are upper triangular and Enc is -C nonsingular. -C -C LDE INTEGER -C The leading dimension of array E. LDE >= MAX(1,L). -C -C B (input/output) DOUBLE PRECISION array, dimension (LDB,M) -C On entry, the leading L-by-M part of this array must -C contain the L-by-M input matrix B in the partitioned -C form -C ( B1 ) -C B = ( ) , -C ( 0 ) -C -C where B1 is N1-by-M. -C On exit, the leading L-by-M part of this array contains -C the transformed input matrix -C -C ( Bc ) -C Qc'*B = ( ) , -C ( 0 ) -C -C where Bc is NR-by-M. -C The matrix ( Bc Ac ) is in the controlability -C staircase form (1). -C -C LDB INTEGER -C The leading dimension of array B. LDB >= MAX(1,L). -C -C C (input/output) DOUBLE PRECISION array, dimension (LDC,N) -C On entry, the leading P-by-N part of this array must -C contain the state/output matrix C. -C On exit, the leading P-by-N part of this array contains -C the transformed matrix C*Zc. -C -C LDC INTEGER -C The leading dimension of array C. LDC >= MAX(1,P). -C -C Q (input/output) DOUBLE PRECISION array, dimension (LDQ,L) -C If COMPQ = 'N': Q is not referenced. -C If COMPQ = 'I': on entry, Q need not be set; -C on exit, the leading L-by-L part of this -C array contains the orthogonal matrix Q, -C where Q' is the product of transformations -C which are applied to A, E, and B on -C the left. -C If COMPQ = 'U': on entry, the leading L-by-L part of this -C array must contain an orthogonal matrix -C Qc; -C on exit, the leading L-by-L part of this -C array contains the orthogonal matrix -C Qc*Q. -C -C LDQ INTEGER -C The leading dimension of array Q. -C LDQ >= 1, if COMPQ = 'N'; -C LDQ >= MAX(1,L), if COMPQ = 'U' or 'I'. -C -C Z (input/output) DOUBLE PRECISION array, dimension (LDZ,N) -C If COMPZ = 'N': Z is not referenced. -C If COMPZ = 'I': on entry, Z need not be set; -C on exit, the leading N-by-N part of this -C array contains the orthogonal matrix Z, -C which is the product of transformations -C applied to A, E, and C on the right. -C If COMPZ = 'U': on entry, the leading N-by-N part of this -C array must contain an orthogonal matrix -C Zc; -C on exit, the leading N-by-N part of this -C array contains the orthogonal matrix -C Zc*Z. -C -C LDZ INTEGER -C The leading dimension of array Z. -C LDZ >= 1, if COMPZ = 'N'; -C LDZ >= MAX(1,N), if COMPZ = 'U' or 'I'. -C -C NR (output) INTEGER -C The order of the reduced matrices Ac and Ec, and the -C number of rows of the reduced matrix Bc; also the order of -C the controllable part of the pair (B, A-lambda*E). -C -C NRBLCK (output) INTEGER _ -C The number k, of full row rank blocks Ai,i in the -C staircase form of the pencil (Bc Ac-lambda*Ec) (see (1) -C and (2)). -C -C RTAU (output) INTEGER array, dimension (N1) -C RTAU(i), for i = 1, ..., NRBLCK, is the row dimension of -C _ -C the full row rank block Ai,i-1 in the staircase form (1). -C -C Tolerances -C -C TOL DOUBLE PRECISION -C The tolerance to be used in rank determinations when -C transforming (A-lambda*E, B). If the user sets TOL > 0, -C then the given value of TOL is used as a lower bound for -C reciprocal condition numbers in rank determinations; a -C (sub)matrix whose estimated condition number is less than -C 1/TOL is considered to be of full rank. If the user sets -C TOL <= 0, then an implicitly computed, default tolerance, -C defined by TOLDEF = L*N*EPS, is used instead, where -C EPS is the machine precision (see LAPACK Library routine -C DLAMCH). TOL < 1. -C -C Workspace -C -C IWORK INTEGER array, dimension (M) -C -C DWORK DOUBLE PRECISION array, dimension MAX(N,L,2*M) -C -C Error Indicator -C -C INFO INTEGER -C = 0: successful exit; -C < 0: if INFO = -i, the i-th argument had an illegal -C value. -C -C METHOD -C -C The subroutine is based on the reduction algorithm of [1]. -C -C REFERENCES -C -C [1] A. Varga -C Computation of Irreducible Generalized State-Space -C Realizations. -C Kybernetika, vol. 26, pp. 89-106, 1990. -C -C NUMERICAL ASPECTS -C -C The algorithm is numerically backward stable and requires -C 0( N*N1**2 ) floating point operations. -C -C CONTRIBUTOR -C -C A. Varga, German Aerospace Center, DLR Oberpfaffenhofen. -C March 1999. Based on the RASP routine RPDS05. -C -C REVISIONS -C -C V. Sima, Research Institute for Informatics, Bucharest, July 1999, -C May 2003, Nov. 2003. -C A. Varga, German Aerospace Center, Oberpfaffenhofen, Nov. 2003. -C -C KEYWORDS -C -C Controllability, minimal realization, orthogonal canonical form, -C orthogonal transformation. -C -C ****************************************************************** -C -C .. Parameters .. - INTEGER IMAX, IMIN - PARAMETER ( IMAX = 1, IMIN = 2 ) - DOUBLE PRECISION ONE, P05, ZERO - PARAMETER ( ONE = 1.0D0, P05 = 0.05D0, ZERO = 0.0D0 ) -C .. Scalar Arguments .. - CHARACTER COMPQ, COMPZ - INTEGER INFO, L, LBE, LDA, LDB, LDC, LDE, LDQ, LDZ, M, - $ N, N1, NR, NRBLCK, P - DOUBLE PRECISION TOL -C .. Array Arguments .. - INTEGER IWORK( * ), RTAU( * ) - DOUBLE PRECISION A( LDA, * ), B( LDB, * ), C( LDC, * ), - $ DWORK( * ), E( LDE, * ), Q( LDQ, * ), - $ Z( LDZ, * ) -C .. Local Scalars .. - LOGICAL ILQ, ILZ, WITHC - INTEGER I, IC, ICOL, ICOMPQ, ICOMPZ, IROW, ISMAX, - $ ISMIN, J, K, MN, NF, NR1, RANK, TAUIM1 - DOUBLE PRECISION CO, C1, C2, RCOND, SMAX, SMAXPR, SMIN, SMINPR, - $ SVLMAX, S1, S2, SI, T, TT -C .. External Functions .. - LOGICAL LSAME - INTEGER IDAMAX - DOUBLE PRECISION DLAMCH, DLANGE, DLAPY2, DNRM2 - EXTERNAL DLAMCH, DLANGE, DLAPY2, DNRM2, IDAMAX, LSAME -C .. External Subroutines .. - EXTERNAL DLACPY, DLARF, DLARFG, DLARTG, DLASET, DROT, - $ DSWAP, XERBLA -C .. Intrinsic Functions .. - INTRINSIC ABS, DBLE, MAX, MIN, SQRT -C -C .. Executable Statements .. -C -C Decode COMPQ. -C - IF( LSAME( COMPQ, 'N' ) ) THEN - ILQ = .FALSE. - ICOMPQ = 1 - ELSE IF( LSAME( COMPQ, 'U' ) ) THEN - ILQ = .TRUE. - ICOMPQ = 2 - ELSE IF( LSAME( COMPQ, 'I' ) ) THEN - ILQ = .TRUE. - ICOMPQ = 3 - ELSE - ICOMPQ = 0 - END IF -C -C Decode COMPZ. -C - IF( LSAME( COMPZ, 'N' ) ) THEN - ILZ = .FALSE. - ICOMPZ = 1 - ELSE IF( LSAME( COMPZ, 'U' ) ) THEN - ILZ = .TRUE. - ICOMPZ = 2 - ELSE IF( LSAME( COMPZ, 'I' ) ) THEN - ILZ = .TRUE. - ICOMPZ = 3 - ELSE - ICOMPZ = 0 - END IF -C -C Test the input scalar parameters. -C - INFO = 0 - IF( ICOMPQ.LE.0 ) THEN - INFO = -1 - ELSE IF( ICOMPZ.LE.0 ) THEN - INFO = -2 - ELSE IF( L.LT.0 ) THEN - INFO = -3 - ELSE IF( N.LT.0 ) THEN - INFO = -4 - ELSE IF( M.LT.0 ) THEN - INFO = -5 - ELSE IF( P.LT.0 ) THEN - INFO = -6 - ELSE IF( N1.LT.0 .OR. N1.GT.MIN( L, N ) ) THEN - INFO = -7 - ELSE IF( LBE.LT.0 .OR. LBE.GT.MAX( 0, N1-1 ) ) THEN - INFO = -8 - ELSE IF( LDA.LT.MAX( 1, L ) ) THEN - INFO = -10 - ELSE IF( LDE.LT.MAX( 1, L ) ) THEN - INFO = -12 - ELSE IF( LDB.LT.MAX( 1, L ) ) THEN - INFO = -14 - ELSE IF( LDC.LT.MAX( 1, P ) ) THEN - INFO = -16 - ELSE IF( ( ILQ .AND. LDQ.LT.L ) .OR. LDQ.LT.1 ) THEN - INFO = -18 - ELSE IF( ( ILZ .AND. LDZ.LT.N ) .OR. LDZ.LT.1 ) THEN - INFO = -20 - ELSE IF( TOL.GE.ONE ) THEN - INFO = -24 - END IF - IF( INFO.NE.0 ) THEN - CALL XERBLA( 'TG01HX', -INFO ) - RETURN - END IF -C -C Initialize Q and Z if necessary. -C - IF( ICOMPQ.EQ.3 ) - $ CALL DLASET( 'Full', L, L, ZERO, ONE, Q, LDQ ) - IF( ICOMPZ.EQ.3 ) - $ CALL DLASET( 'Full', N, N, ZERO, ONE, Z, LDZ ) -C -C Initialize output variables. -C - NR = 0 - NRBLCK = 0 -C -C Quick return if possible. -C - IF( M.EQ.0 .OR. N1.EQ.0 ) THEN - RETURN - END IF -C - WITHC = P.GT.0 - SVLMAX = DLAPY2( DLANGE( 'F', L, M, B, LDB, DWORK ), - $ DLANGE( 'F', L, N, A, LDA, DWORK ) ) - RCOND = TOL - IF ( RCOND.LE.ZERO ) THEN -C -C Use the default tolerance in controllability determination. -C - RCOND = DBLE( L*N )*DLAMCH( 'EPSILON' ) - END IF -C - IF ( SVLMAX.LT.RCOND ) - $ SVLMAX = ONE -C -C Reduce E to upper triangular form if necessary. -C - IF( LBE.GT.0 ) THEN - DO 10 I = 1, N1-1 -C -C Generate elementary reflector H(i) to annihilate -C E(i+1:i+lbe,i). -C - K = MIN( LBE, N1-I ) + 1 - CALL DLARFG( K, E(I,I), E(I+1,I), 1, TT ) - T = E(I,I) - E(I,I) = ONE -C -C Apply H(i) to E(i:n1,i+1:n) from the left. -C - CALL DLARF( 'Left', K, N-I, E(I,I), 1, TT, - $ E(I,I+1), LDE, DWORK ) -C -C Apply H(i) to A(i:n1,1:n) from the left. -C - CALL DLARF( 'Left', K, N, E(I,I), 1, TT, - $ A(I,1), LDA, DWORK ) -C -C Apply H(i) to B(i:n1,1:m) from the left. -C - CALL DLARF( 'Left', K, M, E(I,I), 1, TT, - $ B(I,1), LDB, DWORK ) - IF( ILQ ) THEN -C -C Apply H(i) to Q(1:l,i:n1) from the right. -C - CALL DLARF( 'Right', L, K, E(I,I), 1, TT, - $ Q(1,I), LDQ, DWORK ) - END IF - E(I,I) = T - 10 CONTINUE - IF( N1.GT.1 ) - $ CALL DLASET( 'Lower', N1-1, N1-1, ZERO, ZERO, E(2,1), LDE ) - END IF -C - ISMIN = 1 - ISMAX = ISMIN + M - IC = -M - TAUIM1 = M - NF = N1 -C - 20 CONTINUE - NRBLCK = NRBLCK + 1 - RANK = 0 - IF( NF.GT.0 ) THEN -C -C IROW will point to the current pivot line in B, -C ICOL+1 will point to the first active columns of A. -C - ICOL = IC + TAUIM1 - IROW = NR - NR1 = NR + 1 - IF( NR.GT.0 ) - $ CALL DLACPY( 'Full', NF, TAUIM1, A(NR1,IC+1), LDA, - $ B(NR1,1), LDB ) -C -C Perform QR-decomposition with column pivoting on the current B -C while keeping E upper triangular. -C The current B is at first iteration B and for subsequent -C iterations the NF-by-TAUIM1 matrix delimited by rows -C NR + 1 to N1 and columns IC + 1 to IC + TAUIM1 of A. -C The rank of current B is computed in RANK. -C - IF( TAUIM1.GT.1 ) THEN -C -C Compute column norms. -C - DO 30 J = 1, TAUIM1 - DWORK(J) = DNRM2( NF, B(NR1,J), 1 ) - DWORK(M+J) = DWORK(J) - IWORK(J) = J - 30 CONTINUE - END IF -C - MN = MIN( NF, TAUIM1 ) -C - 40 CONTINUE - IF( RANK.LT.MN ) THEN - J = RANK + 1 - IROW = IROW + 1 -C -C Pivot if necessary. -C - IF( J.NE.TAUIM1 ) THEN - K = ( J - 1 ) + IDAMAX( TAUIM1-J+1, DWORK(J), 1 ) - IF( K.NE.J ) THEN - CALL DSWAP( NF, B(NR1,J), 1, B(NR1,K), 1 ) - I = IWORK(K) - IWORK(K) = IWORK(J) - IWORK(J) = I - DWORK(K) = DWORK(J) - DWORK(M+K) = DWORK(M+J) - END IF - END IF -C -C Zero elements below the current diagonal element of B. -C - DO 50 I = N1-1, IROW, -1 -C -C Rotate rows I and I+1 to zero B(I+1,J). -C - T = B(I,J) - CALL DLARTG( T, B(I+1,J), CO, SI, B(I,J) ) - B(I+1,J) = ZERO - CALL DROT( N-I+1, E(I,I), LDE, E(I+1,I), LDE, CO, SI ) - IF( J.LT.TAUIM1 ) - $ CALL DROT( TAUIM1-J, B(I,J+1), LDB, - $ B(I+1,J+1), LDB, CO, SI ) - CALL DROT( N-ICOL, A(I,ICOL+1), LDA, - $ A(I+1,ICOL+1), LDA, CO, SI ) - IF( ILQ ) CALL DROT( L, Q(1,I), 1, Q(1,I+1), 1, CO, SI ) -C -C Rotate columns I, I+1 to zero E(I+1,I). -C - T = E(I+1,I+1) - CALL DLARTG( T, E(I+1,I), CO, SI, E(I+1,I+1) ) - E(I+1,I) = ZERO - CALL DROT( I, E(1,I+1), 1, E(1,I), 1, CO, SI ) - CALL DROT( N1, A(1,I+1), 1, A(1,I), 1, CO, SI ) - IF( ILZ ) CALL DROT( N, Z(1,I+1), 1, Z(1,I), 1, CO, SI ) - IF( WITHC ) - $ CALL DROT( P, C(1,I+1), 1, C(1,I), 1, CO, SI ) - 50 CONTINUE -C - IF( RANK.EQ.0 ) THEN -C -C Initialize; exit if matrix is zero (RANK = 0). -C - SMAX = ABS( B(NR1,1) ) - IF ( SMAX.EQ.ZERO ) GO TO 80 - SMIN = SMAX - SMAXPR = SMAX - SMINPR = SMIN - C1 = ONE - C2 = ONE - ELSE -C -C One step of incremental condition estimation. -C - CALL DLAIC1( IMIN, RANK, DWORK(ISMIN), SMIN, - $ B(NR1,J), B(IROW,J), SMINPR, S1, C1 ) - CALL DLAIC1( IMAX, RANK, DWORK(ISMAX), SMAX, - $ B(NR1,J), B(IROW,J), SMAXPR, S2, C2 ) - END IF -C -C Check the rank; finish the loop if rank loss occurs. -C - IF( SVLMAX*RCOND.LE.SMAXPR ) THEN - IF( SVLMAX*RCOND.LE.SMINPR ) THEN - IF( SMAXPR*RCOND.LE.SMINPR ) THEN -C -C Finish the loop if last row. -C - IF( IROW.EQ.N1 ) THEN - RANK = RANK + 1 - GO TO 80 - END IF -C -C Update partial column norms. -C - DO 60 I = J + 1, TAUIM1 - IF( DWORK(I).NE.ZERO ) THEN - T = ONE - ( ABS( B(IROW,I) )/DWORK(I) )**2 - T = MAX( T, ZERO ) - TT = ONE + P05*T*( DWORK(I)/DWORK(M+I) )**2 - IF( TT.NE.ONE ) THEN - DWORK(I) = DWORK(I)*SQRT( T ) - ELSE - DWORK(I) = DNRM2( NF-J, B(IROW+1,I), 1 ) - DWORK(M+I) = DWORK(I) - END IF - END IF - 60 CONTINUE -C - DO 70 I = 1, RANK - DWORK(ISMIN+I-1) = S1*DWORK(ISMIN+I-1) - DWORK(ISMAX+I-1) = S2*DWORK(ISMAX+I-1) - 70 CONTINUE -C - DWORK(ISMIN+RANK) = C1 - DWORK(ISMAX+RANK) = C2 - SMIN = SMINPR - SMAX = SMAXPR - RANK = RANK + 1 - GO TO 40 - END IF - END IF - END IF - IF( NR.GT.0 ) THEN - CALL DLASET( 'Full', N1-IROW+1, TAUIM1-J+1, ZERO, ZERO, - $ B(IROW,J), LDB ) - END IF - GO TO 80 - END IF - END IF -C - 80 IF( RANK.GT.0 ) THEN - RTAU(NRBLCK) = RANK -C -C Back permute interchanged columns. -C - IF( TAUIM1.GT.1 ) THEN - DO 100 J = 1, TAUIM1 - IF( IWORK(J).GT.0 ) THEN - K = IWORK(J) - IWORK(J) = -K - 90 CONTINUE - IF( K.NE.J ) THEN - CALL DSWAP( RANK, B(NR1,J), 1, B(NR1,K), 1 ) - IWORK(K) = -IWORK(K) - K = -IWORK(K) - GO TO 90 - END IF - END IF - 100 CONTINUE - END IF - END IF - IF( NR.GT.0 ) - $ CALL DLACPY( 'Full', NF, TAUIM1, B(NR1,1), LDB, - $ A(NR1,IC+1), LDA ) - IF( RANK.GT.0 ) THEN - NR = NR + RANK - NF = NF - RANK - IC = IC + TAUIM1 - TAUIM1 = RANK - GO TO 20 - ELSE - NRBLCK = NRBLCK - 1 - END IF -C - IF( NRBLCK.GT.0 ) RANK = RTAU(1) - IF( RANK.LT.N1 ) - $ CALL DLASET( 'Full', N1-RANK, M, ZERO, ZERO, B(RANK+1,1), LDB ) -C - RETURN -C *** Last line of TG01HX *** - END diff --git a/mex/sources/libslicot/TG01ID.f b/mex/sources/libslicot/TG01ID.f deleted file mode 100644 index dfd3888a3..000000000 --- a/mex/sources/libslicot/TG01ID.f +++ /dev/null @@ -1,587 +0,0 @@ - SUBROUTINE TG01ID( JOBOBS, COMPQ, COMPZ, N, M, P, A, LDA, E, LDE, - $ B, LDB, C, LDC, Q, LDQ, Z, LDZ, NOBSV, NIUOBS, - $ NLBLCK, CTAU, TOL, IWORK, DWORK, INFO ) -C -C SLICOT RELEASE 5.0. -C -C Copyright (c) 2002-2009 NICONET e.V. -C -C This program is free software: you can redistribute it and/or -C modify it under the terms of the GNU General Public License as -C published by the Free Software Foundation, either version 2 of -C the License, or (at your option) any later version. -C -C This program is distributed in the hope that it will be useful, -C but WITHOUT ANY WARRANTY; without even the implied warranty of -C MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the -C GNU General Public License for more details. -C -C You should have received a copy of the GNU General Public License -C along with this program. If not, see -C . -C -C PURPOSE -C -C To compute orthogonal transformation matrices Q and Z which -C reduce the N-th order descriptor system (A-lambda*E,B,C) -C to the form -C -C ( Ano * ) ( Eno * ) ( Bno ) -C Q'*A*Z = ( ) , Q'*E*Z = ( ) , Q'*B = ( ) , -C ( 0 Ao ) ( 0 Eo ) ( Bo ) -C -C C*Z = ( 0 Co ) , -C -C where the NOBSV-th order descriptor system (Ao-lambda*Eo,Bo,Co) -C is a finite and/or infinite observable. The pencil -C Ano - lambda*Eno is regular of order N-NOBSV and contains the -C unobservable finite and/or infinite eigenvalues of the pencil -C A-lambda*E. -C -C For JOBOBS = 'O' or 'I', the pencil ( Eo-lambda*Ao ) has full -C ( Co ) -C column rank NOBSV for all finite lambda and is in a staircase form -C with -C _ _ _ _ -C ( Ek,k Ek,k-1 ... Ek,2 Ek,1 ) -C ( _ _ _ _ ) -C ( Eo ) = ( Ek-1,k Ek-1,k-1 ... Ek-1,2 Ek-1,1 ) , (1) -C ( Co ) ( ... ... _ _ ) -C ( 0 0 ... E1,2 E1,1 ) -C ( _ ) -C ( 0 0 ... 0 E0,1 ) -C _ _ _ -C ( Ak,k ... Ak,2 Ak,1 ) -C ( ... _ _ ) -C Ao = ( 0 ... A2,2 A2,1 ) , (2) -C ( _ ) -C ( 0 ... 0 A1,1 ) -C _ -C where Ei-1,i is a CTAU(i-1)-by-CTAU(i) full column rank matrix -C _ -C (with CTAU(0) = P) and Ai,i is a CTAU(i)-by-CTAU(i) -C upper triangular matrix. -C -C For JOBOBS = 'F', the pencil ( Ao-lambda*Eo ) has full -C ( Co ) -C column rank NOBSV for all finite lambda and is in a staircase form -C with -C _ _ _ _ -C ( Ak,k Ak,k-1 ... Ak,2 Ak,1 ) -C ( _ _ _ _ ) -C ( Ao ) = ( Ak-1,k Ak-1,k-1 ... Ak-1,2 Ak-1,1 ) , (3) -C ( Co ) ( ... ... _ _ ) -C ( 0 0 ... A1,2 A1,1 ) -C ( _ ) -C ( 0 0 ... 0 A0,1 ) -C _ _ _ -C ( Ek,k ... Ek,2 Ek,1 ) -C ( ... _ _ ) -C Eo = ( 0 ... E2,2 E2,1 ) , (4) -C ( _ ) -C ( 0 ... 0 E1,1 ) -C _ -C where Ai-1,i is a CTAU(i-1)-by-CTAU(i) full column rank matrix -C _ -C (with CTAU(0) = P) and Ei,i is a CTAU(i)-by-CTAU(i) -C upper triangular matrix. -C -C For JOBOBS = 'O', the (N-NOBSV)-by-(N-NOBSV) regular pencil -C Ano - lambda*Eno has the form -C -C ( Afno - lambda*Efno * ) -C Ano - lambda*Eno = ( ) , -C ( 0 Aino - lambda*Eino ) -C -C where: -C 1) the NIUOBS-by-NIUOBS regular pencil Aino - lambda*Eino, -C with Aino upper triangular and nonsingular, contains the -C unobservable infinite eigenvalues of A - lambda*E; -C 2) the (N-NOBSV-NIUOBS)-by-(N-NOBSV-NIUOBS) regular pencil -C Afno - lambda*Efno, with Efno upper triangular and -C nonsingular, contains the unobservable finite -C eigenvalues of A - lambda*E. -C -C Note: The significance of the two diagonal blocks can be -C interchanged by calling the routine with the -C arguments A and E interchanged. In this case, -C Aino - lambda*Eino contains the unobservable zero -C eigenvalues of A - lambda*E, while Afno - lambda*Efno -C contains the unobservable nonzero finite and infinite -C eigenvalues of A - lambda*E. -C -C For JOBOBS = 'F', the pencil Ano - lambda*Eno has the form -C -C Ano - lambda*Eno = Afno - lambda*Efno , -C -C where the regular pencil Afno - lambda*Efno, with Efno -C upper triangular and nonsingular, contains the unobservable -C finite eigenvalues of A - lambda*E. -C -C For JOBOBS = 'I', the pencil Ano - lambda*Eno has the form -C -C Ano - lambda*Eno = Aino - lambda*Eino , -C -C where the regular pencil Aino - lambda*Eino, with Aino -C upper triangular and nonsingular, contains the unobservable -C nonzero finite and infinite eigenvalues of A - lambda*E. -C -C The left and/or right orthogonal transformations Q and Z -C performed to reduce the system matrices can be optionally -C accumulated. -C -C The reduced order descriptor system (Ao-lambda*Eo,Bo,Co) has -C the same transfer-function matrix as the original system -C (A-lambda*E,B,C). -C -C ARGUMENTS -C -C Mode Parameters -C -C JOBOBS CHARACTER*1 -C = 'O': separate both finite and infinite unobservable -C eigenvalues; -C = 'F': separate only finite unobservable eigenvalues; -C = 'I': separate only nonzero finite and infinite -C unobservable eigenvalues. -C -C COMPQ CHARACTER*1 -C = 'N': do not compute Q; -C = 'I': Q is initialized to the unit matrix, and the -C orthogonal matrix Q is returned; -C = 'U': Q must contain an orthogonal matrix Q1 on entry, -C and the product Q1*Q is returned. -C -C COMPZ CHARACTER*1 -C = 'N': do not compute Z; -C = 'I': Z is initialized to the unit matrix, and the -C orthogonal matrix Z is returned; -C = 'U': Z must contain an orthogonal matrix Z1 on entry, -C and the product Z1*Z is returned. -C -C Input/Output Parameters -C -C N (input) INTEGER -C The dimension of the descriptor state vector; also the -C order of square matrices A and E, the number of rows of -C matrix B, and the number of columns of matrix C. N >= 0. -C -C M (input) INTEGER -C The dimension of descriptor system input vector; also the -C number of columns of matrix B. M >= 0. -C -C P (input) INTEGER -C The dimension of descriptor system output vector; also the -C number of rows of matrix C. P >= 0. -C -C A (input/output) DOUBLE PRECISION array, dimension (LDA,N) -C On entry, the leading N-by-N part of this array must -C contain the N-by-N state matrix A. -C On exit, the leading N-by-N part of this array contains -C the transformed state matrix Q'*A*Z, -C -C ( Ano * ) -C Q'*A*Z = ( ) , -C ( 0 Ao ) -C -C where Ao is NOBSV-by-NOBSV and Ano is -C (N-NOBSV)-by-(N-NOBSV). -C If JOBOBS = 'F', the matrix ( Ao ) is in the observability -C ( Co ) -C staircase form (3). -C If JOBOBS = 'O' or 'I', the submatrix Ao is upper -C triangular. -C If JOBOBS = 'O', the submatrix Ano has the form -C -C ( Afno * ) -C Ano = ( ) , -C ( 0 Aino ) -C -C where the NIUOBS-by-NIUOBS matrix Aino is nonsingular and -C upper triangular. -C If JOBOBS = 'I', Ano is nonsingular and upper triangular. -C -C LDA INTEGER -C The leading dimension of array A. LDA >= MAX(1,N). -C -C E (input/output) DOUBLE PRECISION array, dimension (LDE,N) -C On entry, the leading N-by-N part of this array must -C contain the N-by-N descriptor matrix E. -C On exit, the leading N-by-N part of this array contains -C the transformed state matrix Q'*E*Z, -C -C ( Eno * ) -C Q'*E*Z = ( ) , -C ( 0 Eo ) -C -C where Eo is NOBSV-by-NOBSV and Eno is -C (N-NOBSV)-by-(N-NOBSV). -C If JOBOBS = 'O' or 'I', the matrix ( Eo ) is in the -C ( Co ) -C observability staircase form (1). -C If JOBOBS = 'F', the submatrix Eo is upper triangular. -C If JOBOBS = 'O', the Eno matrix has the form -C -C ( Efno * ) -C Eno = ( ) , -C ( 0 Eino ) -C -C where the NIUOBS-by-NIUOBS matrix Eino is nilpotent -C and the (N-NOBSV-NIUOBS)-by-(N-NOBSV-NIUOBS) matrix Efno -C is nonsingular and upper triangular. -C If JOBOBS = 'F', Eno is nonsingular and upper triangular. -C -C LDE INTEGER -C The leading dimension of array E. LDE >= MAX(1,N). -C -C B (input/output) DOUBLE PRECISION array, dimension -C (LDB,MAX(M,P)) -C On entry, the leading N-by-M part of this array must -C contain the N-by-M input matrix B. -C On exit, the leading N-by-M part of this array contains -C the transformed input matrix Q'*B. -C -C LDB INTEGER -C The leading dimension of array B. -C LDB >= MAX(1,N) if M > 0 or LDB >= 1 if M = 0. -C -C C (input/output) DOUBLE PRECISION array, dimension (LDC,N) -C On entry, the leading P-by-N part of this array must -C contain the state/output matrix C. -C On exit, the leading P-by-N part of this array contains -C the transformed matrix -C -C C*Z = ( 0 Co ) , -C -C where Co is P-by-NOBSV. -C If JOBOBS = 'O' or 'I', the matrix ( Eo ) is in the -C ( Co ) -C observability staircase form (1). -C If JOBOBS = 'F', the matrix ( Ao ) is in the observability -C ( Co ) -C staircase form (3). -C -C LDC INTEGER -C The leading dimension of array C. LDC >= MAX(1,M,P). -C -C Q (input/output) DOUBLE PRECISION array, dimension (LDQ,N) -C If COMPQ = 'N': Q is not referenced. -C If COMPQ = 'I': on entry, Q need not be set; -C on exit, the leading N-by-N part of this -C array contains the orthogonal matrix Q, -C where Q' is the product of transformations -C which are applied to A, E, and B on -C the left. -C If COMPQ = 'U': on entry, the leading N-by-N part of this -C array must contain an orthogonal matrix -C Qc; -C on exit, the leading N-by-N part of this -C array contains the orthogonal matrix -C Qc*Q. -C -C LDQ INTEGER -C The leading dimension of array Q. -C LDQ >= 1, if COMPQ = 'N'; -C LDQ >= MAX(1,N), if COMPQ = 'U' or 'I'. -C -C Z (input/output) DOUBLE PRECISION array, dimension (LDZ,N) -C If COMPZ = 'N': Z is not referenced. -C If COMPZ = 'I': on entry, Z need not be set; -C on exit, the leading N-by-N part of this -C array contains the orthogonal matrix Z, -C which is the product of transformations -C applied to A, E, and C on the right. -C If COMPZ = 'U': on entry, the leading N-by-N part of this -C array must contain an orthogonal matrix -C Zc; -C on exit, the leading N-by-N part of this -C array contains the orthogonal matrix -C Zc*Z. -C -C LDZ INTEGER -C The leading dimension of array Z. -C LDZ >= 1, if COMPZ = 'N'; -C LDZ >= MAX(1,N), if COMPZ = 'U' or 'I'. -C -C NOBSV (output) INTEGER -C The order of the reduced matrices Ao and Eo, and the -C number of columns of reduced matrix Co; also the order of -C observable part of the pair (C, A-lambda*E). -C -C NIUOBS (output) INTEGER -C For JOBOBS = 'O', the order of the reduced matrices -C Aino and Eino; also the number of unobservable -C infinite eigenvalues of the pencil A - lambda*E. -C For JOBOBS = 'F' or 'I', NIUOBS has no significance -C and is set to zero. -C -C NLBLCK (output) INTEGER -C For JOBOBS = 'O' or 'I', the number k, of full column rank -C _ -C blocks Ei-1,i in the staircase form of the pencil -C (Eo-lambda*Ao) (see (1) and (2)). -C ( Co ) -C For JOBOBS = 'F', the number k, of full column rank blocks -C _ -C Ai-1,i in the staircase form of the pencil (Ao-lambda*Eo) -C ( Co ) -C (see (3) and (4)). -C -C CTAU (output) INTEGER array, dimension (N) -C CTAU(i), for i = 1, ..., NLBLCK, is the column dimension -C _ _ -C of the full column rank block Ei-1,i or Ai-1,i in the -C staircase form (1) or (3) for JOBOBS = 'O' or 'I', or -C for JOBOBS = 'F', respectively. -C -C Tolerances -C -C TOL DOUBLE PRECISION -C The tolerance to be used in rank determinations when -C transforming (A'-lambda*E',C')'. If the user sets TOL > 0, -C then the given value of TOL is used as a lower bound for -C reciprocal condition numbers in rank determinations; a -C (sub)matrix whose estimated condition number is less than -C 1/TOL is considered to be of full rank. If the user sets -C TOL <= 0, then an implicitly computed, default tolerance, -C defined by TOLDEF = N*N*EPS, is used instead, where EPS -C is the machine precision (see LAPACK Library routine -C DLAMCH). TOL < 1. -C -C Workspace -C -C IWORK INTEGER array, dimension (P) -C -C DWORK DOUBLE PRECISION array, dimension MAX(N,2*P) -C -C Error Indicator -C -C INFO INTEGER -C = 0: successful exit; -C < 0: if INFO = -i, the i-th argument had an illegal -C value. -C -C METHOD -C -C The subroutine is based on the dual of the reduction -C algorithms of [1]. -C -C REFERENCES -C -C [1] A. Varga -C Computation of Irreducible Generalized State-Space -C Realizations. -C Kybernetika, vol. 26, pp. 89-106, 1990. -C -C NUMERICAL ASPECTS -C -C The algorithm is numerically backward stable and requires -C 0( N**3 ) floating point operations. -C -C FURTHER COMMENTS -C -C If the system matrices A, E and C are badly scaled, it is -C generally recommendable to scale them with the SLICOT routine -C TG01AD, before calling TG01ID. -C -C CONTRIBUTOR -C -C C. Oara, University "Politehnica" Bucharest. -C A. Varga, German Aerospace Center, DLR Oberpfaffenhofen. -C March 1999. Based on the RASP routine RPDSCF. -C -C REVISIONS -C -C July 1999, V. Sima, Research Institute for Informatics, Bucharest. -C May 2003, March 2004, V. Sima. -C -C KEYWORDS -C -C Observability, minimal realization, orthogonal canonical form, -C orthogonal transformation. -C -C ****************************************************************** -C -C .. Parameters .. - DOUBLE PRECISION ONE - PARAMETER ( ONE = 1.0D0 ) -C .. Scalar Arguments .. - CHARACTER COMPQ, COMPZ, JOBOBS - INTEGER INFO, LDA, LDB, LDC, LDE, LDQ, LDZ, - $ M, N, NIUOBS, NLBLCK, NOBSV, P - DOUBLE PRECISION TOL -C .. Array Arguments .. - INTEGER CTAU( * ), IWORK( * ) - DOUBLE PRECISION A( LDA, * ), B( LDB, * ), C( LDC, * ), - $ DWORK( * ), E( LDE, * ), Q( LDQ, * ), - $ Z( LDZ, * ) -C .. Local Scalars .. - CHARACTER JOBQ, JOBZ - LOGICAL FINOBS, ILQ, ILZ, INFOBS - INTEGER I, ICOMPQ, ICOMPZ, LBA, LBE, NR -C .. Local Arrays .. - DOUBLE PRECISION DUM(1) -C .. External Functions .. - LOGICAL LSAME - EXTERNAL LSAME -C .. External Subroutines .. - EXTERNAL AB07MD, DSWAP, MA02BD, MA02CD, TB01XD, - $ TG01HX, XERBLA -C .. Intrinsic Functions .. - INTRINSIC MAX -C -C .. Executable Statements .. -C -C Decode JOBOBS. -C - IF( LSAME( JOBOBS, 'O') ) THEN - FINOBS = .TRUE. - INFOBS = .TRUE. - ELSE IF( LSAME( JOBOBS, 'F') ) THEN - FINOBS = .TRUE. - INFOBS = .FALSE. - ELSE IF( LSAME( JOBOBS, 'I') ) THEN - FINOBS = .FALSE. - INFOBS = .TRUE. - ELSE - FINOBS = .FALSE. - INFOBS = .FALSE. - END IF -C -C Decode COMPQ. -C - IF( LSAME( COMPQ, 'N' ) ) THEN - ILQ = .FALSE. - ICOMPQ = 1 - ELSE IF( LSAME( COMPQ, 'U' ) ) THEN - ILQ = .TRUE. - ICOMPQ = 2 - ELSE IF( LSAME( COMPQ, 'I' ) ) THEN - ILQ = .TRUE. - ICOMPQ = 3 - ELSE - ICOMPQ = 0 - END IF -C -C Decode COMPZ. -C - IF( LSAME( COMPZ, 'N' ) ) THEN - ILZ = .FALSE. - ICOMPZ = 1 - ELSE IF( LSAME( COMPZ, 'U' ) ) THEN - ILZ = .TRUE. - ICOMPZ = 2 - ELSE IF( LSAME( COMPZ, 'I' ) ) THEN - ILZ = .TRUE. - ICOMPZ = 3 - ELSE - ICOMPZ = 0 - END IF -C -C Test the input scalar parameters. -C - INFO = 0 - IF( .NOT.FINOBS .AND. .NOT.INFOBS ) THEN - INFO = -1 - ELSE IF( ICOMPQ.LE.0 ) THEN - INFO = -2 - ELSE IF( ICOMPZ.LE.0 ) THEN - INFO = -3 - ELSE IF( N.LT.0 ) THEN - INFO = -4 - ELSE IF( M.LT.0 ) THEN - INFO = -5 - ELSE IF( P.LT.0 ) THEN - INFO = -6 - ELSE IF( LDA.LT.MAX( 1, N ) ) THEN - INFO = -8 - ELSE IF( LDE.LT.MAX( 1, N ) ) THEN - INFO = -10 - ELSE IF( LDB.LT.1 .OR. ( M.GT.0 .AND. LDB.LT.N ) ) THEN - INFO = -12 - ELSE IF( LDC.LT.MAX( 1, M, P ) ) THEN - INFO = -14 - ELSE IF( ( ILQ .AND. LDQ.LT.N ) .OR. LDQ.LT.1 ) THEN - INFO = -16 - ELSE IF( ( ILZ .AND. LDZ.LT.N ) .OR. LDZ.LT.1 ) THEN - INFO = -18 - ELSE IF( TOL.GE.ONE ) THEN - INFO = -23 - END IF - IF( INFO.NE.0 ) THEN - CALL XERBLA( 'TG01ID', -INFO ) - RETURN - END IF -C - JOBQ = COMPQ - JOBZ = COMPZ -C -C Build the dual system. -C - CALL AB07MD( 'Z', N, M, P, A, LDA, B, LDB, C, LDC, DUM, 1, - $ INFO ) - DO 10 I = 2, N - CALL DSWAP( I-1, E(I,1), LDE, E(1,I), 1 ) - 10 CONTINUE -C - IF( FINOBS ) THEN -C -C Perform finite observability form reduction. -C - CALL TG01HX( JOBZ, JOBQ, N, N, P, M, N, MAX( 0, N-1 ), A, LDA, - $ E, LDE, B, LDB, C, LDC, Z, LDZ, Q, LDQ, NR, - $ NLBLCK, CTAU, TOL, IWORK, DWORK, INFO ) - IF( NLBLCK.GT.1 ) THEN - LBA = CTAU(1) + CTAU(2) - 1 - ELSE IF( NLBLCK.EQ.1 ) THEN - LBA = CTAU(1) - 1 - ELSE - LBA = 0 - END IF - IF( ILQ ) JOBQ = 'U' - IF( ILZ ) JOBZ = 'U' - LBE = 0 - ELSE - NR = N - LBA = MAX( 0, N-1 ) - LBE = LBA - END IF -C - IF( INFOBS ) THEN -C -C Perform infinite observability form reduction. -C - CALL TG01HX( JOBZ, JOBQ, N, N, P, M, NR, LBA, E, LDE, - $ A, LDA, B, LDB, C, LDC, Z, LDZ, Q, LDQ, NOBSV, - $ NLBLCK, CTAU, TOL, IWORK, DWORK, INFO ) - IF( FINOBS ) THEN - NIUOBS = NR - NOBSV - ELSE - NIUOBS = 0 - END IF - IF( NLBLCK.GT.1 ) THEN - LBE = CTAU(1) + CTAU(2) - 1 - ELSE IF( NLBLCK.EQ.1 ) THEN - LBE = CTAU(1) - 1 - ELSE - LBE = 0 - END IF - LBA = 0 - ELSE - NOBSV = NR - NIUOBS = 0 - END IF -C -C Compute the pertransposed dual system exploiting matrix shapes. -C - LBA = MAX( LBA, NIUOBS-1, N-NOBSV-NIUOBS-1 ) - IF ( P.EQ.0 .OR. NR.EQ.0 ) - $ LBE = MAX( 0, N - 1 ) - CALL TB01XD( 'Z', N, P, M, LBA, MAX( 0, N-1 ), A, LDA, B, LDB, - $ C, LDC, DUM, 1, INFO ) - CALL MA02CD( N, LBE, MAX( 0, N-1 ), E, LDE ) - IF( ILZ ) CALL MA02BD( 'Right', N, N, Z, LDZ ) - IF( ILQ ) CALL MA02BD( 'Right', N, N, Q, LDQ ) - RETURN -C *** Last line of TG01ID *** - END diff --git a/mex/sources/libslicot/TG01JD.f b/mex/sources/libslicot/TG01JD.f deleted file mode 100644 index 93cecec4e..000000000 --- a/mex/sources/libslicot/TG01JD.f +++ /dev/null @@ -1,613 +0,0 @@ - SUBROUTINE TG01JD( JOB, SYSTYP, EQUIL, N, M, P, A, LDA, E, LDE, - $ B, LDB, C, LDC, NR, INFRED, TOL, IWORK, DWORK, - $ LDWORK, INFO ) -C -C SLICOT RELEASE 5.0. -C -C Copyright (c) 2002-2009 NICONET e.V. -C -C This program is free software: you can redistribute it and/or -C modify it under the terms of the GNU General Public License as -C published by the Free Software Foundation, either version 2 of -C the License, or (at your option) any later version. -C -C This program is distributed in the hope that it will be useful, -C but WITHOUT ANY WARRANTY; without even the implied warranty of -C MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the -C GNU General Public License for more details. -C -C You should have received a copy of the GNU General Public License -C along with this program. If not, see -C . -C -C PURPOSE -C -C To find a reduced (controllable, observable, or irreducible) -C descriptor representation (Ar-lambda*Er,Br,Cr) for an original -C descriptor representation (A-lambda*E,B,C). -C The pencil Ar-lambda*Er is in an upper block Hessenberg form, with -C either Ar or Er upper triangular. -C -C ARGUMENTS -C -C Mode Parameters -C -C JOB CHARACTER*1 -C Indicates whether the user wishes to remove the -C uncontrollable and/or unobservable parts as follows: -C = 'I': Remove both the uncontrollable and unobservable -C parts to get an irreducible descriptor -C representation; -C = 'C': Remove the uncontrollable part only to get a -C controllable descriptor representation; -C = 'O': Remove the unobservable part only to get an -C observable descriptor representation. -C -C SYSTYP CHARACTER*1 -C Indicates the type of descriptor system algorithm -C to be applied according to the assumed -C transfer-function matrix as follows: -C = 'R': Rational transfer-function matrix; -C = 'S': Proper (standard) transfer-function matrix; -C = 'P': Polynomial transfer-function matrix. -C -C EQUIL CHARACTER*1 -C Specifies whether the user wishes to preliminarily scale -C the system (A-lambda*E,B,C) as follows: -C = 'S': Perform scaling; -C = 'N': Do not perform scaling. -C -C Input/Output Parameters -C -C N (input) INTEGER -C The dimension of the descriptor state vector; also the -C order of square matrices A and E, the number of rows of -C matrix B, and the number of columns of matrix C. N >= 0. -C -C M (input) INTEGER -C The dimension of descriptor system input vector; also the -C number of columns of matrix B. M >= 0. -C -C P (input) INTEGER -C The dimension of descriptor system output vector; also the -C number of rows of matrix C. P >= 0. -C -C A (input/output) DOUBLE PRECISION array, dimension (LDA,N) -C On entry, the leading N-by-N part of this array must -C contain the original state matrix A. -C On exit, the leading NR-by-NR part of this array contains -C the reduced order state matrix Ar of an irreducible, -C controllable, or observable realization for the original -C system, depending on the value of JOB, JOB = 'I', -C JOB = 'C', or JOB = 'O', respectively. -C The matrix Ar is upper triangular if SYSTYP = 'R' or 'P'. -C If SYSTYP = 'S' and JOB = 'C', the matrix [Br Ar] -C is in a controllable staircase form (see TG01HD). -C If SYSTYP = 'S' and JOB = 'I' or 'O', the matrix ( Ar ) -C ( Cr ) -C is in an observable staircase form (see TG01HD). -C The block structure of staircase forms is contained -C in the leading INFRED(7) elements of IWORK. -C -C LDA INTEGER -C The leading dimension of array A. LDA >= MAX(1,N). -C -C E (input/output) DOUBLE PRECISION array, dimension (LDE,N) -C On entry, the leading N-by-N part of this array must -C contain the original descriptor matrix E. -C On exit, the leading NR-by-NR part of this array contains -C the reduced order descriptor matrix Er of an irreducible, -C controllable, or observable realization for the original -C system, depending on the value of JOB, JOB = 'I', -C JOB = 'C', or JOB = 'O', respectively. -C The resulting Er has INFRED(6) nonzero sub-diagonals. -C If at least for one k = 1,...,4, INFRED(k) >= 0, then the -C resulting Er is structured being either upper triangular -C or block Hessenberg, in accordance to the last -C performed order reduction phase (see METHOD). -C The block structure of staircase forms is contained -C in the leading INFRED(7) elements of IWORK. -C -C LDE INTEGER -C The leading dimension of array E. LDE >= MAX(1,N). -C -C B (input/output) DOUBLE PRECISION array, dimension (LDB,M), -C if JOB = 'C', or (LDB,MAX(M,P)), otherwise. -C On entry, the leading N-by-M part of this array must -C contain the original input matrix B; if JOB = 'I', -C or JOB = 'O', the remainder of the leading N-by-MAX(M,P) -C part is used as internal workspace. -C On exit, the leading NR-by-M part of this array contains -C the reduced input matrix Br of an irreducible, -C controllable, or observable realization for the original -C system, depending on the value of JOB, JOB = 'I', -C JOB = 'C', or JOB = 'O', respectively. -C If JOB = 'C', only the first IWORK(1) rows of B are -C nonzero. -C -C LDB INTEGER -C The leading dimension of array B. LDB >= MAX(1,N). -C -C C (input/output) DOUBLE PRECISION array, dimension (LDC,N) -C On entry, the leading P-by-N part of this array must -C contain the original output matrix C; if JOB = 'I', -C or JOB = 'O', the remainder of the leading MAX(M,P)-by-N -C part is used as internal workspace. -C On exit, the leading P-by-NR part of this array contains -C the transformed state/output matrix Cr of an irreducible, -C controllable, or observable realization for the original -C system, depending on the value of JOB, JOB = 'I', -C JOB = 'C', or JOB = 'O', respectively. -C If JOB = 'I', or JOB = 'O', only the last IWORK(1) columns -C (in the first NR columns) of C are nonzero. -C -C LDC INTEGER -C The leading dimension of array C. -C LDC >= MAX(1,M,P) if N > 0. -C LDC >= 1 if N = 0. -C -C NR (output) INTEGER -C The order of the reduced descriptor representation -C (Ar-lambda*Er,Br,Cr) of an irreducible, controllable, -C or observable realization for the original system, -C depending on JOB = 'I', JOB = 'C', or JOB = 'O', -C respectively. -C -C INFRED (output) INTEGER array, dimension 7 -C This array contains information on performed reduction -C and on structure of resulting system matrices as follows: -C INFRED(k) >= 0 (k = 1, 2, 3, or 4) if Phase k of reduction -C (see METHOD) has been performed. In this -C case, INFRED(k) is the achieved order -C reduction in Phase k. -C INFRED(k) < 0 (k = 1, 2, 3, or 4) if Phase k was not -C performed. -C INFRED(5) - the number of nonzero sub-diagonals of A. -C INFRED(6) - the number of nonzero sub-diagonals of E. -C INFRED(7) - the number of blocks in the resulting -C staircase form at last performed reduction -C phase. The block dimensions are contained -C in the first INFRED(7) elements of IWORK. -C -C Tolerances -C -C TOL DOUBLE PRECISION -C The tolerance to be used in rank determinations when -C transforming (A-lambda*E,B,C). If the user sets TOL > 0, -C then the given value of TOL is used as a lower bound for -C reciprocal condition numbers in rank determinations; a -C (sub)matrix whose estimated condition number is less than -C 1/TOL is considered to be of full rank. If the user sets -C TOL <= 0, then an implicitly computed, default tolerance, -C defined by TOLDEF = N*N*EPS, is used instead, where -C EPS is the machine precision (see LAPACK Library routine -C DLAMCH). TOL < 1. -C -C Workspace -C -C IWORK INTEGER array, dimension N+MAX(M,P) -C On exit, if INFO = 0, the leading INFRED(7) elements of -C IWORK contain the orders of the diagonal blocks of -C Ar-lambda*Er. -C -C DWORK DOUBLE PRECISION array, dimension LDWORK -C -C LDWORK INTEGER -C The length of the array DWORK. -C LDWORK >= MAX(8*N,2*M,2*P), if EQUIL = 'S'; -C LDWORK >= MAX(N,2*M,2*P), if EQUIL = 'N'. -C If LDWORK >= MAX(2*N*N+N*M+N*P)+MAX(N,2*M,2*P) then more -C accurate results are to be expected by performing only -C those reductions phases (see METHOD), where effective -C order reduction occurs. This is achieved by saving the -C system matrices before each phase and restoring them if no -C order reduction took place. -C -C Error Indicator -C -C INFO INTEGER -C = 0: successful exit; -C < 0: if INFO = -i, the i-th argument had an illegal -C value. -C -C METHOD -C -C The subroutine is based on the reduction algorithms of [1]. -C The order reduction is performed in 4 phases: -C Phase 1: Eliminate all finite uncontrolable eigenvalues. -C The resulting matrix ( Br Ar ) is in a controllable -C staircase form (see SLICOT Library routine TG01HD), and -C Er is upper triangular. -C This phase is performed if JOB = 'I' or 'C' and -C SYSTYP = 'R' or 'S'. -C Phase 2: Eliminate all infinite and finite nonzero uncontrollable -C eigenvalues. The resulting matrix ( Br Er ) is in a -C controllable staircase form (see TG01HD), and Ar is -C upper triangular. -C This phase is performed if JOB = 'I' or 'C' and -C SYSTYP = 'R' or 'P'. -C Phase 3: Eliminate all finite unobservable eigenvalues. -C The resulting matrix ( Ar ) is in an observable -C ( Cr ) -C staircase form (see SLICOT Library routine TG01ID), and -C Er is upper triangular. -C This phase is performed if JOB = 'I' or 'O' and -C SYSTYP = 'R' or 'S'. -C Phase 4: Eliminate all infinite and finite nonzero unobservable -C eigenvalues. The resulting matrix ( Er ) is in an -C ( Cr ) -C observable staircase form (see TG01ID), and Ar is -C upper triangular. -C This phase is performed if JOB = 'I' or 'O' and -C SYSTYP = 'R' or 'P'. -C -C REFERENCES -C -C [1] A. Varga -C Computation of Irreducible Generalized State-Space -C Realizations. -C Kybernetika, vol. 26, pp. 89-106, 1990. -C -C NUMERICAL ASPECTS -C -C The algorithm is numerically backward stable and requires -C 0( N**3 ) floating point operations. -C -C FURTHER COMMENTS -C -C If the pencil (A-lambda*E) has no zero eigenvalues, then an -C irreducible realization can be computed skipping Phases 1 and 3 -C by using the setting: JOB = 'I' and SYSTYP = 'P'. -C -C CONTRIBUTOR -C -C A. Varga, German Aerospace Center, DLR Oberpfaffenhofen. -C April 1999. Based on the RASP routine RPDSIR. -C -C REVISIONS -C -C July 1999, V. Sima, Research Institute for Informatics, Bucharest. -C May 2003, A. Varga, German Aerospace Center, DLR Oberpfaffenhofen. -C May 2003, March 2004, V. Sima. -C -C KEYWORDS -C -C Controllability, irreducible realization, observability, -C orthogonal canonical form, orthogonal transformation. -C -C ****************************************************************** -C -C .. Parameters .. - DOUBLE PRECISION ONE, ZERO - PARAMETER ( ONE = 1.0D0, ZERO = 0.0D0 ) -C .. Scalar Arguments .. - CHARACTER EQUIL, JOB, SYSTYP - INTEGER INFO, LDA, LDB, LDC, LDE, LDWORK, M, N, NR, P - DOUBLE PRECISION TOL -C .. Array Arguments .. - INTEGER INFRED(*), IWORK(*) - DOUBLE PRECISION A(LDA,*), B(LDB,*), C(LDC,*), DWORK(*), E(LDE,*) -C .. Local Scalars .. - CHARACTER JOBQ, JOBZ - LOGICAL FINCON, FINOBS, INFCON, INFOBS, LEQUIL, LJOBC, - $ LJOBIR, LJOBO, LSPACE, LSYSP, LSYSR, LSYSS - INTEGER KWA, KWB, KWC, KWE, LBA, LBE, LDM, LDP, LDQ, - $ LDZ, M1, MAXMP, N1, NBLCK, NC, P1 -C .. Local Arrays .. - DOUBLE PRECISION DUM(1) -C .. External Functions .. - LOGICAL LSAME - EXTERNAL LSAME -C .. External Subroutines .. - EXTERNAL DLACPY, MA02CD, TB01XD, TG01AD, TG01HX, XERBLA -C .. Intrinsic Functions .. - INTRINSIC MAX -C .. Executable Statements .. -C - INFO = 0 - MAXMP = MAX( M, P ) - N1 = MAX( 1, N ) -C -C Decode JOB. -C - LJOBIR = LSAME( JOB, 'I' ) - LJOBC = LJOBIR .OR. LSAME( JOB, 'C' ) - LJOBO = LJOBIR .OR. LSAME( JOB, 'O' ) -C -C Decode SYSTYP. -C - LSYSR = LSAME( SYSTYP, 'R' ) - LSYSS = LSYSR .OR. LSAME( SYSTYP, 'S' ) - LSYSP = LSYSR .OR. LSAME( SYSTYP, 'P' ) -C - LEQUIL = LSAME( EQUIL, 'S' ) -C -C Test the input scalar arguments. -C - IF( .NOT.LJOBC .AND. .NOT.LJOBO ) THEN - INFO = -1 - ELSE IF( .NOT.LSYSS .AND. .NOT.LSYSP ) THEN - INFO = -2 - ELSE IF( .NOT.LEQUIL .AND. .NOT.LSAME( EQUIL, 'N' ) ) THEN - INFO = -3 - ELSE IF( N.LT.0 ) THEN - INFO = -4 - ELSE IF( M.LT.0 ) THEN - INFO = -5 - ELSE IF( P.LT.0 ) THEN - INFO = -6 - ELSE IF( LDA.LT.N1 ) THEN - INFO = -8 - ELSE IF( LDE.LT.N1 ) THEN - INFO = -10 - ELSE IF( LDB.LT.N1 ) THEN - INFO = -12 - ELSE IF( LDC.LT.1 .OR. ( N.GT.0 .AND. LDC.LT.MAXMP ) ) THEN - INFO = -14 - ELSE IF( TOL.GE.ONE ) THEN - INFO = -17 - ELSE IF( ( .NOT.LEQUIL .AND. LDWORK.LT.MAX( N, 2*MAXMP ) ) .OR. - $ ( LEQUIL .AND. LDWORK.LT.MAX( 8*N, 2*MAXMP ) ) ) THEN - INFO = -20 - END IF -C - IF ( INFO.NE.0 ) THEN -C -C Error return. -C - CALL XERBLA( 'TG01JD', -INFO ) - RETURN - END IF -C -C Quick return if possible. -C - INFRED(1) = -1 - INFRED(2) = -1 - INFRED(3) = -1 - INFRED(4) = -1 - INFRED(5) = 0 - INFRED(6) = 0 - INFRED(7) = 0 -C - IF( MAX( N, MAXMP ).EQ.0 ) THEN - NR = 0 - RETURN - END IF -C - M1 = MAX( 1, M ) - P1 = MAX( 1, P ) - LDM = MAX( LDC, M ) - LDP = MAX( LDC, P ) -C -C Set controllability/observability determination options. -C - FINCON = LJOBC .AND. LSYSS - INFCON = LJOBC .AND. LSYSP - FINOBS = LJOBO .AND. LSYSS - INFOBS = LJOBO .AND. LSYSP -C -C Set large workspace option and determine offsets. -C - LSPACE = LDWORK.GE.N*( 2*N + M + P ) + MAX( N, 2*MAXMP ) - KWA = MAX( N, 2*MAXMP ) + 1 - KWE = KWA + N*N - KWB = KWE + N*N - KWC = KWB + N*M -C -C If required, scale the system (A-lambda*E,B,C). -C Workspace: need 8*N. -C - IF( LEQUIL ) THEN - CALL TG01AD( 'All', N, N, M, P, ZERO, A, LDA, E, LDE, B, LDB, - $ C, LDP, DWORK(1), DWORK(N+1), DWORK(2*N+1), INFO ) - END IF -C - JOBQ = 'N' - JOBZ = 'N' - LDQ = 1 - LDZ = 1 - LBA = MAX( 0, N-1 ) - LBE = LBA - NC = N - NR = N -C - IF( FINCON ) THEN -C -C Phase 1: Eliminate all finite uncontrolable eigenvalues. -C - IF( LSPACE) THEN -C -C Save system matrices. -C - CALL DLACPY( 'Full', NC, NC, A, LDA, DWORK(KWA), N1 ) - CALL DLACPY( 'Full', NC, NC, E, LDE, DWORK(KWE), N1 ) - CALL DLACPY( 'Full', NC, M, B, LDB, DWORK(KWB), N1 ) - CALL DLACPY( 'Full', P, NC, C, LDC, DWORK(KWC), P1 ) - END IF -C -C Perform finite controllability form reduction. -C Workspace: need MAX(N,2*M). -C - CALL TG01HX( JOBQ, JOBZ, NC, NC, M, P, NC, LBE, A, LDA, - $ E, LDE, B, LDB, C, LDP, DUM, LDQ, DUM, LDZ, NR, - $ NBLCK, IWORK, TOL, IWORK(N+1), DWORK, INFO ) - IF( NR.LT.NC .OR. .NOT.LSPACE ) THEN - IF( NBLCK.GT.1 ) THEN - LBA = IWORK(1) + IWORK(2) - 1 - ELSE IF( NBLCK.EQ.1 ) THEN - LBA = IWORK(1) - 1 - ELSE - LBA = 0 - END IF - LBE = 0 - INFRED(1) = NC - NR - INFRED(7) = NBLCK - NC = NR - ELSE -C -C Restore system matrices. -C - CALL DLACPY( 'Full', NC, NC, DWORK(KWA), N1, A, LDA ) - CALL DLACPY( 'Full', NC, NC, DWORK(KWE), N1, E, LDE ) - CALL DLACPY( 'Full', NC, M, DWORK(KWB), N1, B, LDB ) - CALL DLACPY( 'Full', P, NC, DWORK(KWC), P1, C, LDC ) - END IF - END IF -C - IF( INFCON ) THEN -C -C Phase 2: Eliminate all infinite and all finite nonzero -C uncontrolable eigenvalues. -C - IF( LSPACE ) THEN -C -C Save system matrices. -C - CALL DLACPY( 'Full', NC, NC, A, LDA, DWORK(KWA), N1 ) - CALL DLACPY( 'Full', NC, NC, E, LDE, DWORK(KWE), N1 ) - CALL DLACPY( 'Full', NC, M, B, LDB, DWORK(KWB), N1 ) - CALL DLACPY( 'Full', P, NC, C, LDC, DWORK(KWC), P1 ) - END IF -C -C Perform infinite controllability form reduction. -C Workspace: need MAX(N,2*M). -C - CALL TG01HX( JOBQ, JOBZ, NC, NC, M, P, NC, LBA, E, LDE, - $ A, LDA, B, LDB, C, LDP, DUM, LDQ, DUM, LDZ, NR, - $ NBLCK, IWORK, TOL, IWORK(N+1), DWORK, INFO ) - IF( NR.LT.NC .OR. .NOT.LSPACE ) THEN - IF( NBLCK.GT.1 ) THEN - LBE = IWORK(1) + IWORK(2) - 1 - ELSE IF( NBLCK.EQ.1 ) THEN - LBE = IWORK(1) - 1 - ELSE - LBE = 0 - END IF - LBA = 0 - INFRED(2) = NC - NR - INFRED(7) = NBLCK - NC = NR - ELSE -C -C Restore system matrices. -C - CALL DLACPY( 'Full', NC, NC, DWORK(KWA), N1, A, LDA ) - CALL DLACPY( 'Full', NC, NC, DWORK(KWE), N1, E, LDE ) - CALL DLACPY( 'Full', NC, M, DWORK(KWB), N1, B, LDB ) - CALL DLACPY( 'Full', P, NC, DWORK(KWC), P1, C, LDC ) - END IF - END IF -C - IF( FINOBS .OR. INFOBS) THEN -C -C Compute the pertransposed dual system exploiting matrix shapes. -C - CALL TB01XD( 'Z', NC, M, P, LBA, MAX( 0, NC-1 ), A, LDA, - $ B, LDB, C, LDC, DUM, 1, INFO ) - CALL MA02CD( NC, LBE, MAX( 0, NC-1 ), E, LDE ) - END IF -C - IF( FINOBS ) THEN -C -C Phase 3: Eliminate all finite unobservable eigenvalues. -C - IF( LSPACE ) THEN -C -C Save system matrices. -C - CALL DLACPY( 'Full', NC, NC, A, LDA, DWORK(KWA), N1 ) - CALL DLACPY( 'Full', NC, NC, E, LDE, DWORK(KWE), N1 ) - CALL DLACPY( 'Full', NC, P, B, LDB, DWORK(KWC), N1 ) - CALL DLACPY( 'Full', M, NC, C, LDC, DWORK(KWB), M1 ) - END IF -C -C Perform finite observability form reduction. -C Workspace: need MAX(N,2*P). -C - CALL TG01HX( JOBZ, JOBQ, NC, NC, P, M, NC, LBE, A, LDA, - $ E, LDE, B, LDB, C, LDM, DUM, LDZ, DUM, LDQ, NR, - $ NBLCK, IWORK, TOL, IWORK(N+1), DWORK, INFO ) - IF( NR.LT.NC .OR. .NOT.LSPACE ) THEN - IF( NBLCK.GT.1 ) THEN - LBA = IWORK(1) + IWORK(2) - 1 - ELSE IF( NBLCK.EQ.1 ) THEN - LBA = IWORK(1) - 1 - ELSE - LBA = 0 - END IF - LBE = 0 - INFRED(3) = NC - NR - INFRED(7) = NBLCK - NC = NR - ELSE -C -C Restore system matrices. -C - CALL DLACPY( 'Full', NC, NC, DWORK(KWA), N1, A, LDA ) - CALL DLACPY( 'Full', NC, NC, DWORK(KWE), N1, E, LDE ) - CALL DLACPY( 'Full', NC, P, DWORK(KWC), N1, B, LDB ) - CALL DLACPY( 'Full', M, NC, DWORK(KWB), M1, C, LDC ) - END IF - END IF -C - IF( INFOBS ) THEN -C -C Phase 4: Eliminate all infinite and all finite nonzero -C unobservable eigenvalues. -C - IF( LSPACE) THEN -C -C Save system matrices. -C - CALL DLACPY( 'Full', NC, NC, A, LDA, DWORK(KWA), N1 ) - CALL DLACPY( 'Full', NC, NC, E, LDE, DWORK(KWE), N1 ) - CALL DLACPY( 'Full', NC, P, B, LDB, DWORK(KWC), N1 ) - CALL DLACPY( 'Full', M, NC, C, LDC, DWORK(KWB), M1 ) - END IF -C -C Perform infinite observability form reduction. -C Workspace: need MAX(N,2*P). -C - CALL TG01HX( JOBZ, JOBQ, NC, NC, P, M, NC, LBA, E, LDE, - $ A, LDA, B, LDB, C, LDM, DUM, LDZ, DUM, LDQ, NR, - $ NBLCK, IWORK, TOL, IWORK(N+1), DWORK, INFO ) - IF( NR.LT.NC .OR. .NOT.LSPACE ) THEN - IF( NBLCK.GT.1 ) THEN - LBE = IWORK(1) + IWORK(2) - 1 - ELSE IF( NBLCK.EQ.1 ) THEN - LBE = IWORK(1) - 1 - ELSE - LBE = 0 - END IF - LBA = 0 - INFRED(4) = NC - NR - INFRED(7) = NBLCK - NC = NR - ELSE -C -C Restore system matrices. -C - CALL DLACPY( 'Full', NC, NC, DWORK(KWA), N1, A, LDA ) - CALL DLACPY( 'Full', NC, NC, DWORK(KWE), N1, E, LDE ) - CALL DLACPY( 'Full', NC, P, DWORK(KWC), N1, B, LDB ) - CALL DLACPY( 'Full', M, NC, DWORK(KWB), M1, C, LDC ) - END IF - END IF -C - IF( FINOBS .OR. INFOBS ) THEN -C -C Compute the pertransposed dual system exploiting matrix shapes. -C - CALL TB01XD( 'Z', NC, P, M, LBA, MAX( 0, NC-1 ), A, LDA, - $ B, LDB, C, LDC, DUM, 1, INFO ) - CALL MA02CD( NC, LBE, MAX( 0, NC-1 ), E, LDE ) - END IF -C -C Set structural information on A and E. -C - INFRED(5) = LBA - INFRED(6) = LBE -C - RETURN -C *** Last line of TG01JD *** - END diff --git a/mex/sources/libslicot/TG01WD.f b/mex/sources/libslicot/TG01WD.f deleted file mode 100644 index 26d06848e..000000000 --- a/mex/sources/libslicot/TG01WD.f +++ /dev/null @@ -1,319 +0,0 @@ - SUBROUTINE TG01WD( N, M, P, A, LDA, E, LDE, B, LDB, C, LDC, - $ Q, LDQ, Z, LDZ, ALPHAR, ALPHAI, BETA, DWORK, - $ LDWORK, INFO ) -C -C SLICOT RELEASE 5.0. -C -C Copyright (c) 2002-2009 NICONET e.V. -C -C This program is free software: you can redistribute it and/or -C modify it under the terms of the GNU General Public License as -C published by the Free Software Foundation, either version 2 of -C the License, or (at your option) any later version. -C -C This program is distributed in the hope that it will be useful, -C but WITHOUT ANY WARRANTY; without even the implied warranty of -C MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the -C GNU General Public License for more details. -C -C You should have received a copy of the GNU General Public License -C along with this program. If not, see -C . -C -C PURPOSE -C -C To reduce the pair (A,E) to a real generalized Schur form -C by using an orthogonal equivalence transformation -C (A,E) <-- (Q'*A*Z,Q'*E*Z) and to apply the transformation -C to the matrices B and C: B <-- Q'*B and C <-- C*Z. -C -C ARGUMENTS -C -C Input/Output Parameters -C -C N (input) INTEGER -C The order of the original state-space representation, -C i.e., the order of the matrices A and E. N >= 0. -C -C M (input) INTEGER -C The number of system inputs, or of columns of B. M >= 0. -C -C P (input) INTEGER -C The number of system outputs, or of rows of C. P >= 0. -C -C A (input/output) DOUBLE PRECISION array, dimension (LDA,N) -C On entry, the leading N-by-N part of this array must -C contain the original state dynamics matrix A. -C On exit, the leading N-by-N part of this array contains -C the matrix Q' * A * Z in an upper quasi-triangular form. -C The elements below the first subdiagonal are set to zero. -C -C LDA INTEGER -C The leading dimension of array A. LDA >= MAX(1,N). -C -C E (input/output) DOUBLE PRECISION array, dimension (LDE,N) -C On entry, the leading N-by-N part of this array must -C contain the original descriptor matrix E. -C On exit, the leading N-by-N part of this array contains -C the matrix Q' * E * Z in an upper triangular form. -C The elements below the diagonal are set to zero. -C -C LDE INTEGER -C The leading dimension of array E. LDE >= MAX(1,N). -C -C B (input/output) DOUBLE PRECISION array, dimension (LDB,M) -C On entry, the leading N-by-M part of this array must -C contain the input matrix B. -C On exit, the leading N-by-M part of this array contains -C the transformed input matrix Q' * B. -C -C LDB INTEGER -C The leading dimension of array B. LDB >= MAX(1,N). -C -C C (input/output) DOUBLE PRECISION array, dimension (LDC,N) -C On entry, the leading P-by-N part of this array must -C contain the output matrix C. -C On exit, the leading P-by-N part of this array contains -C the transformed output matrix C * Z. -C -C LDC INTEGER -C The leading dimension of array C. LDC >= MAX(1,P). -C -C Q (output) DOUBLE PRECISION array, dimension (LDQ,N) -C The leading N-by-N part of this array contains the left -C orthogonal transformation matrix used to reduce (A,E) to -C the real generalized Schur form. -C The columns of Q are the left generalized Schur vectors -C of the pair (A,E). -C -C LDQ INTEGER -C The leading dimension of array Q. LDQ >= max(1,N). -C -C Z (output) DOUBLE PRECISION array, dimension (LDZ,N) -C The leading N-by-N part of this array contains the right -C orthogonal transformation matrix used to reduce (A,E) to -C the real generalized Schur form. -C The columns of Z are the right generalized Schur vectors -C of the pair (A,E). -C -C LDZ INTEGER -C The leading dimension of array Z. LDZ >= max(1,N). -C -C ALPHAR (output) DOUBLE PRECISION array, dimension (N) -C ALPHAI (output) DOUBLE PRECISION array, dimension (N) -C BETA (output) DOUBLE PRECISION array, dimension (N) -C On exit, if INFO = 0, (ALPHAR(j) + ALPHAI(j)*i)/BETA(j), -C j=1,...,N, will be the generalized eigenvalues. -C ALPHAR(j) + ALPHAI(j)*i, and BETA(j), j=1,...,N, are the -C diagonals of the complex Schur form that would result if -C the 2-by-2 diagonal blocks of the real Schur form of -C (A,E) were further reduced to triangular form using -C 2-by-2 complex unitary transformations. -C If ALPHAI(j) is zero, then the j-th eigenvalue is real; -C if positive, then the j-th and (j+1)-st eigenvalues are a -C complex conjugate pair, with ALPHAI(j+1) negative. -C -C Workspace -C -C DWORK DOUBLE PRECISION array, dimension (LDWORK) -C On exit, if INFO = 0, DWORK(1) returns the optimal value -C of LDWORK. -C -C LDWORK INTEGER -C The dimension of working array DWORK. LDWORK >= 8*N+16. -C For optimum performance LDWORK should be larger. -C -C Error Indicator -C -C INFO INTEGER -C = 0: successful exit; -C < 0: if INFO = -i, the i-th argument had an illegal -C value; -C > 0: if INFO = i, the QZ algorithm failed to compute -C the generalized real Schur form; elements i+1:N of -C ALPHAR, ALPHAI, and BETA should be correct. -C -C METHOD -C -C The pair (A,E) is reduced to a real generalized Schur form using -C an orthogonal equivalence transformation (A,E) <-- (Q'*A*Z,Q'*E*Z) -C and the transformation is applied to the matrices B and C: -C B <-- Q'*B and C <-- C*Z. -C -C NUMERICAL ASPECTS -C 3 -C The algorithm requires about 25N floating point operations. -C -C CONTRIBUTOR -C -C A. Varga, German Aerospace Center, -C DLR Oberpfaffenhofen, July 2000. -C -C REVISIONS -C -C V. Sima, Research Institute for Informatics, Bucharest, Mar. 2001. -C -C KEYWORDS -C -C Orthogonal transformation, generalized real Schur form, similarity -C transformation. -C -C ****************************************************************** -C -C .. Parameters .. - DOUBLE PRECISION ZERO, ONE - PARAMETER ( ZERO = 0.0D0, ONE = 1.0D0 ) -C .. Scalar Arguments .. - INTEGER INFO, LDA, LDB, LDC, LDE, LDQ, LDWORK, LDZ, - $ M, N, P -C .. Array Arguments .. - DOUBLE PRECISION A(LDA,*), ALPHAI(*), ALPHAR(*), B(LDB,*), - $ BETA(*), C(LDC,*), DWORK(*), E(LDE,*), - $ Q(LDQ,*), Z(LDZ,*) -C .. Local Scalars .. - LOGICAL BLAS3, BLOCK - INTEGER BL, CHUNK, I, J, MAXWRK, SDIM -C .. Local Arrays .. - LOGICAL BWORK(1) -C .. External Functions .. - LOGICAL LSAME, DELCTG - EXTERNAL LSAME, DELCTG -C .. External Subroutines .. - EXTERNAL DCOPY, DGEMM, DGEMV, DGGES, DLACPY, XERBLA -C .. Intrinsic Functions .. - INTRINSIC DBLE, INT, MAX, MIN -C -C .. Executable Statements .. -C - INFO = 0 -C -C Check the scalar input parameters. -C - IF( N.LT.0 ) THEN - INFO = -1 - ELSE IF( M.LT.0 ) THEN - INFO = -2 - ELSE IF( P.LT.0 ) THEN - INFO = -3 - ELSE IF( LDA.LT.MAX( 1, N ) ) THEN - INFO = -5 - ELSE IF( LDE.LT.MAX( 1, N ) ) THEN - INFO = -7 - ELSE IF( LDB.LT.MAX( 1, N ) ) THEN - INFO = -9 - ELSE IF( LDC.LT.MAX( 1, P ) ) THEN - INFO = -11 - ELSE IF( LDQ.LT.MAX( 1, N ) ) THEN - INFO = -13 - ELSE IF( LDZ.LT.MAX( 1, N ) ) THEN - INFO = -15 - ELSE IF( LDWORK.LT.8*N+16 ) THEN - INFO = -20 - END IF -C - IF( INFO.NE.0 ) THEN -C -C Error return. -C - CALL XERBLA( 'TG01WD', -INFO ) - RETURN - END IF -C -C Quick return if possible. -C - IF( N.EQ.0 ) THEN - DWORK(1) = ONE - RETURN - END IF -C -C Reduce (A,E) to real generalized Schur form using an orthogonal -C equivalence transformation (A,E) <-- (Q'*A*Z,Q'*E*Z), accumulate -C the transformations in Q and Z, and compute the generalized -C eigenvalues of the pair (A,E) in (ALPHAR, ALPHAI, BETA). -C -C Workspace: need 8*N+16; -C prefer larger. -C - CALL DGGES( 'Vectors', 'Vectors', 'Not ordered', DELCTG, N, - $ A, LDA, E, LDE, SDIM, ALPHAR, ALPHAI, BETA, Q, LDQ, - $ Z, LDZ, DWORK, LDWORK, BWORK, INFO ) - IF( INFO.NE.0 ) - $ RETURN - MAXWRK = INT( DWORK(1) ) -C -C Apply the transformation: B <-- Q'*B. Use BLAS 3, if enough space. -C - CHUNK = LDWORK / N - BLOCK = M.GT.1 - BLAS3 = CHUNK.GE.M .AND. BLOCK -C - IF( BLAS3 ) THEN -C -C Enough workspace for a fast BLAS 3 algorithm. -C - CALL DLACPY( 'Full', N, M, B, LDB, DWORK, N ) - CALL DGEMM( 'Transpose', 'No transpose', N, M, N, ONE, Q, LDQ, - $ DWORK, N, ZERO, B, LDB ) -C - ELSE IF ( BLOCK ) THEN -C -C Use as many columns of B as possible. -C - DO 10 J = 1, M, CHUNK - BL = MIN( M-J+1, CHUNK ) - CALL DLACPY( 'Full', N, BL, B(1,J), LDB, DWORK, N ) - CALL DGEMM( 'Transpose', 'NoTranspose', N, BL, N, ONE, Q, - $ LDQ, DWORK, N, ZERO, B(1,J), LDB ) - 10 CONTINUE -C - ELSE -C -C Use a BLAS 2 algorithm. Here, M <= 1. -C - IF ( M.GT.0 ) THEN - CALL DCOPY( N, B, 1, DWORK, 1 ) - CALL DGEMV( 'Transpose', N, N, ONE, Q, LDQ, DWORK, 1, ZERO, - $ B, 1 ) - END IF - END IF - MAXWRK = MAX( MAXWRK, N*M ) -C -C Apply the transformation: C <-- C*Z. Use BLAS 3, if enough space. -C - BLOCK = P.GT.1 - BLAS3 = CHUNK.GE.P .AND. BLOCK -C - IF ( BLAS3 ) THEN - CALL DLACPY( 'Full', P, N, C, LDC, DWORK, P ) - CALL DGEMM( 'No transpose', 'No transpose', P, N, N, ONE, - $ DWORK, P, Z, LDZ, ZERO, C, LDC ) -C - ELSE IF ( BLOCK ) THEN -C -C Use as many rows of C as possible. -C - DO 20 I = 1, P, CHUNK - BL = MIN( P-I+1, CHUNK ) - CALL DLACPY( 'Full', BL, N, C(I,1), LDC, DWORK, BL ) - CALL DGEMM( 'NoTranspose', 'NoTranspose', BL, N, N, ONE, - $ DWORK, BL, Z, LDZ, ZERO, C(I,1), LDC ) - 20 CONTINUE -C - ELSE -C -C Use a BLAS 2 algorithm. Here, P <= 1. -C - IF ( P.GT.0 ) THEN - CALL DCOPY( N, C, LDC, DWORK, 1 ) - CALL DGEMV( 'Transpose', N, N, ONE, Z, LDZ, DWORK, 1, ZERO, - $ C, LDC ) - END IF -C - END IF - MAXWRK = MAX( MAXWRK, P*N ) -C - DWORK(1) = DBLE( MAXWRK ) -C - RETURN -C *** Last line of TG01WD *** - END diff --git a/mex/sources/libslicot/UD01BD.f b/mex/sources/libslicot/UD01BD.f deleted file mode 100644 index 256984c17..000000000 --- a/mex/sources/libslicot/UD01BD.f +++ /dev/null @@ -1,149 +0,0 @@ - SUBROUTINE UD01BD( MP, NP, DP, NIN, P, LDP1, LDP2, INFO ) -C -C SLICOT RELEASE 5.0. -C -C Copyright (c) 2002-2009 NICONET e.V. -C -C This program is free software: you can redistribute it and/or -C modify it under the terms of the GNU General Public License as -C published by the Free Software Foundation, either version 2 of -C the License, or (at your option) any later version. -C -C This program is distributed in the hope that it will be useful, -C but WITHOUT ANY WARRANTY; without even the implied warranty of -C MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the -C GNU General Public License for more details. -C -C You should have received a copy of the GNU General Public License -C along with this program. If not, see -C . -C -C PURPOSE -C -C To read the coefficients of a matrix polynomial -C dp-1 dp -C P(s) = P(0) + P(1) * s + . . . + P(dp-1) * s + P(dp) * s . -C -C ARGUMENTS -C -C Input/Output Parameters -C -C MP (input) INTEGER -C The number of rows of the matrix polynomial P(s). -C MP >= 1. -C -C NP (input) INTEGER -C The number of columns of the matrix polynomial P(s). -C NP >= 1. -C -C DP (input) INTEGER -C The degree of the matrix polynomial P(s). DP >= 0. -C -C NIN (input) INTEGER -C The input channel from which the elements of P(s) are -C read. NIN >= 0. -C -C P (output) DOUBLE PRECISION array, dimension -C (LDP1,LDP2,DP+1) -C The leading MP-by-NP-by-(DP+1) part of this array contains -C the coefficients of the matrix polynomial P(s). -C Specifically, P(i,j,k) contains the coefficient of -C s**(k-1) of the polynomial which is the (i,j)-th element -C of P(s), where i = 1,2,...,MP, j = 1,2,...,NP and -C k = 1,2,...,DP+1. -C -C LDP1 INTEGER -C The leading dimension of array P. LDP1 >= MP. -C -C LDP2 INTEGER -C The second dimension of array P. LDP2 >= NP. -C -C Error Indicator -C -C INFO INTEGER -C = 0: successful exit; -C < 0: if INFO = -i, the i-th argument had an illegal -C value. -C -C METHOD -C -C The coefficients P(i), i = 0, ..., DP, which are MP-by-NP -C matrices, are read from the input file NIN row by row. Each P(i) -C must be preceded by a text line. This text line can be used to -C indicate the coefficient matrices. -C -C REFERENCES -C -C None. -C -C NUMERICAL ASPECTS -C -C None. -C -C CONTRIBUTOR -C -C Release 3.0: V. Sima, Katholieke Univ. Leuven, Belgium, June 1998. -C Based on routine RDMAPO by A.J. Geurts, Eindhoven University of -C Technology, Holland. -C -C REVISIONS -C -C - -C -C ****************************************************************** -C -C .. Parameters .. - DOUBLE PRECISION ZERO - PARAMETER ( ZERO = 0.0D0 ) -C .. Scalar Arguments .. - INTEGER DP, INFO, LDP1, LDP2, MP, NP, NIN -C .. Array Arguments .. - DOUBLE PRECISION P(LDP1,LDP2,*) -C .. Local Scalars .. - INTEGER I, J, K -C .. External Subroutines .. - EXTERNAL XERBLA -C -C .. Executable Statements .. -C - INFO = 0 -C -C Check the input scalar arguments. -C - IF( MP.LT.1 ) THEN - INFO = -1 - ELSE IF( NP.LT.1 ) THEN - INFO = -2 - ELSE IF( DP.LT.0 ) THEN - INFO = -3 - ELSE IF( NIN.LT.0 ) THEN - INFO = -4 - ELSE IF( LDP1.LT.MP ) THEN - INFO = -6 - ELSE IF( LDP2.LT.NP ) THEN - INFO = -7 - END IF -C - IF ( INFO.NE.0 ) THEN -C -C Error return. -C - CALL XERBLA( 'UD01BD', -INFO ) - RETURN - END IF -C -C Skip the text line preceding P(i) and read P(i), i = 0, ..., DP, -C row after row. -C - DO 20 K = 1, DP + 1 - READ ( NIN, FMT = '()' ) -C - DO 10 I = 1, MP - READ ( NIN, FMT = * ) ( P(I,J,K), J = 1, NP ) - 10 CONTINUE -C - 20 CONTINUE -C - RETURN -C *** Last line of UD01BD *** - END diff --git a/mex/sources/libslicot/UD01CD.f b/mex/sources/libslicot/UD01CD.f deleted file mode 100644 index 52a104558..000000000 --- a/mex/sources/libslicot/UD01CD.f +++ /dev/null @@ -1,174 +0,0 @@ - SUBROUTINE UD01CD( MP, NP, DP, NIN, P, LDP1, LDP2, INFO ) -C -C SLICOT RELEASE 5.0. -C -C Copyright (c) 2002-2009 NICONET e.V. -C -C This program is free software: you can redistribute it and/or -C modify it under the terms of the GNU General Public License as -C published by the Free Software Foundation, either version 2 of -C the License, or (at your option) any later version. -C -C This program is distributed in the hope that it will be useful, -C but WITHOUT ANY WARRANTY; without even the implied warranty of -C MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the -C GNU General Public License for more details. -C -C You should have received a copy of the GNU General Public License -C along with this program. If not, see -C . -C -C PURPOSE -C -C To read the elements of a sparse matrix polynomial -C dp-1 dp -C P(s) = P(0) + P(1) * s + . . . + P(dp-1) * s + P(dp) * s . -C -C ARGUMENTS -C -C Input/Output Parameters -C -C MP (input) INTEGER -C The number of rows of the matrix polynomial P(s). -C MP >= 1. -C -C NP (input) INTEGER -C The number of columns of the matrix polynomial P(s). -C NP >= 1. -C -C DP (input) INTEGER -C The degree of the matrix polynomial P(s). DP >= 0. -C -C NIN (input) INTEGER -C The input channel from which the elements of P(s) are -C read. NIN >= 0. -C -C P (output) DOUBLE PRECISION array, dimension -C (LDP1,LDP2,DP+1) -C The leading MP-by-NP-by-(DP+1) part of this array contains -C the coefficients of the matrix polynomial P(s). -C Specifically, P(i,j,k) contains the coefficient of -C s**(k-1) of the polynomial which is the (i,j)-th element -C of P(s), where i = 1,2,...,MP, j = 1,2,...,NP and -C k = 1,2,...,DP+1. -C The not assigned elements are set to zero. -C -C LDP1 INTEGER -C The leading dimension of array P. LDP1 >= MP. -C -C LDP2 INTEGER -C The second dimension of array P. LDP2 >= NP. -C -C Error Indicator -C -C INFO INTEGER -C = 0: successful exit; -C < 0: if INFO = -i, the i-th argument had an illegal -C value; -C = 1 : if a row index i is read with i < 1 or i > MP or -C a column index j is read with j < 1 or j > NP or -C a coefficient degree d is read with d < 0 or -C d > DP + 1. This is a warning. -C -C METHOD -C -C First, the elements P(i,j,k) with 1 <= i <= MP, 1 <= j <= NP and -C 1 <= k <= DP + 1 are set to zero. Next the nonzero (polynomial) -C elements are read from the input file NIN. Each nonzero element is -C given by the values i, j, d, P(i,j,k), k = 1, ..., d+1, where d is -C the degree and P(i,j,k) is the coefficient of s**(k-1) in the -C (i,j)-th element of P(s), i.e., let -C d -C P (s) = P (0) + P (1) * s + . . . + P (d) * s -C i,j i,j i,j i,j -C -C be the nonzero (i,j)-th element of the matrix polynomial P(s). -C -C Then P(i,j,k) corresponds to coefficient P (k-1), k = 1,...,d+1. -C i,j -C For each nonzero element, the values i, j, and d are read as one -C record of the file NIN, and the values P(i,j,k), k = 1,...,d+1, -C are read as the following record. -C The routine terminates after the last line has been read. -C -C REFERENCES -C -C None. -C -C NUMERICAL ASPECTS -C -C None. -C -C CONTRIBUTOR -C -C Release 3.0: V. Sima, Katholieke Univ. Leuven, Belgium, June 1998. -C Based on routine RDSPOM by A.J. Geurts, Eindhoven University of -C Technology, Holland. -C -C REVISIONS -C -C - -C -C ****************************************************************** -C -C .. Parameters .. - DOUBLE PRECISION ZERO - PARAMETER ( ZERO = 0.0D0 ) -C .. Scalar Arguments .. - INTEGER DP, INFO, LDP1, LDP2, MP, NP, NIN -C .. Array Arguments .. - DOUBLE PRECISION P(LDP1,LDP2,*) -C .. Local Scalars .. - INTEGER D, I, J, K -C .. External Subroutines .. - EXTERNAL DLASET, XERBLA -C -C .. Executable Statements .. -C - INFO = 0 -C -C Check the input scalar arguments. -C - IF( MP.LT.1 ) THEN - INFO = -1 - ELSE IF( NP.LT.1 ) THEN - INFO = -2 - ELSE IF( DP.LT.0 ) THEN - INFO = -3 - ELSE IF( NIN.LT.0 ) THEN - INFO = -4 - ELSE IF( LDP1.LT.MP ) THEN - INFO = -6 - ELSE IF( LDP2.LT.NP ) THEN - INFO = -7 - END IF -C - IF ( INFO.NE.0 ) THEN -C -C Error return. -C - CALL XERBLA( 'UD01CD', -INFO ) - RETURN - END IF -C - DO 10 K = 1, DP+1 - CALL DLASET( 'Full', MP, NP, ZERO, ZERO, P(1,1,K), LDP1 ) - 10 CONTINUE -C -C Read (i, j, d, P(i,j,k), k=1,...,d+1) of the nonzero elements one -C by one. -C - 20 READ( NIN, FMT = *, END = 30 ) I, J, D - IF ( I.LT.1 .OR. I.GT.MP .OR. J.LT.1 .OR. J.GT.NP .OR. - $ D.LT.0 .OR. D.GT.(DP+1) ) THEN - INFO = 1 - READ ( NIN, FMT = * ) - ELSE - READ ( NIN, FMT = * ) ( P(I,J,K), K = 1, D+1 ) - END IF - GO TO 20 -C - 30 CONTINUE - RETURN -C *** Last line of UD01CD *** - END diff --git a/mex/sources/libslicot/UD01DD.f b/mex/sources/libslicot/UD01DD.f deleted file mode 100644 index d09cadbd3..000000000 --- a/mex/sources/libslicot/UD01DD.f +++ /dev/null @@ -1,138 +0,0 @@ - SUBROUTINE UD01DD( M, N, NIN, A, LDA, INFO ) -C -C SLICOT RELEASE 5.0. -C -C Copyright (c) 2002-2009 NICONET e.V. -C -C This program is free software: you can redistribute it and/or -C modify it under the terms of the GNU General Public License as -C published by the Free Software Foundation, either version 2 of -C the License, or (at your option) any later version. -C -C This program is distributed in the hope that it will be useful, -C but WITHOUT ANY WARRANTY; without even the implied warranty of -C MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the -C GNU General Public License for more details. -C -C You should have received a copy of the GNU General Public License -C along with this program. If not, see -C . -C -C PURPOSE -C -C To read the elements of a sparse matrix. -C -C ARGUMENTS -C -C Input/Output Parameters -C -C M (input) INTEGER -C The number of rows of the matrix A. M >= 0. -C -C N (input) INTEGER -C The number of columns of the matrix A. N >= 0. -C -C NIN (input) INTEGER -C The input channel from which the elements of A are read. -C NIN >= 0. -C -C A (output) DOUBLE PRECISION array, dimension (LDA,N) -C The leading M-by-N part of this array contains the sparse -C matrix A. The not assigned elements are set to zero. -C -C LDA INTEGER -C The leading dimension of array A. LDA >= MAX(1,M). -C -C Error Indicator -C -C INFO INTEGER -C = 0: successful exit; -C < 0: if INFO = -i, the i-th argument had an illegal -C value; -C = 1 : if a row index i is read with i < 1 or i > M or -C a column index j is read with j < 1 or j > N. -C This is a warning. -C -C METHOD -C -C First, the elements A(i,j) with 1 <= i <= M and 1 <= j <= N are -C set to zero. Next the nonzero elements are read from the input -C file NIN. Each line of NIN must contain consecutively the values -C i, j, A(i,j). The routine terminates after the last line has been -C read. -C -C REFERENCES -C -C None. -C -C NUMERICAL ASPECTS -C -C None. -C -C CONTRIBUTOR -C -C Release 3.0: V. Sima, Katholieke Univ. Leuven, Belgium, June 1998. -C Based on routine RDSPAR by A.J. Geurts, Eindhoven University of -C Technology, Holland. -C -C REVISIONS -C -C - -C -C ****************************************************************** -C -C .. Parameters .. - DOUBLE PRECISION ZERO - PARAMETER ( ZERO = 0.0D0 ) -C .. Scalar Arguments .. - INTEGER INFO, LDA, M, N, NIN -C .. Array Arguments .. - DOUBLE PRECISION A(LDA,*) -C .. Local Scalars .. - INTEGER I, J - DOUBLE PRECISION AIJ -C .. External Subroutines .. - EXTERNAL DLASET, XERBLA -C .. Intrinsic Functions .. - INTRINSIC MAX -C -C .. Executable statements .. -C - INFO = 0 -C -C Check the input scalar arguments. -C - IF( M.LT.0 ) THEN - INFO = -1 - ELSE IF( N.LT.0 ) THEN - INFO = -2 - ELSE IF( NIN.LT.0 ) THEN - INFO = -3 - ELSE IF( LDA.LT.MAX( 1, M ) ) THEN - INFO = -5 - END IF -C - IF ( INFO.NE.0 ) THEN -C -C Error return. -C - CALL XERBLA( 'UD01DD', -INFO ) - RETURN - END IF -C - CALL DLASET( 'Full', M, N, ZERO, ZERO, A, LDA ) -C -C Read (i, j, A(i,j)) of the nonzero elements one by one. -C - 10 READ( NIN, FMT = *, END = 20 ) I, J, AIJ - IF ( I.LT.1 .OR. I.GT.M .OR. J.LT.1 .OR. J.GT.N ) THEN - INFO = 1 - ELSE - A(I,J) = AIJ - END IF - GO TO 10 - 20 CONTINUE -C - RETURN -C *** Last line of UD01DD *** - END diff --git a/mex/sources/libslicot/UD01MD.f b/mex/sources/libslicot/UD01MD.f deleted file mode 100644 index a44e6545c..000000000 --- a/mex/sources/libslicot/UD01MD.f +++ /dev/null @@ -1,175 +0,0 @@ - SUBROUTINE UD01MD( M, N, L, NOUT, A, LDA, TEXT, INFO ) -C -C SLICOT RELEASE 5.0. -C -C Copyright (c) 2002-2009 NICONET e.V. -C -C This program is free software: you can redistribute it and/or -C modify it under the terms of the GNU General Public License as -C published by the Free Software Foundation, either version 2 of -C the License, or (at your option) any later version. -C -C This program is distributed in the hope that it will be useful, -C but WITHOUT ANY WARRANTY; without even the implied warranty of -C MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the -C GNU General Public License for more details. -C -C You should have received a copy of the GNU General Public License -C along with this program. If not, see -C . -C -C PURPOSE -C -C To print an M-by-N real matrix A row by row. The elements of A -C are output to 7 significant figures. -C -C ARGUMENTS -C -C Input/Output Parameters -C -C M (input) INTEGER -C The number of rows of matrix A to be printed. M >= 1. -C -C N (input) INTEGER -C The number of columns of matrix A to be printed. N >= 1. -C -C L (input) INTEGER -C The number of elements of matrix A to be printed per line. -C 1 <= L <= 5. -C -C NOUT (input) INTEGER -C The output channel to which the results are sent. -C NOUT >= 0. -C -C A (input) DOUBLE PRECISION array, dimension (LDA,N) -C The leading M-by-N part of this array must contain the -C matrix to be printed. -C -C LDA INTEGER -C The leading dimension of array A. LDA >= M. -C -C TEXT (input) CHARACTER*72. -C Title caption of the matrix to be printed (up to a -C maximum of 72 characters). For example, TEXT = 'Matrix A'. -C -C Error Indicator -C -C INFO INTEGER -C = 0: successful exit; -C < 0: if INFO = -i, the i-th argument had an illegal -C value. -C -C METHOD -C -C The routine first prints the contents of TEXT as a title, followed -C by the elements of the matrix A such that -C -C (i) if N <= L, the leading M-by-N part is printed; -C (ii) if N = k*L + p (where k,p > 0), then k M-by-L blocks of -C consecutive columns of A are printed one after another -C followed by one M-by-p block containing the last p columns -C of A. -C -C Row numbers are printed on the left of each row and a column -C number appears on top of each column. -C The routine uses 2 + (k + 1)*(m + 1) lines and 8 + 15*c positions -C per line where c is the actual number of columns, (i.e. c = L -C or c = p). -C -C REFERENCES -C -C None. -C -C NUMERICAL ASPECTS -C -C None. -C -C CONTRIBUTOR -C -C Release 3.0: V. Sima, Katholieke Univ. Leuven, Belgium, Oct. 1997. -C Supersedes Release 2.0 routine UD01AD by H. Willemsen, Eindhoven -C University of Technology, Holland. -C -C REVISIONS -C -C V. Sima, Research Institute for Informatics, Bucharest, Jan. 2009. -C -C ****************************************************************** -C -C .. Scalar Arguments .. - INTEGER INFO, L, LDA, M, N, NOUT - CHARACTER*(*) TEXT -C .. Array Arguments .. - DOUBLE PRECISION A(LDA,*) -C .. Local Scalars .. - INTEGER I, J, J1, J2, JJ, LENTXT, LTEXT, N1 -C .. External Subroutines .. - EXTERNAL XERBLA -C .. Intrinsic Functions .. - INTRINSIC LEN, MIN -C .. Executable Statements .. -C - INFO = 0 -C -C Test the input scalar arguments. -C - IF( M.LT.1 ) THEN - INFO = -1 - ELSE IF( N.LT.1 ) THEN - INFO = -2 - ELSE IF( L.LT.1 .OR. L.GT.5 ) THEN - INFO = -3 - ELSE IF( NOUT.LT.0 ) THEN - INFO = -4 - ELSE IF( LDA.LT.M ) THEN - INFO = -6 - END IF -C - IF ( INFO.NE.0 ) THEN -C -C Error return. -C - CALL XERBLA( 'UD01MD', -INFO ) - RETURN - END IF -C - LENTXT = LEN( TEXT ) -C - DO 20 LTEXT = MIN( 72, LENTXT ), 2, -1 - IF ( TEXT(LTEXT:LTEXT).NE.' ' ) GO TO 40 - 20 CONTINUE -C - 40 CONTINUE - WRITE ( NOUT, FMT=99996 ) TEXT(1:LTEXT), M, N - N1 = ( N-1 )/L - J1 = 1 - J2 = L -C - DO 80 J = 1, N1 - WRITE ( NOUT, FMT=99999 ) ( JJ, JJ=J1, J2 ) -C - DO 60 I = 1, M - WRITE ( NOUT, FMT=99997 ) I, ( A(I,JJ), JJ=J1, J2 ) - 60 CONTINUE -C - WRITE ( NOUT, FMT=99998 ) - J1 = J1 + L - J2 = J2 + L - 80 CONTINUE -C - WRITE ( NOUT, FMT=99999 ) ( J, J=J1, N ) -C - DO 100 I = 1, M - WRITE ( NOUT, FMT=99997 ) I, ( A(I,JJ), JJ=J1, N ) - 100 CONTINUE -C - WRITE ( NOUT, FMT=99998 ) -C - RETURN -C -99999 FORMAT (8X,5(5X,I5,5X) ) -99998 FORMAT (' ' ) -99997 FORMAT (1X,I5,2X,5D15.7 ) -99996 FORMAT (1X,A,' (',I5,'X',I5,')',/ ) -C *** Last line of UD01MD *** - END diff --git a/mex/sources/libslicot/UD01MZ.f b/mex/sources/libslicot/UD01MZ.f deleted file mode 100644 index a9d83f706..000000000 --- a/mex/sources/libslicot/UD01MZ.f +++ /dev/null @@ -1,175 +0,0 @@ - SUBROUTINE UD01MZ( M, N, L, NOUT, A, LDA, TEXT, INFO ) -C -C SLICOT RELEASE 5.0. -C -C Copyright (c) 2002-2009 NICONET e.V. -C -C This program is free software: you can redistribute it and/or -C modify it under the terms of the GNU General Public License as -C published by the Free Software Foundation, either version 2 of -C the License, or (at your option) any later version. -C -C This program is distributed in the hope that it will be useful, -C but WITHOUT ANY WARRANTY; without even the implied warranty of -C MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the -C GNU General Public License for more details. -C -C You should have received a copy of the GNU General Public License -C along with this program. If not, see -C . -C -C PURPOSE -C -C To print an M-by-N real matrix A row by row. The elements of A -C are output to 7 significant figures. -C -C ARGUMENTS -C -C Input/Output Parameters -C -C M (input) INTEGER -C The number of rows of matrix A to be printed. M >= 1. -C -C N (input) INTEGER -C The number of columns of matrix A to be printed. N >= 1. -C -C L (input) INTEGER -C The number of elements of matrix A to be printed per line. -C 1 <= L <= 3. -C -C NOUT (input) INTEGER -C The output channel to which the results are sent. -C NOUT >= 0. -C -C A (input) COMPLEX*16 array, dimension (LDA,N) -C The leading M-by-N part of this array must contain the -C matrix to be printed. -C -C LDA INTEGER -C The leading dimension of array A. LDA >= M. -C -C TEXT (input) CHARACTER*72. -C Title caption of the matrix to be printed (up to a -C maximum of 72 characters). For example, TEXT = 'Matrix A'. -C -C Error Indicator -C -C INFO INTEGER -C = 0: successful exit; -C < 0: if INFO = -i, the i-th argument had an illegal -C value. -C -C METHOD -C -C The routine first prints the contents of TEXT as a title, followed -C by the elements of the matrix A such that -C -C (i) if N <= L, the leading M-by-N part is printed; -C (ii) if N = k*L + p (where k,p > 0), then k M-by-L blocks of -C consecutive columns of A are printed one after another -C followed by one M-by-p block containing the last p columns -C of A. -C -C Row numbers are printed on the left of each row and a column -C number appears on top of each complex column. -C The routine uses 2 + (k + 1)*(m + 1) lines and 7 + 32*c positions -C per line where c is the actual number of columns, (i.e. c = L -C or c = p). -C -C REFERENCES -C -C None. -C -C NUMERICAL ASPECTS -C -C None. -C -C CONTRIBUTOR -C -C Release 3.0: V. Sima, Katholieke Univ. Leuven, Belgium, Oct. 1997. -C Complex version: V. Sima, Research Institute for Informatics, -C Bucharest, Dec. 2008. -C -C REVISIONS -C -C - -C -C ****************************************************************** -C -C .. Scalar Arguments .. - INTEGER INFO, L, LDA, M, N, NOUT - CHARACTER*(*) TEXT -C .. Array Arguments .. - COMPLEX*16 A(LDA,*) -C .. Local Scalars .. - INTEGER I, J, J1, J2, JJ, LENTXT, LTEXT, N1 -C .. External Subroutines .. - EXTERNAL XERBLA -C .. Intrinsic Functions .. - INTRINSIC LEN, MIN -C .. Executable Statements .. -C - INFO = 0 -C -C Test the input scalar arguments. -C - IF( M.LT.1 ) THEN - INFO = -1 - ELSE IF( N.LT.1 ) THEN - INFO = -2 - ELSE IF( L.LT.1 .OR. L.GT.3 ) THEN - INFO = -3 - ELSE IF( NOUT.LT.0 ) THEN - INFO = -4 - ELSE IF( LDA.LT.M ) THEN - INFO = -6 - END IF -C - IF ( INFO.NE.0 ) THEN -C -C Error return. -C - CALL XERBLA( 'UD01MZ', -INFO ) - RETURN - END IF -C - LENTXT = LEN( TEXT ) -C - DO 20 LTEXT = MIN( 72, LENTXT ), 2, -1 - IF ( TEXT(LTEXT:LTEXT).NE.' ' ) GO TO 40 - 20 CONTINUE -C - 40 CONTINUE - WRITE ( NOUT, FMT=99996 ) TEXT(1:LTEXT), M, N - N1 = ( N-1 )/L - J1 = 1 - J2 = L -C - DO 80 J = 1, N1 - WRITE ( NOUT, FMT=99999 ) ( JJ, JJ=J1, J2 ) -C - DO 60 I = 1, M - WRITE ( NOUT, FMT=99997 ) I, ( A(I,JJ), JJ=J1, J2 ) - 60 CONTINUE -C - WRITE ( NOUT, FMT=99998 ) - J1 = J1 + L - J2 = J2 + L - 80 CONTINUE -C - WRITE ( NOUT, FMT=99999 ) ( J, J=J1, N ) -C - DO 100 I = 1, M - WRITE ( NOUT, FMT=99997 ) I, ( A(I,JJ), JJ=J1, N ) - 100 CONTINUE -C - WRITE ( NOUT, FMT=99998 ) -C - RETURN -C -99999 FORMAT (7X,5(13X,I5,14X) ) -99998 FORMAT (' ' ) -99997 FORMAT (1X,I5,2X,3(D15.7,SP,D15.7,S,'i ') ) -99996 FORMAT (1X,A,' (',I5,'X',I5,')',/ ) -C *** Last line of UD01MZ *** - END diff --git a/mex/sources/libslicot/UD01ND.f b/mex/sources/libslicot/UD01ND.f deleted file mode 100644 index 1791f9865..000000000 --- a/mex/sources/libslicot/UD01ND.f +++ /dev/null @@ -1,203 +0,0 @@ - SUBROUTINE UD01ND( MP, NP, DP, L, NOUT, P, LDP1, LDP2, TEXT, - $ INFO ) -C -C SLICOT RELEASE 5.0. -C -C Copyright (c) 2002-2009 NICONET e.V. -C -C This program is free software: you can redistribute it and/or -C modify it under the terms of the GNU General Public License as -C published by the Free Software Foundation, either version 2 of -C the License, or (at your option) any later version. -C -C This program is distributed in the hope that it will be useful, -C but WITHOUT ANY WARRANTY; without even the implied warranty of -C MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the -C GNU General Public License for more details. -C -C You should have received a copy of the GNU General Public License -C along with this program. If not, see -C . -C -C PURPOSE -C -C To print the MP-by-NP coefficient matrices of a matrix polynomial -C dp-1 dp -C P(s) = P(0) + P(1) * s + . . . + P(dp-1) * s + P(dp) * s . -C -C The elements of the matrices are output to 7 significant figures. -C -C ARGUMENTS -C -C Input/Output Parameters -C -C MP (input) INTEGER -C The number of rows of the matrix polynomial P(s). -C MP >= 1. -C -C NP (input) INTEGER -C The number of columns of the matrix polynomial P(s). -C NP >= 1. -C -C DP (input) INTEGER -C The degree of the matrix polynomial P(s). DP >= 0. -C -C L (input) INTEGER -C The number of elements of the coefficient matrices to be -C printed per line. 1 <= L <= 5. -C -C NOUT (input) INTEGER -C The output channel to which the results are sent. -C NOUT >= 0. -C -C P (input) DOUBLE PRECISION array, dimension (LDP1,LDP2,DP+1) -C The leading MP-by-NP-by-(DP+1) part of this array must -C contain the coefficients of the matrix polynomial P(s). -C Specifically, P(i,j,k) must contain the coefficient of -C s**(k-1) of the polynomial which is the (i,j)-th element -C of P(s), where i = 1,2,...,MP, j = 1,2,...,NP and -C k = 1,2,...,DP+1. -C -C LDP1 INTEGER -C The leading dimension of array P. LDP1 >= MP. -C -C LDP2 INTEGER -C The second dimension of array P. LDP2 >= NP. -C -C TEXT (input) CHARACTER*72 -C Title caption of the coefficient matrices to be printed. -C TEXT is followed by the degree of the coefficient matrix, -C within brackets. If TEXT = ' ', then the coefficient -C matrices are separated by an empty line. -C -C Error Indicator -C -C INFO INTEGER -C = 0: successful exit; -C < 0: if INFO = -i, the i-th argument had an illegal -C value. -C -C METHOD -C -C For i = 1, 2, ..., DP + 1 the routine first prints the contents of -C TEXT followed by (i-1) as a title, followed by the elements of the -C MP-by-NP coefficient matrix P(i) such that -C (i) if NP < L, then the leading MP-by-NP part is printed; -C (ii) if NP = k*L + p (where k, p > 0), then k MP-by-L blocks of -C consecutive columns of P(i) are printed one after another -C followed by one MP-by-p block containing the last p columns -C of P(i). -C Row numbers are printed on the left of each row and a column -C number on top of each column. -C -C REFERENCES -C -C None. -C -C NUMERICAL ASPECTS -C -C None. -C -C CONTRIBUTOR -C -C Release 3.0: V. Sima, Katholieke Univ. Leuven, Belgium, June 1998. -C Based on routine PRMAPO by A.J. Geurts, Eindhoven University of -C Technology, Holland. -C -C REVISIONS -C -C - -C -C ****************************************************************** -C -C .. Scalar Arguments .. - INTEGER DP, INFO, L, LDP1, LDP2, MP, NP, NOUT - CHARACTER*(*) TEXT -C .. Array Arguments .. - DOUBLE PRECISION P(LDP1,LDP2,*) -C .. Local Scalars .. - INTEGER I, J, J1, J2, JJ, K, LENTXT, LTEXT, N1 -C .. External Subroutines .. - EXTERNAL XERBLA -C .. Intrinsic Functions .. - INTRINSIC LEN, MIN -C -C .. Executable Statements .. -C - INFO = 0 -C -C Check the input scalar arguments. -C - IF( MP.LT.1 ) THEN - INFO = -1 - ELSE IF( NP.LT.1 ) THEN - INFO = -2 - ELSE IF( DP.LT.0 ) THEN - INFO = -3 - ELSE IF( L.LT.1 .OR. L.GT.5 ) THEN - INFO = -4 - ELSE IF( NOUT.LT.0 ) THEN - INFO = -5 - ELSE IF( LDP1.LT.MP ) THEN - INFO = -7 - ELSE IF( LDP2.LT.NP ) THEN - INFO = -8 - END IF -C - IF ( INFO.NE.0 ) THEN -C -C Error return. -C - CALL XERBLA( 'UD01ND', -INFO ) - RETURN - END IF -C - LENTXT = LEN( TEXT ) - LTEXT = MIN( 72, LENTXT ) -C WHILE ( TEXT(LTEXT:LTEXT) = ' ' ) DO - 10 IF ( TEXT(LTEXT:LTEXT).EQ.' ' ) THEN - LTEXT = LTEXT - 1 - GO TO 10 - END IF -C END WHILE 10 -C - DO 50 K = 1, DP + 1 - IF ( LTEXT.EQ.0 ) THEN - WRITE ( NOUT, FMT = 99999 ) - ELSE - WRITE ( NOUT, FMT = 99998 ) TEXT(1:LTEXT), K - 1, MP, NP - END IF - N1 = ( NP - 1 )/L - J1 = 1 - J2 = L -C - DO 30 J = 1, N1 - WRITE ( NOUT, FMT = 99997 ) ( JJ, JJ = J1, J2 ) -C - DO 20 I = 1, MP - WRITE ( NOUT, FMT = 99996 ) I, ( P(I,JJ,K), JJ = J1, J2 ) - 20 CONTINUE -C - J1 = J1 + L - J2 = J2 + L - 30 CONTINUE -C - WRITE ( NOUT, FMT = 99997 ) ( J, J = J1, NP ) -C - DO 40 I = 1, MP - WRITE ( NOUT, FMT = 99996 ) I, ( P(I,JJ,K), JJ = J1, NP ) - 40 CONTINUE -C - 50 CONTINUE -C - WRITE ( NOUT, FMT = 99999 ) -C - RETURN -C -99999 FORMAT (' ') -99998 FORMAT (/, 1X, A, '(', I2, ')', ' (', I2, 'X', I2, ')') -99997 FORMAT (5X, 5(6X, I2, 7X)) -99996 FORMAT (1X, I2, 2X, 5D15.7) -C -C *** Last line of UD01ND *** - END diff --git a/mex/sources/libslicot/UE01MD.f b/mex/sources/libslicot/UE01MD.f deleted file mode 100644 index c460bf9bf..000000000 --- a/mex/sources/libslicot/UE01MD.f +++ /dev/null @@ -1,266 +0,0 @@ - INTEGER FUNCTION UE01MD( ISPEC, NAME, OPTS, N1, N2, N3 ) -C -C SLICOT RELEASE 5.0. -C -C Copyright (c) 2002-2009 NICONET e.V. -C -C This program is free software: you can redistribute it and/or -C modify it under the terms of the GNU General Public License as -C published by the Free Software Foundation, either version 2 of -C the License, or (at your option) any later version. -C -C This program is distributed in the hope that it will be useful, -C but WITHOUT ANY WARRANTY; without even the implied warranty of -C MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the -C GNU General Public License for more details. -C -C You should have received a copy of the GNU General Public License -C along with this program. If not, see -C . -C -C PURPOSE -C -C To provide an extension of the LAPACK routine ILAENV to -C machine-specific parameters for SLICOT routines. -C -C The default values in this version aim to give good performance on -C a wide range of computers. For optimal performance, however, the -C user is advised to modify this routine. Note that an optimized -C BLAS is a crucial prerequisite for any speed gains. For further -C details, see ILAENV. -C -C FUNCTION VALUE -C -C UE01MD INTEGER -C The function value set according to ISPEC. -C -C ARGUMENTS -C -C Input/Output Parameters -C -C ISPEC (input) INTEGER -C Specifies the parameter to be returned as the value of -C UE01MD, as follows: -C = 1: the optimal blocksize; if the returned value is 1, an -C unblocked algorithm will give the best performance; -C = 2: the minimum block size for which the block routine -C should be used; if the usable block size is less than -C this value, an unblocked routine should be used; -C = 3: the crossover point (in a block routine, for N less -C than this value, an unblocked routine should be used) -C = 4: the number of shifts, used in the product eigenvalue -C routine; -C = 8: the crossover point for the multishift QR method for -C product eigenvalue problems. -C -C NAME (input) CHARACTER*(*) -C The name of the calling subroutine, in either upper case -C or lower case. -C -C OPTS (input) CHARACTER*(*) -C The character options to the subroutine NAME, concatenated -C into a single character string. -C -C N1 (input) INTEGER -C N2 (input) INTEGER -C N3 (input) INTEGER -C Problem dimensions for the subroutine NAME; these may not -C all be required. -C -C CONTRIBUTORS -C -C D. Kressner, Technical Univ. Berlin, Germany, and -C P. Benner, Technical Univ. Chemnitz, Germany, December 2003. -C -C REVISIONS -C -C V. Sima, June 2008 (SLICOT version of the HAPACK routine ILAHAP). -C -C ****************************************************************** -C -C .. Scalar Arguments .. - CHARACTER*( * ) NAME, OPTS - INTEGER ISPEC, N1, N2, N3 -C -C .. Local Scalars .. - LOGICAL CNAME, SNAME - CHARACTER*1 C1, C3 - CHARACTER*2 C2 - CHARACTER*6 SUBNAM - INTEGER I, IC, IZ, NB, NBMIN, NX -C .. External Functions .. - INTEGER ILAENV - EXTERNAL ILAENV -C .. Intrinsic Functions .. - INTRINSIC CHAR, ICHAR, MAX -C -C .. Executable Statements .. -C - IF ( ISPEC.EQ.1 .OR. ISPEC.EQ.2 .OR. ISPEC.EQ.3 ) THEN -C -C Convert NAME to upper case if the first character is lower -C case. -C - UE01MD = 1 - SUBNAM = NAME - IC = ICHAR( SUBNAM( 1:1 ) ) - IZ = ICHAR( 'Z' ) - IF ( IZ.EQ.90 .OR. IZ.EQ.122 ) THEN -C -C ASCII character set. -C - IF ( IC.GE.97 .AND. IC.LE.122 ) THEN - SUBNAM( 1:1 ) = CHAR( IC-32 ) - DO 10 I = 2, 6 - IC = ICHAR( SUBNAM( I:I ) ) - IF( IC.GE.97 .AND. IC.LE.122 ) - $ SUBNAM( I:I ) = CHAR( IC-32 ) - 10 CONTINUE - END IF -C - ELSE IF ( IZ.EQ.233 .OR. IZ.EQ.169 ) THEN -C -C EBCDIC character set. -C - IF ( ( IC.GE.129 .AND. IC.LE.137 ) .OR. - $ ( IC.GE.145 .AND. IC.LE.153 ) .OR. - $ ( IC.GE.162 .AND. IC.LE.169 ) ) THEN - SUBNAM( 1:1 ) = CHAR( IC+64 ) - DO 20 I = 2, 6 - IC = ICHAR( SUBNAM( I:I ) ) - IF ( ( IC.GE.129 .AND. IC.LE.137 ) .OR. - $ ( IC.GE.145 .AND. IC.LE.153 ) .OR. - $ ( IC.GE.162 .AND. IC.LE.169 ) ) - $ SUBNAM( I:I ) = CHAR( IC+64 ) - 20 CONTINUE - END IF -C - ELSE IF ( IZ.EQ.218 .OR. IZ.EQ.250 ) THEN -C -C Prime machines: ASCII+128. -C - IF ( IC.GE.225 .AND. IC.LE.250 ) THEN - SUBNAM( 1:1 ) = CHAR( IC-32 ) - DO 30 I = 2, 6 - IC = ICHAR( SUBNAM( I:I ) ) - IF ( IC.GE.225 .AND. IC.LE.250 ) - $ SUBNAM( I:I ) = CHAR( IC-32 ) - 30 CONTINUE - END IF - END IF -C - C1 = SUBNAM( 1:1 ) - SNAME = C1.EQ.'S' .OR. C1.EQ.'D' - CNAME = C1.EQ.'C' .OR. C1.EQ.'Z' - IF ( .NOT.( CNAME .OR. SNAME ) ) - $ RETURN - C2 = SUBNAM( 4:5 ) - C3 = SUBNAM( 6:6 ) -C - IF ( ISPEC.EQ.1 ) THEN -C -C Block size. -C - NB = 1 - IF ( C2.EQ.'4S' .OR. C2.EQ.'4T' ) THEN - IF ( C3.EQ.'B' ) THEN - NB = ILAENV( 1, 'DGEQRF', ' ', N1, N2, -1, -1 ) / 2 - ELSE IF ( C3.EQ.'T' ) THEN - NB = ILAENV( 1, 'DGEHRD', ' ', N1, N2, N1, -1 ) / 4 - END IF - ELSE IF ( C2.EQ.'4P' ) THEN - IF ( C3.EQ.'B' ) THEN - NB = ILAENV( 1, 'DGEHRD', ' ', N1, N2, N1, -1 ) / 2 - END IF - ELSE IF ( C2.EQ.'4W' .OR. C2.EQ.'4Q' ) THEN - IF ( C3.EQ.'D' ) THEN - NB = ILAENV( 1, 'DORGQR', ' ', N1, N2, N3, -1 ) / 2 - ELSE IF ( C3.EQ.'B' ) THEN - NB = ILAENV( 1, 'DORMQR', ' ', N1, N2, N3, -1 ) / 2 - END IF -** ELSE IF ( C2.EQ.'SH' ) THEN -** IF ( C3.EQ.'PVB' ) THEN -** NB = ILAENV( 1, 'DGEHRD', ' ', N1, N2, N1, -1 ) / 2 -** END IF - END IF - UE01MD = NB - ELSE IF ( ISPEC.EQ.2 ) THEN -C -C Minimum block size. -C - NBMIN = 2 - IF ( C2.EQ.'4S' .OR. C2.EQ.'4T' ) THEN - IF ( C3.EQ.'B' ) THEN - NBMIN = MAX( 2, ILAENV( 2, 'DGEQRF', ' ', N1, N2, -1, - $ -1 ) / 2 ) - ELSE IF ( C3.EQ.'T' ) THEN - NBMIN = MAX( 2, ILAENV( 2, 'DGEHRD', ' ', N1, N2, N1, - $ -1 ) / 4 ) - END IF - ELSE IF ( C2.EQ.'4P' ) THEN - IF ( C3.EQ.'B' ) THEN - NBMIN = MAX( 2, ILAENV( 2, 'DGEHRD', ' ', N1, N2, N1, - $ -1 ) / 4 ) - END IF - ELSE IF ( C2.EQ.'4W' .OR. C2.EQ.'4Q' ) THEN - IF ( C3.EQ.'D' ) THEN - NBMIN = MAX( 2, ILAENV( 2, 'DORGQR', ' ', N1, N2, N3, - $ -1 ) / 2 ) - ELSE IF ( C3.EQ.'B' ) THEN - NBMIN = MAX( 2, ILAENV( 2, 'DORMQR', ' ', N1, N2, N3, - $ -1 ) / 2 ) - END IF -** ELSE IF ( C2.EQ.'SH' ) THEN -** IF ( C3.EQ.'PVB' ) THEN -** NBMIN = MAX( 2, ILAENV( 2, 'DGEHRD', ' ', N1, N2, N1, -** $ -1 ) / 4 ) -** END IF - END IF - UE01MD = NBMIN - ELSE IF ( ISPEC.EQ.3 ) THEN -C -C Crossover point. -C - NX = 0 - IF ( C2.EQ.'4S' .OR. C2.EQ.'4T' ) THEN - IF ( C3.EQ.'B' ) THEN - NX = ILAENV( 3, 'DGEQRF', ' ', N1, N2, -1, -1 ) - ELSE IF ( C3.EQ.'T' ) THEN - NX = ILAENV( 3, 'DGEHRD', ' ', N1, N2, N1, -1 ) / 2 - END IF - ELSE IF ( C2.EQ.'4P' ) THEN - IF ( C3.EQ.'B' ) THEN - NX = ILAENV( 3, 'DGEHRD', ' ', N1, N2, N1, -1 ) / 2 - END IF - ELSE IF ( C2.EQ.'4W' .OR. C2.EQ.'4Q' ) THEN - IF ( C3.EQ.'D' ) THEN - NX = ILAENV( 3, 'DORGQR', ' ', N1, N2, N3, -1 ) - ELSE IF ( C3.EQ.'B' ) THEN - NX = ILAENV( 3, 'DORGQR', ' ', N1, N2, N3, -1 ) - END IF -** ELSE IF ( C2.EQ.'SH' ) THEN -** IF ( C3.EQ.'PVB' ) THEN -** NX = ILAENV( 3, 'DGEHRD', ' ', N1, N2, N1, -1 ) / 2 -** END IF - END IF - UE01MD = NX - END IF - ELSE IF ( ISPEC.EQ.4 ) THEN -C -C Number of shifts (used by MB03XP). -C - UE01MD = ILAENV( 4, 'DHSEQR', OPTS, N1, N2, N3, -1 ) - ELSE IF ( ISPEC.EQ.8 ) THEN -C -C Crossover point for multishift (used by MB03XP). -C - UE01MD = ILAENV( 8, 'DHSEQR', OPTS, N1, N2, N3, -1 ) - ELSE -C -C Invalid value for ISPEC. -C - UE01MD = -1 - END IF - RETURN -C *** Last line of UE01MD *** - END diff --git a/mex/sources/libslicot/dcabs1.f b/mex/sources/libslicot/dcabs1.f deleted file mode 100644 index c4acbeb5a..000000000 --- a/mex/sources/libslicot/dcabs1.f +++ /dev/null @@ -1,16 +0,0 @@ - DOUBLE PRECISION FUNCTION DCABS1(Z) -* .. Scalar Arguments .. - DOUBLE COMPLEX Z -* .. -* .. -* Purpose -* ======= -* -* DCABS1 computes absolute value of a double complex number -* -* .. Intrinsic Functions .. - INTRINSIC ABS,DBLE,DIMAG -* - DCABS1 = ABS(DBLE(Z)) + ABS(DIMAG(Z)) - RETURN - END diff --git a/mex/sources/libslicot/delctg.f b/mex/sources/libslicot/delctg.f deleted file mode 100644 index b6b44b7c8..000000000 --- a/mex/sources/libslicot/delctg.f +++ /dev/null @@ -1,27 +0,0 @@ - LOGICAL FUNCTION DELCTG( PAR1, PAR2, PAR3 ) -C -C SLICOT RELEASE 5.0. -C -C Copyright (c) 2002-2009 NICONET e.V. -C -C This program is free software: you can redistribute it and/or -C modify it under the terms of the GNU General Public License as -C published by the Free Software Foundation, either version 2 of -C the License, or (at your option) any later version. -C -C This program is distributed in the hope that it will be useful, -C but WITHOUT ANY WARRANTY; without even the implied warranty of -C MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the -C GNU General Public License for more details. -C -C You should have received a copy of the GNU General Public License -C along with this program. If not, see -C . -C -C Void logical function for DGGES. -C - DOUBLE PRECISION PAR1, PAR2, PAR3 -C - DELCTG = .TRUE. - RETURN - END diff --git a/mex/sources/libslicot/dhgeqz.f b/mex/sources/libslicot/dhgeqz.f deleted file mode 100644 index 2269451e1..000000000 --- a/mex/sources/libslicot/dhgeqz.f +++ /dev/null @@ -1,1249 +0,0 @@ - SUBROUTINE DHGEQZ( JOB, COMPQ, COMPZ, N, ILO, IHI, H, LDH, T, LDT, - $ ALPHAR, ALPHAI, BETA, Q, LDQ, Z, LDZ, WORK, - $ LWORK, INFO ) -* -* -- LAPACK routine (version 3.2) -- -* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. -* November 2006 -* -* .. Scalar Arguments .. - CHARACTER COMPQ, COMPZ, JOB - INTEGER IHI, ILO, INFO, LDH, LDQ, LDT, LDZ, LWORK, N -* .. -* .. Array Arguments .. - DOUBLE PRECISION ALPHAI( * ), ALPHAR( * ), BETA( * ), - $ H( LDH, * ), Q( LDQ, * ), T( LDT, * ), - $ WORK( * ), Z( LDZ, * ) -* .. -* -* Purpose -* ======= -* -* DHGEQZ computes the eigenvalues of a real matrix pair (H,T), -* where H is an upper Hessenberg matrix and T is upper triangular, -* using the double-shift QZ method. -* Matrix pairs of this type are produced by the reduction to -* generalized upper Hessenberg form of a real matrix pair (A,B): -* -* A = Q1*H*Z1**T, B = Q1*T*Z1**T, -* -* as computed by DGGHRD. -* -* If JOB='S', then the Hessenberg-triangular pair (H,T) is -* also reduced to generalized Schur form, -* -* H = Q*S*Z**T, T = Q*P*Z**T, -* -* where Q and Z are orthogonal matrices, P is an upper triangular -* matrix, and S is a quasi-triangular matrix with 1-by-1 and 2-by-2 -* diagonal blocks. -* -* The 1-by-1 blocks correspond to real eigenvalues of the matrix pair -* (H,T) and the 2-by-2 blocks correspond to complex conjugate pairs of -* eigenvalues. -* -* Additionally, the 2-by-2 upper triangular diagonal blocks of P -* corresponding to 2-by-2 blocks of S are reduced to positive diagonal -* form, i.e., if S(j+1,j) is non-zero, then P(j+1,j) = P(j,j+1) = 0, -* P(j,j) > 0, and P(j+1,j+1) > 0. -* -* Optionally, the orthogonal matrix Q from the generalized Schur -* factorization may be postmultiplied into an input matrix Q1, and the -* orthogonal matrix Z may be postmultiplied into an input matrix Z1. -* If Q1 and Z1 are the orthogonal matrices from DGGHRD that reduced -* the matrix pair (A,B) to generalized upper Hessenberg form, then the -* output matrices Q1*Q and Z1*Z are the orthogonal factors from the -* generalized Schur factorization of (A,B): -* -* A = (Q1*Q)*S*(Z1*Z)**T, B = (Q1*Q)*P*(Z1*Z)**T. -* -* To avoid overflow, eigenvalues of the matrix pair (H,T) (equivalently, -* of (A,B)) are computed as a pair of values (alpha,beta), where alpha is -* complex and beta real. -* If beta is nonzero, lambda = alpha / beta is an eigenvalue of the -* generalized nonsymmetric eigenvalue problem (GNEP) -* A*x = lambda*B*x -* and if alpha is nonzero, mu = beta / alpha is an eigenvalue of the -* alternate form of the GNEP -* mu*A*y = B*y. -* Real eigenvalues can be read directly from the generalized Schur -* form: -* alpha = S(i,i), beta = P(i,i). -* -* Ref: C.B. Moler & G.W. Stewart, "An Algorithm for Generalized Matrix -* Eigenvalue Problems", SIAM J. Numer. Anal., 10(1973), -* pp. 241--256. -* -* Arguments -* ========= -* -* JOB (input) CHARACTER*1 -* = 'E': Compute eigenvalues only; -* = 'S': Compute eigenvalues and the Schur form. -* -* COMPQ (input) CHARACTER*1 -* = 'N': Left Schur vectors (Q) are not computed; -* = 'I': Q is initialized to the unit matrix and the matrix Q -* of left Schur vectors of (H,T) is returned; -* = 'V': Q must contain an orthogonal matrix Q1 on entry and -* the product Q1*Q is returned. -* -* COMPZ (input) CHARACTER*1 -* = 'N': Right Schur vectors (Z) are not computed; -* = 'I': Z is initialized to the unit matrix and the matrix Z -* of right Schur vectors of (H,T) is returned; -* = 'V': Z must contain an orthogonal matrix Z1 on entry and -* the product Z1*Z is returned. -* -* N (input) INTEGER -* The order of the matrices H, T, Q, and Z. N >= 0. -* -* ILO (input) INTEGER -* IHI (input) INTEGER -* ILO and IHI mark the rows and columns of H which are in -* Hessenberg form. It is assumed that A is already upper -* triangular in rows and columns 1:ILO-1 and IHI+1:N. -* If N > 0, 1 <= ILO <= IHI <= N; if N = 0, ILO=1 and IHI=0. -* -* H (input/output) DOUBLE PRECISION array, dimension (LDH, N) -* On entry, the N-by-N upper Hessenberg matrix H. -* On exit, if JOB = 'S', H contains the upper quasi-triangular -* matrix S from the generalized Schur factorization; -* 2-by-2 diagonal blocks (corresponding to complex conjugate -* pairs of eigenvalues) are returned in standard form, with -* H(i,i) = H(i+1,i+1) and H(i+1,i)*H(i,i+1) < 0. -* If JOB = 'E', the diagonal blocks of H match those of S, but -* the rest of H is unspecified. -* -* LDH (input) INTEGER -* The leading dimension of the array H. LDH >= max( 1, N ). -* -* T (input/output) DOUBLE PRECISION array, dimension (LDT, N) -* On entry, the N-by-N upper triangular matrix T. -* On exit, if JOB = 'S', T contains the upper triangular -* matrix P from the generalized Schur factorization; -* 2-by-2 diagonal blocks of P corresponding to 2-by-2 blocks of S -* are reduced to positive diagonal form, i.e., if H(j+1,j) is -* non-zero, then T(j+1,j) = T(j,j+1) = 0, T(j,j) > 0, and -* T(j+1,j+1) > 0. -* If JOB = 'E', the diagonal blocks of T match those of P, but -* the rest of T is unspecified. -* -* LDT (input) INTEGER -* The leading dimension of the array T. LDT >= max( 1, N ). -* -* ALPHAR (output) DOUBLE PRECISION array, dimension (N) -* The real parts of each scalar alpha defining an eigenvalue -* of GNEP. -* -* ALPHAI (output) DOUBLE PRECISION array, dimension (N) -* The imaginary parts of each scalar alpha defining an -* eigenvalue of GNEP. -* If ALPHAI(j) is zero, then the j-th eigenvalue is real; if -* positive, then the j-th and (j+1)-st eigenvalues are a -* complex conjugate pair, with ALPHAI(j+1) = -ALPHAI(j). -* -* BETA (output) DOUBLE PRECISION array, dimension (N) -* The scalars beta that define the eigenvalues of GNEP. -* Together, the quantities alpha = (ALPHAR(j),ALPHAI(j)) and -* beta = BETA(j) represent the j-th eigenvalue of the matrix -* pair (A,B), in one of the forms lambda = alpha/beta or -* mu = beta/alpha. Since either lambda or mu may overflow, -* they should not, in general, be computed. -* -* Q (input/output) DOUBLE PRECISION array, dimension (LDQ, N) -* On entry, if COMPZ = 'V', the orthogonal matrix Q1 used in -* the reduction of (A,B) to generalized Hessenberg form. -* On exit, if COMPZ = 'I', the orthogonal matrix of left Schur -* vectors of (H,T), and if COMPZ = 'V', the orthogonal matrix -* of left Schur vectors of (A,B). -* Not referenced if COMPZ = 'N'. -* -* LDQ (input) INTEGER -* The leading dimension of the array Q. LDQ >= 1. -* If COMPQ='V' or 'I', then LDQ >= N. -* -* Z (input/output) DOUBLE PRECISION array, dimension (LDZ, N) -* On entry, if COMPZ = 'V', the orthogonal matrix Z1 used in -* the reduction of (A,B) to generalized Hessenberg form. -* On exit, if COMPZ = 'I', the orthogonal matrix of -* right Schur vectors of (H,T), and if COMPZ = 'V', the -* orthogonal matrix of right Schur vectors of (A,B). -* Not referenced if COMPZ = 'N'. -* -* LDZ (input) INTEGER -* The leading dimension of the array Z. LDZ >= 1. -* If COMPZ='V' or 'I', then LDZ >= N. -* -* WORK (workspace/output) DOUBLE PRECISION array, dimension (MAX(1,LWORK)) -* On exit, if INFO >= 0, WORK(1) returns the optimal LWORK. -* -* LWORK (input) INTEGER -* The dimension of the array WORK. LWORK >= max(1,N). -* -* If LWORK = -1, then a workspace query is assumed; the routine -* only calculates the optimal size of the WORK array, returns -* this value as the first entry of the WORK array, and no error -* message related to LWORK is issued by XERBLA. -* -* INFO (output) INTEGER -* = 0: successful exit -* < 0: if INFO = -i, the i-th argument had an illegal value -* = 1,...,N: the QZ iteration did not converge. (H,T) is not -* in Schur form, but ALPHAR(i), ALPHAI(i), and -* BETA(i), i=INFO+1,...,N should be correct. -* = N+1,...,2*N: the shift calculation failed. (H,T) is not -* in Schur form, but ALPHAR(i), ALPHAI(i), and -* BETA(i), i=INFO-N+1,...,N should be correct. -* -* Further Details -* =============== -* -* Iteration counters: -* -* JITER -- counts iterations. -* IITER -- counts iterations run since ILAST was last -* changed. This is therefore reset only when a 1-by-1 or -* 2-by-2 block deflates off the bottom. -* -* ===================================================================== -* -* .. Parameters .. -* $ SAFETY = 1.0E+0 ) - DOUBLE PRECISION HALF, ZERO, ONE, SAFETY - PARAMETER ( HALF = 0.5D+0, ZERO = 0.0D+0, ONE = 1.0D+0, - $ SAFETY = 1.0D+2 ) -* .. -* .. Local Scalars .. - LOGICAL ILAZR2, ILAZRO, ILPIVT, ILQ, ILSCHR, ILZ, - $ LQUERY - INTEGER ICOMPQ, ICOMPZ, IFIRST, IFRSTM, IITER, ILAST, - $ ILASTM, IN, ISCHUR, ISTART, J, JC, JCH, JITER, - $ JR, MAXIT - DOUBLE PRECISION A11, A12, A1I, A1R, A21, A22, A2I, A2R, AD11, - $ AD11L, AD12, AD12L, AD21, AD21L, AD22, AD22L, - $ AD32L, AN, ANORM, ASCALE, ATOL, B11, B1A, B1I, - $ B1R, B22, B2A, B2I, B2R, BN, BNORM, BSCALE, - $ BTOL, C, C11I, C11R, C12, C21, C22I, C22R, CL, - $ CQ, CR, CZ, ESHIFT, S, S1, S1INV, S2, SAFMAX, - $ SAFMIN, SCALE, SL, SQI, SQR, SR, SZI, SZR, T1, - $ TAU, TEMP, TEMP2, TEMPI, TEMPR, U1, U12, U12L, - $ U2, ULP, VS, W11, W12, W21, W22, WABS, WI, WR, - $ WR2 -* .. -* .. Local Arrays .. - DOUBLE PRECISION V( 3 ) -* .. -* .. External Functions .. - LOGICAL LSAME - DOUBLE PRECISION DLAMCH, DLANHS, DLAPY2, DLAPY3 - EXTERNAL LSAME, DLAMCH, DLANHS, DLAPY2, DLAPY3 -* .. -* .. External Subroutines .. - EXTERNAL DLAG2, DLARFG, DLARTG, DLASET, DLASV2, DROT, - $ XERBLA -* .. -* .. Intrinsic Functions .. - INTRINSIC ABS, DBLE, MAX, MIN, SQRT -* .. -* .. Executable Statements .. -* -* Decode JOB, COMPQ, COMPZ -* - IF( LSAME( JOB, 'E' ) ) THEN - ILSCHR = .FALSE. - ISCHUR = 1 - ELSE IF( LSAME( JOB, 'S' ) ) THEN - ILSCHR = .TRUE. - ISCHUR = 2 - ELSE - ISCHUR = 0 - END IF -* - IF( LSAME( COMPQ, 'N' ) ) THEN - ILQ = .FALSE. - ICOMPQ = 1 - ELSE IF( LSAME( COMPQ, 'V' ) ) THEN - ILQ = .TRUE. - ICOMPQ = 2 - ELSE IF( LSAME( COMPQ, 'I' ) ) THEN - ILQ = .TRUE. - ICOMPQ = 3 - ELSE - ICOMPQ = 0 - END IF -* - IF( LSAME( COMPZ, 'N' ) ) THEN - ILZ = .FALSE. - ICOMPZ = 1 - ELSE IF( LSAME( COMPZ, 'V' ) ) THEN - ILZ = .TRUE. - ICOMPZ = 2 - ELSE IF( LSAME( COMPZ, 'I' ) ) THEN - ILZ = .TRUE. - ICOMPZ = 3 - ELSE - ICOMPZ = 0 - END IF -* -* Check Argument Values -* - INFO = 0 - WORK( 1 ) = MAX( 1, N ) - LQUERY = ( LWORK.EQ.-1 ) - IF( ISCHUR.EQ.0 ) THEN - INFO = -1 - ELSE IF( ICOMPQ.EQ.0 ) THEN - INFO = -2 - ELSE IF( ICOMPZ.EQ.0 ) THEN - INFO = -3 - ELSE IF( N.LT.0 ) THEN - INFO = -4 - ELSE IF( ILO.LT.1 ) THEN - INFO = -5 - ELSE IF( IHI.GT.N .OR. IHI.LT.ILO-1 ) THEN - INFO = -6 - ELSE IF( LDH.LT.N ) THEN - INFO = -8 - ELSE IF( LDT.LT.N ) THEN - INFO = -10 - ELSE IF( LDQ.LT.1 .OR. ( ILQ .AND. LDQ.LT.N ) ) THEN - INFO = -15 - ELSE IF( LDZ.LT.1 .OR. ( ILZ .AND. LDZ.LT.N ) ) THEN - INFO = -17 - ELSE IF( LWORK.LT.MAX( 1, N ) .AND. .NOT.LQUERY ) THEN - INFO = -19 - END IF - IF( INFO.NE.0 ) THEN - CALL XERBLA( 'DHGEQZ', -INFO ) - RETURN - ELSE IF( LQUERY ) THEN - RETURN - END IF -* -* Quick return if possible -* - IF( N.LE.0 ) THEN - WORK( 1 ) = DBLE( 1 ) - RETURN - END IF -* -* Initialize Q and Z -* - IF( ICOMPQ.EQ.3 ) - $ CALL DLASET( 'Full', N, N, ZERO, ONE, Q, LDQ ) - IF( ICOMPZ.EQ.3 ) - $ CALL DLASET( 'Full', N, N, ZERO, ONE, Z, LDZ ) -* -* Machine Constants -* - IN = IHI + 1 - ILO - SAFMIN = DLAMCH( 'S' ) - SAFMAX = ONE / SAFMIN - ULP = DLAMCH( 'E' )*DLAMCH( 'B' ) - ANORM = DLANHS( 'F', IN, H( ILO, ILO ), LDH, WORK ) - BNORM = DLANHS( 'F', IN, T( ILO, ILO ), LDT, WORK ) - ATOL = MAX( SAFMIN, ULP*ANORM ) - BTOL = MAX( SAFMIN, ULP*BNORM ) - ASCALE = ONE / MAX( SAFMIN, ANORM ) - BSCALE = ONE / MAX( SAFMIN, BNORM ) -* -* Set Eigenvalues IHI+1:N -* - DO 30 J = IHI + 1, N - IF( T( J, J ).LT.ZERO ) THEN - IF( ILSCHR ) THEN - DO 10 JR = 1, J - H( JR, J ) = -H( JR, J ) - T( JR, J ) = -T( JR, J ) - 10 CONTINUE - ELSE - H( J, J ) = -H( J, J ) - T( J, J ) = -T( J, J ) - END IF - IF( ILZ ) THEN - DO 20 JR = 1, N - Z( JR, J ) = -Z( JR, J ) - 20 CONTINUE - END IF - END IF - ALPHAR( J ) = H( J, J ) - ALPHAI( J ) = ZERO - BETA( J ) = T( J, J ) - 30 CONTINUE -* -* If IHI < ILO, skip QZ steps -* - IF( IHI.LT.ILO ) - $ GO TO 380 -* -* MAIN QZ ITERATION LOOP -* -* Initialize dynamic indices -* -* Eigenvalues ILAST+1:N have been found. -* Column operations modify rows IFRSTM:whatever. -* Row operations modify columns whatever:ILASTM. -* -* If only eigenvalues are being computed, then -* IFRSTM is the row of the last splitting row above row ILAST; -* this is always at least ILO. -* IITER counts iterations since the last eigenvalue was found, -* to tell when to use an extraordinary shift. -* MAXIT is the maximum number of QZ sweeps allowed. -* - ILAST = IHI - IF( ILSCHR ) THEN - IFRSTM = 1 - ILASTM = N - ELSE - IFRSTM = ILO - ILASTM = IHI - END IF - IITER = 0 - ESHIFT = ZERO - MAXIT = 30*( IHI-ILO+1 ) -* - DO 360 JITER = 1, MAXIT -* -* Split the matrix if possible. -* -* Two tests: -* 1: H(j,j-1)=0 or j=ILO -* 2: T(j,j)=0 -* - IF( ILAST.EQ.ILO ) THEN -* -* Special case: j=ILAST -* - GO TO 80 - ELSE - IF( ABS( H( ILAST, ILAST-1 ) ).LE.ATOL ) THEN - H( ILAST, ILAST-1 ) = ZERO - GO TO 80 - END IF - END IF -* - IF( ABS( T( ILAST, ILAST ) ).LE.BTOL ) THEN - T( ILAST, ILAST ) = ZERO - GO TO 70 - END IF -* -* General case: j unfl ) -* __ -* (sA - wB) ( CZ -SZ ) -* ( SZ CZ ) -* - C11R = S1*A11 - WR*B11 - C11I = -WI*B11 - C12 = S1*A12 - C21 = S1*A21 - C22R = S1*A22 - WR*B22 - C22I = -WI*B22 -* - IF( ABS( C11R )+ABS( C11I )+ABS( C12 ).GT.ABS( C21 )+ - $ ABS( C22R )+ABS( C22I ) ) THEN - T1 = DLAPY3( C12, C11R, C11I ) - CZ = C12 / T1 - SZR = -C11R / T1 - SZI = -C11I / T1 - ELSE - CZ = DLAPY2( C22R, C22I ) - IF( CZ.LE.SAFMIN ) THEN - CZ = ZERO - SZR = ONE - SZI = ZERO - ELSE - TEMPR = C22R / CZ - TEMPI = C22I / CZ - T1 = DLAPY2( CZ, C21 ) - CZ = CZ / T1 - SZR = -C21*TEMPR / T1 - SZI = C21*TEMPI / T1 - END IF - END IF -* -* Compute Givens rotation on left -* -* ( CQ SQ ) -* ( __ ) A or B -* ( -SQ CQ ) -* - AN = ABS( A11 ) + ABS( A12 ) + ABS( A21 ) + ABS( A22 ) - BN = ABS( B11 ) + ABS( B22 ) - WABS = ABS( WR ) + ABS( WI ) - IF( S1*AN.GT.WABS*BN ) THEN - CQ = CZ*B11 - SQR = SZR*B22 - SQI = -SZI*B22 - ELSE - A1R = CZ*A11 + SZR*A12 - A1I = SZI*A12 - A2R = CZ*A21 + SZR*A22 - A2I = SZI*A22 - CQ = DLAPY2( A1R, A1I ) - IF( CQ.LE.SAFMIN ) THEN - CQ = ZERO - SQR = ONE - SQI = ZERO - ELSE - TEMPR = A1R / CQ - TEMPI = A1I / CQ - SQR = TEMPR*A2R + TEMPI*A2I - SQI = TEMPI*A2R - TEMPR*A2I - END IF - END IF - T1 = DLAPY3( CQ, SQR, SQI ) - CQ = CQ / T1 - SQR = SQR / T1 - SQI = SQI / T1 -* -* Compute diagonal elements of QBZ -* - TEMPR = SQR*SZR - SQI*SZI - TEMPI = SQR*SZI + SQI*SZR - B1R = CQ*CZ*B11 + TEMPR*B22 - B1I = TEMPI*B22 - B1A = DLAPY2( B1R, B1I ) - B2R = CQ*CZ*B22 + TEMPR*B11 - B2I = -TEMPI*B11 - B2A = DLAPY2( B2R, B2I ) -* -* Normalize so beta > 0, and Im( alpha1 ) > 0 -* - BETA( ILAST-1 ) = B1A - BETA( ILAST ) = B2A - ALPHAR( ILAST-1 ) = ( WR*B1A )*S1INV - ALPHAI( ILAST-1 ) = ( WI*B1A )*S1INV - ALPHAR( ILAST ) = ( WR*B2A )*S1INV - ALPHAI( ILAST ) = -( WI*B2A )*S1INV -* -* Step 3: Go to next block -- exit if finished. -* - ILAST = IFIRST - 1 - IF( ILAST.LT.ILO ) - $ GO TO 380 -* -* Reset counters -* - IITER = 0 - ESHIFT = ZERO - IF( .NOT.ILSCHR ) THEN - ILASTM = ILAST - IF( IFRSTM.GT.ILAST ) - $ IFRSTM = ILO - END IF - GO TO 350 - ELSE -* -* Usual case: 3x3 or larger block, using Francis implicit -* double-shift -* -* 2 -* Eigenvalue equation is w - c w + d = 0, -* -* -1 2 -1 -* so compute 1st column of (A B ) - c A B + d -* using the formula in QZIT (from EISPACK) -* -* We assume that the block is at least 3x3 -* - AD11 = ( ASCALE*H( ILAST-1, ILAST-1 ) ) / - $ ( BSCALE*T( ILAST-1, ILAST-1 ) ) - AD21 = ( ASCALE*H( ILAST, ILAST-1 ) ) / - $ ( BSCALE*T( ILAST-1, ILAST-1 ) ) - AD12 = ( ASCALE*H( ILAST-1, ILAST ) ) / - $ ( BSCALE*T( ILAST, ILAST ) ) - AD22 = ( ASCALE*H( ILAST, ILAST ) ) / - $ ( BSCALE*T( ILAST, ILAST ) ) - U12 = T( ILAST-1, ILAST ) / T( ILAST, ILAST ) - AD11L = ( ASCALE*H( IFIRST, IFIRST ) ) / - $ ( BSCALE*T( IFIRST, IFIRST ) ) - AD21L = ( ASCALE*H( IFIRST+1, IFIRST ) ) / - $ ( BSCALE*T( IFIRST, IFIRST ) ) - AD12L = ( ASCALE*H( IFIRST, IFIRST+1 ) ) / - $ ( BSCALE*T( IFIRST+1, IFIRST+1 ) ) - AD22L = ( ASCALE*H( IFIRST+1, IFIRST+1 ) ) / - $ ( BSCALE*T( IFIRST+1, IFIRST+1 ) ) - AD32L = ( ASCALE*H( IFIRST+2, IFIRST+1 ) ) / - $ ( BSCALE*T( IFIRST+1, IFIRST+1 ) ) - U12L = T( IFIRST, IFIRST+1 ) / T( IFIRST+1, IFIRST+1 ) -* - V( 1 ) = ( AD11-AD11L )*( AD22-AD11L ) - AD12*AD21 + - $ AD21*U12*AD11L + ( AD12L-AD11L*U12L )*AD21L - V( 2 ) = ( ( AD22L-AD11L )-AD21L*U12L-( AD11-AD11L )- - $ ( AD22-AD11L )+AD21*U12 )*AD21L - V( 3 ) = AD32L*AD21L -* - ISTART = IFIRST -* - CALL DLARFG( 3, V( 1 ), V( 2 ), 1, TAU ) - V( 1 ) = ONE -* -* Sweep -* - DO 290 J = ISTART, ILAST - 2 -* -* All but last elements: use 3x3 Householder transforms. -* -* Zero (j-1)st column of A -* - IF( J.GT.ISTART ) THEN - V( 1 ) = H( J, J-1 ) - V( 2 ) = H( J+1, J-1 ) - V( 3 ) = H( J+2, J-1 ) -* - CALL DLARFG( 3, H( J, J-1 ), V( 2 ), 1, TAU ) - V( 1 ) = ONE - H( J+1, J-1 ) = ZERO - H( J+2, J-1 ) = ZERO - END IF -* - DO 230 JC = J, ILASTM - TEMP = TAU*( H( J, JC )+V( 2 )*H( J+1, JC )+V( 3 )* - $ H( J+2, JC ) ) - H( J, JC ) = H( J, JC ) - TEMP - H( J+1, JC ) = H( J+1, JC ) - TEMP*V( 2 ) - H( J+2, JC ) = H( J+2, JC ) - TEMP*V( 3 ) - TEMP2 = TAU*( T( J, JC )+V( 2 )*T( J+1, JC )+V( 3 )* - $ T( J+2, JC ) ) - T( J, JC ) = T( J, JC ) - TEMP2 - T( J+1, JC ) = T( J+1, JC ) - TEMP2*V( 2 ) - T( J+2, JC ) = T( J+2, JC ) - TEMP2*V( 3 ) - 230 CONTINUE - IF( ILQ ) THEN - DO 240 JR = 1, N - TEMP = TAU*( Q( JR, J )+V( 2 )*Q( JR, J+1 )+V( 3 )* - $ Q( JR, J+2 ) ) - Q( JR, J ) = Q( JR, J ) - TEMP - Q( JR, J+1 ) = Q( JR, J+1 ) - TEMP*V( 2 ) - Q( JR, J+2 ) = Q( JR, J+2 ) - TEMP*V( 3 ) - 240 CONTINUE - END IF -* -* Zero j-th column of B (see DLAGBC for details) -* -* Swap rows to pivot -* - ILPIVT = .FALSE. - TEMP = MAX( ABS( T( J+1, J+1 ) ), ABS( T( J+1, J+2 ) ) ) - TEMP2 = MAX( ABS( T( J+2, J+1 ) ), ABS( T( J+2, J+2 ) ) ) - IF( MAX( TEMP, TEMP2 ).LT.SAFMIN ) THEN - SCALE = ZERO - U1 = ONE - U2 = ZERO - GO TO 250 - ELSE IF( TEMP.GE.TEMP2 ) THEN - W11 = T( J+1, J+1 ) - W21 = T( J+2, J+1 ) - W12 = T( J+1, J+2 ) - W22 = T( J+2, J+2 ) - U1 = T( J+1, J ) - U2 = T( J+2, J ) - ELSE - W21 = T( J+1, J+1 ) - W11 = T( J+2, J+1 ) - W22 = T( J+1, J+2 ) - W12 = T( J+2, J+2 ) - U2 = T( J+1, J ) - U1 = T( J+2, J ) - END IF -* -* Swap columns if nec. -* - IF( ABS( W12 ).GT.ABS( W11 ) ) THEN - ILPIVT = .TRUE. - TEMP = W12 - TEMP2 = W22 - W12 = W11 - W22 = W21 - W11 = TEMP - W21 = TEMP2 - END IF -* -* LU-factor -* - TEMP = W21 / W11 - U2 = U2 - TEMP*U1 - W22 = W22 - TEMP*W12 - W21 = ZERO -* -* Compute SCALE -* - SCALE = ONE - IF( ABS( W22 ).LT.SAFMIN ) THEN - SCALE = ZERO - U2 = ONE - U1 = -W12 / W11 - GO TO 250 - END IF - IF( ABS( W22 ).LT.ABS( U2 ) ) - $ SCALE = ABS( W22 / U2 ) - IF( ABS( W11 ).LT.ABS( U1 ) ) - $ SCALE = MIN( SCALE, ABS( W11 / U1 ) ) -* -* Solve -* - U2 = ( SCALE*U2 ) / W22 - U1 = ( SCALE*U1-W12*U2 ) / W11 -* - 250 CONTINUE - IF( ILPIVT ) THEN - TEMP = U2 - U2 = U1 - U1 = TEMP - END IF -* -* Compute Householder Vector -* - T1 = SQRT( SCALE**2+U1**2+U2**2 ) - TAU = ONE + SCALE / T1 - VS = -ONE / ( SCALE+T1 ) - V( 1 ) = ONE - V( 2 ) = VS*U1 - V( 3 ) = VS*U2 -* -* Apply transformations from the right. -* - DO 260 JR = IFRSTM, MIN( J+3, ILAST ) - TEMP = TAU*( H( JR, J )+V( 2 )*H( JR, J+1 )+V( 3 )* - $ H( JR, J+2 ) ) - H( JR, J ) = H( JR, J ) - TEMP - H( JR, J+1 ) = H( JR, J+1 ) - TEMP*V( 2 ) - H( JR, J+2 ) = H( JR, J+2 ) - TEMP*V( 3 ) - 260 CONTINUE - DO 270 JR = IFRSTM, J + 2 - TEMP = TAU*( T( JR, J )+V( 2 )*T( JR, J+1 )+V( 3 )* - $ T( JR, J+2 ) ) - T( JR, J ) = T( JR, J ) - TEMP - T( JR, J+1 ) = T( JR, J+1 ) - TEMP*V( 2 ) - T( JR, J+2 ) = T( JR, J+2 ) - TEMP*V( 3 ) - 270 CONTINUE - IF( ILZ ) THEN - DO 280 JR = 1, N - TEMP = TAU*( Z( JR, J )+V( 2 )*Z( JR, J+1 )+V( 3 )* - $ Z( JR, J+2 ) ) - Z( JR, J ) = Z( JR, J ) - TEMP - Z( JR, J+1 ) = Z( JR, J+1 ) - TEMP*V( 2 ) - Z( JR, J+2 ) = Z( JR, J+2 ) - TEMP*V( 3 ) - 280 CONTINUE - END IF - T( J+1, J ) = ZERO - T( J+2, J ) = ZERO - 290 CONTINUE -* -* Last elements: Use Givens rotations -* -* Rotations from the left -* - J = ILAST - 1 - TEMP = H( J, J-1 ) - CALL DLARTG( TEMP, H( J+1, J-1 ), C, S, H( J, J-1 ) ) - H( J+1, J-1 ) = ZERO -* - DO 300 JC = J, ILASTM - TEMP = C*H( J, JC ) + S*H( J+1, JC ) - H( J+1, JC ) = -S*H( J, JC ) + C*H( J+1, JC ) - H( J, JC ) = TEMP - TEMP2 = C*T( J, JC ) + S*T( J+1, JC ) - T( J+1, JC ) = -S*T( J, JC ) + C*T( J+1, JC ) - T( J, JC ) = TEMP2 - 300 CONTINUE - IF( ILQ ) THEN - DO 310 JR = 1, N - TEMP = C*Q( JR, J ) + S*Q( JR, J+1 ) - Q( JR, J+1 ) = -S*Q( JR, J ) + C*Q( JR, J+1 ) - Q( JR, J ) = TEMP - 310 CONTINUE - END IF -* -* Rotations from the right. -* - TEMP = T( J+1, J+1 ) - CALL DLARTG( TEMP, T( J+1, J ), C, S, T( J+1, J+1 ) ) - T( J+1, J ) = ZERO -* - DO 320 JR = IFRSTM, ILAST - TEMP = C*H( JR, J+1 ) + S*H( JR, J ) - H( JR, J ) = -S*H( JR, J+1 ) + C*H( JR, J ) - H( JR, J+1 ) = TEMP - 320 CONTINUE - DO 330 JR = IFRSTM, ILAST - 1 - TEMP = C*T( JR, J+1 ) + S*T( JR, J ) - T( JR, J ) = -S*T( JR, J+1 ) + C*T( JR, J ) - T( JR, J+1 ) = TEMP - 330 CONTINUE - IF( ILZ ) THEN - DO 340 JR = 1, N - TEMP = C*Z( JR, J+1 ) + S*Z( JR, J ) - Z( JR, J ) = -S*Z( JR, J+1 ) + C*Z( JR, J ) - Z( JR, J+1 ) = TEMP - 340 CONTINUE - END IF -* -* End of Double-Shift code -* - END IF -* - GO TO 350 -* -* End of iteration loop -* - 350 CONTINUE - 360 CONTINUE -* -* Drop-through = non-convergence -* - INFO = ILAST - GO TO 420 -* -* Successful completion of all QZ steps -* - 380 CONTINUE -* -* Set Eigenvalues 1:ILO-1 -* - DO 410 J = 1, ILO - 1 - IF( T( J, J ).LT.ZERO ) THEN - IF( ILSCHR ) THEN - DO 390 JR = 1, J - H( JR, J ) = -H( JR, J ) - T( JR, J ) = -T( JR, J ) - 390 CONTINUE - ELSE - H( J, J ) = -H( J, J ) - T( J, J ) = -T( J, J ) - END IF - IF( ILZ ) THEN - DO 400 JR = 1, N - Z( JR, J ) = -Z( JR, J ) - 400 CONTINUE - END IF - END IF - ALPHAR( J ) = H( J, J ) - ALPHAI( J ) = ZERO - BETA( J ) = T( J, J ) - 410 CONTINUE -* -* Normal Termination -* - INFO = 0 -* -* Exit (other than argument error) -- return optimal workspace size -* - 420 CONTINUE - WORK( 1 ) = DBLE( N ) - RETURN -* -* End of DHGEQZ -* - END diff --git a/mex/sources/libslicot/dtgsy2.f b/mex/sources/libslicot/dtgsy2.f deleted file mode 100644 index 3486ec482..000000000 --- a/mex/sources/libslicot/dtgsy2.f +++ /dev/null @@ -1,956 +0,0 @@ - SUBROUTINE DTGSY2( TRANS, IJOB, M, N, A, LDA, B, LDB, C, LDC, D, - $ LDD, E, LDE, F, LDF, SCALE, RDSUM, RDSCAL, - $ IWORK, PQ, INFO ) -* -* -- LAPACK auxiliary routine (version 3.2) -- -* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. -* January 2007. V. Sima, February 2009: added IWORK in former 640. -* -* .. Scalar Arguments .. - CHARACTER TRANS - INTEGER IJOB, INFO, LDA, LDB, LDC, LDD, LDE, LDF, M, N, - $ PQ - DOUBLE PRECISION RDSCAL, RDSUM, SCALE -* .. -* .. Array Arguments .. - INTEGER IWORK( * ) - DOUBLE PRECISION A( LDA, * ), B( LDB, * ), C( LDC, * ), - $ D( LDD, * ), E( LDE, * ), F( LDF, * ) -* .. -* -* Purpose -* ======= -* -* DTGSY2 solves the generalized Sylvester equation: -* -* A * R - L * B = scale * C (1) -* D * R - L * E = scale * F, -* -* using Level 1 and 2 BLAS. where R and L are unknown M-by-N matrices, -* (A, D), (B, E) and (C, F) are given matrix pairs of size M-by-M, -* N-by-N and M-by-N, respectively, with real entries. (A, D) and (B, E) -* must be in generalized Schur canonical form, i.e. A, B are upper -* quasi triangular and D, E are upper triangular. The solution (R, L) -* overwrites (C, F). 0 <= SCALE <= 1 is an output scaling factor -* chosen to avoid overflow. -* -* In matrix notation solving equation (1) corresponds to solve -* Z*x = scale*b, where Z is defined as -* -* Z = [ kron(In, A) -kron(B', Im) ] (2) -* [ kron(In, D) -kron(E', Im) ], -* -* Ik is the identity matrix of size k and X' is the transpose of X. -* kron(X, Y) is the Kronecker product between the matrices X and Y. -* In the process of solving (1), we solve a number of such systems -* where Dim(In), Dim(In) = 1 or 2. -* -* If TRANS = 'T', solve the transposed system Z'*y = scale*b for y, -* which is equivalent to solve for R and L in -* -* A' * R + D' * L = scale * C (3) -* R * B' + L * E' = scale * -F -* -* This case is used to compute an estimate of Dif[(A, D), (B, E)] = -* sigma_min(Z) using reverse communicaton with DLACON. -* -* DTGSY2 also (IJOB >= 1) contributes to the computation in DTGSYL -* of an upper bound on the separation between to matrix pairs. Then -* the input (A, D), (B, E) are sub-pencils of the matrix pair in -* DTGSYL. See DTGSYL for details. -* -* Arguments -* ========= -* -* TRANS (input) CHARACTER*1 -* = 'N', solve the generalized Sylvester equation (1). -* = 'T': solve the 'transposed' system (3). -* -* IJOB (input) INTEGER -* Specifies what kind of functionality to be performed. -* = 0: solve (1) only. -* = 1: A contribution from this subsystem to a Frobenius -* norm-based estimate of the separation between two matrix -* pairs is computed. (look ahead strategy is used). -* = 2: A contribution from this subsystem to a Frobenius -* norm-based estimate of the separation between two matrix -* pairs is computed. (DGECON on sub-systems is used.) -* Not referenced if TRANS = 'T'. -* -* M (input) INTEGER -* On entry, M specifies the order of A and D, and the row -* dimension of C, F, R and L. -* -* N (input) INTEGER -* On entry, N specifies the order of B and E, and the column -* dimension of C, F, R and L. -* -* A (input) DOUBLE PRECISION array, dimension (LDA, M) -* On entry, A contains an upper quasi triangular matrix. -* -* LDA (input) INTEGER -* The leading dimension of the matrix A. LDA >= max(1, M). -* -* B (input) DOUBLE PRECISION array, dimension (LDB, N) -* On entry, B contains an upper quasi triangular matrix. -* -* LDB (input) INTEGER -* The leading dimension of the matrix B. LDB >= max(1, N). -* -* C (input/output) DOUBLE PRECISION array, dimension (LDC, N) -* On entry, C contains the right-hand-side of the first matrix -* equation in (1). -* On exit, if IJOB = 0, C has been overwritten by the -* solution R. -* -* LDC (input) INTEGER -* The leading dimension of the matrix C. LDC >= max(1, M). -* -* D (input) DOUBLE PRECISION array, dimension (LDD, M) -* On entry, D contains an upper triangular matrix. -* -* LDD (input) INTEGER -* The leading dimension of the matrix D. LDD >= max(1, M). -* -* E (input) DOUBLE PRECISION array, dimension (LDE, N) -* On entry, E contains an upper triangular matrix. -* -* LDE (input) INTEGER -* The leading dimension of the matrix E. LDE >= max(1, N). -* -* F (input/output) DOUBLE PRECISION array, dimension (LDF, N) -* On entry, F contains the right-hand-side of the second matrix -* equation in (1). -* On exit, if IJOB = 0, F has been overwritten by the -* solution L. -* -* LDF (input) INTEGER -* The leading dimension of the matrix F. LDF >= max(1, M). -* -* SCALE (output) DOUBLE PRECISION -* On exit, 0 <= SCALE <= 1. If 0 < SCALE < 1, the solutions -* R and L (C and F on entry) will hold the solutions to a -* slightly perturbed system but the input matrices A, B, D and -* E have not been changed. If SCALE = 0, R and L will hold the -* solutions to the homogeneous system with C = F = 0. Normally, -* SCALE = 1. -* -* RDSUM (input/output) DOUBLE PRECISION -* On entry, the sum of squares of computed contributions to -* the Dif-estimate under computation by DTGSYL, where the -* scaling factor RDSCAL (see below) has been factored out. -* On exit, the corresponding sum of squares updated with the -* contributions from the current sub-system. -* If TRANS = 'T' RDSUM is not touched. -* NOTE: RDSUM only makes sense when DTGSY2 is called by DTGSYL. -* -* RDSCAL (input/output) DOUBLE PRECISION -* On entry, scaling factor used to prevent overflow in RDSUM. -* On exit, RDSCAL is updated w.r.t. the current contributions -* in RDSUM. -* If TRANS = 'T', RDSCAL is not touched. -* NOTE: RDSCAL only makes sense when DTGSY2 is called by -* DTGSYL. -* -* IWORK (workspace) INTEGER array, dimension (M+N+2) -* -* PQ (output) INTEGER -* On exit, the number of subsystems (of size 2-by-2, 4-by-4 and -* 8-by-8) solved by this routine. -* -* INFO (output) INTEGER -* On exit, if INFO is set to -* =0: Successful exit -* <0: If INFO = -i, the i-th argument had an illegal value. -* >0: The matrix pairs (A, D) and (B, E) have common or very -* close eigenvalues. -* -* Further Details -* =============== -* -* Based on contributions by -* Bo Kagstrom and Peter Poromaa, Department of Computing Science, -* Umea University, S-901 87 Umea, Sweden. -* -* ===================================================================== -* Replaced various illegal calls to DCOPY by calls to DLASET. -* Sven Hammarling, 27/5/02. -* -* .. Parameters .. - INTEGER LDZ - PARAMETER ( LDZ = 8 ) - DOUBLE PRECISION ZERO, ONE - PARAMETER ( ZERO = 0.0D+0, ONE = 1.0D+0 ) -* .. -* .. Local Scalars .. - LOGICAL NOTRAN - INTEGER I, IE, IERR, II, IS, ISP1, J, JE, JJ, JS, JSP1, - $ K, MB, NB, P, Q, ZDIM - DOUBLE PRECISION ALPHA, SCALOC -* .. -* .. Local Arrays .. - INTEGER IPIV( LDZ ), JPIV( LDZ ) - DOUBLE PRECISION RHS( LDZ ), Z( LDZ, LDZ ) -* .. -* .. External Functions .. - LOGICAL LSAME - EXTERNAL LSAME -* .. -* .. External Subroutines .. - EXTERNAL DAXPY, DCOPY, DGEMM, DGEMV, DGER, DGESC2, - $ DGETC2, DLASET, DLATDF, DSCAL, XERBLA -* .. -* .. Intrinsic Functions .. - INTRINSIC MAX -* .. -* .. Executable Statements .. -* -* Decode and test input parameters -* - INFO = 0 - IERR = 0 - NOTRAN = LSAME( TRANS, 'N' ) - IF( .NOT.NOTRAN .AND. .NOT.LSAME( TRANS, 'T' ) ) THEN - INFO = -1 - ELSE IF( NOTRAN ) THEN - IF( ( IJOB.LT.0 ) .OR. ( IJOB.GT.2 ) ) THEN - INFO = -2 - END IF - END IF - IF( INFO.EQ.0 ) THEN - IF( M.LE.0 ) THEN - INFO = -3 - ELSE IF( N.LE.0 ) THEN - INFO = -4 - ELSE IF( LDA.LT.MAX( 1, M ) ) THEN - INFO = -5 - ELSE IF( LDB.LT.MAX( 1, N ) ) THEN - INFO = -8 - ELSE IF( LDC.LT.MAX( 1, M ) ) THEN - INFO = -10 - ELSE IF( LDD.LT.MAX( 1, M ) ) THEN - INFO = -12 - ELSE IF( LDE.LT.MAX( 1, N ) ) THEN - INFO = -14 - ELSE IF( LDF.LT.MAX( 1, M ) ) THEN - INFO = -16 - END IF - END IF - IF( INFO.NE.0 ) THEN - CALL XERBLA( 'DTGSY2', -INFO ) - RETURN - END IF -* -* Determine block structure of A -* - PQ = 0 - P = 0 - I = 1 - 10 CONTINUE - IF( I.GT.M ) - $ GO TO 20 - P = P + 1 - IWORK( P ) = I - IF( I.EQ.M ) - $ GO TO 20 - IF( A( I+1, I ).NE.ZERO ) THEN - I = I + 2 - ELSE - I = I + 1 - END IF - GO TO 10 - 20 CONTINUE - IWORK( P+1 ) = M + 1 -* -* Determine block structure of B -* - Q = P + 1 - J = 1 - 30 CONTINUE - IF( J.GT.N ) - $ GO TO 40 - Q = Q + 1 - IWORK( Q ) = J - IF( J.EQ.N ) - $ GO TO 40 - IF( B( J+1, J ).NE.ZERO ) THEN - J = J + 2 - ELSE - J = J + 1 - END IF - GO TO 30 - 40 CONTINUE - IWORK( Q+1 ) = N + 1 - PQ = P*( Q-P-1 ) -* - IF( NOTRAN ) THEN -* -* Solve (I, J) - subsystem -* A(I, I) * R(I, J) - L(I, J) * B(J, J) = C(I, J) -* D(I, I) * R(I, J) - L(I, J) * E(J, J) = F(I, J) -* for I = P, P - 1, ..., 1; J = 1, 2, ..., Q -* - SCALE = ONE - SCALOC = ONE - DO 120 J = P + 2, Q - JS = IWORK( J ) - JSP1 = JS + 1 - JE = IWORK( J+1 ) - 1 - NB = JE - JS + 1 - DO 110 I = P, 1, -1 -* - IS = IWORK( I ) - ISP1 = IS + 1 - IE = IWORK( I+1 ) - 1 - MB = IE - IS + 1 - ZDIM = MB*NB*2 -* - IF( ( MB.EQ.1 ) .AND. ( NB.EQ.1 ) ) THEN -* -* Build a 2-by-2 system Z * x = RHS -* - Z( 1, 1 ) = A( IS, IS ) - Z( 2, 1 ) = D( IS, IS ) - Z( 1, 2 ) = -B( JS, JS ) - Z( 2, 2 ) = -E( JS, JS ) -* -* Set up right hand side(s) -* - RHS( 1 ) = C( IS, JS ) - RHS( 2 ) = F( IS, JS ) -* -* Solve Z * x = RHS -* - CALL DGETC2( ZDIM, Z, LDZ, IPIV, JPIV, IERR ) - IF( IERR.GT.0 ) - $ INFO = IERR -* - IF( IJOB.EQ.0 ) THEN - CALL DGESC2( ZDIM, Z, LDZ, RHS, IPIV, JPIV, - $ SCALOC ) - IF( SCALOC.NE.ONE ) THEN - DO 50 K = 1, N - CALL DSCAL( M, SCALOC, C( 1, K ), 1 ) - CALL DSCAL( M, SCALOC, F( 1, K ), 1 ) - 50 CONTINUE - SCALE = SCALE*SCALOC - END IF - ELSE - CALL DLATDF( IJOB, ZDIM, Z, LDZ, RHS, RDSUM, - $ RDSCAL, IPIV, JPIV ) - END IF -* -* Unpack solution vector(s) -* - C( IS, JS ) = RHS( 1 ) - F( IS, JS ) = RHS( 2 ) -* -* Substitute R(I, J) and L(I, J) into remaining -* equation. -* - IF( I.GT.1 ) THEN - ALPHA = -RHS( 1 ) - CALL DAXPY( IS-1, ALPHA, A( 1, IS ), 1, C( 1, JS ), - $ 1 ) - CALL DAXPY( IS-1, ALPHA, D( 1, IS ), 1, F( 1, JS ), - $ 1 ) - END IF - IF( J.LT.Q ) THEN - CALL DAXPY( N-JE, RHS( 2 ), B( JS, JE+1 ), LDB, - $ C( IS, JE+1 ), LDC ) - CALL DAXPY( N-JE, RHS( 2 ), E( JS, JE+1 ), LDE, - $ F( IS, JE+1 ), LDF ) - END IF -* - ELSE IF( ( MB.EQ.1 ) .AND. ( NB.EQ.2 ) ) THEN -* -* Build a 4-by-4 system Z * x = RHS -* - Z( 1, 1 ) = A( IS, IS ) - Z( 2, 1 ) = ZERO - Z( 3, 1 ) = D( IS, IS ) - Z( 4, 1 ) = ZERO -* - Z( 1, 2 ) = ZERO - Z( 2, 2 ) = A( IS, IS ) - Z( 3, 2 ) = ZERO - Z( 4, 2 ) = D( IS, IS ) -* - Z( 1, 3 ) = -B( JS, JS ) - Z( 2, 3 ) = -B( JS, JSP1 ) - Z( 3, 3 ) = -E( JS, JS ) - Z( 4, 3 ) = -E( JS, JSP1 ) -* - Z( 1, 4 ) = -B( JSP1, JS ) - Z( 2, 4 ) = -B( JSP1, JSP1 ) - Z( 3, 4 ) = ZERO - Z( 4, 4 ) = -E( JSP1, JSP1 ) -* -* Set up right hand side(s) -* - RHS( 1 ) = C( IS, JS ) - RHS( 2 ) = C( IS, JSP1 ) - RHS( 3 ) = F( IS, JS ) - RHS( 4 ) = F( IS, JSP1 ) -* -* Solve Z * x = RHS -* - CALL DGETC2( ZDIM, Z, LDZ, IPIV, JPIV, IERR ) - IF( IERR.GT.0 ) - $ INFO = IERR -* - IF( IJOB.EQ.0 ) THEN - CALL DGESC2( ZDIM, Z, LDZ, RHS, IPIV, JPIV, - $ SCALOC ) - IF( SCALOC.NE.ONE ) THEN - DO 60 K = 1, N - CALL DSCAL( M, SCALOC, C( 1, K ), 1 ) - CALL DSCAL( M, SCALOC, F( 1, K ), 1 ) - 60 CONTINUE - SCALE = SCALE*SCALOC - END IF - ELSE - CALL DLATDF( IJOB, ZDIM, Z, LDZ, RHS, RDSUM, - $ RDSCAL, IPIV, JPIV ) - END IF -* -* Unpack solution vector(s) -* - C( IS, JS ) = RHS( 1 ) - C( IS, JSP1 ) = RHS( 2 ) - F( IS, JS ) = RHS( 3 ) - F( IS, JSP1 ) = RHS( 4 ) -* -* Substitute R(I, J) and L(I, J) into remaining -* equation. -* - IF( I.GT.1 ) THEN - CALL DGER( IS-1, NB, -ONE, A( 1, IS ), 1, RHS( 1 ), - $ 1, C( 1, JS ), LDC ) - CALL DGER( IS-1, NB, -ONE, D( 1, IS ), 1, RHS( 1 ), - $ 1, F( 1, JS ), LDF ) - END IF - IF( J.LT.Q ) THEN - CALL DAXPY( N-JE, RHS( 3 ), B( JS, JE+1 ), LDB, - $ C( IS, JE+1 ), LDC ) - CALL DAXPY( N-JE, RHS( 3 ), E( JS, JE+1 ), LDE, - $ F( IS, JE+1 ), LDF ) - CALL DAXPY( N-JE, RHS( 4 ), B( JSP1, JE+1 ), LDB, - $ C( IS, JE+1 ), LDC ) - CALL DAXPY( N-JE, RHS( 4 ), E( JSP1, JE+1 ), LDE, - $ F( IS, JE+1 ), LDF ) - END IF -* - ELSE IF( ( MB.EQ.2 ) .AND. ( NB.EQ.1 ) ) THEN -* -* Build a 4-by-4 system Z * x = RHS -* - Z( 1, 1 ) = A( IS, IS ) - Z( 2, 1 ) = A( ISP1, IS ) - Z( 3, 1 ) = D( IS, IS ) - Z( 4, 1 ) = ZERO -* - Z( 1, 2 ) = A( IS, ISP1 ) - Z( 2, 2 ) = A( ISP1, ISP1 ) - Z( 3, 2 ) = D( IS, ISP1 ) - Z( 4, 2 ) = D( ISP1, ISP1 ) -* - Z( 1, 3 ) = -B( JS, JS ) - Z( 2, 3 ) = ZERO - Z( 3, 3 ) = -E( JS, JS ) - Z( 4, 3 ) = ZERO -* - Z( 1, 4 ) = ZERO - Z( 2, 4 ) = -B( JS, JS ) - Z( 3, 4 ) = ZERO - Z( 4, 4 ) = -E( JS, JS ) -* -* Set up right hand side(s) -* - RHS( 1 ) = C( IS, JS ) - RHS( 2 ) = C( ISP1, JS ) - RHS( 3 ) = F( IS, JS ) - RHS( 4 ) = F( ISP1, JS ) -* -* Solve Z * x = RHS -* - CALL DGETC2( ZDIM, Z, LDZ, IPIV, JPIV, IERR ) - IF( IERR.GT.0 ) - $ INFO = IERR - IF( IJOB.EQ.0 ) THEN - CALL DGESC2( ZDIM, Z, LDZ, RHS, IPIV, JPIV, - $ SCALOC ) - IF( SCALOC.NE.ONE ) THEN - DO 70 K = 1, N - CALL DSCAL( M, SCALOC, C( 1, K ), 1 ) - CALL DSCAL( M, SCALOC, F( 1, K ), 1 ) - 70 CONTINUE - SCALE = SCALE*SCALOC - END IF - ELSE - CALL DLATDF( IJOB, ZDIM, Z, LDZ, RHS, RDSUM, - $ RDSCAL, IPIV, JPIV ) - END IF -* -* Unpack solution vector(s) -* - C( IS, JS ) = RHS( 1 ) - C( ISP1, JS ) = RHS( 2 ) - F( IS, JS ) = RHS( 3 ) - F( ISP1, JS ) = RHS( 4 ) -* -* Substitute R(I, J) and L(I, J) into remaining -* equation. -* - IF( I.GT.1 ) THEN - CALL DGEMV( 'N', IS-1, MB, -ONE, A( 1, IS ), LDA, - $ RHS( 1 ), 1, ONE, C( 1, JS ), 1 ) - CALL DGEMV( 'N', IS-1, MB, -ONE, D( 1, IS ), LDD, - $ RHS( 1 ), 1, ONE, F( 1, JS ), 1 ) - END IF - IF( J.LT.Q ) THEN - CALL DGER( MB, N-JE, ONE, RHS( 3 ), 1, - $ B( JS, JE+1 ), LDB, C( IS, JE+1 ), LDC ) - CALL DGER( MB, N-JE, ONE, RHS( 3 ), 1, - $ E( JS, JE+1 ), LDE, F( IS, JE+1 ), LDF ) - END IF -* - ELSE IF( ( MB.EQ.2 ) .AND. ( NB.EQ.2 ) ) THEN -* -* Build an 8-by-8 system Z * x = RHS -* - CALL DLASET( 'F', LDZ, LDZ, ZERO, ZERO, Z, LDZ ) -* - Z( 1, 1 ) = A( IS, IS ) - Z( 2, 1 ) = A( ISP1, IS ) - Z( 5, 1 ) = D( IS, IS ) -* - Z( 1, 2 ) = A( IS, ISP1 ) - Z( 2, 2 ) = A( ISP1, ISP1 ) - Z( 5, 2 ) = D( IS, ISP1 ) - Z( 6, 2 ) = D( ISP1, ISP1 ) -* - Z( 3, 3 ) = A( IS, IS ) - Z( 4, 3 ) = A( ISP1, IS ) - Z( 7, 3 ) = D( IS, IS ) -* - Z( 3, 4 ) = A( IS, ISP1 ) - Z( 4, 4 ) = A( ISP1, ISP1 ) - Z( 7, 4 ) = D( IS, ISP1 ) - Z( 8, 4 ) = D( ISP1, ISP1 ) -* - Z( 1, 5 ) = -B( JS, JS ) - Z( 3, 5 ) = -B( JS, JSP1 ) - Z( 5, 5 ) = -E( JS, JS ) - Z( 7, 5 ) = -E( JS, JSP1 ) -* - Z( 2, 6 ) = -B( JS, JS ) - Z( 4, 6 ) = -B( JS, JSP1 ) - Z( 6, 6 ) = -E( JS, JS ) - Z( 8, 6 ) = -E( JS, JSP1 ) -* - Z( 1, 7 ) = -B( JSP1, JS ) - Z( 3, 7 ) = -B( JSP1, JSP1 ) - Z( 7, 7 ) = -E( JSP1, JSP1 ) -* - Z( 2, 8 ) = -B( JSP1, JS ) - Z( 4, 8 ) = -B( JSP1, JSP1 ) - Z( 8, 8 ) = -E( JSP1, JSP1 ) -* -* Set up right hand side(s) -* - K = 1 - II = MB*NB + 1 - DO 80 JJ = 0, NB - 1 - CALL DCOPY( MB, C( IS, JS+JJ ), 1, RHS( K ), 1 ) - CALL DCOPY( MB, F( IS, JS+JJ ), 1, RHS( II ), 1 ) - K = K + MB - II = II + MB - 80 CONTINUE -* -* Solve Z * x = RHS -* - CALL DGETC2( ZDIM, Z, LDZ, IPIV, JPIV, IERR ) - IF( IERR.GT.0 ) - $ INFO = IERR - IF( IJOB.EQ.0 ) THEN - CALL DGESC2( ZDIM, Z, LDZ, RHS, IPIV, JPIV, - $ SCALOC ) - IF( SCALOC.NE.ONE ) THEN - DO 90 K = 1, N - CALL DSCAL( M, SCALOC, C( 1, K ), 1 ) - CALL DSCAL( M, SCALOC, F( 1, K ), 1 ) - 90 CONTINUE - SCALE = SCALE*SCALOC - END IF - ELSE - CALL DLATDF( IJOB, ZDIM, Z, LDZ, RHS, RDSUM, - $ RDSCAL, IPIV, JPIV ) - END IF -* -* Unpack solution vector(s) -* - K = 1 - II = MB*NB + 1 - DO 100 JJ = 0, NB - 1 - CALL DCOPY( MB, RHS( K ), 1, C( IS, JS+JJ ), 1 ) - CALL DCOPY( MB, RHS( II ), 1, F( IS, JS+JJ ), 1 ) - K = K + MB - II = II + MB - 100 CONTINUE -* -* Substitute R(I, J) and L(I, J) into remaining -* equation. -* - IF( I.GT.1 ) THEN - CALL DGEMM( 'N', 'N', IS-1, NB, MB, -ONE, - $ A( 1, IS ), LDA, RHS( 1 ), MB, ONE, - $ C( 1, JS ), LDC ) - CALL DGEMM( 'N', 'N', IS-1, NB, MB, -ONE, - $ D( 1, IS ), LDD, RHS( 1 ), MB, ONE, - $ F( 1, JS ), LDF ) - END IF - IF( J.LT.Q ) THEN - K = MB*NB + 1 - CALL DGEMM( 'N', 'N', MB, N-JE, NB, ONE, RHS( K ), - $ MB, B( JS, JE+1 ), LDB, ONE, - $ C( IS, JE+1 ), LDC ) - CALL DGEMM( 'N', 'N', MB, N-JE, NB, ONE, RHS( K ), - $ MB, E( JS, JE+1 ), LDE, ONE, - $ F( IS, JE+1 ), LDF ) - END IF -* - END IF -* - 110 CONTINUE - 120 CONTINUE - ELSE -* -* Solve (I, J) - subsystem -* A(I, I)' * R(I, J) + D(I, I)' * L(J, J) = C(I, J) -* R(I, I) * B(J, J) + L(I, J) * E(J, J) = -F(I, J) -* for I = 1, 2, ..., P, J = Q, Q - 1, ..., 1 -* - SCALE = ONE - SCALOC = ONE - DO 200 I = 1, P -* - IS = IWORK( I ) - ISP1 = IS + 1 - IE = IWORK( I+1 ) - 1 - MB = IE - IS + 1 - DO 190 J = Q, P + 2, -1 -* - JS = IWORK( J ) - JSP1 = JS + 1 - JE = IWORK( J+1 ) - 1 - NB = JE - JS + 1 - ZDIM = MB*NB*2 - IF( ( MB.EQ.1 ) .AND. ( NB.EQ.1 ) ) THEN -* -* Build a 2-by-2 system Z' * x = RHS -* - Z( 1, 1 ) = A( IS, IS ) - Z( 2, 1 ) = -B( JS, JS ) - Z( 1, 2 ) = D( IS, IS ) - Z( 2, 2 ) = -E( JS, JS ) -* -* Set up right hand side(s) -* - RHS( 1 ) = C( IS, JS ) - RHS( 2 ) = F( IS, JS ) -* -* Solve Z' * x = RHS -* - CALL DGETC2( ZDIM, Z, LDZ, IPIV, JPIV, IERR ) - IF( IERR.GT.0 ) - $ INFO = IERR -* - CALL DGESC2( ZDIM, Z, LDZ, RHS, IPIV, JPIV, SCALOC ) - IF( SCALOC.NE.ONE ) THEN - DO 130 K = 1, N - CALL DSCAL( M, SCALOC, C( 1, K ), 1 ) - CALL DSCAL( M, SCALOC, F( 1, K ), 1 ) - 130 CONTINUE - SCALE = SCALE*SCALOC - END IF -* -* Unpack solution vector(s) -* - C( IS, JS ) = RHS( 1 ) - F( IS, JS ) = RHS( 2 ) -* -* Substitute R(I, J) and L(I, J) into remaining -* equation. -* - IF( J.GT.P+2 ) THEN - ALPHA = RHS( 1 ) - CALL DAXPY( JS-1, ALPHA, B( 1, JS ), 1, F( IS, 1 ), - $ LDF ) - ALPHA = RHS( 2 ) - CALL DAXPY( JS-1, ALPHA, E( 1, JS ), 1, F( IS, 1 ), - $ LDF ) - END IF - IF( I.LT.P ) THEN - ALPHA = -RHS( 1 ) - CALL DAXPY( M-IE, ALPHA, A( IS, IE+1 ), LDA, - $ C( IE+1, JS ), 1 ) - ALPHA = -RHS( 2 ) - CALL DAXPY( M-IE, ALPHA, D( IS, IE+1 ), LDD, - $ C( IE+1, JS ), 1 ) - END IF -* - ELSE IF( ( MB.EQ.1 ) .AND. ( NB.EQ.2 ) ) THEN -* -* Build a 4-by-4 system Z' * x = RHS -* - Z( 1, 1 ) = A( IS, IS ) - Z( 2, 1 ) = ZERO - Z( 3, 1 ) = -B( JS, JS ) - Z( 4, 1 ) = -B( JSP1, JS ) -* - Z( 1, 2 ) = ZERO - Z( 2, 2 ) = A( IS, IS ) - Z( 3, 2 ) = -B( JS, JSP1 ) - Z( 4, 2 ) = -B( JSP1, JSP1 ) -* - Z( 1, 3 ) = D( IS, IS ) - Z( 2, 3 ) = ZERO - Z( 3, 3 ) = -E( JS, JS ) - Z( 4, 3 ) = ZERO -* - Z( 1, 4 ) = ZERO - Z( 2, 4 ) = D( IS, IS ) - Z( 3, 4 ) = -E( JS, JSP1 ) - Z( 4, 4 ) = -E( JSP1, JSP1 ) -* -* Set up right hand side(s) -* - RHS( 1 ) = C( IS, JS ) - RHS( 2 ) = C( IS, JSP1 ) - RHS( 3 ) = F( IS, JS ) - RHS( 4 ) = F( IS, JSP1 ) -* -* Solve Z' * x = RHS -* - CALL DGETC2( ZDIM, Z, LDZ, IPIV, JPIV, IERR ) - IF( IERR.GT.0 ) - $ INFO = IERR - CALL DGESC2( ZDIM, Z, LDZ, RHS, IPIV, JPIV, SCALOC ) - IF( SCALOC.NE.ONE ) THEN - DO 140 K = 1, N - CALL DSCAL( M, SCALOC, C( 1, K ), 1 ) - CALL DSCAL( M, SCALOC, F( 1, K ), 1 ) - 140 CONTINUE - SCALE = SCALE*SCALOC - END IF -* -* Unpack solution vector(s) -* - C( IS, JS ) = RHS( 1 ) - C( IS, JSP1 ) = RHS( 2 ) - F( IS, JS ) = RHS( 3 ) - F( IS, JSP1 ) = RHS( 4 ) -* -* Substitute R(I, J) and L(I, J) into remaining -* equation. -* - IF( J.GT.P+2 ) THEN - CALL DAXPY( JS-1, RHS( 1 ), B( 1, JS ), 1, - $ F( IS, 1 ), LDF ) - CALL DAXPY( JS-1, RHS( 2 ), B( 1, JSP1 ), 1, - $ F( IS, 1 ), LDF ) - CALL DAXPY( JS-1, RHS( 3 ), E( 1, JS ), 1, - $ F( IS, 1 ), LDF ) - CALL DAXPY( JS-1, RHS( 4 ), E( 1, JSP1 ), 1, - $ F( IS, 1 ), LDF ) - END IF - IF( I.LT.P ) THEN - CALL DGER( M-IE, NB, -ONE, A( IS, IE+1 ), LDA, - $ RHS( 1 ), 1, C( IE+1, JS ), LDC ) - CALL DGER( M-IE, NB, -ONE, D( IS, IE+1 ), LDD, - $ RHS( 3 ), 1, C( IE+1, JS ), LDC ) - END IF -* - ELSE IF( ( MB.EQ.2 ) .AND. ( NB.EQ.1 ) ) THEN -* -* Build a 4-by-4 system Z' * x = RHS -* - Z( 1, 1 ) = A( IS, IS ) - Z( 2, 1 ) = A( IS, ISP1 ) - Z( 3, 1 ) = -B( JS, JS ) - Z( 4, 1 ) = ZERO -* - Z( 1, 2 ) = A( ISP1, IS ) - Z( 2, 2 ) = A( ISP1, ISP1 ) - Z( 3, 2 ) = ZERO - Z( 4, 2 ) = -B( JS, JS ) -* - Z( 1, 3 ) = D( IS, IS ) - Z( 2, 3 ) = D( IS, ISP1 ) - Z( 3, 3 ) = -E( JS, JS ) - Z( 4, 3 ) = ZERO -* - Z( 1, 4 ) = ZERO - Z( 2, 4 ) = D( ISP1, ISP1 ) - Z( 3, 4 ) = ZERO - Z( 4, 4 ) = -E( JS, JS ) -* -* Set up right hand side(s) -* - RHS( 1 ) = C( IS, JS ) - RHS( 2 ) = C( ISP1, JS ) - RHS( 3 ) = F( IS, JS ) - RHS( 4 ) = F( ISP1, JS ) -* -* Solve Z' * x = RHS -* - CALL DGETC2( ZDIM, Z, LDZ, IPIV, JPIV, IERR ) - IF( IERR.GT.0 ) - $ INFO = IERR -* - CALL DGESC2( ZDIM, Z, LDZ, RHS, IPIV, JPIV, SCALOC ) - IF( SCALOC.NE.ONE ) THEN - DO 150 K = 1, N - CALL DSCAL( M, SCALOC, C( 1, K ), 1 ) - CALL DSCAL( M, SCALOC, F( 1, K ), 1 ) - 150 CONTINUE - SCALE = SCALE*SCALOC - END IF -* -* Unpack solution vector(s) -* - C( IS, JS ) = RHS( 1 ) - C( ISP1, JS ) = RHS( 2 ) - F( IS, JS ) = RHS( 3 ) - F( ISP1, JS ) = RHS( 4 ) -* -* Substitute R(I, J) and L(I, J) into remaining -* equation. -* - IF( J.GT.P+2 ) THEN - CALL DGER( MB, JS-1, ONE, RHS( 1 ), 1, B( 1, JS ), - $ 1, F( IS, 1 ), LDF ) - CALL DGER( MB, JS-1, ONE, RHS( 3 ), 1, E( 1, JS ), - $ 1, F( IS, 1 ), LDF ) - END IF - IF( I.LT.P ) THEN - CALL DGEMV( 'T', MB, M-IE, -ONE, A( IS, IE+1 ), - $ LDA, RHS( 1 ), 1, ONE, C( IE+1, JS ), - $ 1 ) - CALL DGEMV( 'T', MB, M-IE, -ONE, D( IS, IE+1 ), - $ LDD, RHS( 3 ), 1, ONE, C( IE+1, JS ), - $ 1 ) - END IF -* - ELSE IF( ( MB.EQ.2 ) .AND. ( NB.EQ.2 ) ) THEN -* -* Build an 8-by-8 system Z' * x = RHS -* - CALL DLASET( 'F', LDZ, LDZ, ZERO, ZERO, Z, LDZ ) -* - Z( 1, 1 ) = A( IS, IS ) - Z( 2, 1 ) = A( IS, ISP1 ) - Z( 5, 1 ) = -B( JS, JS ) - Z( 7, 1 ) = -B( JSP1, JS ) -* - Z( 1, 2 ) = A( ISP1, IS ) - Z( 2, 2 ) = A( ISP1, ISP1 ) - Z( 6, 2 ) = -B( JS, JS ) - Z( 8, 2 ) = -B( JSP1, JS ) -* - Z( 3, 3 ) = A( IS, IS ) - Z( 4, 3 ) = A( IS, ISP1 ) - Z( 5, 3 ) = -B( JS, JSP1 ) - Z( 7, 3 ) = -B( JSP1, JSP1 ) -* - Z( 3, 4 ) = A( ISP1, IS ) - Z( 4, 4 ) = A( ISP1, ISP1 ) - Z( 6, 4 ) = -B( JS, JSP1 ) - Z( 8, 4 ) = -B( JSP1, JSP1 ) -* - Z( 1, 5 ) = D( IS, IS ) - Z( 2, 5 ) = D( IS, ISP1 ) - Z( 5, 5 ) = -E( JS, JS ) -* - Z( 2, 6 ) = D( ISP1, ISP1 ) - Z( 6, 6 ) = -E( JS, JS ) -* - Z( 3, 7 ) = D( IS, IS ) - Z( 4, 7 ) = D( IS, ISP1 ) - Z( 5, 7 ) = -E( JS, JSP1 ) - Z( 7, 7 ) = -E( JSP1, JSP1 ) -* - Z( 4, 8 ) = D( ISP1, ISP1 ) - Z( 6, 8 ) = -E( JS, JSP1 ) - Z( 8, 8 ) = -E( JSP1, JSP1 ) -* -* Set up right hand side(s) -* - K = 1 - II = MB*NB + 1 - DO 160 JJ = 0, NB - 1 - CALL DCOPY( MB, C( IS, JS+JJ ), 1, RHS( K ), 1 ) - CALL DCOPY( MB, F( IS, JS+JJ ), 1, RHS( II ), 1 ) - K = K + MB - II = II + MB - 160 CONTINUE -* -* -* Solve Z' * x = RHS -* - CALL DGETC2( ZDIM, Z, LDZ, IPIV, JPIV, IERR ) - IF( IERR.GT.0 ) - $ INFO = IERR -* - CALL DGESC2( ZDIM, Z, LDZ, RHS, IPIV, JPIV, SCALOC ) - IF( SCALOC.NE.ONE ) THEN - DO 170 K = 1, N - CALL DSCAL( M, SCALOC, C( 1, K ), 1 ) - CALL DSCAL( M, SCALOC, F( 1, K ), 1 ) - 170 CONTINUE - SCALE = SCALE*SCALOC - END IF -* -* Unpack solution vector(s) -* - K = 1 - II = MB*NB + 1 - DO 180 JJ = 0, NB - 1 - CALL DCOPY( MB, RHS( K ), 1, C( IS, JS+JJ ), 1 ) - CALL DCOPY( MB, RHS( II ), 1, F( IS, JS+JJ ), 1 ) - K = K + MB - II = II + MB - 180 CONTINUE -* -* Substitute R(I, J) and L(I, J) into remaining -* equation. -* - IF( J.GT.P+2 ) THEN - CALL DGEMM( 'N', 'T', MB, JS-1, NB, ONE, - $ C( IS, JS ), LDC, B( 1, JS ), LDB, ONE, - $ F( IS, 1 ), LDF ) - CALL DGEMM( 'N', 'T', MB, JS-1, NB, ONE, - $ F( IS, JS ), LDF, E( 1, JS ), LDE, ONE, - $ F( IS, 1 ), LDF ) - END IF - IF( I.LT.P ) THEN - CALL DGEMM( 'T', 'N', M-IE, NB, MB, -ONE, - $ A( IS, IE+1 ), LDA, C( IS, JS ), LDC, - $ ONE, C( IE+1, JS ), LDC ) - CALL DGEMM( 'T', 'N', M-IE, NB, MB, -ONE, - $ D( IS, IE+1 ), LDD, F( IS, JS ), LDF, - $ ONE, C( IE+1, JS ), LDC ) - END IF -* - END IF -* - 190 CONTINUE - 200 CONTINUE -* - END IF - RETURN -* -* End of DTGSY2 -* - END diff --git a/mex/sources/libslicot/readme b/mex/sources/libslicot/readme deleted file mode 100644 index 85f5bce37..000000000 --- a/mex/sources/libslicot/readme +++ /dev/null @@ -1,8 +0,0 @@ -SLICOT Library Subdirectory src -------------------------------- - -SLICOT Library Subdirectory src contains all source files of the -SLICOT Library routines. The codes follow the Fortran 77 language -conventions. SLICOT routines make calls to the state-of-the-art -packages LAPACK (Linear Algebra Package) and BLAS (Basic Linear -Algebra Subprograms). diff --git a/mex/sources/libslicot/select.f b/mex/sources/libslicot/select.f deleted file mode 100644 index dd3e62baf..000000000 --- a/mex/sources/libslicot/select.f +++ /dev/null @@ -1,27 +0,0 @@ - LOGICAL FUNCTION SELECT( PAR1, PAR2 ) -C -C SLICOT RELEASE 5.0. -C -C Copyright (c) 2002-2009 NICONET e.V. -C -C This program is free software: you can redistribute it and/or -C modify it under the terms of the GNU General Public License as -C published by the Free Software Foundation, either version 2 of -C the License, or (at your option) any later version. -C -C This program is distributed in the hope that it will be useful, -C but WITHOUT ANY WARRANTY; without even the implied warranty of -C MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the -C GNU General Public License for more details. -C -C You should have received a copy of the GNU General Public License -C along with this program. If not, see -C . -C -C Void logical function for DGEES. -C - DOUBLE PRECISION PAR1, PAR2 -C - SELECT = .TRUE. - RETURN - END